diff options
author | Joey Hess <joey@kitenet.net> | 2010-10-13 21:28:47 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2010-10-13 21:28:47 -0400 |
commit | b1607485168e851f69fe3a5b74d73f3c36edf886 (patch) | |
tree | 496133383a3aa77ecc373c383c6655e50d71f9c9 /Annex.hs | |
parent | e5c1db355f5fa31af14ed8474aee89872b934f1a (diff) |
use a state monad
enormous reworking
Diffstat (limited to 'Annex.hs')
-rw-r--r-- | Annex.hs | 138 |
1 files changed, 79 insertions, 59 deletions
@@ -12,6 +12,7 @@ module Annex ( annexPullRepo ) where +import Control.Monad.State (liftIO) import System.Posix.Files import System.Directory import Data.String.Utils @@ -25,22 +26,27 @@ import UUID import LocationLog import Types -{- On startup, examine the git repo, prepare it, and record state for - - later. -} -startAnnex :: IO State +{- Create and returns an Annex state object. + - Examines and prepares the git repo. + -} +startAnnex :: IO AnnexState startAnnex = do - r <- gitRepoFromCwd - r' <- gitConfigRead r - r'' <- prepUUID r' - gitSetup r'' - - return State { - repo = r', - backends = parseBackendList $ gitConfig r' "annex.backends" "" - } + g <- gitRepoFromCwd + let s = makeAnnexState g + (_,s') <- runAnnexState s (prep g) + return s' + where + prep g = do + -- setup git and read its config; update state + liftIO $ gitSetup g + g' <- liftIO $ gitConfigRead g + gitAnnexChange g' + backendsAnnexChange $ parseBackendList $ + gitConfig g' "annex.backends" "" + prepUUID inBackend file yes no = do - r <- lookupFile file + r <- liftIO $ lookupFile file case (r) of Just v -> yes v Nothing -> no @@ -48,13 +54,16 @@ notinBackend file yes no = inBackend file no yes {- Annexes a file, storing it in a backend, and then moving it into - the annex directory and setting up the symlink pointing to its content. -} -annexFile :: State -> FilePath -> IO () -annexFile state file = inBackend file err $ do - checkLegal file - stored <- storeFile state file +annexFile :: FilePath -> Annex () +annexFile file = inBackend file err $ do + liftIO $ checkLegal file + stored <- storeFile file + g <- gitAnnex case (stored) of Nothing -> error $ "no backend could store: " ++ file - Just (key, backend) -> setup key backend + Just (key, backend) -> do + logStatus key ValuePresent + liftIO $ setup g key backend where err = error $ "already annexed " ++ file checkLegal file = do @@ -62,15 +71,14 @@ annexFile state file = inBackend file err $ do if ((isSymbolicLink s) || (not $ isRegularFile s)) then error $ "not a regular file: " ++ file else return () - setup key backend = do - logStatus state key ValuePresent - let dest = annexLocation (repo state) backend key - let reldest = annexLocationRelative (repo state) backend key + setup g key backend = do + let dest = annexLocation g backend key + let reldest = annexLocationRelative g backend key createDirectoryIfMissing True (parentDir dest) renameFile file dest createSymbolicLink ((linkTarget file) ++ reldest) file - gitRun (repo state) ["add", file] - gitRun (repo state) ["commit", "-m", + gitRun g ["add", file] + gitRun g ["commit", "-m", ("git-annex annexed " ++ file), file] linkTarget file = -- relies on file being relative to the top of the @@ -83,56 +91,60 @@ annexFile state file = inBackend file err $ do {- Inverse of annexFile. -} -unannexFile :: State -> FilePath -> IO () -unannexFile state file = notinBackend file err $ \(key, backend) -> do - dropFile state backend key - logStatus state key ValueMissing - removeFile file - gitRun (repo state) ["rm", file] - gitRun (repo state) ["commit", "-m", - ("git-annex unannexed " ++ file), file] - -- git rm deletes empty directories; - -- put them back - createDirectoryIfMissing True (parentDir file) - let src = annexLocation (repo state) backend key - renameFile src file - return () +unannexFile :: FilePath -> Annex () +unannexFile file = notinBackend file err $ \(key, backend) -> do + dropFile backend key + logStatus key ValueMissing + g <- gitAnnex + let src = annexLocation g backend key + liftIO $ moveout g src where err = error $ "not annexed " ++ file + moveout g src = do + removeFile file + gitRun g ["rm", file] + gitRun g ["commit", "-m", + ("git-annex unannexed " ++ file), file] + -- git rm deletes empty directories; + -- put them back + createDirectoryIfMissing True (parentDir file) + renameFile src file + return () {- Gets an annexed file from one of the backends. -} -annexGetFile :: State -> FilePath -> IO () -annexGetFile state file = notinBackend file err $ \(key, backend) -> do - inannex <- inAnnex state backend key +annexGetFile :: FilePath -> Annex () +annexGetFile file = notinBackend file err $ \(key, backend) -> do + inannex <- inAnnex backend key if (inannex) then return () else do - let dest = annexLocation (repo state) backend key - createDirectoryIfMissing True (parentDir dest) - success <- retrieveFile state backend key dest + g <- gitAnnex + let dest = annexLocation g backend key + liftIO $ createDirectoryIfMissing True (parentDir dest) + success <- retrieveFile backend key dest if (success) then do - logStatus state key ValuePresent + logStatus key ValuePresent return () else error $ "failed to get " ++ file where err = error $ "not annexed " ++ file {- Indicates a file is wanted. -} -annexWantFile :: State -> FilePath -> IO () -annexWantFile state file = do error "not implemented" -- TODO +annexWantFile :: FilePath -> Annex () +annexWantFile file = do error "not implemented" -- TODO {- Indicates a file is not wanted. -} -annexDropFile :: State -> FilePath -> IO () -annexDropFile state file = do error "not implemented" -- TODO +annexDropFile :: FilePath -> Annex () +annexDropFile file = do error "not implemented" -- TODO {- Pushes all files to a remote repository. -} -annexPushRepo :: State -> String -> IO () -annexPushRepo state reponame = do error "not implemented" -- TODO +annexPushRepo :: String -> Annex () +annexPushRepo reponame = do error "not implemented" -- TODO {- Pulls all files from a remote repository. -} -annexPullRepo :: State -> String -> IO () -annexPullRepo state reponame = do error "not implemented" -- TODO +annexPullRepo :: String -> Annex () +annexPullRepo reponame = do error "not implemented" -- TODO {- Sets up a git repo for git-annex. May be called repeatedly. -} gitSetup :: GitRepo -> IO () @@ -159,11 +171,19 @@ gitSetup repo = do attributes] {- Updates the LocationLog when a key's presence changes. -} -logStatus state key status = do - f <- logChange (repo state) key (getUUID state (repo state)) status - gitRun (repo state) ["add", f] - gitRun (repo state) ["commit", "-m", "git-annex log update", f] +logStatus :: Key -> LogStatus -> Annex () +logStatus key status = do + g <- gitAnnex + u <- getUUID g + f <- liftIO $ logChange g key u status + liftIO $ commit g f + where + commit g f = do + gitRun g ["add", f] + gitRun g ["commit", "-m", "git-annex log update", f] {- Checks if a given key is currently present in the annexLocation -} -inAnnex :: State -> Backend -> Key -> IO Bool -inAnnex state backend key = doesFileExist $ annexLocation (repo state) backend key +inAnnex :: Backend -> Key -> Annex Bool +inAnnex backend key = do + g <- gitAnnex + liftIO $ doesFileExist $ annexLocation g backend key |