use a state monad

enormous reworking
This commit is contained in:
Joey Hess 2010-10-13 21:28:47 -04:00
parent e5c1db355f
commit b160748516
11 changed files with 251 additions and 157 deletions

138
Annex.hs
View file

@ -12,6 +12,7 @@ module Annex (
annexPullRepo annexPullRepo
) where ) where
import Control.Monad.State (liftIO)
import System.Posix.Files import System.Posix.Files
import System.Directory import System.Directory
import Data.String.Utils import Data.String.Utils
@ -25,22 +26,27 @@ import UUID
import LocationLog import LocationLog
import Types import Types
{- On startup, examine the git repo, prepare it, and record state for {- Create and returns an Annex state object.
- later. -} - Examines and prepares the git repo.
startAnnex :: IO State -}
startAnnex :: IO AnnexState
startAnnex = do startAnnex = do
r <- gitRepoFromCwd g <- gitRepoFromCwd
r' <- gitConfigRead r let s = makeAnnexState g
r'' <- prepUUID r' (_,s') <- runAnnexState s (prep g)
gitSetup r'' return s'
where
return State { prep g = do
repo = r', -- setup git and read its config; update state
backends = parseBackendList $ gitConfig r' "annex.backends" "" liftIO $ gitSetup g
} g' <- liftIO $ gitConfigRead g
gitAnnexChange g'
backendsAnnexChange $ parseBackendList $
gitConfig g' "annex.backends" ""
prepUUID
inBackend file yes no = do inBackend file yes no = do
r <- lookupFile file r <- liftIO $ lookupFile file
case (r) of case (r) of
Just v -> yes v Just v -> yes v
Nothing -> no 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 {- 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. -} - the annex directory and setting up the symlink pointing to its content. -}
annexFile :: State -> FilePath -> IO () annexFile :: FilePath -> Annex ()
annexFile state file = inBackend file err $ do annexFile file = inBackend file err $ do
checkLegal file liftIO $ checkLegal file
stored <- storeFile state file stored <- storeFile file
g <- gitAnnex
case (stored) of case (stored) of
Nothing -> error $ "no backend could store: " ++ file 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 where
err = error $ "already annexed " ++ file err = error $ "already annexed " ++ file
checkLegal file = do checkLegal file = do
@ -62,15 +71,14 @@ annexFile state file = inBackend file err $ do
if ((isSymbolicLink s) || (not $ isRegularFile s)) if ((isSymbolicLink s) || (not $ isRegularFile s))
then error $ "not a regular file: " ++ file then error $ "not a regular file: " ++ file
else return () else return ()
setup key backend = do setup g key backend = do
logStatus state key ValuePresent let dest = annexLocation g backend key
let dest = annexLocation (repo state) backend key let reldest = annexLocationRelative g backend key
let reldest = annexLocationRelative (repo state) backend key
createDirectoryIfMissing True (parentDir dest) createDirectoryIfMissing True (parentDir dest)
renameFile file dest renameFile file dest
createSymbolicLink ((linkTarget file) ++ reldest) file createSymbolicLink ((linkTarget file) ++ reldest) file
gitRun (repo state) ["add", file] gitRun g ["add", file]
gitRun (repo state) ["commit", "-m", gitRun g ["commit", "-m",
("git-annex annexed " ++ file), file] ("git-annex annexed " ++ file), file]
linkTarget file = linkTarget file =
-- relies on file being relative to the top of the -- relies on file being relative to the top of the
@ -83,56 +91,60 @@ annexFile state file = inBackend file err $ do
{- Inverse of annexFile. -} {- Inverse of annexFile. -}
unannexFile :: State -> FilePath -> IO () unannexFile :: FilePath -> Annex ()
unannexFile state file = notinBackend file err $ \(key, backend) -> do unannexFile file = notinBackend file err $ \(key, backend) -> do
dropFile state backend key dropFile backend key
logStatus state key ValueMissing logStatus key ValueMissing
removeFile file g <- gitAnnex
gitRun (repo state) ["rm", file] let src = annexLocation g backend key
gitRun (repo state) ["commit", "-m", liftIO $ moveout g src
("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 ()
where where
err = error $ "not annexed " ++ file 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. -} {- Gets an annexed file from one of the backends. -}
annexGetFile :: State -> FilePath -> IO () annexGetFile :: FilePath -> Annex ()
annexGetFile state file = notinBackend file err $ \(key, backend) -> do annexGetFile file = notinBackend file err $ \(key, backend) -> do
inannex <- inAnnex state backend key inannex <- inAnnex backend key
if (inannex) if (inannex)
then return () then return ()
else do else do
let dest = annexLocation (repo state) backend key g <- gitAnnex
createDirectoryIfMissing True (parentDir dest) let dest = annexLocation g backend key
success <- retrieveFile state backend key dest liftIO $ createDirectoryIfMissing True (parentDir dest)
success <- retrieveFile backend key dest
if (success) if (success)
then do then do
logStatus state key ValuePresent logStatus key ValuePresent
return () return ()
else error $ "failed to get " ++ file else error $ "failed to get " ++ file
where where
err = error $ "not annexed " ++ file err = error $ "not annexed " ++ file
{- Indicates a file is wanted. -} {- Indicates a file is wanted. -}
annexWantFile :: State -> FilePath -> IO () annexWantFile :: FilePath -> Annex ()
annexWantFile state file = do error "not implemented" -- TODO annexWantFile file = do error "not implemented" -- TODO
{- Indicates a file is not wanted. -} {- Indicates a file is not wanted. -}
annexDropFile :: State -> FilePath -> IO () annexDropFile :: FilePath -> Annex ()
annexDropFile state file = do error "not implemented" -- TODO annexDropFile file = do error "not implemented" -- TODO
{- Pushes all files to a remote repository. -} {- Pushes all files to a remote repository. -}
annexPushRepo :: State -> String -> IO () annexPushRepo :: String -> Annex ()
annexPushRepo state reponame = do error "not implemented" -- TODO annexPushRepo reponame = do error "not implemented" -- TODO
{- Pulls all files from a remote repository. -} {- Pulls all files from a remote repository. -}
annexPullRepo :: State -> String -> IO () annexPullRepo :: String -> Annex ()
annexPullRepo state reponame = do error "not implemented" -- TODO annexPullRepo reponame = do error "not implemented" -- TODO
{- Sets up a git repo for git-annex. May be called repeatedly. -} {- Sets up a git repo for git-annex. May be called repeatedly. -}
gitSetup :: GitRepo -> IO () gitSetup :: GitRepo -> IO ()
@ -159,11 +171,19 @@ gitSetup repo = do
attributes] attributes]
{- Updates the LocationLog when a key's presence changes. -} {- Updates the LocationLog when a key's presence changes. -}
logStatus state key status = do logStatus :: Key -> LogStatus -> Annex ()
f <- logChange (repo state) key (getUUID state (repo state)) status logStatus key status = do
gitRun (repo state) ["add", f] g <- gitAnnex
gitRun (repo state) ["commit", "-m", "git-annex log update", f] 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 -} {- Checks if a given key is currently present in the annexLocation -}
inAnnex :: State -> Backend -> Key -> IO Bool inAnnex :: Backend -> Key -> Annex Bool
inAnnex state backend key = doesFileExist $ annexLocation (repo state) backend key inAnnex backend key = do
g <- gitAnnex
liftIO $ doesFileExist $ annexLocation g backend key

