more reorg, spiffed up state monad

This commit is contained in:
Joey Hess 2010-10-14 03:18:11 -04:00
parent 0b55bd05de
commit 6f3572e47f
11 changed files with 259 additions and 249 deletions

215
Annex.hs
View file

@ -1,189 +1,42 @@
{- git-annex toplevel code
-}
{- git-annex monad -}
module Annex (
start,
annexCmd,
unannexCmd,
getCmd,
wantCmd,
dropCmd,
pushCmd,
pullCmd
new,
run,
gitRepo,
gitRepoChange,
backends,
backendsChange,
) where
import Control.Monad.State (liftIO)
import System.Posix.Files
import System.Directory
import Data.String.Utils
import List
import Control.Monad.State
import qualified GitRepo as Git
import Utility
import Locations
import qualified Backend
import BackendList
import UUID
import LocationLog
import AbstractTypes
import Types
import qualified BackendTypes as Backend
{- Create and returns an Annex state object.
- Examines and prepares the git repo.
-}
start :: IO AnnexState
start = do
g <- Git.repoFromCwd
let s = makeAnnexState g
(_,s') <- runAnnexState s (prep g)
return s'
where
prep g = do
-- setup git and read its config; update state
g' <- liftIO $ Git.configRead g
gitAnnexChange g'
liftIO $ gitSetup g'
backendsAnnexChange $ parseBackendList $
Git.configGet g' "annex.backends" ""
prepUUID
-- constructor
new :: Git.Repo -> AnnexState
new g = Backend.AnnexState { Backend.repo = g, Backend.backends = [] }
inBackend file yes no = do
r <- liftIO $ Backend.lookupFile file
case (r) of
Just v -> yes v
Nothing -> no
notinBackend file yes no = inBackend file no yes
-- performs an action in the Annex monad
run state action = runStateT (action) state
{- 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. -}
annexCmd :: FilePath -> Annex ()
annexCmd file = inBackend file err $ do
liftIO $ checkLegal file
stored <- Backend.storeFile file
g <- gitAnnex
case (stored) of
Nothing -> error $ "no backend could store: " ++ file
Just (key, backend) -> do
logStatus key ValuePresent
liftIO $ setup g key backend
where
err = error $ "already annexed " ++ file
checkLegal file = do
s <- getSymbolicLinkStatus file
if ((isSymbolicLink s) || (not $ isRegularFile s))
then error $ "not a regular file: " ++ file
else return ()
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
Git.run g ["add", file]
Git.run g ["commit", "-m",
("git-annex annexed " ++ file), file]
linkTarget file =
-- relies on file being relative to the top of the
-- git repo; just replace each subdirectory with ".."
if (subdirs > 0)
then (join "/" $ take subdirs $ repeat "..") ++ "/"
else ""
where
subdirs = (length $ split "/" file) - 1
{- Inverse of annexCmd. -}
unannexCmd :: FilePath -> Annex ()
unannexCmd file = notinBackend file err $ \(key, backend) -> do
Backend.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
Git.run g ["rm", file]
Git.run 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. -}
getCmd :: FilePath -> Annex ()
getCmd file = notinBackend file err $ \(key, backend) -> do
inannex <- inAnnex backend key
if (inannex)
then return ()
else do
g <- gitAnnex
let dest = annexLocation g backend key
liftIO $ createDirectoryIfMissing True (parentDir dest)
success <- Backend.retrieveFile backend key dest
if (success)
then do
logStatus key ValuePresent
return ()
else error $ "failed to get " ++ file
where
err = error $ "not annexed " ++ file
{- Indicates a file is wanted. -}
wantCmd :: FilePath -> Annex ()
wantCmd file = do error "not implemented" -- TODO
{- Indicates a file is not wanted. -}
dropCmd :: FilePath -> Annex ()
dropCmd file = do error "not implemented" -- TODO
{- Pushes all files to a remote repository. -}
pushCmd :: String -> Annex ()
pushCmd reponame = do error "not implemented" -- TODO
{- Pulls all files from a remote repository. -}
pullCmd :: String -> Annex ()
pullCmd reponame = do error "not implemented" -- TODO
{- Sets up a git repo for git-annex. May be called repeatedly. -}
gitSetup :: Git.Repo -> IO ()
gitSetup repo = do
-- configure git to use union merge driver on state files
exists <- doesFileExist attributes
if (not exists)
then do
writeFile attributes $ attrLine ++ "\n"
commit
else do
content <- readFile attributes
if (all (/= attrLine) (lines content))
then do
appendFile attributes $ attrLine ++ "\n"
commit
else return ()
where
attrLine = stateLoc ++ "/*.log merge=union"
attributes = Git.attributes repo
commit = do
Git.run repo ["add", attributes]
Git.run repo ["commit", "-m", "git-annex setup",
attributes]
{- Updates the LocationLog when a key's presence changes. -}
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
Git.run g ["add", f]
Git.run g ["commit", "-m", "git-annex log update", f]
{- Checks if a given key is currently present in the annexLocation -}
inAnnex :: Backend -> Key -> Annex Bool
inAnnex backend key = do
g <- gitAnnex
liftIO $ doesFileExist $ annexLocation g backend key
-- Annex monad state accessors
gitRepo :: Annex Git.Repo
gitRepo = do
state <- get
return (Backend.repo state)
gitRepoChange :: Git.Repo -> Annex ()
gitRepoChange r = do
state <- get
put state { Backend.repo = r }
return ()
backends :: Annex [Backend]
backends = do
state <- get
return (Backend.backends state)
backendsChange :: [Backend] -> Annex ()
backendsChange b = do
state <- get
put state { Backend.backends = b }
return ()