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
|
module Assistant.Threads.WebApp where
|
||||||
|
|
||||||
import Assistant.Common
|
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.ThreadedMonad
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import Assistant.TransferQueue
|
import Assistant.TransferQueue
|
||||||
import Assistant.Alert hiding (Widget)
|
|
||||||
import Utility.NotificationBroadcaster
|
|
||||||
import Utility.WebApp
|
import Utility.WebApp
|
||||||
import Utility.Yesod
|
import Utility.Yesod
|
||||||
import Utility.FileMode
|
import Utility.FileMode
|
||||||
import Utility.TempFile
|
import Utility.TempFile
|
||||||
import Git
|
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
|
||||||
import Yesod.Static
|
import Yesod.Static
|
||||||
import Text.Hamlet
|
import Text.Hamlet
|
||||||
import Network.Socket (PortNumber)
|
import Network.Socket (PortNumber)
|
||||||
import Text.Blaze.Renderer.String
|
import Text.Blaze.Renderer.String
|
||||||
import Data.Text (Text, pack, unpack)
|
import Data.Text (pack, unpack)
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Control.Concurrent.STM
|
|
||||||
|
|
||||||
thisThread :: String
|
thisThread :: String
|
||||||
thisThread = "WebApp"
|
thisThread = "WebApp"
|
||||||
|
|
||||||
data WebApp = WebApp
|
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
|
||||||
{ 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|]
|
|
||||||
|
|
||||||
webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO ()
|
webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO ()
|
||||||
webAppThread st dstatus transferqueue onstartup = do
|
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…
Add table
Add a link
Reference in a new issue