summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-10-30 14:34:48 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-10-30 14:34:48 -0400
commitca03b7fef80cf97e89cd785ec8393a27d5328d99 (patch)
tree2d28cd2db176911d2f2b49df6440e10e8eeeeccc /Assistant
parentdbf9ac41086ffb39296bd1d977cc1db844ff0b32 (diff)
split remaining assistant types
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Common.hs95
-rw-r--r--Assistant/DaemonStatus.hs58
-rw-r--r--Assistant/Monad.hs9
-rw-r--r--Assistant/NamedThread.hs30
-rw-r--r--Assistant/Threads/Committer.hs1
-rw-r--r--Assistant/Threads/PairListener.hs1
-rw-r--r--Assistant/Threads/PushNotifier.hs1
-rw-r--r--Assistant/Threads/Pusher.hs1
-rw-r--r--Assistant/TransferQueue.hs16
-rw-r--r--Assistant/TransferSlots.hs30
-rw-r--r--Assistant/Types/NamedThread.hs21
-rw-r--r--Assistant/Types/TransferQueue.hs29
-rw-r--r--Assistant/Types/TransferSlots.hs40
13 files changed, 186 insertions, 146 deletions
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 <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
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 <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
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 <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
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 <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 []
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 <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