1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
{- git-annex assistant webapp types
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Assistant.WebApp.Types where
import Assistant.Common
import Assistant.Ssh
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.TransferQueue
import Assistant.TransferSlots
import Assistant.Alert
import Assistant.Pairing
import Utility.NotificationBroadcaster
import Utility.WebApp
import Logs.Transfer
import Yesod
import Yesod.Static
import Data.Text (Text, pack, unpack)
import Control.Concurrent.STM
staticFiles "static"
mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
data WebApp = WebApp
{ threadState :: Maybe ThreadState
, daemonStatus :: DaemonStatusHandle
, scanRemotes :: ScanRemoteMap
, transferQueue :: TransferQueue
, transferSlots :: TransferSlots
, secretToken :: Text
, relDir :: Maybe FilePath
, getStatic :: Static
, webAppState :: TMVar WebAppState
, postFirstRun :: Maybe (IO String)
}
instance Yesod WebApp where
{- Require an auth token be set when accessing any (non-static route) -}
isAuthorized _ _ = checkAuthToken secretToken
{- Add the auth token to every url generated, except static subsite
- urls (which can show up in Permission Denied pages). -}
joinPath = insertAuthToken secretToken excludeStatic
where
excludeStatic [] = True
excludeStatic (p:_) = p /= "static"
makeSessionBackend = webAppSessionBackend
jsLoader _ = BottomOfHeadBlocking
instance RenderMessage WebApp FormMessage where
renderMessage _ _ = defaultFormMessage
type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
data WebAppState = WebAppState
{ showIntro :: Bool -- should the into message be displayed?
, otherRepos :: [(String, String)] -- name and path to other repos
}
instance PathPiece SshData where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece NotificationId where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece AlertId where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece Transfer where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece PairMsg where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece SecretReminder where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece UUID where
toPathPiece = pack . show
fromPathPiece = readish . unpack
|