View file

@ -20,6 +20,7 @@ module Backend (
lookupFile lookupFile
) where ) where
import Control.Monad.State
import Control.Exception import Control.Exception
import System.Directory import System.Directory
import System.FilePath import System.FilePath
@ -32,30 +33,34 @@ import Utility
import Types import Types
{- Attempts to store a file in one of the backends. -} {- Attempts to store a file in one of the backends. -}
storeFile :: State -> FilePath -> IO (Maybe (Key, Backend)) storeFile :: FilePath -> Annex (Maybe (Key, Backend))
storeFile state file = storeFile' (backends state) state file storeFile file = do
g <- gitAnnex
let relfile = gitRelative g file
b <- backendsAnnex
storeFile' b file relfile
storeFile' [] _ _ = return Nothing storeFile' [] _ _ = return Nothing
storeFile' (b:bs) state file = do storeFile' (b:bs) file relfile = do
try <- (getKey b) state (gitRelative (repo state) file) try <- (getKey b) relfile
case (try) of case (try) of
Nothing -> nextbackend Nothing -> nextbackend
Just key -> do Just key -> do
stored <- (storeFileKey b) state file key stored <- (storeFileKey b) file key
if (not stored) if (not stored)
then nextbackend then nextbackend
else do else do
return $ Just (key, b) return $ Just (key, b)
where where
nextbackend = storeFile' bs state file nextbackend = storeFile' bs file relfile
{- Attempts to retrieve an key from one of the backends, saving it to {- Attempts to retrieve an key from one of the backends, saving it to
- a specified location. -} - a specified location. -}
retrieveFile :: State -> Backend -> Key -> FilePath -> IO Bool retrieveFile :: Backend -> Key -> FilePath -> Annex Bool
retrieveFile state backend key dest = (retrieveKeyFile backend) state key dest retrieveFile backend key dest = (retrieveKeyFile backend) key dest
{- Drops a key from a backend. -} {- Drops a key from a backend. -}
dropFile :: State -> Backend -> Key -> IO Bool dropFile :: Backend -> Key -> Annex Bool
dropFile state backend key = (removeKey backend) state key dropFile backend key = (removeKey backend) key
{- Looks up the key and backend corresponding to an annexed file, {- Looks up the key and backend corresponding to an annexed file,
- by examining what the file symlinks to. -} - by examining what the file symlinks to. -}

