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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
{- git-annex assistant webapp data 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 where
import Assistant.Common
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.TransferQueue
import Assistant.Alert
import Utility.NotificationBroadcaster
import Utility.WebApp
import Utility.Yesod
import Yesod
import Yesod.Static
import Text.Hamlet
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
, secretToken :: Text
, relDir :: Maybe FilePath
, getStatic :: Static
, webAppState :: TMVar WebAppState
, postFirstRun :: Maybe (IO String)
}
data NavBarItem = DashBoard | Config | About
deriving (Eq)
navBarName :: NavBarItem -> Text
navBarName DashBoard = "Dashboard"
navBarName Config = "Configuration"
navBarName About = "About"
navBarRoute :: NavBarItem -> Route WebApp
navBarRoute DashBoard = HomeR
navBarRoute Config = ConfigR
navBarRoute About = AboutR
defaultNavBar :: [NavBarItem]
defaultNavBar = [DashBoard, Config, About]
firstRunNavBar :: [NavBarItem]
firstRunNavBar = [Config, About]
selectNavBar :: Handler [NavBarItem]
selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
inFirstRun :: Handler Bool
inFirstRun = isNothing . relDir <$> getYesod
{- Used instead of defaultContent; highlights the current page if it's
- on the navbar. -}
bootstrap :: Maybe NavBarItem -> Widget -> Handler RepHtml
bootstrap navbaritem content = do
webapp <- getYesod
navbar <- map navdetails <$> selectNavBar
page <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_css
addStylesheet $ StaticR css_bootstrap_responsive_css
addScript $ StaticR jquery_full_js
addScript $ StaticR js_bootstrap_dropdown_js
addScript $ StaticR js_bootstrap_modal_js
$(widgetFile "page")
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
where
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
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
}
newWebAppState :: IO (TMVar WebAppState)
newWebAppState = liftIO $ atomically $
newTMVar $ WebAppState { showIntro = True }
getWebAppState :: forall sub. GHandler sub WebApp WebAppState
getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
modifyWebAppState :: forall sub. (WebAppState -> WebAppState) -> GHandler sub WebApp ()
modifyWebAppState a = go =<< webAppState <$> getYesod
where
go s = liftIO $ atomically $ do
v <- takeTMVar s
putTMVar s $ a v
{- Runs an Annex action from the webapp.
-
- When the webapp is run outside a git-annex repository, the fallback
- value is returned.
-}
runAnnex :: forall sub a. a -> Annex a -> GHandler sub WebApp a
runAnnex fallback a = maybe (return fallback) go =<< threadState <$> getYesod
where
go st = liftIO $ runThreadState st a
waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
waitNotifier selector nid = do
notifier <- getNotifier selector
liftIO $ waitNotification $ notificationHandleFromId notifier nid
newNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationId
newNotifier selector = do
notifier <- getNotifier selector
liftIO $ notificationHandleToId <$> newNotificationHandle notifier
getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster
getNotifier selector = do
webapp <- getYesod
liftIO $ selector <$> getDaemonStatus (daemonStatus webapp)
instance PathPiece NotificationId where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece AlertId where
toPathPiece = pack . show
fromPathPiece = readish . unpack
{- Adds the auth parameter as a hidden field on a form. Must be put into
- every form. -}
webAppFormAuthToken :: Widget
webAppFormAuthToken = do
webapp <- lift getYesod
[whamlet|<input type="hidden" name="auth" value="#{secretToken webapp}">|]
|
