split remaining assistant types

15 files changed, 188 insertions, 146 deletions

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