From ca03b7fef80cf97e89cd785ec8393a27d5328d99 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 30 Oct 2012 14:34:48 -0400 Subject: split remaining assistant types --- Assistant.hs | 1 + Assistant/Common.hs | 95 ++------------------------------------- Assistant/DaemonStatus.hs | 58 ++++++++++++++++++++++-- Assistant/Monad.hs | 9 +--- Assistant/NamedThread.hs | 30 +++++++++++++ Assistant/Threads/Committer.hs | 1 + Assistant/Threads/PairListener.hs | 1 + Assistant/Threads/PushNotifier.hs | 1 + Assistant/Threads/Pusher.hs | 1 + Assistant/TransferQueue.hs | 16 +------ Assistant/TransferSlots.hs | 30 +------------ Assistant/Types/NamedThread.hs | 21 +++++++++ Assistant/Types/TransferQueue.hs | 29 ++++++++++++ Assistant/Types/TransferSlots.hs | 40 +++++++++++++++++ Command/WebApp.hs | 1 + 15 files changed, 188 insertions(+), 146 deletions(-) create mode 100644 Assistant/NamedThread.hs create mode 100644 Assistant/Types/NamedThread.hs create mode 100644 Assistant/Types/TransferQueue.hs create mode 100644 Assistant/Types/TransferSlots.hs diff --git a/Assistant.hs b/Assistant.hs index 3ef7c9a11..0f0b4c243 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -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 diff --git a/Assistant/Common.hs b/Assistant/Common.hs index e65564a17..0be536250 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -1,102 +1,13 @@ -{- Common infrastructure for the git-annex assistant threads. +{- Common infrastructure for the git-annex assistant. - - Copyright 2012 Joey Hess - - 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 diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 421ade975..6525247eb 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -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 diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 4286e0afb..dcb01724c 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -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 diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs new file mode 100644 index 000000000..8871ee6c8 --- /dev/null +++ b/Assistant/NamedThread.hs @@ -0,0 +1,30 @@ +{- git-annex assistant named threads. + - + - Copyright 2012 Joey Hess + - + - 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 diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 79b3812ee..d73dc1eb0 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -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 diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 70981b99e..235f7f124 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -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 diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index cbc3877bb..85c7fd9d9 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -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 diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 1dea0a79e..905cf81db 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -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 diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index daf736c13..94a294549 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -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 diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 478bb573a..1963252e0 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -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. diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs new file mode 100644 index 000000000..569f787d1 --- /dev/null +++ b/Assistant/Types/NamedThread.hs @@ -0,0 +1,21 @@ +{- git-annex assistant named threads. + - + - Copyright 2012 Joey Hess + - + - 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 diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs new file mode 100644 index 000000000..6620ebdf6 --- /dev/null +++ b/Assistant/Types/TransferQueue.hs @@ -0,0 +1,29 @@ +{- git-annex assistant pending transfer queue + - + - Copyright 2012 Joey Hess + - + - 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 [] diff --git a/Assistant/Types/TransferSlots.hs b/Assistant/Types/TransferSlots.hs new file mode 100644 index 000000000..f8673fcfc --- /dev/null +++ b/Assistant/Types/TransferSlots.hs @@ -0,0 +1,40 @@ +{- git-annex assistant transfer slots + - + - Copyright 2012 Joey Hess + - + - 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 diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 6a995fdca..26afa2791 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -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 -- cgit v1.2.3