webapp now displays the real running and queued transfers

yowza!!!

3 files changed, 57 insertions, 30 deletions

diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index 4ee5290e1..d8a146948 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/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)
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 050d62cf1..171c7fd9c 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/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. -}
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 9f0ea5cbe..414a1f9be 100644
--- a/Assistant/TransferQueue.hs
+++ b/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)