webapp now displays the real running and queued transfers

yowza!!!

Assistant.hs

@@ -155,7 +155,7 @@ startDaemon assistant foreground
 				, mountWatcherThread st dstatus scanremotes
 				, transferScannerThread st scanremotes transferqueue
 #ifdef WITH_WEBAPP
-				, webAppThread st dstatus
+				, webAppThread st dstatus transferqueue
 #endif
 				, watchThread st dstatus transferqueue changechan
 				]

Assistant/Threads/Transferrer.hs

@@ -38,7 +38,7 @@ transfererThread st dstatus transferqueue slots = go
 			ifM (runThreadState st $ shouldTransfer dstatus t info)
 				( do
 					debug thisThread [ "Transferring:" , show t ]
-					runTransfer st dstatus slots t info
+					transferThread st dstatus slots t info
 				, debug thisThread [ "Skipping unnecessary transfer:" , show t ]
 				)
 			go
@@ -76,8 +76,8 @@ shouldTransfer dstatus t info =
  - thread's cache must be invalidated once a transfer completes, as
  - changes may have been made to the git-annex branch.
  -}
-runTransfer :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO ()
-runTransfer st dstatus slots t info = case (transferRemote info, associatedFile info) of
+transferThread :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO ()
+transferThread st dstatus slots t info = case (transferRemote info, associatedFile info) of
 	(Nothing, _) -> noop
 	(_, Nothing) -> noop
 	(Just remote, Just file) -> do
