diff options
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/Threads/Transferrer.hs | 8 | ||||
-rw-r--r-- | Assistant/Threads/WebApp.hs | 54 | ||||
-rw-r--r-- | Assistant/TransferQueue.hs | 25 |
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) |