View file

@ -14,5 +14,5 @@ backend = BackendFile.backend {
} }
-- checksum the file to get its key -- checksum the file to get its key
keyValue :: State -> FilePath -> IO (Maybe Key) keyValue :: FilePath -> Annex (Maybe Key)
keyValue k = error "checksum keyValue unimplemented" -- TODO keyValue k = error "checksum keyValue unimplemented" -- TODO

View file

@ -3,6 +3,7 @@
module BackendFile (backend) where module BackendFile (backend) where
import Control.Monad.State
import System.IO import System.IO
import System.Cmd import System.Cmd
import Control.Exception import Control.Exception
@ -21,28 +22,28 @@ backend = Backend {
} }
-- direct mapping from filename to key -- direct mapping from filename to key
keyValue :: State -> FilePath -> IO (Maybe Key) keyValue :: FilePath -> Annex (Maybe Key)
keyValue state file = return $ Just $ Key file keyValue file = return $ Just $ Key file
{- This backend does not really do any independant data storage, {- This backend does not really do any independant data storage,
- it relies on the file contents in .git/annex/ in this repo, - it relies on the file contents in .git/annex/ in this repo,
- and other accessible repos. So storing or removing a key is - and other accessible repos. So storing or removing a key is
- a no-op. TODO until support is added for git annex --push otherrepo, - a no-op. TODO until support is added for git annex --push otherrepo,
- then these could implement that.. -} - then these could implement that.. -}
dummyStore :: State -> FilePath -> Key -> IO (Bool) dummyStore :: FilePath -> Key -> Annex (Bool)
dummyStore state file key = return True dummyStore file key = return True
dummyRemove :: State -> Key -> IO Bool dummyRemove :: Key -> Annex Bool
dummyRemove state url = return False dummyRemove url = return False
{- Try to find a copy of the file in one of the remotes, {- Try to find a copy of the file in one of the remotes,
- and copy it over to this one. -} - and copy it over to this one. -}
copyKeyFile :: State -> Key -> FilePath -> IO (Bool) copyKeyFile :: Key -> FilePath -> Annex (Bool)
copyKeyFile state key file = do copyKeyFile key file = do
remotes <- remotesWithKey state key remotes <- remotesWithKey key
if (0 == length remotes) if (0 == length remotes)
then error $ "no known remotes have: " ++ (keyFile key) ++ "\n" ++ then error $ "no known remotes have: " ++ (keyFile key) ++ "\n" ++
"(Perhaps you need to git remote add a repository?)" "(Perhaps you need to git remote add a repository?)"
else trycopy remotes remotes else liftIO $ trycopy remotes remotes
where where
trycopy full [] = error $ "unable to get: " ++ (keyFile key) ++ "\n" ++ trycopy full [] = error $ "unable to get: " ++ (keyFile key) ++ "\n" ++
"To get that file, need access to one of these remotes: " ++ "To get that file, need access to one of these remotes: " ++

View file

