split remaining assistant types
This commit is contained in:
parent
f78ca9bc58
commit
68118b8986
19 changed files with 192 additions and 146 deletions
|
@ -119,6 +119,7 @@ module Assistant where
|
|||
|
||||
import Assistant.Common
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.NamedThread
|
||||
import Assistant.Types.ThreadedMonad
|
||||
import Assistant.Threads.DaemonStatus
|
||||
import Assistant.Threads.Watcher
|
||||
|
|
|
@ -1,102 +1,13 @@
|
|||
{- Common infrastructure for the git-annex assistant threads.
|
||||
{- Common infrastructure for the git-annex assistant.
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.Common (
|
||||
module X,
|
||||
ThreadName,
|
||||
NamedThread(..),
|
||||
runNamedThread,
|
||||
debug,
|
||||
addAlert,
|
||||
removeAlert,
|
||||
alertWhile,
|
||||
alertWhile',
|
||||
alertDuring,
|
||||
) where
|
||||
module Assistant.Common (module X) where
|
||||
|
||||
import Common.Annex as X
|
||||
import Assistant.Monad as X
|
||||
import Assistant.Types.DaemonStatus as X
|
||||
import Assistant.Alert
|
||||
import Assistant.DaemonStatus
|
||||
|
||||
import System.Log.Logger
|
||||
import qualified Control.Exception as E
|
||||
import qualified Data.Map as M
|
||||
|
||||
type ThreadName = String
|
||||
data NamedThread = NamedThread ThreadName (Assistant ())
|
||||
|
||||
debug :: [String] -> Assistant ()
|
||||
debug ws = do
|
||||
name <- getAssistant threadName
|
||||
liftIO $ debugM name $ unwords $ (name ++ ":") : ws
|
||||
|
||||
runNamedThread :: NamedThread -> Assistant ()
|
||||
runNamedThread (NamedThread name a) = do
|
||||
d <- getAssistant id
|
||||
liftIO . go $ d { threadName = name }
|
||||
where
|
||||
go d = do
|
||||
r <- E.try (runAssistant a d) :: IO (Either E.SomeException ())
|
||||
case r of
|
||||
Right _ -> noop
|
||||
Left e -> do
|
||||
let msg = unwords [name, "crashed:", show e]
|
||||
hPutStrLn stderr msg
|
||||
-- TODO click to restart
|
||||
void $ addAlert (daemonStatusHandle d) $
|
||||
warningAlert name msg
|
||||
|
||||
{- Returns the alert's identifier, which can be used to remove it. -}
|
||||
addAlert :: DaemonStatusHandle -> Alert -> IO AlertId
|
||||
addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus go
|
||||
where
|
||||
go s = (s { lastAlertId = i, alertMap = m }, i)
|
||||
where
|
||||
i = nextAlertId $ lastAlertId s
|
||||
m = mergeAlert i alert (alertMap s)
|
||||
|
||||
removeAlert :: DaemonStatusHandle -> AlertId -> IO ()
|
||||
removeAlert dstatus i = updateAlert dstatus i (const Nothing)
|
||||
|
||||
updateAlert :: DaemonStatusHandle -> AlertId -> (Alert -> Maybe Alert) -> IO ()
|
||||
updateAlert dstatus i a = updateAlertMap dstatus $ \m -> M.update a i m
|
||||
|
||||
updateAlertMap :: DaemonStatusHandle -> (AlertMap -> AlertMap) -> IO ()
|
||||
updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go
|
||||
where
|
||||
go s = s { alertMap = a (alertMap s) }
|
||||
|
||||
{- Displays an alert while performing an activity that returns True on
|
||||
- success.
|
||||
-
|
||||
- The alert is left visible afterwards, as filler.
|
||||
- Old filler is pruned, to prevent the map growing too large. -}
|
||||
alertWhile :: Alert -> Assistant Bool -> Assistant Bool
|
||||
alertWhile alert a = alertWhile' alert $ do
|
||||
r <- a
|
||||
return (r, r)
|
||||
|
||||
{- Like alertWhile, but allows the activity to return a value too. -}
|
||||
alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
|
||||
alertWhile' alert a = do
|
||||
let alert' = alert { alertClass = Activity }
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
i <- liftIO $ addAlert dstatus alert'
|
||||
(ok, r) <- a
|
||||
liftIO $ updateAlertMap dstatus $
|
||||
mergeAlert i $ makeAlertFiller ok alert'
|
||||
return r
|
||||
|
||||
{- Displays an alert while performing an activity, then removes it. -}
|
||||
alertDuring :: Alert -> Assistant a -> Assistant a
|
||||
alertDuring alert a = do
|
||||
let alert' = alert { alertClass = Activity }
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
i <- liftIO $ addAlert dstatus alert'
|
||||
liftIO (removeAlert dstatus i) `after` a
|
||||
import Assistant.Types.NamedThread as X
|
||||
|
|
|
@ -5,12 +5,10 @@
|
|||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes #-}
|
||||
|
||||
module Assistant.DaemonStatus where
|
||||
|
||||
import Common.Annex
|
||||
import Assistant.Types.DaemonStatus
|
||||
import Assistant.Common
|
||||
import Assistant.Alert
|
||||
import Utility.TempFile
|
||||
import Utility.NotificationBroadcaster
|
||||
import Logs.Transfer
|
||||
|
@ -26,6 +24,9 @@ import Data.Time
|
|||
import System.Locale
|
||||
import qualified Data.Map as M
|
||||
|
||||
daemonStatus :: Assistant DaemonStatus
|
||||
daemonStatus = getDaemonStatus <<~ daemonStatusHandle
|
||||
|
||||
getDaemonStatus :: DaemonStatusHandle -> IO DaemonStatus
|
||||
getDaemonStatus = atomically . readTMVar
|
||||
|
||||
|
@ -176,3 +177,52 @@ notifyTransfer dstatus = sendNotification
|
|||
notifyAlert :: DaemonStatusHandle -> IO ()
|
||||
notifyAlert dstatus = sendNotification
|
||||
=<< alertNotifier <$> atomically (readTMVar dstatus)
|
||||
|
||||
{- Returns the alert's identifier, which can be used to remove it. -}
|
||||
addAlert :: DaemonStatusHandle -> Alert -> IO AlertId
|
||||
addAlert dstatus alert = notifyAlert dstatus `after` modifyDaemonStatus dstatus go
|
||||
where
|
||||
go s = (s { lastAlertId = i, alertMap = m }, i)
|
||||
where
|
||||
i = nextAlertId $ lastAlertId s
|
||||
m = mergeAlert i alert (alertMap s)
|
||||
|
||||
removeAlert :: DaemonStatusHandle -> AlertId -> IO ()
|
||||
removeAlert dstatus i = updateAlert dstatus i (const Nothing)
|
||||
|
||||
updateAlert :: DaemonStatusHandle -> AlertId -> (Alert -> Maybe Alert) -> IO ()
|
||||
updateAlert dstatus i a = updateAlertMap dstatus $ \m -> M.update a i m
|
||||
|
||||
updateAlertMap :: DaemonStatusHandle -> (AlertMap -> AlertMap) -> IO ()
|
||||
updateAlertMap dstatus a = notifyAlert dstatus `after` modifyDaemonStatus_ dstatus go
|
||||
where
|
||||
go s = s { alertMap = a (alertMap s) }
|
||||
|
||||
{- Displays an alert while performing an activity that returns True on
|
||||
- success.
|
||||
-
|
||||
- The alert is left visible afterwards, as filler.
|
||||
- Old filler is pruned, to prevent the map growing too large. -}
|
||||
alertWhile :: Alert -> Assistant Bool -> Assistant Bool
|
||||
alertWhile alert a = alertWhile' alert $ do
|
||||
r <- a
|
||||
return (r, r)
|
||||
|
||||
{- Like alertWhile, but allows the activity to return a value too. -}
|
||||
alertWhile' :: Alert -> Assistant (Bool, a) -> Assistant a
|
||||
alertWhile' alert a = do
|
||||
let alert' = alert { alertClass = Activity }
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
i <- liftIO $ addAlert dstatus alert'
|
||||
(ok, r) <- a
|
||||
liftIO $ updateAlertMap dstatus $
|
||||
mergeAlert i $ makeAlertFiller ok alert'
|
||||
return r
|
||||
|
||||
{- Displays an alert while performing an activity, then removes it. -}
|
||||
alertDuring :: Alert -> Assistant a -> Assistant a
|
||||
alertDuring alert a = do
|
||||
let alert' = alert { alertClass = Activity }
|
||||
dstatus <- getAssistant daemonStatusHandle
|
||||
i <- liftIO $ addAlert dstatus alert'
|
||||
liftIO (removeAlert dstatus i) `after` a
|
||||
|
|
|
@ -17,7 +17,6 @@ module Assistant.Monad (
|
|||
liftAnnex,
|
||||
(<~>),
|
||||
(<<~),
|
||||
daemonStatus,
|
||||
asIO,
|
||||
asIO2,
|
||||
) where
|
||||
|
@ -28,10 +27,9 @@ import Control.Monad.Base (liftBase, MonadBase)
|
|||
import Common.Annex
|
||||
import Assistant.Types.ThreadedMonad
|
||||
import Assistant.Types.DaemonStatus
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.Types.ScanRemotes
|
||||
import Assistant.TransferQueue
|
||||
import Assistant.TransferSlots
|
||||
import Assistant.Types.TransferQueue
|
||||
import Assistant.Types.TransferSlots
|
||||
import Assistant.Types.Pushes
|
||||
import Assistant.Types.BranchChange
|
||||
import Assistant.Types.Commits
|
||||
|
@ -115,6 +113,3 @@ io <<~ v = reader v >>= liftIO . io
|
|||
|
||||
withAssistant :: (AssistantData -> a) -> (a -> IO b) -> Assistant b
|
||||
withAssistant v io = io <<~ v
|
||||
|
||||
daemonStatus :: Assistant DaemonStatus
|
||||
daemonStatus = getDaemonStatus <<~ daemonStatusHandle
|
||||
|
|
30
Assistant/NamedThread.hs
Normal file
30
Assistant/NamedThread.hs
Normal file
|
@ -0,0 +1,30 @@
|
|||
{- git-annex assistant named threads.
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.NamedThread where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.Alert
|
||||
|
||||
import qualified Control.Exception as E
|
||||
|
||||
runNamedThread :: NamedThread -> Assistant ()
|
||||
runNamedThread (NamedThread name a) = do
|
||||
d <- getAssistant id
|
||||
liftIO . go $ d { threadName = name }
|
||||
where
|
||||
go d = do
|
||||
r <- E.try (runAssistant a d) :: IO (Either E.SomeException ())
|
||||
case r of
|
||||
Right _ -> noop
|
||||
Left e -> do
|
||||
let msg = unwords [name, "crashed:", show e]
|
||||
hPutStrLn stderr msg
|
||||
-- TODO click to restart
|
||||
void $ addAlert (daemonStatusHandle d) $
|
||||
warningAlert name msg
|
|
@ -14,6 +14,7 @@ import Assistant.Changes
|
|||
import Assistant.Types.Changes
|
||||
import Assistant.Commits
|
||||
import Assistant.Alert
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.Threads.Watcher
|
||||
import Assistant.TransferQueue
|
||||
import Logs.Transfer
|
||||
|
|
|
@ -14,6 +14,7 @@ import Assistant.Pairing.MakeRemote
|
|||
import Assistant.WebApp
|
||||
import Assistant.WebApp.Types
|
||||
import Assistant.Alert
|
||||
import Assistant.DaemonStatus
|
||||
import Utility.ThreadScheduler
|
||||
|
||||
import Network.Multicast
|
||||
|
|
|
@ -14,6 +14,7 @@ import Assistant.Common
|
|||
import Assistant.XMPP
|
||||
import Assistant.Pushes
|
||||
import Assistant.Sync
|
||||
import Assistant.DaemonStatus
|
||||
import qualified Remote
|
||||
import Utility.ThreadScheduler
|
||||
|
||||
|
|
|
@ -12,6 +12,7 @@ import Assistant.Commits
|
|||
import Assistant.Types.Commits
|
||||
import Assistant.Pushes
|
||||
import Assistant.Alert
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.Sync
|
||||
import Utility.ThreadScheduler
|
||||
import qualified Remote
|
||||
|
|
|
@ -24,6 +24,7 @@ module Assistant.TransferQueue (
|
|||
import Common.Annex
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.Types.DaemonStatus
|
||||
import Assistant.Types.TransferQueue
|
||||
import Logs.Transfer
|
||||
import Types.Remote
|
||||
import qualified Remote
|
||||
|
@ -33,21 +34,6 @@ import Annex.Wanted
|
|||
import Control.Concurrent.STM
|
||||
import qualified Data.Map as M
|
||||
|
||||
data TransferQueue = TransferQueue
|
||||
{ queuesize :: TVar Int
|
||||
, queuelist :: TVar [(Transfer, TransferInfo)]
|
||||
, deferreddownloads :: TVar [(Key, AssociatedFile)]
|
||||
}
|
||||
|
||||
data Schedule = Next | Later
|
||||
deriving (Eq)
|
||||
|
||||
newTransferQueue :: IO TransferQueue
|
||||
newTransferQueue = atomically $ TransferQueue
|
||||
<$> newTVar 0
|
||||
<*> newTVar []
|
||||
<*> newTVar []
|
||||
|
||||
{- Reads the queue's content without blocking or changing it. -}
|
||||
getTransferQueue :: TransferQueue -> IO [(Transfer, TransferInfo)]
|
||||
getTransferQueue q = atomically $ readTVar $ queuelist q
|
||||
|
|
|
@ -5,43 +5,17 @@
|
|||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
module Assistant.TransferSlots where
|
||||
|
||||
import Common.Annex
|
||||
import Assistant.Common
|
||||
import Utility.ThreadScheduler
|
||||
import Assistant.Types.TransferSlots
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.Types.DaemonStatus
|
||||
import Logs.Transfer
|
||||
|
||||
import qualified Control.Exception as E
|
||||
import Control.Concurrent
|
||||
import qualified Control.Concurrent.MSemN as MSemN
|
||||
import Data.Typeable
|
||||
|
||||
type TransferSlots = MSemN.MSemN Int
|
||||
|
||||
{- A special exception that can be thrown to pause or resume a transfer, while
|
||||
- keeping its slot in use. -}
|
||||
data TransferException = PauseTransfer | ResumeTransfer
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
instance E.Exception TransferException
|
||||
|
||||
type TransferSlotRunner = DaemonStatusHandle -> TransferSlots -> TransferGenerator -> IO ()
|
||||
type TransferGenerator = IO (Maybe (Transfer, TransferInfo, IO ()))
|
||||
|
||||
{- Number of concurrent transfers allowed to be run from the assistant.
|
||||
-
|
||||
- Transfers launched by other means, including by remote assistants,
|
||||
- do not currently take up slots.
|
||||
-}
|
||||
numSlots :: Int
|
||||
numSlots = 1
|
||||
|
||||
newTransferSlots :: IO TransferSlots
|
||||
newTransferSlots = MSemN.new numSlots
|
||||
|
||||
{- Waits until a transfer slot becomes available, then runs a
|
||||
- TransferGenerator, and then runs the transfer action in its own thread.
|
||||
|
|
21
Assistant/Types/NamedThread.hs
Normal file
21
Assistant/Types/NamedThread.hs
Normal file
|
@ -0,0 +1,21 @@
|
|||
{- git-annex assistant named threads.
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.Types.NamedThread where
|
||||
|
||||
import Common.Annex
|
||||
import Assistant.Monad
|
||||
|
||||
import System.Log.Logger
|
||||
|
||||
type ThreadName = String
|
||||
data NamedThread = NamedThread ThreadName (Assistant ())
|
||||
|
||||
debug :: [String] -> Assistant ()
|
||||
debug ws = do
|
||||
name <- getAssistant threadName
|
||||
liftIO $ debugM name $ unwords $ (name ++ ":") : ws
|
29
Assistant/Types/TransferQueue.hs
Normal file
29
Assistant/Types/TransferQueue.hs
Normal file
|
@ -0,0 +1,29 @@
|
|||
{- git-annex assistant pending transfer queue
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Assistant.Types.TransferQueue where
|
||||
|
||||
import Common.Annex
|
||||
import Logs.Transfer
|
||||
import Types.Remote
|
||||
|
||||
import Control.Concurrent.STM
|
||||
|
||||
data TransferQueue = TransferQueue
|
||||
{ queuesize :: TVar Int
|
||||
, queuelist :: TVar [(Transfer, TransferInfo)]
|
||||
, deferreddownloads :: TVar [(Key, AssociatedFile)]
|
||||
}
|
||||
|
||||
data Schedule = Next | Later
|
||||
deriving (Eq)
|
||||
|
||||
newTransferQueue :: IO TransferQueue
|
||||
newTransferQueue = atomically $ TransferQueue
|
||||
<$> newTVar 0
|
||||
<*> newTVar []
|
||||
<*> newTVar []
|
40
Assistant/Types/TransferSlots.hs
Normal file
40
Assistant/Types/TransferSlots.hs
Normal file
|
@ -0,0 +1,40 @@
|
|||
{- git-annex assistant transfer slots
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
module Assistant.Types.TransferSlots where
|
||||
|
||||
import Assistant.Types.DaemonStatus
|
||||
import Logs.Transfer
|
||||
|
||||
import qualified Control.Exception as E
|
||||
import qualified Control.Concurrent.MSemN as MSemN
|
||||
import Data.Typeable
|
||||
|
||||
type TransferSlots = MSemN.MSemN Int
|
||||
|
||||
{- A special exception that can be thrown to pause or resume a transfer, while
|
||||
- keeping its slot in use. -}
|
||||
data TransferException = PauseTransfer | ResumeTransfer
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
instance E.Exception TransferException
|
||||
|
||||
type TransferSlotRunner = DaemonStatusHandle -> TransferSlots -> TransferGenerator -> IO ()
|
||||
type TransferGenerator = IO (Maybe (Transfer, TransferInfo, IO ()))
|
||||
|
||||
{- Number of concurrent transfers allowed to be run from the assistant.
|
||||
-
|
||||
- Transfers launched by other means, including by remote assistants,
|
||||
- do not currently take up slots.
|
||||
-}
|
||||
numSlots :: Int
|
||||
numSlots = 1
|
||||
|
||||
newTransferSlots :: IO TransferSlots
|
||||
newTransferSlots = MSemN.new numSlots
|
|
@ -21,6 +21,7 @@ import Assistant.Pairing.Network
|
|||
import Assistant.Pairing.MakeRemote
|
||||
import Assistant.Ssh
|
||||
import Assistant.Alert
|
||||
import Assistant.DaemonStatus
|
||||
import Utility.Verifiable
|
||||
import Utility.Network
|
||||
import Annex.UUID
|
||||
|
|
|
@ -14,6 +14,7 @@ import Assistant.WebApp
|
|||
import Assistant.WebApp.Types
|
||||
import Assistant.WebApp.SideBar
|
||||
import Assistant.Alert
|
||||
import Assistant.DaemonStatus
|
||||
import Utility.Yesod
|
||||
#ifdef WITH_XMPP
|
||||
import Assistant.Common
|
||||
|
|
|
@ -14,6 +14,7 @@ import Assistant.WebApp
|
|||
import Assistant.WebApp.Types
|
||||
import Assistant.WebApp.Notifications
|
||||
import Assistant.Alert
|
||||
import Assistant.DaemonStatus
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
|
||||
|
|
|
@ -12,6 +12,7 @@ import Assistant.WebApp
|
|||
import Assistant.WebApp.Types
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.TransferQueue
|
||||
import Assistant.Types.TransferSlots
|
||||
import Assistant.TransferSlots
|
||||
import Assistant.Sync
|
||||
import qualified Remote
|
||||
|
|
|
@ -11,6 +11,7 @@ import Common.Annex
|
|||
import Command
|
||||
import Assistant
|
||||
import Assistant.Common
|
||||
import Assistant.NamedThread
|
||||
import Assistant.Threads.WebApp
|
||||
import Assistant.WebApp
|
||||
import Assistant.Install
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue