webapp now displays the real running and queued transfers

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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