@ -3,6 +3,7 @@
module BackendUrl (backend) where module BackendUrl (backend) where
import Control.Monad.State
import System.Cmd import System.Cmd
import IO import IO
import Types import Types
@ -16,19 +17,19 @@ backend = Backend {
} }
-- cannot generate url from filename -- cannot generate url from filename
keyValue :: State -> FilePath -> IO (Maybe Key) keyValue :: FilePath -> Annex (Maybe Key)
keyValue repo file = return Nothing keyValue file = return Nothing
-- cannot change url contents -- cannot change url contents
dummyStore :: State -> FilePath -> Key -> IO Bool dummyStore :: FilePath -> Key -> Annex Bool
dummyStore repo file url = return False dummyStore file url = return False
dummyRemove :: State -> Key -> IO Bool dummyRemove :: Key -> Annex Bool
dummyRemove state url = return False dummyRemove url = return False
downloadUrl :: State -> Key -> FilePath -> IO Bool downloadUrl :: Key -> FilePath -> Annex Bool
downloadUrl state url file = do downloadUrl url file = do
putStrLn $ "download: " ++ (show url) liftIO $ putStrLn $ "download: " ++ (show url)
result <- try $ rawSystem "curl" ["-#", "-o", file, (show url)] result <- liftIO $ try $ rawSystem "curl" ["-#", "-o", file, (show url)]
case (result) of case (result) of
Left _ -> return False Left _ -> return False
Right _ -> return True Right _ -> return True

View file

@ -6,7 +6,8 @@
module CmdLine ( module CmdLine (
argvToMode, argvToMode,
dispatch dispatch,
Mode
) where ) where
import System.Console.GetOpt import System.Console.GetOpt
@ -39,13 +40,13 @@ argvToMode argv = do
(_,files,errs) -> ioError (userError (concat errs ++ usageInfo header options)) (_,files,errs) -> ioError (userError (concat errs ++ usageInfo header options))
where header = "Usage: git-annex [mode] file" where header = "Usage: git-annex [mode] file"
dispatch :: State -> Mode -> FilePath -> IO () dispatch :: Mode -> FilePath -> Annex ()
dispatch state mode item = do dispatch mode item = do
case (mode) of case (mode) of
Add -> annexFile state item Add -> annexFile item
Push -> annexPushRepo state item Push -> annexPushRepo item
Pull -> annexPullRepo state item Pull -> annexPullRepo item
Want -> annexWantFile state item Want -> annexWantFile item
Get -> annexGetFile state item Get -> annexGetFile item
Drop -> annexDropFile state item Drop -> annexDropFile item
Unannex -> unannexFile state item Unannex -> unannexFile item

View file

@ -5,6 +5,7 @@ module Remotes (
remotesWithKey remotesWithKey
) where ) where
import Control.Monad.State (liftIO)
import Types import Types
import GitRepo import GitRepo
import LocationLog import LocationLog
@ -17,34 +18,43 @@ remotesList :: [GitRepo] -> String
remotesList remotes = join " " $ map gitRepoDescribe remotes remotesList remotes = join " " $ map gitRepoDescribe remotes
{- Cost ordered list of remotes that the LocationLog indicate may have a key. -} {- Cost ordered list of remotes that the LocationLog indicate may have a key. -}
remotesWithKey :: State -> Key -> IO [GitRepo] remotesWithKey :: Key -> Annex [GitRepo]
remotesWithKey state key = do remotesWithKey key = do
uuids <- keyLocations (repo state) key g <- gitAnnex
return $ reposByUUID state (remotesByCost state) uuids uuids <- liftIO $ keyLocations g key
remotes <- remotesByCost
reposByUUID remotes uuids
{- Cost Ordered list of remotes. -} {- Cost Ordered list of remotes. -}
remotesByCost :: State -> [GitRepo] remotesByCost :: Annex [GitRepo]
remotesByCost state = reposByCost state $ gitConfigRemotes (repo state) remotesByCost = do
g <- gitAnnex
reposByCost $ gitConfigRemotes g
{- Orders a list of git repos by cost. -} {- Orders a list of git repos by cost. -}
reposByCost :: State -> [GitRepo] -> [GitRepo] reposByCost :: [GitRepo] -> Annex [GitRepo]
reposByCost state l = reposByCost l = do
fst $ unzip $ sortBy (\(r1, c1) (r2, c2) -> compare c1 c2) $ costpairs l costpairs <- mapM costpair l
return $ fst $ unzip $ sortBy bycost $ costpairs
where where
costpairs l = map (\r -> (r, repoCost state r)) l costpair r = do
cost <- repoCost r
return (r, cost)
bycost (_, c1) (_, c2) = compare c1 c2
{- Calculates cost for a repo. {- Calculates cost for a repo.
- -
- The default cost is 100 for local repositories, and 200 for remote - The default cost is 100 for local repositories, and 200 for remote
- repositories; it can also be configured by remote.<name>.annex-cost - repositories; it can also be configured by remote.<name>.annex-cost
-} -}
repoCost :: State -> GitRepo -> Int repoCost :: GitRepo -> Annex Int
repoCost state r = repoCost r = do
if ((length $ config state r) > 0) g <- gitAnnex
then read $ config state r if ((length $ config g r) > 0)
then return $ read $ config g r
else if (gitRepoIsLocal r) else if (gitRepoIsLocal r)
then 100 then return 100
else 200 else return 200
where where
config state r = gitConfig (repo state) (configkey r) "" config g r = gitConfig g (configkey r) ""
configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-cost" configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-cost"

