add intro

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,

Remote.hs

@@ -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

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}

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.

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>