1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
{- git-annex assistant monad
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
module Assistant.Monad (
Assistant,
AssistantData(..),
newAssistantData,
runAssistant,
getAssistant,
LiftAnnex,
liftAnnex,
(<~>),
(<<~),
asIO,
asIO1,
asIO2,
ThreadName,
debug,
) where
import "mtl" Control.Monad.Reader
import qualified Control.Monad.Fail as Fail
import Annex.Common hiding (debug)
import Assistant.Types.ThreadedMonad
import Assistant.Types.DaemonStatus
import Assistant.Types.ScanRemotes
import Assistant.Types.TransferQueue
import Assistant.Types.TransferSlots
import Assistant.Types.Pushes
import Assistant.Types.BranchChange
import Assistant.Types.Commits
import Assistant.Types.Changes
import Assistant.Types.RepoProblem
import Assistant.Types.ThreadName
import Assistant.Types.RemoteControl
import Assistant.Types.CredPairCache
import qualified Utility.Debug as Debug
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
deriving (
Monad,
MonadIO,
MonadReader AssistantData,
MonadCatch,
MonadThrow,
MonadMask,
Fail.MonadFail,
Functor,
Applicative
)
data AssistantData = AssistantData
{ threadName :: ThreadName
, threadState :: ThreadState
, daemonStatusHandle :: DaemonStatusHandle
, scanRemoteMap :: ScanRemoteMap
, transferQueue :: TransferQueue
, transferSlots :: TransferSlots
, failedPushMap :: FailedPushMap
, failedExportMap :: FailedPushMap
, commitChan :: CommitChan
, exportCommitChan :: CommitChan
, changePool :: ChangePool
, repoProblemChan :: RepoProblemChan
, branchChangeHandle :: BranchChangeHandle
, remoteControl :: RemoteControl
, credPairCache :: CredPairCache
}
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
newAssistantData st dstatus = AssistantData
<$> pure (ThreadName "main")
<*> pure st
<*> pure dstatus
<*> newScanRemoteMap
<*> newTransferQueue
<*> newTransferSlots
<*> newFailedPushMap
<*> newFailedPushMap
<*> newCommitChan
<*> newCommitChan
<*> newChangePool
<*> newRepoProblemChan
<*> newBranchChangeHandle
<*> newRemoteControl
<*> newCredPairCache
runAssistant :: AssistantData -> Assistant a -> IO a
runAssistant d a = runReaderT (mkAssistant a) d
getAssistant :: (AssistantData -> a) -> Assistant a
getAssistant = reader
{- 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
{- Runs an action in the git-annex monad. Note that the same monad state
- is shared among all assistant threads, so only one of these can run at
- a time. Therefore, long-duration actions should be avoided. -}
instance LiftAnnex Assistant where
liftAnnex a = do
st <- reader threadState
liftIO $ runThreadState st a
{- 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
liftIO $ io $ runAssistant d a
{- Creates an IO action that will run an Assistant action when run. -}
asIO :: Assistant a -> Assistant (IO a)
asIO a = do
d <- reader id
return $ runAssistant d a
asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
asIO1 a = do
d <- reader id
return $ \v -> runAssistant d $ a v
asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
asIO2 a = do
d <- reader id
return $ \v1 v2 -> runAssistant d (a v1 v2)
{- Runs an IO action on a selected field of the AssistantData. -}
(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
io <<~ v = reader v >>= liftIO . io
debug :: [String] -> Assistant ()
debug ws = do
ThreadName name <- getAssistant threadName
liftIO $ Debug.debug (Debug.DebugSource (encodeBS name)) (unwords ws)
|