4
TODO
View file

@ -1,9 +1,9 @@
* bug when annexing files while in a subdir of a git repo * bug when annexing files while in a subdir of a git repo
* bug when specifying absolute path to files when annexing * bug when specifying absolute path to files when annexing
* implement retrieval for backendfile * state monad
* query remotes for their annex.uuid settings * query remotes for their annex.uuid settings and cache
* --push/--pull/--want/--drop * --push/--pull/--want/--drop

View file

@ -1,20 +1,59 @@
{- git-annex core data types -} {- git-annex core data types -}
module Types ( module Types (
State(..), Annex(..),
makeAnnexState,
runAnnexState,
gitAnnex,
gitAnnexChange,
backendsAnnex,
backendsAnnexChange,
AnnexState(..),
Key(..), Key(..),
Backend(..) Backend(..)
) where ) where
import Control.Monad.State
import Data.String.Utils import Data.String.Utils
import GitRepo import GitRepo
-- git-annex's runtime state -- git-annex's runtime state
data State = State { data AnnexState = AnnexState {
repo :: GitRepo, repo :: GitRepo,
backends :: [Backend] backends :: [Backend]
} deriving (Show) } deriving (Show)
-- git-annex's monad
type Annex = StateT AnnexState IO
-- constructor
makeAnnexState :: GitRepo -> AnnexState
makeAnnexState g = AnnexState { repo = g, backends = [] }
-- performs an action in the Annex monad
runAnnexState state action = runStateT (action) state
-- state accessors
gitAnnex :: Annex GitRepo
gitAnnex = do
state <- get
return (repo state)
gitAnnexChange :: GitRepo -> Annex ()
gitAnnexChange r = do
state <- get
put state { repo = r }
return ()
backendsAnnex :: Annex [Backend]
backendsAnnex = do
state <- get
return (backends state)
backendsAnnexChange :: [Backend] -> Annex ()
backendsAnnexChange b = do
state <- get
put state { backends = b }
return ()
-- annexed filenames are mapped into keys -- annexed filenames are mapped into keys
data Key = Key String deriving (Eq) data Key = Key String deriving (Eq)
@ -27,13 +66,13 @@ data Backend = Backend {
-- name of this backend -- name of this backend
name :: String, name :: String,
-- converts a filename to a key -- converts a filename to a key
getKey :: State -> FilePath -> IO (Maybe Key), getKey :: FilePath -> Annex (Maybe Key),
-- stores a file's contents to a key -- stores a file's contents to a key
storeFileKey :: State -> FilePath -> Key -> IO Bool, storeFileKey :: FilePath -> Key -> Annex Bool,
-- retrieves a key's contents to a file -- retrieves a key's contents to a file
retrieveKeyFile :: State -> Key -> FilePath -> IO Bool, retrieveKeyFile :: Key -> FilePath -> Annex Bool,
-- removes a key -- removes a key
removeKey :: State -> Key -> IO Bool removeKey :: Key -> Annex Bool
} }
instance Show Backend where instance Show Backend where

50
UUID.hs
View file

