split remaining assistant types

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

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

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

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

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

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

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

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
 

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

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

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. 

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

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

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

Assistant/WebApp/Configurators/Pairing.hs

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

Assistant/WebApp/Configurators/XMPP.hs

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

Assistant/WebApp/SideBar.hs

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

Assistant/WebApp/Utility.hs

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

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