split up webapp files
This commit is contained in:
Joey Hess
parent
6e40aed948
commit
58dfa3fa5b
7 changed files with 413 additions and 297 deletions
|
|
@ -11,321 +11,31 @@
|
|||
module Assistant.Threads.WebApp where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.WebApp
|
||||
import Assistant.WebApp.DashBoard
|
||||
import Assistant.WebApp.SideBar
|
||||
import Assistant.WebApp.Notifications
|
||||
import Assistant.WebApp.Configurators
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.TransferQueue
|
||||
import Assistant.Alert hiding (Widget)
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.WebApp
|
||||
import Utility.Yesod
|
||||
import Utility.FileMode
|
||||
import Utility.TempFile
|
||||
import Git
|
||||
import Logs.Transfer
|
||||
import Utility.Percentage
|
||||
import Utility.DataUnits
|
||||
import Types.Key
|
||||
import qualified Remote
|
||||
import Logs.Web (webUUID)
|
||||
import Logs.Trust
|
||||
import Annex.UUID (getUUID)
|
||||
|
||||
import Yesod
|
||||
import Yesod.Static
|
||||
import Text.Hamlet
|
||||
import Network.Socket (PortNumber)
|
||||
import Text.Blaze.Renderer.String
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
import Control.Concurrent.STM
|
||||
import Data.Text (pack, unpack)
|
||||
|
||||
thisThread :: String
|
||||
thisThread = "WebApp"
|
||||
|
||||
data WebApp = WebApp
|
||||
{ threadState :: ThreadState
|
||||
, daemonStatus :: DaemonStatusHandle
|
||||
, transferQueue :: TransferQueue
|
||||
, secretToken :: Text
|
||||
, relDir :: FilePath
|
||||
, getStatic :: Static
|
||||
, webAppState :: TMVar WebAppState
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
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)
|
||||
|
||||
staticFiles "static"
|
||||
|
||||
mkYesod "WebApp" [parseRoutes|
|
||||
/ HomeR GET
|
||||
/noscript NoScriptR GET
|
||||
/noscriptauto NoScriptAutoR GET
|
||||
/transfers/#NotificationId TransfersR GET
|
||||
/sidebar/#NotificationId SideBarR GET
|
||||
/notifier/transfers NotifierTransfersR GET
|
||||
/notifier/sidebar NotifierSideBarR GET
|
||||
/closealert/#AlertId CloseAlert GET
|
||||
/config ConfigR GET
|
||||
/addrepository AddRepositoryR GET
|
||||
/static StaticR Static getStatic
|
||||
|]
|
||||
|
||||
instance PathPiece NotificationId where
|
||||
toPathPiece = pack . show
|
||||
fromPathPiece = readish . unpack
|
||||
|
||||
instance PathPiece AlertId where
|
||||
toPathPiece = pack . show
|
||||
fromPathPiece = readish . unpack
|
||||
|
||||
instance Yesod WebApp where
|
||||
defaultLayout content = do
|
||||
webapp <- getYesod
|
||||
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")
|
||||
|
||||
{- 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
|
||||
|
||||
{- Add to any widget to make it auto-update using long polling.
|
||||
-
|
||||
- The widget should have a html element with an id=ident, which will be
|
||||
- replaced when it's updated.
|
||||
-
|
||||
- The geturl route should return the notifier url to use for polling.
|
||||
-
|
||||
- ms_delay is how long to delay between AJAX updates
|
||||
- ms_startdelay is how long to delay before updating with AJAX at the start
|
||||
-}
|
||||
autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget
|
||||
autoUpdate ident geturl ms_delay ms_startdelay = do
|
||||
let delay = show ms_delay
|
||||
let startdelay = show ms_startdelay
|
||||
addScript $ StaticR longpolling_js
|
||||
$(widgetFile "longpolling")
|
||||
|
||||
{- Notifier urls are requested by the javascript, to avoid allocation
|
||||
- of NotificationIds when noscript pages are loaded. This constructs a
|
||||
- notifier url for a given Route and NotificationBroadcaster.
|
||||
-}
|
||||
notifierUrl :: (NotificationId -> Route WebApp) -> (DaemonStatus -> NotificationBroadcaster) -> Handler RepPlain
|
||||
notifierUrl route selector = do
|
||||
(urlbits, _params) <- renderRoute . route <$> newNotifier selector
|
||||
webapp <- getYesod
|
||||
return $ RepPlain $ toContent $ T.concat
|
||||
[ "/"
|
||||
, T.intercalate "/" urlbits
|
||||
, "?auth="
|
||||
, secretToken webapp
|
||||
]
|
||||
|
||||
getNotifierTransfersR :: Handler RepPlain
|
||||
getNotifierTransfersR = notifierUrl TransfersR transferNotifier
|
||||
|
||||
getNotifierSideBarR :: Handler RepPlain
|
||||
getNotifierSideBarR = notifierUrl SideBarR alertNotifier
|
||||
|
||||
{- A display of currently running and queued transfers.
|
||||
-
|
||||
- Or, if there have never been any this run, an intro display. -}
|
||||
transfersDisplay :: Bool -> Widget
|
||||
transfersDisplay warnNoScript = do
|
||||
webapp <- lift getYesod
|
||||
current <- liftIO $ runThreadState (threadState webapp) $
|
||||
M.toList . currentTransfers
|
||||
<$> liftIO (getDaemonStatus $ daemonStatus webapp)
|
||||
queued <- liftIO $ getTransferQueue $ transferQueue webapp
|
||||
let ident = "transfers"
|
||||
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
|
||||
let transfers = current ++ queued
|
||||
if null transfers
|
||||
then ifM (lift $ showIntro <$> getWebAppState)
|
||||
( introDisplay ident
|
||||
, $(widgetFile "transfers")
|
||||
)
|
||||
else $(widgetFile "transfers")
|
||||
|
||||
{- An intro message, and list of repositories. -}
|
||||
introDisplay :: Text -> Widget
|
||||
introDisplay ident = do
|
||||
webapp <- lift getYesod
|
||||
let reldir = relDir webapp
|
||||
l <- liftIO $ runThreadState (threadState webapp) $ do
|
||||
u <- getUUID
|
||||
rs <- map Remote.uuid <$> Remote.remoteList
|
||||
rs' <- snd <$> trustPartition DeadTrusted rs
|
||||
Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs'
|
||||
let remotelist = zip counter l
|
||||
let n = length l
|
||||
let numrepos = show n
|
||||
let notenough = n < 2
|
||||
let barelyenough = n == 2
|
||||
let morethanenough = n > 2
|
||||
$(widgetFile "intro")
|
||||
lift $ modifyWebAppState $ \s -> s { showIntro = False }
|
||||
where
|
||||
counter = map show ([1..] :: [Int])
|
||||
|
||||
{- Called by client to get a display of currently in process transfers.
|
||||
-
|
||||
- Returns a div, which will be inserted into the calling page.
|
||||
-
|
||||
- Note that the head of the widget is not included, only its
|
||||
- body is. To get the widget head content, the widget is also
|
||||
- inserted onto the getHomeR page.
|
||||
-}
|
||||
getTransfersR :: NotificationId -> Handler RepHtml
|
||||
getTransfersR nid = do
|
||||
waitNotifier transferNotifier nid
|
||||
|
||||
page <- widgetToPageContent $ transfersDisplay False
|
||||
hamletToRepHtml $ [hamlet|^{pageBody page}|]
|
||||
|
||||
sideBarDisplay :: Widget
|
||||
sideBarDisplay = do
|
||||
let content = do
|
||||
{- Any yesod message appears as the first alert. -}
|
||||
maybe noop rendermessage =<< lift getMessage
|
||||
|
||||
{- Add newest alerts to the sidebar. -}
|
||||
webapp <- lift getYesod
|
||||
alertpairs <- M.toList . alertMap
|
||||
<$> liftIO (getDaemonStatus $ daemonStatus webapp)
|
||||
mapM_ renderalert $
|
||||
take displayAlerts $ reverse $ sortAlertPairs alertpairs
|
||||
let ident = "sidebar"
|
||||
$(widgetFile "sidebar")
|
||||
autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
|
||||
where
|
||||
bootstrapclass Activity = "alert-info"
|
||||
bootstrapclass Warning = "alert"
|
||||
bootstrapclass Error = "alert-error"
|
||||
bootstrapclass Success = "alert-success"
|
||||
bootstrapclass Message = "alert-info"
|
||||
|
||||
renderalert (alertid, alert) = addalert
|
||||
alertid
|
||||
(alertClosable alert)
|
||||
(alertBlockDisplay alert)
|
||||
(bootstrapclass $ alertClass alert)
|
||||
(alertHeader alert)
|
||||
$ case alertMessage alert of
|
||||
StringAlert s -> [whamlet|#{s}|]
|
||||
WidgetAlert w -> w alert
|
||||
|
||||
rendermessage msg = addalert firstAlertId True False
|
||||
"alert-info" Nothing [whamlet|#{msg}|]
|
||||
|
||||
addalert :: AlertId -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget
|
||||
addalert i closable block divclass heading widget = do
|
||||
let alertid = show i
|
||||
let closealert = CloseAlert i
|
||||
$(widgetFile "alert")
|
||||
|
||||
{- Called by client to get a sidebar display.
|
||||
-
|
||||
- Returns a div, which will be inserted into the calling page.
|
||||
-
|
||||
- Note that the head of the widget is not included, only its
|
||||
- body is. To get the widget head content, the widget is also
|
||||
- inserted onto all pages.
|
||||
-}
|
||||
getSideBarR :: NotificationId -> Handler RepHtml
|
||||
getSideBarR nid = do
|
||||
waitNotifier alertNotifier nid
|
||||
|
||||
page <- widgetToPageContent sideBarDisplay
|
||||
hamletToRepHtml $ [hamlet|^{pageBody page}|]
|
||||
|
||||
{- Called by the client to close an alert. -}
|
||||
getCloseAlert :: AlertId -> Handler ()
|
||||
getCloseAlert i = do
|
||||
webapp <- getYesod
|
||||
void $ liftIO $ removeAlert (daemonStatus webapp) i
|
||||
|
||||
{- The main dashboard. -}
|
||||
dashboard :: Bool -> Widget
|
||||
dashboard warnNoScript = do
|
||||
sideBarDisplay
|
||||
let content = transfersDisplay warnNoScript
|
||||
$(widgetFile "dashboard")
|
||||
|
||||
getHomeR :: Handler RepHtml
|
||||
getHomeR = defaultLayout $ dashboard True
|
||||
|
||||
{- Same as HomeR, except with autorefreshing via meta refresh. -}
|
||||
getNoScriptAutoR :: Handler RepHtml
|
||||
getNoScriptAutoR = defaultLayout $ do
|
||||
let ident = NoScriptR
|
||||
let delayseconds = 3 :: Int
|
||||
let this = NoScriptAutoR
|
||||
toWidgetHead $(hamletFile $ hamletTemplate "metarefresh")
|
||||
dashboard False
|
||||
|
||||
{- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
|
||||
getNoScriptR :: Handler RepHtml
|
||||
getNoScriptR = defaultLayout $
|
||||
dashboard False
|
||||
|
||||
getConfigR :: Handler RepHtml
|
||||
getConfigR = defaultLayout $ do
|
||||
sideBarDisplay
|
||||
setTitle "Configuration"
|
||||
[whamlet|<a href="@{HomeR}">main|]
|
||||
|
||||
getAddRepositoryR :: Handler RepHtml
|
||||
getAddRepositoryR = defaultLayout $ do
|
||||
sideBarDisplay
|
||||
setTitle "Add repository"
|
||||
[whamlet|<a href="@{HomeR}">main|]
|
||||
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
|
||||
|
||||
webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO ()
|
||||
webAppThread st dstatus transferqueue onstartup = do
|
||||
|
|
|
|||
106
Assistant/WebApp.hs
Normal file
106
Assistant/WebApp.hs
Normal file
|
|
@ -0,0 +1,106 @@
|
|||
{- 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.TransferQueue
|
||||
import Assistant.Alert hiding (Widget)
|
||||
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 :: ThreadState
|
||||
, daemonStatus :: DaemonStatusHandle
|
||||
, transferQueue :: TransferQueue
|
||||
, secretToken :: Text
|
||||
, relDir :: FilePath
|
||||
, getStatic :: Static
|
||||
, webAppState :: TMVar WebAppState
|
||||
}
|
||||
|
||||
instance Yesod WebApp where
|
||||
defaultLayout content = do
|
||||
webapp <- getYesod
|
||||
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")
|
||||
|
||||
{- 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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
56
Assistant/WebApp/Configurators.hs
Normal file
56
Assistant/WebApp/Configurators.hs
Normal file
|
|
@ -0,0 +1,56 @@
|
|||
{- git-annex assistant webapp configurators
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||||
|
||||
module Assistant.WebApp.Configurators where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.WebApp
|
||||
import Assistant.WebApp.SideBar
|
||||
import Assistant.ThreadedMonad
|
||||
import Utility.Yesod
|
||||
import qualified Remote
|
||||
import Logs.Web (webUUID)
|
||||
import Logs.Trust
|
||||
import Annex.UUID (getUUID)
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
|
||||
{- An intro message, list of repositories, and nudge to make more. -}
|
||||
introDisplay :: Text -> Widget
|
||||
introDisplay ident = do
|
||||
webapp <- lift getYesod
|
||||
let reldir = relDir webapp
|
||||
l <- liftIO $ runThreadState (threadState webapp) $ do
|
||||
u <- getUUID
|
||||
rs <- map Remote.uuid <$> Remote.remoteList
|
||||
rs' <- snd <$> trustPartition DeadTrusted rs
|
||||
Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs'
|
||||
let remotelist = zip counter l
|
||||
let n = length l
|
||||
let numrepos = show n
|
||||
let notenough = n < 2
|
||||
let barelyenough = n == 2
|
||||
let morethanenough = n > 2
|
||||
$(widgetFile "intro")
|
||||
lift $ modifyWebAppState $ \s -> s { showIntro = False }
|
||||
where
|
||||
counter = map show ([1..] :: [Int])
|
||||
|
||||
getConfigR :: Handler RepHtml
|
||||
getConfigR = defaultLayout $ do
|
||||
sideBarDisplay
|
||||
setTitle "Configuration"
|
||||
[whamlet|<a href="@{HomeR}">main|]
|
||||
|
||||
getAddRepositoryR :: Handler RepHtml
|
||||
getAddRepositoryR = defaultLayout $ do
|
||||
sideBarDisplay
|
||||
setTitle "Add repository"
|
||||
[whamlet|<a href="@{HomeR}">main|]
|
||||
89
Assistant/WebApp/DashBoard.hs
Normal file
89
Assistant/WebApp/DashBoard.hs
Normal file
|
|
@ -0,0 +1,89 @@
|
|||
{- git-annex assistant webapp dashboard
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||||
|
||||
module Assistant.WebApp.DashBoard where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.WebApp
|
||||
import Assistant.WebApp.SideBar
|
||||
import Assistant.WebApp.Notifications
|
||||
import Assistant.WebApp.Configurators
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.TransferQueue
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
import Logs.Transfer
|
||||
import Utility.Percentage
|
||||
import Utility.DataUnits
|
||||
import Types.Key
|
||||
import qualified Remote
|
||||
|
||||
import Yesod
|
||||
import Text.Hamlet
|
||||
import qualified Data.Map as M
|
||||
|
||||
{- A display of currently running and queued transfers.
|
||||
-
|
||||
- Or, if there have never been any this run, an intro display. -}
|
||||
transfersDisplay :: Bool -> Widget
|
||||
transfersDisplay warnNoScript = do
|
||||
webapp <- lift getYesod
|
||||
current <- liftIO $ runThreadState (threadState webapp) $
|
||||
M.toList . currentTransfers
|
||||
<$> liftIO (getDaemonStatus $ daemonStatus webapp)
|
||||
queued <- liftIO $ getTransferQueue $ transferQueue webapp
|
||||
let ident = "transfers"
|
||||
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
|
||||
let transfers = current ++ queued
|
||||
if null transfers
|
||||
then ifM (lift $ showIntro <$> getWebAppState)
|
||||
( introDisplay ident
|
||||
, $(widgetFile "transfers")
|
||||
)
|
||||
else $(widgetFile "transfers")
|
||||
|
||||
{- Called by client to get a display of currently in process transfers.
|
||||
-
|
||||
- Returns a div, which will be inserted into the calling page.
|
||||
-
|
||||
- Note that the head of the widget is not included, only its
|
||||
- body is. To get the widget head content, the widget is also
|
||||
- inserted onto the getHomeR page.
|
||||
-}
|
||||
getTransfersR :: NotificationId -> Handler RepHtml
|
||||
getTransfersR nid = do
|
||||
waitNotifier transferNotifier nid
|
||||
|
||||
page <- widgetToPageContent $ transfersDisplay False
|
||||
hamletToRepHtml $ [hamlet|^{pageBody page}|]
|
||||
|
||||
{- The main dashboard. -}
|
||||
dashboard :: Bool -> Widget
|
||||
dashboard warnNoScript = do
|
||||
sideBarDisplay
|
||||
let content = transfersDisplay warnNoScript
|
||||
$(widgetFile "dashboard")
|
||||
|
||||
getHomeR :: Handler RepHtml
|
||||
getHomeR = defaultLayout $ dashboard True
|
||||
|
||||
{- Same as HomeR, except with autorefreshing via meta refresh. -}
|
||||
getNoScriptAutoR :: Handler RepHtml
|
||||
getNoScriptAutoR = defaultLayout $ do
|
||||
let ident = NoScriptR
|
||||
let delayseconds = 3 :: Int
|
||||
let this = NoScriptAutoR
|
||||
toWidgetHead $(hamletFile $ hamletTemplate "metarefresh")
|
||||
dashboard False
|
||||
|
||||
{- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
|
||||
getNoScriptR :: Handler RepHtml
|
||||
getNoScriptR = defaultLayout $
|
||||
dashboard False
|
||||
58
Assistant/WebApp/Notifications.hs
Normal file
58
Assistant/WebApp/Notifications.hs
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
{- git-annex assistant webapp notifications
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||||
|
||||
module Assistant.WebApp.Notifications where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.WebApp
|
||||
import Assistant.DaemonStatus
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
{- Add to any widget to make it auto-update using long polling.
|
||||
-
|
||||
- The widget should have a html element with an id=ident, which will be
|
||||
- replaced when it's updated.
|
||||
-
|
||||
- The geturl route should return the notifier url to use for polling.
|
||||
-
|
||||
- ms_delay is how long to delay between AJAX updates
|
||||
- ms_startdelay is how long to delay before updating with AJAX at the start
|
||||
-}
|
||||
autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget
|
||||
autoUpdate ident geturl ms_delay ms_startdelay = do
|
||||
let delay = show ms_delay
|
||||
let startdelay = show ms_startdelay
|
||||
addScript $ StaticR longpolling_js
|
||||
$(widgetFile "longpolling")
|
||||
|
||||
{- Notifier urls are requested by the javascript, to avoid allocation
|
||||
- of NotificationIds when noscript pages are loaded. This constructs a
|
||||
- notifier url for a given Route and NotificationBroadcaster.
|
||||
-}
|
||||
notifierUrl :: (NotificationId -> Route WebApp) -> (DaemonStatus -> NotificationBroadcaster) -> Handler RepPlain
|
||||
notifierUrl route selector = do
|
||||
(urlbits, _params) <- renderRoute . route <$> newNotifier selector
|
||||
webapp <- getYesod
|
||||
return $ RepPlain $ toContent $ T.concat
|
||||
[ "/"
|
||||
, T.intercalate "/" urlbits
|
||||
, "?auth="
|
||||
, secretToken webapp
|
||||
]
|
||||
|
||||
getNotifierTransfersR :: Handler RepPlain
|
||||
getNotifierTransfersR = notifierUrl TransfersR transferNotifier
|
||||
|
||||
getNotifierSideBarR :: Handler RepPlain
|
||||
getNotifierSideBarR = notifierUrl SideBarR alertNotifier
|
||||
84
Assistant/WebApp/SideBar.hs
Normal file
84
Assistant/WebApp/SideBar.hs
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
{- git-annex assistant webapp sidebar
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||||
|
||||
module Assistant.WebApp.SideBar where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.WebApp
|
||||
import Assistant.WebApp.Notifications
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.Alert hiding (Widget)
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Map as M
|
||||
|
||||
sideBarDisplay :: Widget
|
||||
sideBarDisplay = do
|
||||
let content = do
|
||||
{- Any yesod message appears as the first alert. -}
|
||||
maybe noop rendermessage =<< lift getMessage
|
||||
|
||||
{- Add newest alerts to the sidebar. -}
|
||||
webapp <- lift getYesod
|
||||
alertpairs <- M.toList . alertMap
|
||||
<$> liftIO (getDaemonStatus $ daemonStatus webapp)
|
||||
mapM_ renderalert $
|
||||
take displayAlerts $ reverse $ sortAlertPairs alertpairs
|
||||
let ident = "sidebar"
|
||||
$(widgetFile "sidebar")
|
||||
autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
|
||||
where
|
||||
bootstrapclass Activity = "alert-info"
|
||||
bootstrapclass Warning = "alert"
|
||||
bootstrapclass Error = "alert-error"
|
||||
bootstrapclass Success = "alert-success"
|
||||
bootstrapclass Message = "alert-info"
|
||||
|
||||
renderalert (alertid, alert) = addalert
|
||||
alertid
|
||||
(alertClosable alert)
|
||||
(alertBlockDisplay alert)
|
||||
(bootstrapclass $ alertClass alert)
|
||||
(alertHeader alert)
|
||||
$ case alertMessage alert of
|
||||
StringAlert s -> [whamlet|#{s}|]
|
||||
WidgetAlert w -> w alert
|
||||
|
||||
rendermessage msg = addalert firstAlertId True False
|
||||
"alert-info" Nothing [whamlet|#{msg}|]
|
||||
|
||||
addalert :: AlertId -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget
|
||||
addalert i closable block divclass heading widget = do
|
||||
let alertid = show i
|
||||
let closealert = CloseAlert i
|
||||
$(widgetFile "alert")
|
||||
|
||||
{- Called by client to get a sidebar display.
|
||||
-
|
||||
- Returns a div, which will be inserted into the calling page.
|
||||
-
|
||||
- Note that the head of the widget is not included, only its
|
||||
- body is. To get the widget head content, the widget is also
|
||||
- inserted onto all pages.
|
||||
-}
|
||||
getSideBarR :: NotificationId -> Handler RepHtml
|
||||
getSideBarR nid = do
|
||||
waitNotifier alertNotifier nid
|
||||
|
||||
page <- widgetToPageContent sideBarDisplay
|
||||
hamletToRepHtml $ [hamlet|^{pageBody page}|]
|
||||
|
||||
{- Called by the client to close an alert. -}
|
||||
getCloseAlert :: AlertId -> Handler ()
|
||||
getCloseAlert i = do
|
||||
webapp <- getYesod
|
||||
void $ liftIO $ removeAlert (daemonStatus webapp) i
|
||||
13
Assistant/WebApp/routes
Normal file
13
Assistant/WebApp/routes
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
/ HomeR GET
|
||||
/noscript NoScriptR GET
|
||||
/noscriptauto NoScriptAutoR GET
|
||||
/config ConfigR GET
|
||||
/addrepository AddRepositoryR GET
|
||||
|
||||
/transfers/#NotificationId TransfersR GET
|
||||
/sidebar/#NotificationId SideBarR GET
|
||||
/notifier/transfers NotifierTransfersR GET
|
||||
/notifier/sidebar NotifierSideBarR GET
|
||||
/closealert/#AlertId CloseAlert GET
|
||||
|
||||
/static StaticR Static getStatic
|
||||
Loading…
Reference in a new issue