diff options
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 66 | ||||
| -rw-r--r-- | Remote.hs | 10 | ||||
| -rw-r--r-- | templates/bootstrap.hamlet | 2 | ||||
| -rw-r--r-- | templates/intro.hamlet | 23 | ||||
| -rw-r--r-- | templates/page.hamlet | 6 |
5 files changed, 97 insertions, 10 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 84b9bcd20..daddbc28c 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -26,6 +26,7 @@ import Utility.Percentage import Utility.DataUnits import Types.Key import qualified Remote +import Logs.Web (webUUID) import Yesod import Yesod.Static @@ -34,6 +35,7 @@ import Network.Socket (PortNumber) import Text.Blaze.Renderer.String import Data.Text (Text, pack, unpack) import qualified Data.Map as M +import Control.Concurrent.STM thisThread :: String thisThread = "WebApp" @@ -43,10 +45,29 @@ data WebApp = WebApp , daemonStatus :: DaemonStatusHandle , transferQueue :: TransferQueue , secretToken :: Text - , baseTitle :: String + , 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 @@ -71,6 +92,7 @@ mkYesod "WebApp" [parseRoutes| /transfers/#NotificationId TransfersR GET /sidebar/#NotificationId SideBarR GET /config ConfigR GET +/addrepository AddRepositoryR GET /static StaticR Static getStatic |] @@ -119,7 +141,9 @@ autoUpdate ident gethtml ms_delay ms_startdelay = do let startdelay = show ms_startdelay $(widgetFile "longpolling") -{- A display of currently running and queued transfers. -} +{- 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 @@ -127,13 +151,35 @@ transfersDisplay warnNoScript = do M.toList . currentTransfers <$> liftIO (getDaemonStatus $ daemonStatus webapp) queued <- liftIO $ getTransferQueue $ transferQueue webapp - let transfers = current ++ queued let ident = transfersDisplayIdent - $(widgetFile "transfers") + let transfers = current ++ queued + if null transfers + then ifM (lift $ showIntro <$> getWebAppState) + ( introDisplay ident + , noop + ) + else do + lift $ modifyWebAppState $ \s -> s { showIntro = False } + $(widgetFile "transfers") transfersDisplayIdent :: Text transfersDisplayIdent = "transfers" +introDisplay :: Text -> Widget +introDisplay ident = do + webapp <- lift getYesod + let reldir = relDir webapp + remotelist <- liftIO $ runThreadState (threadState webapp) $ + Remote.prettyListUUIDs + =<< filter (/= webUUID) . nub . map Remote.uuid + <$> Remote.remoteList + let n = (length remotelist) + 1 -- plus this one + let numrepos = show n + let notenough = n < 2 + let barelyenough = n == 2 + let morethanenough = n > 2 + $(widgetFile "intro") + {- Called by client to get a display of currently in process transfers. - - Returns a div, which will be inserted into the calling page. @@ -237,7 +283,13 @@ getNoScriptR = defaultLayout $ getConfigR :: Handler RepHtml getConfigR = defaultLayout $ do sideBarDisplay False - setTitle "configuration" + setTitle "Configuration" + [whamlet|<a href="@{HomeR}">main|] + +getAddRepositoryR :: Handler RepHtml +getAddRepositoryR = defaultLayout $ do + sideBarDisplay False + setTitle "Add repository" [whamlet|<a href="@{HomeR}">main|] webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO () @@ -259,13 +311,15 @@ webAppThread st dstatus transferqueue onstartup = do then relPathDirToFile home dir else dir token <- genRandomToken + s <- newWebAppState return $ WebApp { threadState = st , daemonStatus = dstatus , transferQueue = transferqueue , secretToken = pack token - , baseTitle = reldir + , relDir = reldir , getStatic = $(embed "static") + , webAppState = s } {- Creates a html shim file that's used to redirect into the webapp, @@ -24,6 +24,7 @@ module Remote ( uuidDescriptions, byName, prettyPrintUUIDs, + prettyListUUIDs, remotesWithUUID, remotesWithoutUUID, keyLocations, @@ -128,6 +129,15 @@ prettyPrintUUIDs desc uuids = do , ("here", toJSON $ hereu == u) ] +{- List of remote names and/or descriptions, for human display. + - Omits the current repisitory. -} +prettyListUUIDs :: [UUID] -> Annex [String] +prettyListUUIDs uuids = do + hereu <- getUUID + m <- uuidDescriptions + return $ map (\u -> M.findWithDefault "" u m) $ + filter (/= hereu) uuids + {- Filters a list of remotes to ones that have the listed uuids. -} remotesWithUUID :: [Remote] -> [UUID] -> [Remote] remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs diff --git a/templates/bootstrap.hamlet b/templates/bootstrap.hamlet index 389895df7..13aefd486 100644 --- a/templates/bootstrap.hamlet +++ b/templates/bootstrap.hamlet @@ -1,7 +1,7 @@ $doctype 5 <html> <head> - <title>#{baseTitle webapp} #{pageTitle page} + <title>#{relDir webapp} #{pageTitle page} <link rel="icon" href=@{StaticR favicon_ico} type="image/x-icon"> <meta name="viewport" content="width=device-width,initial-scale=1.0"> ^{pageHead page} diff --git a/templates/intro.hamlet b/templates/intro.hamlet new file mode 100644 index 000000000..ef82df79b --- /dev/null +++ b/templates/intro.hamlet @@ -0,0 +1,23 @@ +<div .span9 ##{ident} .hero-unit> + <h2> + git-annex is watching over your files in <small><tt>#{reldir}</tt></small> + <p> + It will automatically notice changes, and keep files in sync between # + $if notenough + repositories on your devices ... + <h2> + But no other repositories are set up yet. + <a .btn .btn-primary .btn-large href="@{AddRepositoryR}">Add another repository</a> + $else + these # + $if barelyenough + <span .badge .badge-warning>#{numrepos}</span> + $else + <span .badge .badge-success>#{numrepos}</span> + \ repositories and devices: + <ul> + $forall name <- remotelist + <li>#{name} + <a .btn .btn-primary .btn-large href="@{AddRepositoryR}">Add another repository</a> + <div> + Or just sit back, watch the magic, and get on with using your files. diff --git a/templates/page.hamlet b/templates/page.hamlet index c397d248c..500424125 100644 --- a/templates/page.hamlet +++ b/templates/page.hamlet @@ -11,12 +11,12 @@ <ul .nav .pull-right> <li .dropdown #menu1> <a .dropdown-toggle data-toggle="dropdown" href="#menu1"> - Current Repository: #{baseTitle webapp} + Current Repository: #{relDir webapp} <b .caret></b> <ul .dropdown-menu> - <li><a href="#">#{baseTitle webapp}</a></li> + <li><a href="#">#{relDir webapp}</a></li> <li .divider></li> - <li><a href="#">Add new repository</a></li> + <li><a href="@{AddRepositoryR}">Add new repository</a></li> <div .container-fluid> <div .row-fluid> |