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
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
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,
|
|
|
|
notice
|
2012-10-29 04:15:43 +00:00
|
|
|
) where
|
|
|
|
|
|
|
|
import "mtl" Control.Monad.Reader
|
2013-01-26 03:14:32 +00:00
|
|
|
import System.Log.Logger
|
2012-10-29 04:15:43 +00:00
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
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
|
2013-03-19 22:46:29 +00:00
|
|
|
import Assistant.Types.TransferrerPool
|
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
|
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,
|
|
|
|
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
|
2013-03-19 22:46:29 +00:00
|
|
|
, transferrerPool :: TransferrerPool
|
2012-10-29 04:15:43 +00:00
|
|
|
, failedPushMap :: FailedPushMap
|
|
|
|
, commitChan :: 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
|
assistant: Start a new git-annex transferkeys process after a network connection change
So that remotes that use a persistent network connection are restarted.
A remote might keep open a long duration network connection, and could
fail to deal well with losing the connection. This is particularly a
concern now that we have external special reotes. An external
special remote that is implemented naively might open the connection only
when PREPARE is sent, and if it loses connection, throw errors on each
request that is made.
(Note that the ssh connection caching should not have this problem; if the
long-duration ssh process loses connection, the named pipe is disconnected
and the next ssh attempt will reconnect. Also, XMPP already deals with
disconnection robustly in its own way.)
There's no way for git-annex to know if a lost network connection actually
affects a given remote, which might have a transfer in process. It does not
make sense to force kill the transferkeys process every time the NetWatcher
detects a change. (Especially because the NetWatcher sometimes polls 1
change per hour.)
In any case, the NetWatcher only detects connection to a network, not
disconnection. So if a transfer is in progress over the network, and the
network goes down, that will need to time out on its own.
An alternate approch that was considered is to use a separate transferkeys
process for each remote, and detect when a request fails, and assume that
means that process is in a failing state and restart it. The problem with
that approach is that if a resource is not available and a remote fails
every time, it degrades to starting a new transferkeys process for every
file transfer, which is too expensive.
Instead, this commit only handles the network reconnection case, and restarts
transferkeys only once the network has reconnected and another transfer needs
to be made. So, a transferkeys process will be reused for 1 hour, or until the
next network connection.
----
The NotificationBroadcaster was rewritten to use TMVars rather than MSampleVars,
to allow checking without blocking if a notification has been received.
----
This commit was sponsored by Tobias Brunner.
2014-01-06 20:03:39 +00:00
|
|
|
<*> newTransferrerPool (checkNetworkConnections dstatus)
|
2012-10-29 04:15:43 +00:00
|
|
|
<*> newFailedPushMap
|
|
|
|
<*> 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 ()
|
|
|
|
debug = logaction debugM
|
|
|
|
|
|
|
|
notice :: [String] -> Assistant ()
|
|
|
|
notice = logaction noticeM
|
|
|
|
|
|
|
|
logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
|
|
|
|
logaction a ws = do
|
2013-01-26 06:09:33 +00:00
|
|
|
ThreadName name <- getAssistant threadName
|
2013-01-26 03:14:32 +00:00
|
|
|
liftIO $ a name $ unwords $ (name ++ ":") : ws
|