@ -13,6 +13,7 @@ module UUID (
reposByUUID reposByUUID
) where ) where
import Control.Monad.State
import Maybe import Maybe
import List import List
import System.Cmd.Utils import System.Cmd.Utils
@ -26,9 +27,8 @@ configkey="annex.uuid"
{- Generates a UUID. There is a library for this, but it's not packaged, {- Generates a UUID. There is a library for this, but it's not packaged,
- so use the command line tool. -} - so use the command line tool. -}
genUUID :: IO UUID genUUID :: Annex UUID
genUUID = do genUUID = liftIO $ pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h
pOpen ReadFromPipe "uuid" ["-m"] $ \h -> hGetLine h
{- Looks up a repo's UUID. May return "" if none is known. {- Looks up a repo's UUID. May return "" if none is known.
- -
@ -36,28 +36,38 @@ genUUID = do
- remote.<name>.annex-uuid - remote.<name>.annex-uuid
- -
- -} - -}
getUUID :: State -> GitRepo -> UUID getUUID :: GitRepo -> Annex UUID
getUUID s r = getUUID r = do
if ("" /= getUUID' r) if ("" /= configured r)
then getUUID' r then return $ configured r
else cached s r else cached r
where where
cached s r = gitConfig (repo s) (configkey r) "" configured r = gitConfig r "annex.uuid" ""
cached r = do
g <- gitAnnex
return $ gitConfig g (configkey r) ""
configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-uuid" configkey r = "remote." ++ (gitRepoRemoteName r) ++ ".annex-uuid"
getUUID' r = gitConfig r "annex.uuid" ""
{- Make sure that the repo has an annex.uuid setting. -} {- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: GitRepo -> IO GitRepo prepUUID :: Annex ()
prepUUID repo = prepUUID = do
if ("" == getUUID' repo) g <- gitAnnex
u <- getUUID g
if ("" == u)
then do then do
uuid <- genUUID uuid <- genUUID
gitRun repo ["config", configkey, uuid] liftIO $ gitRun g ["config", configkey, uuid]
-- return new repo with updated config -- re-read git config and update the repo's state
gitConfigRead repo u' <- liftIO $ gitConfigRead g
else return repo gitAnnexChange u'
return ()
else return ()
{- Filters a list of repos to ones that have listed UUIDs. -} {- Filters a list of repos to ones that have listed UUIDs. -}
reposByUUID :: State -> [GitRepo] -> [UUID] -> [GitRepo] reposByUUID :: [GitRepo] -> [UUID] -> Annex [GitRepo]
reposByUUID state repos uuids = reposByUUID repos uuids = do
filter (\r -> isJust $ elemIndex (getUUID state r) uuids) repos filterM match repos
where
match r = do
u <- getUUID r
return $ isJust $ elemIndex u uuids

View file

@ -1,36 +1,43 @@
{- git-annex main program {- git-annex main program
- -} - -}
import Control.Monad.State
import System.IO import System.IO
import System.Environment import System.Environment
import Control.Exception import Control.Exception
import CmdLine import CmdLine
import Types
import Annex import Annex
main = do main = do
args <- getArgs args <- getArgs
(mode, files) <- argvToMode args (mode, params) <- argvToMode args
state <- startAnnex state <- startAnnex
tryRun state mode 0 0 params
tryRun 0 0 $ map (\f -> dispatch state mode f) files {- Processes each param in the list by dispatching the handler function
- for the user-selection operation mode. Catches exceptions, not stopping
{- Tries to run a series of actions, not stopping if some error out, - if some error out, and propigates an overall error status at the end.
- and propigating an overall error status at the end. -} -
tryRun errnum oknum [] = do - This runs in the IO monad, not in the Annex monad. It seems that
- exceptions can only be caught in the IO monad, not in a stacked monad;
- or more likely I missed an easy way to do it. So, I have to laboriously
- thread AnnexState through this function.
-}
tryRun :: AnnexState -> Mode -> Int -> Int -> [String] -> IO ()
tryRun state mode errnum oknum [] = do
if (errnum > 0) if (errnum > 0)
then error $ (show errnum) ++ " failed ; " ++ show (oknum) ++ " ok" then error $ (show errnum) ++ " failed ; " ++ show (oknum) ++ " ok"
else return () else return ()
tryRun errnum oknum (a:as) = do tryRun state mode errnum oknum (f:fs) = do
result <- try (a)::IO (Either SomeException ()) result <- try (runAnnexState state (dispatch mode f))::IO (Either SomeException ((), AnnexState))
case (result) of case (result) of
Left err -> do Left err -> do
showErr err showErr err
tryRun (errnum + 1) oknum as tryRun state mode (errnum + 1) oknum fs
Right _ -> tryRun errnum (oknum + 1) as Right (_,state') -> tryRun state' mode errnum (oknum + 1) fs
{- Exception pretty-printing. -} {- Exception pretty-printing. -}
showErr :: SomeException -> IO ()
showErr e = do showErr e = do
hPutStrLn stderr $ "git-annex: " ++ (show e) hPutStrLn stderr $ "git-annex: " ++ (show e)
return () return ()