a7821c0581
Added a RemoteChecker thread, that waits for problems to be reported with remotes, and checks if their git repository is in need of repair. Currently, only failures to sync with the remote cause a problem to be reported. This seems enough, but we'll see. Plugging in a removable drive with a repository on it that is corrupted does automatically repair the repository, as long as the corruption causes git push or git pull to fail. Some types of corruption do not, eg missing/corrupt objects for blobs that git push doesn't need to look at. So, this is not really a replacement for scheduled git repository fscking. But it does make the assistant more robust. This commit is sponsored by Fernando Jimenez.
144 lines
3.8 KiB
Haskell
144 lines
3.8 KiB
Haskell
{- git-annex assistant monad
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
|
|
|
|
module Assistant.Monad (
|
|
Assistant,
|
|
AssistantData(..),
|
|
newAssistantData,
|
|
runAssistant,
|
|
getAssistant,
|
|
LiftAnnex,
|
|
liftAnnex,
|
|
(<~>),
|
|
(<<~),
|
|
asIO,
|
|
asIO1,
|
|
asIO2,
|
|
ThreadName,
|
|
debug,
|
|
notice
|
|
) where
|
|
|
|
import "mtl" Control.Monad.Reader
|
|
import System.Log.Logger
|
|
|
|
import Common.Annex
|
|
import Assistant.Types.ThreadedMonad
|
|
import Assistant.Types.DaemonStatus
|
|
import Assistant.Types.ScanRemotes
|
|
import Assistant.Types.TransferQueue
|
|
import Assistant.Types.TransferSlots
|
|
import Assistant.Types.TransferrerPool
|
|
import Assistant.Types.Pushes
|
|
import Assistant.Types.BranchChange
|
|
import Assistant.Types.Commits
|
|
import Assistant.Types.Changes
|
|
import Assistant.Types.RemoteProblem
|
|
import Assistant.Types.Buddies
|
|
import Assistant.Types.NetMessager
|
|
import Assistant.Types.ThreadName
|
|
|
|
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
|
|
deriving (
|
|
Monad,
|
|
MonadIO,
|
|
MonadReader AssistantData,
|
|
Functor,
|
|
Applicative
|
|
)
|
|
|
|
data AssistantData = AssistantData
|
|
{ threadName :: ThreadName
|
|
, threadState :: ThreadState
|
|
, daemonStatusHandle :: DaemonStatusHandle
|
|
, scanRemoteMap :: ScanRemoteMap
|
|
, transferQueue :: TransferQueue
|
|
, transferSlots :: TransferSlots
|
|
, transferrerPool :: TransferrerPool
|
|
, failedPushMap :: FailedPushMap
|
|
, commitChan :: CommitChan
|
|
, changePool :: ChangePool
|
|
, remoteProblemChan :: RemoteProblemChan
|
|
, branchChangeHandle :: BranchChangeHandle
|
|
, buddyList :: BuddyList
|
|
, netMessager :: NetMessager
|
|
}
|
|
|
|
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
|
|
newAssistantData st dstatus = AssistantData
|
|
<$> pure (ThreadName "main")
|
|
<*> pure st
|
|
<*> pure dstatus
|
|
<*> newScanRemoteMap
|
|
<*> newTransferQueue
|
|
<*> newTransferSlots
|
|
<*> newTransferrerPool
|
|
<*> newFailedPushMap
|
|
<*> newCommitChan
|
|
<*> newChangePool
|
|
<*> newRemoteProblemChan
|
|
<*> newBranchChangeHandle
|
|
<*> newBuddyList
|
|
<*> newNetMessager
|
|
|
|
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 amoung 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 = logaction debugM
|
|
|
|
notice :: [String] -> Assistant ()
|
|
notice = logaction noticeM
|
|
|
|
logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
|
|
logaction a ws = do
|
|
ThreadName name <- getAssistant threadName
|
|
liftIO $ a name $ unwords $ (name ++ ":") : ws
|