2012-10-29 04:15:43 +00:00
|
|
|
{- git-annex assistant monad
|
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
2012-10-29 04:15:43 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2012-10-29 04:15:43 +00:00
|
|
|
-}
|
|
|
|
|
2013-04-13 22:12:02 +00:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
|
2012-10-29 04:15:43 +00:00
|
|
|
|
|
|
|
module Assistant.Monad (
|
|
|
|
Assistant,
|
|
|
|
AssistantData(..),
|
|
|
|
newAssistantData,
|
|
|
|
runAssistant,
|
|
|
|
getAssistant,
|
2013-03-16 04:12:28 +00:00
|
|
|
LiftAnnex,
|
2012-10-29 06:21:04 +00:00
|
|
|
liftAnnex,
|
|
|
|
(<~>),
|
|
|
|
(<<~),
|
|
|
|
asIO,
|
2012-10-30 21:14:26 +00:00
|
|
|
asIO1,
|
2012-10-29 06:21:04 +00:00
|
|
|
asIO2,
|
2013-01-26 03:14:32 +00:00
|
|
|
ThreadName,
|
|
|
|
debug,
|
2012-10-29 04:15:43 +00:00
|
|
|
) where
|
|
|
|
|
|
|
|
import "mtl" Control.Monad.Reader
|
2019-01-05 15:54:06 +00:00
|
|
|
import qualified Control.Monad.Fail as Fail
|
2012-10-29 04:15:43 +00:00
|
|
|
|
2021-04-06 19:41:24 +00:00
|
|
|
import Annex.Common hiding (debug)
|
2012-10-29 23:07:10 +00:00
|
|
|
import Assistant.Types.ThreadedMonad
|
2012-10-30 18:11:14 +00:00
|
|
|
import Assistant.Types.DaemonStatus
|
2012-10-29 23:14:30 +00:00
|
|
|
import Assistant.Types.ScanRemotes
|
2012-10-30 18:34:48 +00:00
|
|
|
import Assistant.Types.TransferQueue
|
|
|
|
import Assistant.Types.TransferSlots
|
2012-10-29 21:52:43 +00:00
|
|
|
import Assistant.Types.Pushes
|
2012-10-29 23:20:54 +00:00
|
|
|
import Assistant.Types.BranchChange
|
2012-10-29 23:35:18 +00:00
|
|
|
import Assistant.Types.Commits
|
2012-10-29 23:30:23 +00:00
|
|
|
import Assistant.Types.Changes
|
2013-10-29 17:41:44 +00:00
|
|
|
import Assistant.Types.RepoProblem
|
2013-01-26 06:09:33 +00:00
|
|
|
import Assistant.Types.ThreadName
|
2014-04-08 19:23:50 +00:00
|
|
|
import Assistant.Types.RemoteControl
|
2014-04-29 22:01:14 +00:00
|
|
|
import Assistant.Types.CredPairCache
|
2021-04-05 17:40:31 +00:00
|
|
|
import qualified Utility.Debug as Debug
|
2013-01-26 03:14:32 +00:00
|
|
|
|
2012-10-29 04:15:43 +00:00
|
|
|
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
|
|
|
|
deriving (
|
|
|
|
Monad,
|
|
|
|
MonadIO,
|
|
|
|
MonadReader AssistantData,
|
2020-06-04 19:36:34 +00:00
|
|
|
MonadCatch,
|
|
|
|
MonadThrow,
|
|
|
|
MonadMask,
|
2019-01-05 15:54:06 +00:00
|
|
|
Fail.MonadFail,
|
2012-10-29 04:15:43 +00:00
|
|
|
Functor,
|
|
|
|
Applicative
|
|
|
|
)
|
|
|
|
|
|
|
|
data AssistantData = AssistantData
|
2013-01-26 06:09:33 +00:00
|
|
|
{ threadName :: ThreadName
|
2012-10-29 06:21:04 +00:00
|
|
|
, threadState :: ThreadState
|
|
|
|
, daemonStatusHandle :: DaemonStatusHandle
|
2012-10-29 04:15:43 +00:00
|
|
|
, scanRemoteMap :: ScanRemoteMap
|
|
|
|
, transferQueue :: TransferQueue
|
|
|
|
, transferSlots :: TransferSlots
|
|
|
|
, failedPushMap :: FailedPushMap
|
2017-09-20 18:37:20 +00:00
|
|
|
, failedExportMap :: FailedPushMap
|
2012-10-29 04:15:43 +00:00
|
|
|
, commitChan :: CommitChan
|
2017-09-20 18:37:20 +00:00
|
|
|
, exportCommitChan :: CommitChan
|
2013-04-24 20:13:22 +00:00
|
|
|
, changePool :: ChangePool
|
2013-10-29 17:41:44 +00:00
|
|
|
, repoProblemChan :: RepoProblemChan
|
2012-10-29 04:15:43 +00:00
|
|
|
, branchChangeHandle :: BranchChangeHandle
|
2014-04-08 19:23:50 +00:00
|
|
|
, remoteControl :: RemoteControl
|
2014-04-29 22:01:14 +00:00
|
|
|
, credPairCache :: CredPairCache
|
2012-10-29 04:15:43 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
|
|
|
|
newAssistantData st dstatus = AssistantData
|
2013-01-26 06:09:33 +00:00
|
|
|
<$> pure (ThreadName "main")
|
2012-10-29 06:21:04 +00:00
|
|
|
<*> pure st
|
2012-10-29 04:15:43 +00:00
|
|
|
<*> pure dstatus
|
|
|
|
<*> newScanRemoteMap
|
|
|
|
<*> newTransferQueue
|
|
|
|
<*> newTransferSlots
|
|
|
|
<*> newFailedPushMap
|
2017-09-20 18:37:20 +00:00
|
|
|
<*> newFailedPushMap
|
|
|
|
<*> newCommitChan
|
2012-10-29 04:15:43 +00:00
|
|
|
<*> newCommitChan
|
2013-04-24 20:13:22 +00:00
|
|
|
<*> newChangePool
|
2013-10-29 17:41:44 +00:00
|
|
|
<*> newRepoProblemChan
|
2012-10-29 04:15:43 +00:00
|
|
|
<*> newBranchChangeHandle
|
2014-04-08 19:23:50 +00:00
|
|
|
<*> newRemoteControl
|
2014-04-29 22:01:14 +00:00
|
|
|
<*> newCredPairCache
|
2012-10-29 04:15:43 +00:00
|
|
|
|
2012-11-05 23:39:08 +00:00
|
|
|
runAssistant :: AssistantData -> Assistant a -> IO a
|
|
|
|
runAssistant d a = runReaderT (mkAssistant a) d
|
2012-10-29 04:15:43 +00:00
|
|
|
|
|
|
|
getAssistant :: (AssistantData -> a) -> Assistant a
|
|
|
|
getAssistant = reader
|
|
|
|
|
2013-03-16 04:12:28 +00:00
|
|
|
{- Using a type class for lifting into the annex monad allows
|
|
|
|
- easily lifting to it from multiple different monads. -}
|
|
|
|
class LiftAnnex m where
|
|
|
|
liftAnnex :: Annex a -> m a
|
|
|
|
|
2012-10-29 04:15:43 +00:00
|
|
|
{- Runs an action in the git-annex monad. Note that the same monad state
|
2013-12-19 09:57:50 +00:00
|
|
|
- is shared among all assistant threads, so only one of these can run at
|
2012-10-29 04:15:43 +00:00
|
|
|
- a time. Therefore, long-duration actions should be avoided. -}
|
2013-03-16 04:12:28 +00:00
|
|
|
instance LiftAnnex Assistant where
|
|
|
|
liftAnnex a = do
|
|
|
|
st <- reader threadState
|
|
|
|
liftIO $ runThreadState st a
|
2012-10-29 06:21:04 +00:00
|
|
|
|
|
|
|
{- Runs an IO action, passing it an IO action that runs an Assistant action. -}
|
|
|
|
(<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b
|
|
|
|
io <~> a = do
|
|
|
|
d <- reader id
|
2012-11-05 23:39:08 +00:00
|
|
|
liftIO $ io $ runAssistant d a
|
2012-10-29 06:21:04 +00:00
|
|
|
|
|
|
|
{- Creates an IO action that will run an Assistant action when run. -}
|
2012-10-30 21:14:26 +00:00
|
|
|
asIO :: Assistant a -> Assistant (IO a)
|
2012-10-29 06:21:04 +00:00
|
|
|
asIO a = do
|
2012-10-30 21:14:26 +00:00
|
|
|
d <- reader id
|
2012-11-05 23:39:08 +00:00
|
|
|
return $ runAssistant d a
|
2012-10-30 21:14:26 +00:00
|
|
|
|
|
|
|
asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
|
|
|
|
asIO1 a = do
|
2012-10-29 06:21:04 +00:00
|
|
|
d <- reader id
|
2012-11-05 23:39:08 +00:00
|
|
|
return $ \v -> runAssistant d $ a v
|
2012-10-29 06:21:04 +00:00
|
|
|
|
|
|
|
asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
|
|
|
|
asIO2 a = do
|
|
|
|
d <- reader id
|
2012-11-05 23:39:08 +00:00
|
|
|
return $ \v1 v2 -> runAssistant d (a v1 v2)
|
2012-10-29 06:21:04 +00:00
|
|
|
|
|
|
|
{- Runs an IO action on a selected field of the AssistantData. -}
|
|
|
|
(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
|
|
|
|
io <<~ v = reader v >>= liftIO . io
|
2013-01-26 03:14:32 +00:00
|
|
|
|
|
|
|
debug :: [String] -> Assistant ()
|
2021-04-05 17:40:31 +00:00
|
|
|
debug ws = do
|
2013-01-26 06:09:33 +00:00
|
|
|
ThreadName name <- getAssistant threadName
|
2021-04-05 17:40:31 +00:00
|
|
|
liftIO $ Debug.debug (Debug.DebugSource (encodeBS name)) (unwords ws)
|