webapp now displays the real running and queued transfers
yowza!!!
This commit is contained in:
parent
4b8feea853
commit
0f6292920a
6 changed files with 96 additions and 58 deletions
|
@ -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
|
||||
]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,26 +1,30 @@
|
|||
<span id="#{updating}">
|
||||
<div class="hero-unit">
|
||||
<div class="row-fluid">
|
||||
<h3>
|
||||
foo ←
|
||||
<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 →
|
||||
<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 ←
|
||||
<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
|
||||
→
|
||||
$of Download
|
||||
←
|
||||
<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}
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue