mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

webapp now displays the real running and queued transfers

Browse source 
yowza!!!
This commit is contained in:
Joey Hess 2012-07-27 11:47:34 -04:00
parent 4b8feea853
commit 0f6292920a
6 changed files with 96 additions and 58 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Assistant.hs
View file

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

8
Assistant/Threads/Transferrer.hs
View file

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

54
Assistant/Threads/WebApp.hs
View file

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

25
Assistant/TransferQueue.hs
View file

@ -9,6 +9,7 @@ module Assistant.TransferQueue (
TransferQueue, TransferQueue,
Schedule(..), Schedule(..),
newTransferQueue, newTransferQueue,
getTransferQueue,
queueTransfers, queueTransfers,
queueTransfer, queueTransfer,
queueTransferAt, queueTransferAt,
@ -24,17 +25,26 @@ import qualified Remote
import Control.Concurrent.STM import Control.Concurrent.STM
{- The transfer queue consists of a channel listing the transfers to make; {- 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 data TransferQueue = TransferQueue
{ queue :: TChan (Transfer, TransferInfo) { queue :: TChan (Transfer, TransferInfo)
, queuesize :: TVar Integer , queuesize :: TVar Integer
, queuelist :: TVar [(Transfer, TransferInfo)]
} }
data Schedule = Next | Later data Schedule = Next | Later
deriving (Eq) deriving (Eq)
newTransferQueue :: IO TransferQueue 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 :: AssociatedFile -> Remote -> TransferInfo
stubInfo f r = 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 -> TransferQueue -> Transfer -> TransferInfo -> STM ()
enqueue schedule q t info enqueue schedule q t info
| schedule == Next = go unGetTChan | schedule == Next = go unGetTChan (new:)
| otherwise = go writeTChan | otherwise = go writeTChan (\l -> l++[new])
where where
go a = do new = (t, info)
void $ a (queue q) (t, info) go modqueue modlist = do
void $ modqueue (queue q) new
void $ modifyTVar' (queuesize q) succ void $ modifyTVar' (queuesize q) succ
void $ modifyTVar' (queuelist q) modlist
{- Adds a transfer to the queue. -} {- Adds a transfer to the queue. -}
queueTransfer :: Schedule -> TransferQueue -> AssociatedFile -> Transfer -> Remote -> IO () 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 :: TransferQueue -> IO (Transfer, TransferInfo)
getNextTransfer q = atomically $ do getNextTransfer q = atomically $ do
void $ modifyTVar' (queuesize q) pred void $ modifyTVar' (queuesize q) pred
void $ modifyTVar' (queuelist q) (drop 1)
readTChan (queue q) readTChan (queue q)

17
Logs/Transfer.hs
View file

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

48
templates/status.hamlet
View file

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