2010-10-27 16:53:54 -04:00
|
|
|
|
{- git-annex monad
|
|
|
|
|
-
|
2011-11-09 01:15:51 -04:00
|
|
|
|
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
|
2010-10-27 16:53:54 -04:00
|
|
|
|
-
|
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
|
-}
|
2010-10-10 15:04:07 -04:00
|
|
|
|
|
2011-08-19 14:28:07 -04:00
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
|
|
2010-10-11 17:52:46 -04:00
|
|
|
|
module Annex (
|
2011-01-25 21:49:04 -04:00
|
|
|
|
Annex,
|
|
|
|
|
AnnexState(..),
|
2011-09-01 13:35:07 -04:00
|
|
|
|
OutputType(..),
|
2010-10-14 03:18:11 -04:00
|
|
|
|
new,
|
2011-10-27 14:38:59 -04:00
|
|
|
|
newState,
|
2010-10-14 03:18:11 -04:00
|
|
|
|
run,
|
2010-10-31 23:24:16 -04:00
|
|
|
|
eval,
|
2011-01-26 00:17:38 -04:00
|
|
|
|
getState,
|
|
|
|
|
changeState,
|
2011-11-08 15:34:10 -04:00
|
|
|
|
gitRepo,
|
|
|
|
|
inRepo,
|
|
|
|
|
fromRepo,
|
2010-10-11 17:52:46 -04:00
|
|
|
|
) where
|
2010-10-10 15:04:07 -04:00
|
|
|
|
|
2011-08-19 14:28:07 -04:00
|
|
|
|
import Control.Monad.IO.Control
|
2011-10-03 22:24:57 -04:00
|
|
|
|
import Control.Monad.State
|
2010-10-16 16:20:49 -04:00
|
|
|
|
|
2011-10-03 22:24:57 -04:00
|
|
|
|
import Common
|
2011-06-30 13:16:57 -04:00
|
|
|
|
import qualified Git
|
2011-09-28 15:15:42 -04:00
|
|
|
|
import Git.CatFile
|
2011-06-30 13:25:37 -04:00
|
|
|
|
import Git.Queue
|
2011-06-01 21:56:04 -04:00
|
|
|
|
import Types.Backend
|
2011-09-18 20:11:39 -04:00
|
|
|
|
import qualified Types.Remote
|
2011-06-01 21:56:04 -04:00
|
|
|
|
import Types.Crypto
|
2011-06-22 15:58:30 -04:00
|
|
|
|
import Types.BranchState
|
2011-06-23 21:25:39 -04:00
|
|
|
|
import Types.TrustLevel
|
2011-06-01 21:56:04 -04:00
|
|
|
|
import Types.UUID
|
2011-09-18 17:47:49 -04:00
|
|
|
|
import qualified Utility.Matcher
|
2011-12-08 16:01:46 -04:00
|
|
|
|
import qualified Data.Map as M
|
2011-01-25 21:49:04 -04:00
|
|
|
|
|
|
|
|
|
-- git-annex's monad
|
2011-08-19 14:28:07 -04:00
|
|
|
|
newtype Annex a = Annex { runAnnex :: StateT AnnexState IO a }
|
|
|
|
|
deriving (
|
|
|
|
|
Monad,
|
|
|
|
|
MonadIO,
|
|
|
|
|
MonadControlIO,
|
2011-08-25 00:28:55 -04:00
|
|
|
|
MonadState AnnexState,
|
|
|
|
|
Functor,
|
|
|
|
|
Applicative
|
2011-08-19 14:28:07 -04:00
|
|
|
|
)
|
2011-01-25 21:49:04 -04:00
|
|
|
|
|
2011-11-09 01:15:51 -04:00
|
|
|
|
data OutputType = NormalOutput | QuietOutput | JSONOutput
|
|
|
|
|
|
2011-01-25 21:49:04 -04:00
|
|
|
|
-- internal state storage
|
2011-01-26 00:17:38 -04:00
|
|
|
|
data AnnexState = AnnexState
|
|
|
|
|
{ repo :: Git.Repo
|
2011-06-01 19:10:38 -04:00
|
|
|
|
, backends :: [Backend Annex]
|
2011-09-18 20:11:39 -04:00
|
|
|
|
, remotes :: [Types.Remote.Remote Annex]
|
2011-06-01 19:10:38 -04:00
|
|
|
|
, repoqueue :: Queue
|
2011-09-01 13:35:07 -04:00
|
|
|
|
, output :: OutputType
|
2011-01-26 00:17:38 -04:00
|
|
|
|
, force :: Bool
|
2011-03-22 17:41:06 -04:00
|
|
|
|
, fast :: Bool
|
2011-09-15 13:30:04 -04:00
|
|
|
|
, auto :: Bool
|
2011-11-22 14:06:31 -04:00
|
|
|
|
, print0 :: Bool
|
2011-06-22 15:58:30 -04:00
|
|
|
|
, branchstate :: BranchState
|
2011-09-28 15:15:42 -04:00
|
|
|
|
, catfilehandle :: Maybe CatFileHandle
|
2011-05-18 19:34:46 -04:00
|
|
|
|
, forcebackend :: Maybe String
|
2011-06-01 16:49:17 -04:00
|
|
|
|
, forcenumcopies :: Maybe Int
|
2011-01-26 00:17:38 -04:00
|
|
|
|
, toremote :: Maybe String
|
|
|
|
|
, fromremote :: Maybe String
|
2011-09-18 17:47:49 -04:00
|
|
|
|
, limit :: Either [Utility.Matcher.Token (FilePath -> Annex Bool)] (Utility.Matcher.Matcher (FilePath -> Annex Bool))
|
2011-06-01 19:10:38 -04:00
|
|
|
|
, forcetrust :: [(UUID, TrustLevel)]
|
2011-06-23 21:25:39 -04:00
|
|
|
|
, trustmap :: Maybe TrustMap
|
2011-12-08 16:01:46 -04:00
|
|
|
|
, ciphers :: M.Map EncryptedCipher Cipher
|
2011-04-16 16:41:46 -04:00
|
|
|
|
}
|
2011-01-26 00:17:38 -04:00
|
|
|
|
|
2011-07-05 18:31:46 -04:00
|
|
|
|
newState :: Git.Repo -> AnnexState
|
|
|
|
|
newState gitrepo = AnnexState
|
2011-01-26 00:17:38 -04:00
|
|
|
|
{ repo = gitrepo
|
|
|
|
|
, backends = []
|
2011-03-27 16:17:56 -04:00
|
|
|
|
, remotes = []
|
2011-10-03 22:24:57 -04:00
|
|
|
|
, repoqueue = Git.Queue.empty
|
2011-09-01 13:35:07 -04:00
|
|
|
|
, output = NormalOutput
|
2011-01-26 00:17:38 -04:00
|
|
|
|
, force = False
|
2011-03-22 17:41:06 -04:00
|
|
|
|
, fast = False
|
2011-09-15 13:30:04 -04:00
|
|
|
|
, auto = False
|
2011-11-22 14:06:31 -04:00
|
|
|
|
, print0 = False
|
2011-06-22 15:58:30 -04:00
|
|
|
|
, branchstate = startBranchState
|
2011-09-28 15:15:42 -04:00
|
|
|
|
, catfilehandle = Nothing
|
2011-05-18 19:34:46 -04:00
|
|
|
|
, forcebackend = Nothing
|
2011-06-01 16:49:17 -04:00
|
|
|
|
, forcenumcopies = Nothing
|
2011-01-26 00:17:38 -04:00
|
|
|
|
, toremote = Nothing
|
|
|
|
|
, fromremote = Nothing
|
2011-09-18 17:47:49 -04:00
|
|
|
|
, limit = Left []
|
2011-06-01 17:49:37 -04:00
|
|
|
|
, forcetrust = []
|
2011-06-23 21:25:39 -04:00
|
|
|
|
, trustmap = Nothing
|
2011-12-08 16:01:46 -04:00
|
|
|
|
, ciphers = M.empty
|
2011-01-26 00:17:38 -04:00
|
|
|
|
}
|
2010-10-14 03:18:11 -04:00
|
|
|
|
|
2010-10-26 15:59:50 -04:00
|
|
|
|
{- Create and returns an Annex state object for the specified git repo. -}
|
2011-07-05 18:31:46 -04:00
|
|
|
|
new :: Git.Repo -> IO AnnexState
|
2011-08-25 00:28:55 -04:00
|
|
|
|
new gitrepo = newState <$> Git.configRead gitrepo
|
2010-10-14 03:18:11 -04:00
|
|
|
|
|
2010-10-26 15:59:50 -04:00
|
|
|
|
{- performs an action in the Annex monad -}
|
2011-01-11 18:13:26 -04:00
|
|
|
|
run :: AnnexState -> Annex a -> IO (a, AnnexState)
|
2011-08-19 14:28:07 -04:00
|
|
|
|
run s a = runStateT (runAnnex a) s
|
2011-01-11 18:13:26 -04:00
|
|
|
|
eval :: AnnexState -> Annex a -> IO a
|
2011-08-19 14:28:07 -04:00
|
|
|
|
eval s a = evalStateT (runAnnex a) s
|
2010-10-14 03:18:11 -04:00
|
|
|
|
|
2011-01-26 00:17:38 -04:00
|
|
|
|
{- Gets a value from the internal state, selected by the passed value
|
|
|
|
|
- constructor. -}
|
2011-01-25 21:49:04 -04:00
|
|
|
|
getState :: (AnnexState -> a) -> Annex a
|
2011-06-16 18:27:01 -04:00
|
|
|
|
getState = gets
|
2011-01-26 00:17:38 -04:00
|
|
|
|
|
|
|
|
|
{- Applies a state mutation function to change the internal state.
|
|
|
|
|
-
|
2011-06-16 18:27:01 -04:00
|
|
|
|
- Example: changeState $ \s -> s { quiet = True }
|
2011-01-26 00:17:38 -04:00
|
|
|
|
-}
|
|
|
|
|
changeState :: (AnnexState -> AnnexState) -> Annex ()
|
2011-06-16 18:27:01 -04:00
|
|
|
|
changeState = modify
|
2011-01-25 21:49:04 -04:00
|
|
|
|
|
2011-11-08 15:34:10 -04:00
|
|
|
|
{- Returns the annex's git repository. -}
|
2010-10-14 03:18:11 -04:00
|
|
|
|
gitRepo :: Annex Git.Repo
|
2011-01-25 21:49:04 -04:00
|
|
|
|
gitRepo = getState repo
|
2011-11-08 15:34:10 -04:00
|
|
|
|
|
|
|
|
|
{- Runs an IO action in the annex's git repository. -}
|
|
|
|
|
inRepo :: (Git.Repo -> IO a) -> Annex a
|
2011-11-12 14:24:07 -04:00
|
|
|
|
inRepo a = liftIO . a =<< gitRepo
|
2011-11-08 15:34:10 -04:00
|
|
|
|
|
|
|
|
|
{- Extracts a value from the annex's git repisitory. -}
|
|
|
|
|
fromRepo :: (Git.Repo -> a) -> Annex a
|
|
|
|
|
fromRepo a = a <$> gitRepo
|