@@ -99,7 +99,7 @@ runTransfer st dstatus slots t info = case (transferRemote info, associatedFile
 		transferprocess remote file = do
 			showStart "copy" file
 			showAction $ tofrom ++ " " ++ Remote.name remote
-			ok <- transfer t (Just file) $
+			ok <- runTransfer t (Just file) $
 				if isdownload
 					then getViaTmp key $
 						Remote.retrieveKeyFile remote key (Just file)

Assistant/Threads/WebApp.hs

@@ -12,19 +12,26 @@ module Assistant.Threads.WebApp where
 import Assistant.Common
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
+import Assistant.TransferQueue
 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 Yesod
 import Yesod.Static
 import Text.Hamlet
 import Network.Socket (PortNumber)
 import Text.Blaze.Renderer.String
-import Data.Text
+import Data.Text (Text, pack, unpack)
 import Data.Time.Clock
+import qualified Data.Map as M
 
 thisThread :: String
 thisThread = "WebApp"
@@ -32,6 +39,7 @@ thisThread = "WebApp"
 data WebApp = WebApp
 	{ threadState :: ThreadState
 	, daemonStatus :: DaemonStatusHandle
+	, transferQueue :: TransferQueue
 	, secretToken :: Text
 	, baseTitle :: String
 	, getStatic :: Static
@@ -104,6 +112,12 @@ statusDisplay = do
 	webapp <- lift getYesod
 	time <- show <$> liftIO getCurrentTime
 	
+	current <- liftIO $ runThreadState (threadState webapp) $
+		M.toList . currentTransfers
+			<$> getDaemonStatus (daemonStatus webapp)
+	queued <- liftIO $ getTransferQueue $ transferQueue webapp
+	let transfers = current ++ queued
+
 	updating <- lift newIdent
 	$(widgetFile "status")
 	
@@ -131,31 +145,31 @@ getConfigR = defaultLayout $ do
 	setTitle "configuration"
 	[whamlet|<a href="@{HomeR}">main|]
 
-webAppThread :: ThreadState -> DaemonStatusHandle -> IO ()
-webAppThread st dstatus = do
-	webapp <- mkWebApp st dstatus
+webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> IO ()
+webAppThread st dstatus transferqueue = do
+	webapp <- mkWebApp
 	app <- toWaiAppPlain webapp
 	app' <- ifM debugEnabled
 		( return $ httpDebugLogger app
 		, return app
 		)
 	runWebApp app' $ \port -> runThreadState st $ writeHtmlShim webapp port
-
-mkWebApp :: ThreadState -> DaemonStatusHandle -> IO WebApp
-mkWebApp st dstatus = do
-	dir <- absPath =<< runThreadState st (fromRepo repoPath)
-	home <- myHomeDir
-	let reldir = if dirContains home dir
-		then relPathDirToFile home dir
-		else dir
-	token <- genRandomToken 
-	return $ WebApp 
-		{ threadState = st
-		, daemonStatus = dstatus
-		, secretToken = pack token
-		, baseTitle = reldir
-		, getStatic = $(embed "static")
-		}
+	where
+		mkWebApp = do
+			dir <- absPath =<< runThreadState st (fromRepo repoPath)
+			home <- myHomeDir
+			let reldir = if dirContains home dir
+				then relPathDirToFile home dir
+				else dir
+			token <- genRandomToken 
+			return $ WebApp 
+				{ threadState = st
+				, daemonStatus = dstatus
+				, transferQueue = transferqueue
+				, secretToken = pack token
+				, baseTitle = reldir
+				, getStatic = $(embed "static")
+				}
 
 {- Creates a html shim file that's used to redirect into the webapp,
  - to avoid exposing the secretToken when launching the web browser. -}

Assistant/TransferQueue.hs

@@ -9,6 +9,7 @@ module Assistant.TransferQueue (
 	TransferQueue,
 	Schedule(..),
 	newTransferQueue,
+	getTransferQueue,
 	queueTransfers,
 	queueTransfer,
 	queueTransferAt,
@@ -24,17 +25,26 @@ import qualified Remote
 import Control.Concurrent.STM
 
 {- The transfer queue consists of a channel listing the transfers to make;
- - the size of the queue is also tracked -}
+ - the size of the queue is also tracked, and a list is maintained
+ - in parallel to allow for reading. -}
 data TransferQueue = TransferQueue
 	{ queue :: TChan (Transfer, TransferInfo)
 	, queuesize :: TVar Integer
+	, queuelist :: TVar [(Transfer, TransferInfo)]
 	}
 
 data Schedule = Next | Later
 	deriving (Eq)
 
 newTransferQueue :: IO TransferQueue
-newTransferQueue = atomically $ TransferQueue <$> newTChan <*> newTVar 0
+newTransferQueue = atomically $ TransferQueue
+	<$> newTChan
+	<*> newTVar 0
+	<*> newTVar []
+
+{- Reads the queue's content without blocking or changing it. -}
+getTransferQueue :: TransferQueue -> IO [(Transfer, TransferInfo)]
+getTransferQueue q = atomically $ readTVar $ queuelist q
 
 stubInfo :: AssociatedFile -> Remote -> TransferInfo
 stubInfo f r = TransferInfo
@@ -75,12 +85,14 @@ queueTransfers schedule q daemonstatus k f direction = do
 
 enqueue :: Schedule -> TransferQueue -> Transfer -> TransferInfo -> STM ()
 enqueue schedule q t info
-	| schedule == Next = go unGetTChan
-	| otherwise = go writeTChan
+	| schedule == Next = go unGetTChan (new:)
+	| otherwise = go writeTChan (\l -> l++[new])
 	where
-		go a = do
-			void $ a (queue q) (t, info)
+		new = (t, info)
+		go modqueue modlist = do
+			void $ modqueue (queue q) new
 			void $ modifyTVar' (queuesize q) succ
+			void $ modifyTVar' (queuelist q) modlist
 
 {- Adds a transfer to the queue. -}
 queueTransfer :: Schedule -> TransferQueue -> AssociatedFile -> Transfer -> Remote -> IO ()
@@ -100,4 +112,5 @@ queueTransferAt wantsz schedule q f t remote = atomically $ do
 getNextTransfer :: TransferQueue -> IO (Transfer, TransferInfo)
 getNextTransfer q = atomically $ do
 	void $ modifyTVar' (queuesize q) pred
+	void $ modifyTVar' (queuelist q) (drop 1)
 	readTChan (queue q)

Logs/Transfer.hs

@@ -12,7 +12,9 @@ import Annex.Perms
 import Annex.Exception
 import qualified Git
 import Types.Remote
+import Types.Key
 import qualified Fields
+import Utility.Percentage
 
 import System.Posix.Types
 import Data.Time.Clock
@@ -58,24 +60,29 @@ readDirection "upload" = Just Upload
 readDirection "download" = Just Download
 readDirection _ = Nothing
 
+percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
+percentComplete (Transfer { transferKey = key }) (TransferInfo { bytesComplete = Just complete }) =
+	(\size -> percentage size complete) <$> keySize key
+percentComplete _ _ = Nothing
+
 upload :: UUID -> Key -> AssociatedFile -> Annex a -> Annex a
-upload u key file a = transfer (Transfer Upload u key) file a
+upload u key file a = runTransfer (Transfer Upload u key) file a
 
 download :: UUID -> Key -> AssociatedFile -> Annex a -> Annex a
-download u key file a = transfer (Transfer Download u key) file a
+download u key file a = runTransfer (Transfer Download u key) file a
 
 fieldTransfer :: Direction -> Key -> Annex a -> Annex a
 fieldTransfer direction key a = do
 	afile <- Fields.getField Fields.associatedFile
-	maybe a (\u -> transfer (Transfer direction (toUUID u) key) afile a)
+	maybe a (\u -> runTransfer (Transfer direction (toUUID u) key) afile a)
 		=<< Fields.getField Fields.remoteUUID
 
 {- Runs a transfer action. Creates and locks the lock file while the
  - action is running, and stores info in the transfer information
  - file. Will throw an error if the transfer is already in progress.
  -}
-transfer :: Transfer -> Maybe FilePath -> Annex a -> Annex a
-transfer t file a = do
+runTransfer :: Transfer -> Maybe FilePath -> Annex a -> Annex a
+runTransfer t file a = do
 	tfile <- fromRepo $ transferFile t
 	createAnnexDirectory $ takeDirectory tfile
 	mode <- annexFileMode

templates/status.hamlet

@@ -1,26 +1,30 @@
 <span id="#{updating}">
-  <div class="hero-unit">
-    <div class="row-fluid">
-      <h3>
-        foo &larr;
-        <small>usb drive</small>
-        <small class="pull-right">40% of 10 mb</small>
-    <div class="progress progress-striped">
-      <div class="bar" style="width: 40%;">
-    <div class="row-fluid">
-      <h3>
-        some_filenames_are_long_and_ugly_like_this_one.mp3 &rarr;
-        <small>Amazon S3</small>
-        <small class="pull-right">10% of 50 mb</small>
-    <div class="progress progress-striped">
-      <div class="bar" style="width: 10%;">
-    <div class="row-fluid">
-      <h3>
-        bigfile &larr;
-        <small>usb drive</small>
-        <small class="pull-right">0% of 512 mb</small>
-    <div class="progress progress-striped">
-      <div class="bar" style="width: 0%;">
+  <div class="span9">
+    $if null transfers
+      <h2>No current transfers
+    $else
+      <h2>Transfers
+      $forall (transfer, info) <- transfers
+        $with percent <- maybe "unknown" (showPercentage 0) $ percentComplete transfer info
+          <div class="row-fluid">
+            <h3>
+              $maybe file <- associatedFile info
+                #{file}
+              $nothing
+                #{show $ transferKey transfer}
+              $case transferDirection transfer
+                $of Upload
+                  &rarr;
+                $of Download
+                  &larr;
+              <small>#{maybe "unknown" Remote.name $ transferRemote info}</small>
+                $with size <- maybe "unknown" (roughSize dataUnits True) $ keySize $ transferKey transfer
+                  $if isJust $ startedTime info
+                      <small class="pull-right"><b>#{percent} of #{size}</b></small>
+                  $else
+                      <small class="pull-right">queued (#{size})</small>
+          <div class="progress progress-striped">
+            <div class="bar" style="width: #{percent};">
   <footer>
     <span>
       polled at #{time}