mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

type alias cleanup

Browse source
This commit is contained in:
Joey Hess 2011-12-31 04:11:39 -04:00
parent a2ec2d3760
commit 4a02c2ea62
38 changed files with 129 additions and 122 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Annex.hs
View file

@ -67,8 +67,8 @@ data OutputType = NormalOutput | QuietOutput | JSONOutput
-- internal state storage -- internal state storage
data AnnexState = AnnexState data AnnexState = AnnexState
{ repo :: Git.Repo { repo :: Git.Repo
, backends :: [Backend Annex] , backends :: [BackendA Annex]
, remotes :: [Types.Remote.Remote Annex] , remotes :: [Types.Remote.RemoteA Annex]
, repoqueue :: Git.Queue.Queue , repoqueue :: Git.Queue.Queue
, output :: OutputType , output :: OutputType
, force :: Bool , force :: Bool

16
Backend.hs
View file

@ -31,11 +31,11 @@ import qualified Backend.SHA
import qualified Backend.WORM import qualified Backend.WORM
import qualified Backend.URL import qualified Backend.URL
list :: [Backend Annex] list :: [Backend]
list = Backend.SHA.backends ++ Backend.WORM.backends ++ Backend.URL.backends list = Backend.SHA.backends ++ Backend.WORM.backends ++ Backend.URL.backends
{- List of backends in the order to try them when storing a new key. -} {- List of backends in the order to try them when storing a new key. -}
orderedList :: Annex [Backend Annex] orderedList :: Annex [Backend]
orderedList = do orderedList = do
l <- Annex.getState Annex.backends -- list is cached here l <- Annex.getState Annex.backends -- list is cached here
if not $ null l if not $ null l
@ -54,12 +54,12 @@ orderedList = do
{- Generates a key for a file, trying each backend in turn until one {- Generates a key for a file, trying each backend in turn until one
- accepts it. -} - accepts it. -}
genKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex)) genKey :: FilePath -> Maybe Backend -> Annex (Maybe (Key, Backend))
genKey file trybackend = do genKey file trybackend = do
bs <- orderedList bs <- orderedList
let bs' = maybe bs (: bs) trybackend let bs' = maybe bs (: bs) trybackend
genKey' bs' file genKey' bs' file
genKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex)) genKey' :: [Backend] -> FilePath -> Annex (Maybe (Key, Backend))
genKey' [] _ = return Nothing genKey' [] _ = return Nothing
genKey' (b:bs) file = do genKey' (b:bs) file = do
r <- (B.getKey b) file r <- (B.getKey b) file
@ -75,7 +75,7 @@ genKey' (b:bs) file = do
{- 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. -}
lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile file = do lookupFile file = do
tl <- liftIO $ try getsymlink tl <- liftIO $ try getsymlink
case tl of case tl of
@ -94,7 +94,7 @@ lookupFile file = do
bname ++ ")" bname ++ ")"
return Nothing return Nothing
type BackendFile = (Maybe (Backend Annex), FilePath) type BackendFile = (Maybe Backend, FilePath)
{- Looks up the backends that should be used for each file in a list. {- Looks up the backends that should be used for each file in a list.
- That can be configured on a per-file basis in the gitattributes file. - That can be configured on a per-file basis in the gitattributes file.
@ -110,11 +110,11 @@ chooseBackends fs = Annex.getState Annex.forcebackend >>= go
return $ map (\f -> (Just $ Prelude.head l, f)) fs return $ map (\f -> (Just $ Prelude.head l, f)) fs
{- Looks up a backend by name. May fail if unknown. -} {- Looks up a backend by name. May fail if unknown. -}
lookupBackendName :: String -> Backend Annex lookupBackendName :: String -> Backend
lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
where where
unknown = error $ "unknown backend " ++ s unknown = error $ "unknown backend " ++ s
maybeLookupBackendName :: String -> Maybe (Backend Annex) maybeLookupBackendName :: String -> Maybe Backend
maybeLookupBackendName s = headMaybe matches maybeLookupBackendName s = headMaybe matches
where where
matches = filter (\b -> s == B.name b) list matches = filter (\b -> s == B.name b) list

8
Backend/SHA.hs
View file

@ -21,21 +21,21 @@ type SHASize = Int
sizes :: [Int] sizes :: [Int]
sizes = [256, 1, 512, 224, 384] sizes = [256, 1, 512, 224, 384]
backends :: [Backend Annex] backends :: [Backend]
backends = catMaybes $ map genBackend sizes ++ map genBackendE sizes backends = catMaybes $ map genBackend sizes ++ map genBackendE sizes
genBackend :: SHASize -> Maybe (Backend Annex) genBackend :: SHASize -> Maybe Backend
genBackend size genBackend size
| isNothing (shaCommand size) = Nothing | isNothing (shaCommand size) = Nothing
| otherwise = Just b | otherwise = Just b
where where
b = Types.Backend.Backend b = Backend
{ name = shaName size { name = shaName size
, getKey = keyValue size , getKey = keyValue size
, fsckKey = checkKeyChecksum size , fsckKey = checkKeyChecksum size
} }
genBackendE :: SHASize -> Maybe (Backend Annex) genBackendE :: SHASize -> Maybe Backend
genBackendE size = genBackendE size =
case genBackend size of case genBackend size of
Nothing -> Nothing Nothing -> Nothing

6
Backend/URL.hs
View file

@ -14,11 +14,11 @@ import Common.Annex
import Types.Backend import Types.Backend
import Types.Key import Types.Key
backends :: [Backend Annex] backends :: [Backend]
backends = [backend] backends = [backend]
backend :: Backend Annex backend :: Backend
backend = Types.Backend.Backend { backend = Backend {
name = "URL", name = "URL",
getKey = const (return Nothing), getKey = const (return Nothing),
fsckKey = const (return True) fsckKey = const (return True)

6
Backend/WORM.hs
View file

@ -11,11 +11,11 @@ import Common.Annex
import Types.Backend import Types.Backend
import Types.Key import Types.Key
backends :: [Backend Annex] backends :: [Backend]
backends = [backend] backends = [backend]
backend :: Backend Annex backend :: Backend
backend = Types.Backend.Backend { backend = Backend {
name = "WORM", name = "WORM",
getKey = keyValue, getKey = keyValue,
fsckKey = const (return True) fsckKey = const (return True)

4
Command.hs
View file

@ -77,10 +77,10 @@ doCommand = start
{- Modifies an action to only act on files that are already annexed, {- Modifies an action to only act on files that are already annexed,
- and passes the key and backend on to it. -} - and passes the key and backend on to it. -}
whenAnnexed :: (FilePath -> (Key, Backend Annex) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a) whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a)
whenAnnexed a file = ifAnnexed file (a file) (return Nothing) whenAnnexed a file = ifAnnexed file (a file) (return Nothing)
ifAnnexed :: FilePath -> ((Key, Backend Annex) -> Annex a) -> Annex a -> Annex a ifAnnexed :: FilePath -> ((Key, Backend) -> Annex a) -> Annex a -> Annex a
ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file ifAnnexed file yes no = maybe no yes =<< Backend.lookupFile file
notBareRepo :: Annex a -> Annex a notBareRepo :: Annex a -> Annex a

2
Command/Copy.hs
View file

@ -21,6 +21,6 @@ seek = [withNumCopies $ \n -> whenAnnexed $ start n]
-- A copy is just a move that does not delete the source file. -- A copy is just a move that does not delete the source file.
-- However, --auto mode avoids unnecessary copies. -- However, --auto mode avoids unnecessary copies.
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, backend) = autoCopies key (<) numcopies $ start numcopies file (key, backend) = autoCopies key (<) numcopies $
Command.Move.start False file (key, backend) Command.Move.start False file (key, backend)

14
Command/Drop.hs
View file

@ -24,7 +24,7 @@ def = [dontCheck fromOpt $ command "drop" paramPaths seek
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withNumCopies $ \n -> whenAnnexed $ start n] seek = [withNumCopies $ \n -> whenAnnexed $ start n]
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, _) = autoCopies key (>) numcopies $ do start numcopies file (key, _) = autoCopies key (>) numcopies $ do
from <- Annex.getState Annex.fromremote from <- Annex.getState Annex.fromremote
case from of case from of
@ -41,7 +41,7 @@ startLocal file numcopies key = stopUnless (inAnnex key) $ do
showStart "drop" file showStart "drop" file
next $ performLocal key numcopies next $ performLocal key numcopies
startRemote :: FilePath -> Maybe Int -> Key -> Remote.Remote Annex -> CommandStart startRemote :: FilePath -> Maybe Int -> Key -> Remote -> CommandStart
startRemote file numcopies key remote = do startRemote file numcopies key remote = do
showStart "drop" file showStart "drop" file
next $ performRemote key numcopies remote next $ performRemote key numcopies remote
@ -55,7 +55,7 @@ performLocal key numcopies = lockContent key $ do
whenM (inAnnex key) $ removeAnnex key whenM (inAnnex key) $ removeAnnex key
next $ cleanupLocal key next $ cleanupLocal key
performRemote :: Key -> Maybe Int -> Remote.Remote Annex -> CommandPerform performRemote :: Key -> Maybe Int -> Remote -> CommandPerform
performRemote key numcopies remote = lockContent key $ do performRemote key numcopies remote = lockContent key $ do
-- Filter the remote it's being dropped from out of the lists of -- Filter the remote it's being dropped from out of the lists of
-- places assumed to have the key, and places to check. -- places assumed to have the key, and places to check.
@ -79,7 +79,7 @@ cleanupLocal key = do
logStatus key InfoMissing logStatus key InfoMissing
return True return True
cleanupRemote :: Key -> Remote.Remote Annex -> Bool -> CommandCleanup cleanupRemote :: Key -> Remote -> Bool -> CommandCleanup
cleanupRemote key remote ok = do cleanupRemote key remote ok = do
-- better safe than sorry: assume the remote dropped the key -- better safe than sorry: assume the remote dropped the key
-- even if it seemed to fail; the failure could have occurred -- even if it seemed to fail; the failure could have occurred
@ -90,7 +90,7 @@ cleanupRemote key remote ok = do
{- Checks specified remotes to verify that enough copies of a key exist to {- Checks specified remotes to verify that enough copies of a key exist to
- allow it to be safely removed (with no data loss). Can be provided with - allow it to be safely removed (with no data loss). Can be provided with
- some locations where the key is known/assumed to be present. -} - some locations where the key is known/assumed to be present. -}
canDropKey :: Key -> Maybe Int -> [UUID] -> [Remote.Remote Annex] -> [UUID] -> Annex Bool canDropKey :: Key -> Maybe Int -> [UUID] -> [Remote] -> [UUID] -> Annex Bool
canDropKey key numcopiesM have check skip = do canDropKey key numcopiesM have check skip = do
force <- Annex.getState Annex.force force <- Annex.getState Annex.force
if force || numcopiesM == Just 0 if force || numcopiesM == Just 0
@ -99,7 +99,7 @@ canDropKey key numcopiesM have check skip = do
need <- getNumCopies numcopiesM need <- getNumCopies numcopiesM
findCopies key need skip have check findCopies key need skip have check
findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote.Remote Annex] -> Annex Bool findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
findCopies key need skip = helper [] findCopies key need skip = helper []
where where
helper bad have [] helper bad have []
@ -116,7 +116,7 @@ findCopies key need skip = helper []
(False, Left _) -> helper (r:bad) have rs (False, Left _) -> helper (r:bad) have rs
_ -> helper bad have rs _ -> helper bad have rs
notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote.Remote Annex] -> Annex Bool notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
notEnoughCopies key need have skip bad = do notEnoughCopies key need have skip bad = do
unsafe unsafe
showLongNote $ showLongNote $

2
Command/Find.hs
View file

@ -24,7 +24,7 @@ def = [command "find" paramPaths seek "lists available files"]
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start] seek = [withFilesInGit $ whenAnnexed start]
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do start file (key, _) = do
-- only files inAnnex are shown, unless the user has requested -- only files inAnnex are shown, unless the user has requested
-- others via a limit -- others via a limit

2
Command/Fix.hs
View file

@ -20,7 +20,7 @@ seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start] seek = [withFilesInGit $ whenAnnexed start]
{- Fixes the symlink to an annexed file. -} {- Fixes the symlink to an annexed file. -}
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do start file (key, _) = do
link <- calcGitLink file key link <- calcGitLink file key
stopUnless ((/=) link <$> liftIO (readSymbolicLink file)) $ do stopUnless ((/=) link <$> liftIO (readSymbolicLink file)) $ do

8
Command/Fsck.hs
View file

@ -30,12 +30,12 @@ seek =
, withBarePresentKeys startBare , withBarePresentKeys startBare
] ]
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, backend) = do start numcopies file (key, backend) = do
showStart "fsck" file showStart "fsck" file
next $ perform key file backend numcopies next $ perform key file backend numcopies
perform :: Key -> FilePath -> Backend Annex -> Maybe Int -> CommandPerform perform :: Key -> FilePath -> Backend -> Maybe Int -> CommandPerform
perform key file backend numcopies = check perform key file backend numcopies = check
-- order matters -- order matters
[ verifyLocationLog key file [ verifyLocationLog key file
@ -64,7 +64,7 @@ startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName ke
{- Note that numcopies cannot be checked in a bare repository, because {- Note that numcopies cannot be checked in a bare repository, because
- getting the numcopies value requires a working copy with .gitattributes - getting the numcopies value requires a working copy with .gitattributes
- files. -} - files. -}
performBare :: Key -> Backend Annex -> CommandPerform performBare :: Key -> Backend -> CommandPerform
performBare key backend = check performBare key backend = check
[ verifyLocationLog key (show key) [ verifyLocationLog key (show key)
, checkKeySize key , checkKeySize key
@ -136,7 +136,7 @@ checkKeySize key = do
return False return False
checkBackend :: Backend Annex -> Key -> Annex Bool checkBackend :: Backend -> Key -> Annex Bool
checkBackend = Types.Backend.fsckKey checkBackend = Types.Backend.fsckKey
checkKeyNumCopies :: Key -> FilePath -> Maybe Int -> Annex Bool checkKeyNumCopies :: Key -> FilePath -> Maybe Int -> Annex Bool

2
Command/Get.hs
View file

@ -21,7 +21,7 @@ def = [dontCheck fromOpt $ command "get" paramPaths seek
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withNumCopies $ \n -> whenAnnexed $ start n] seek = [withNumCopies $ \n -> whenAnnexed $ start n]
start :: Maybe Int -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Int -> FilePath -> (Key, Backend) -> CommandStart
start numcopies file (key, _) = stopUnless (not <$> inAnnex key) $ start numcopies file (key, _) = stopUnless (not <$> inAnnex key) $
autoCopies key (<) numcopies $ do autoCopies key (<) numcopies $ do
from <- Annex.getState Annex.fromremote from <- Annex.getState Annex.fromremote

4
Command/InitRemote.hs
View file

@ -42,7 +42,7 @@ start (name:ws) = do
where where
config = Logs.Remote.keyValToConfig ws config = Logs.Remote.keyValToConfig ws
perform :: R.RemoteType Annex -> UUID -> R.RemoteConfig -> CommandPerform perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
perform t u c = do perform t u c = do
c' <- R.setup t u c c' <- R.setup t u c
next $ cleanup u c' next $ cleanup u c'
@ -77,7 +77,7 @@ remoteNames = do
return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m
{- find the specified remote type -} {- find the specified remote type -}
findType :: R.RemoteConfig -> Annex (R.RemoteType Annex) findType :: R.RemoteConfig -> Annex RemoteType
findType config = maybe unspecified specified $ M.lookup typeKey config findType config = maybe unspecified specified $ M.lookup typeKey config
where where
unspecified = error "Specify the type of remote with type=" unspecified = error "Specify the type of remote with type="

4
Command/Migrate.hs
View file

@ -21,7 +21,7 @@ def = [command "migrate" paramPaths seek "switch data to different backend"]
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withBackendFilesInGit $ \(b, f) -> whenAnnexed (start b) f] seek = [withBackendFilesInGit $ \(b, f) -> whenAnnexed (start b) f]
start :: Maybe (Backend Annex) -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Maybe Backend -> FilePath -> (Key, Backend) -> CommandStart
start b file (key, oldbackend) = do start b file (key, oldbackend) = do
exists <- inAnnex key exists <- inAnnex key
newbackend <- choosebackend b newbackend <- choosebackend b
@ -47,7 +47,7 @@ upgradableKey key = isNothing $ Types.Key.keySize key
- backends that allow the filename to influence the keys they - backends that allow the filename to influence the keys they
- generate. - generate.
-} -}
perform :: FilePath -> Key -> Backend Annex -> CommandPerform perform :: FilePath -> Key -> Backend -> CommandPerform
perform file oldkey newbackend = do perform file oldkey newbackend = do
src <- inRepo $ gitAnnexLocation oldkey src <- inRepo $ gitAnnexLocation oldkey
tmp <- fromRepo gitAnnexTmpDir tmp <- fromRepo gitAnnexTmpDir

12
Command/Move.hs
View file

@ -23,7 +23,7 @@ def = [dontCheck toOpt $ dontCheck fromOpt $
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed $ start True] seek = [withFilesInGit $ whenAnnexed $ start True]
start :: Bool -> FilePath -> (Key, Backend Annex) -> CommandStart start :: Bool -> FilePath -> (Key, Backend) -> CommandStart
start move file (key, _) = do start move file (key, _) = do
noAuto noAuto
to <- Annex.getState Annex.toremote to <- Annex.getState Annex.toremote
@ -54,7 +54,7 @@ showMoveAction False file = showStart "copy" file
- A file's content can be moved even if there are insufficient copies to - A file's content can be moved even if there are insufficient copies to
- allow it to be dropped. - allow it to be dropped.
-} -}
toStart :: Remote.Remote Annex -> Bool -> FilePath -> Key -> CommandStart toStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
toStart dest move file key = do toStart dest move file key = do
u <- getUUID u <- getUUID
ishere <- inAnnex key ishere <- inAnnex key
@ -63,7 +63,7 @@ toStart dest move file key = do
else do else do
showMoveAction move file showMoveAction move file
next $ toPerform dest move key next $ toPerform dest move key
toPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform toPerform :: Remote -> Bool -> Key -> CommandPerform
toPerform dest move key = moveLock move key $ do toPerform dest move key = moveLock move key $ do
-- Checking the remote is expensive, so not done in the start step. -- Checking the remote is expensive, so not done in the start step.
-- In fast mode, location tracking is assumed to be correct, -- In fast mode, location tracking is assumed to be correct,
@ -105,7 +105,7 @@ toPerform dest move key = moveLock move key $ do
- If the current repository already has the content, it is still removed - If the current repository already has the content, it is still removed
- from the remote. - from the remote.
-} -}
fromStart :: Remote.Remote Annex -> Bool -> FilePath -> Key -> CommandStart fromStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
fromStart src move file key fromStart src move file key
| move = go | move = go
| otherwise = stopUnless (not <$> inAnnex key) go | otherwise = stopUnless (not <$> inAnnex key) go
@ -113,12 +113,12 @@ fromStart src move file key
go = stopUnless (fromOk src key) $ do go = stopUnless (fromOk src key) $ do
showMoveAction move file showMoveAction move file
next $ fromPerform src move key next $ fromPerform src move key
fromOk :: Remote.Remote Annex -> Key -> Annex Bool fromOk :: Remote -> Key -> Annex Bool
fromOk src key = do fromOk src key = do
u <- getUUID u <- getUUID
remotes <- Remote.keyPossibilities key remotes <- Remote.keyPossibilities key
return $ u /= Remote.uuid src && any (== src) remotes return $ u /= Remote.uuid src && any (== src) remotes
fromPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform fromPerform :: Remote -> Bool -> Key -> CommandPerform
fromPerform src move key = moveLock move key $ do fromPerform src move key = moveLock move key $ do
ishere <- inAnnex key ishere <- inAnnex key
if ishere if ishere

4
Command/Reinject.hs
View file

@ -33,7 +33,7 @@ start (src:dest:[])
next $ whenAnnexed (perform src) dest next $ whenAnnexed (perform src) dest
start _ = error "specify a src file and a dest file" start _ = error "specify a src file and a dest file"
perform :: FilePath -> FilePath -> (Key, Backend Annex) -> CommandPerform perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform
perform src _dest (key, backend) = do perform src _dest (key, backend) = do
unlessM move $ error "mv failed!" unlessM move $ error "mv failed!"
next $ cleanup key backend next $ cleanup key backend
@ -45,7 +45,7 @@ perform src _dest (key, backend) = do
move = getViaTmp key $ \tmp -> move = getViaTmp key $ \tmp ->
liftIO $ boolSystem "mv" [File src, File tmp] liftIO $ boolSystem "mv" [File src, File tmp]
cleanup :: Key -> Backend Annex -> CommandCleanup cleanup :: Key -> Backend -> CommandCleanup
cleanup key backend = do cleanup key backend = do
logStatus key InfoPresent logStatus key InfoPresent

14
Command/Sync.hs
View file

@ -47,10 +47,10 @@ seek rs = do
syncBranch :: Git.Ref -> Git.Ref syncBranch :: Git.Ref -> Git.Ref
syncBranch = Git.Ref.under "refs/heads/synced/" syncBranch = Git.Ref.under "refs/heads/synced/"
remoteBranch :: Remote.Remote Annex -> Git.Ref -> Git.Ref remoteBranch :: Remote -> Git.Ref -> Git.Ref
remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
syncRemotes :: [String] -> Annex [Remote.Remote Annex] syncRemotes :: [String] -> Annex [Remote]
syncRemotes rs = do syncRemotes rs = do
fast <- Annex.getState Annex.fast fast <- Annex.getState Annex.fast
if fast if fast
@ -106,7 +106,7 @@ updateBranch syncbranch =
, Param $ show $ Git.Ref.base syncbranch , Param $ show $ Git.Ref.base syncbranch
] ]
pullRemote :: Remote.Remote Annex -> Git.Ref -> CommandStart pullRemote :: Remote -> Git.Ref -> CommandStart
pullRemote remote branch = do pullRemote remote branch = do
showStart "pull" (Remote.name remote) showStart "pull" (Remote.name remote)
next $ do next $ do
@ -121,13 +121,13 @@ pullRemote remote branch = do
- Which to merge from? Well, the master has whatever latest changes - Which to merge from? Well, the master has whatever latest changes
- were committed, while the synced/master may have changes that some - were committed, while the synced/master may have changes that some
- other remote synced to this remote. So, merge them both. -} - other remote synced to this remote. So, merge them both. -}
mergeRemote :: Remote.Remote Annex -> Git.Ref -> CommandCleanup mergeRemote :: Remote -> Git.Ref -> CommandCleanup
mergeRemote remote branch = all id <$> (mapM merge =<< tomerge) mergeRemote remote branch = all id <$> (mapM merge =<< tomerge)
where where
merge = mergeFrom . remoteBranch remote merge = mergeFrom . remoteBranch remote
tomerge = filterM (changed remote) [branch, syncBranch branch] tomerge = filterM (changed remote) [branch, syncBranch branch]
pushRemote :: Remote.Remote Annex -> Git.Ref -> CommandStart pushRemote :: Remote -> Git.Ref -> CommandStart
pushRemote remote branch = go =<< needpush pushRemote remote branch = go =<< needpush
where where
needpush = anyM (newer remote) [syncbranch, Annex.Branch.name] needpush = anyM (newer remote) [syncbranch, Annex.Branch.name]
@ -154,7 +154,7 @@ mergeFrom branch = do
showOutput showOutput
inRepo $ Git.Command.runBool "merge" [Param $ show branch] inRepo $ Git.Command.runBool "merge" [Param $ show branch]
changed :: Remote.Remote Annex -> Git.Ref -> Annex Bool changed :: Remote -> Git.Ref -> Annex Bool
changed remote b = do changed remote b = do
let r = remoteBranch remote b let r = remoteBranch remote b
e <- inRepo $ Git.Ref.exists r e <- inRepo $ Git.Ref.exists r
@ -162,7 +162,7 @@ changed remote b = do
then inRepo $ Git.Branch.changed b r then inRepo $ Git.Branch.changed b r
else return False else return False
newer :: Remote.Remote Annex -> Git.Ref -> Annex Bool newer :: Remote -> Git.Ref -> Annex Bool
newer remote b = do newer remote b = do
let r = remoteBranch remote b let r = remoteBranch remote b
e <- inRepo $ Git.Ref.exists r e <- inRepo $ Git.Ref.exists r

2
Command/Unannex.hs
View file

@ -22,7 +22,7 @@ def = [command "unannex" paramPaths seek "undo accidential add command"]
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start] seek = [withFilesInGit $ whenAnnexed start]
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = stopUnless (inAnnex key) $ do start file (key, _) = stopUnless (inAnnex key) $ do
showStart "unannex" file showStart "unannex" file
next $ perform file key next $ perform file key

2
Command/Uninit.hs
View file

@ -36,7 +36,7 @@ check = do
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed startUnannex, withNothing start] seek = [withFilesInGit $ whenAnnexed startUnannex, withNothing start]
startUnannex :: FilePath -> (Key, Backend Annex) -> CommandStart startUnannex :: FilePath -> (Key, Backend) -> CommandStart
startUnannex file info = do startUnannex file info = do
-- Force fast mode before running unannex. This way, if multiple -- Force fast mode before running unannex. This way, if multiple
-- files link to a key, it will be left in the annex and hardlinked -- files link to a key, it will be left in the annex and hardlinked

2
Command/Unlock.hs
View file

@ -26,7 +26,7 @@ seek = [withFilesInGit $ whenAnnexed start]
{- The unlock subcommand replaces the symlink with a copy of the file's {- The unlock subcommand replaces the symlink with a copy of the file's
- content. -} - content. -}
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do start file (key, _) = do
showStart "unlock" file showStart "unlock" file
next $ perform file key next $ perform file key

6
Command/Unused.hs
View file

@ -66,7 +66,7 @@ checkRemoteUnused name = do
checkRemoteUnused' =<< Remote.byName name checkRemoteUnused' =<< Remote.byName name
next $ return True next $ return True
checkRemoteUnused' :: Remote.Remote Annex -> Annex () checkRemoteUnused' :: Remote -> Annex ()
checkRemoteUnused' r = do checkRemoteUnused' r = do
showAction "checking for unused data" showAction "checking for unused data"
remotehas <- loggedKeysFor (Remote.uuid r) remotehas <- loggedKeysFor (Remote.uuid r)
@ -112,14 +112,14 @@ unusedMsg' u header trailer = unlines $
["(To see where data was previously used, try: git log --stat -S'KEY')"] ++ ["(To see where data was previously used, try: git log --stat -S'KEY')"] ++
trailer trailer
remoteUnusedMsg :: Remote.Remote Annex -> [(Int, Key)] -> String remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
remoteUnusedMsg r u = unusedMsg' u remoteUnusedMsg r u = unusedMsg' u
["Some annexed data on " ++ name ++ " is not used by any files:"] ["Some annexed data on " ++ name ++ " is not used by any files:"]
[dropMsg $ Just r] [dropMsg $ Just r]
where where
name = Remote.name r name = Remote.name r
dropMsg :: Maybe (Remote.Remote Annex) -> String dropMsg :: Maybe Remote -> String
dropMsg Nothing = dropMsg' "" dropMsg Nothing = dropMsg' ""
dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r
dropMsg' :: String -> String dropMsg' :: String -> String

2
Command/Whereis.hs
View file

@ -20,7 +20,7 @@ def = [command "whereis" paramPaths seek
seek :: [CommandSeek] seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start] seek = [withFilesInGit $ whenAnnexed start]
start :: FilePath -> (Key, Backend Annex) -> CommandStart start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do start file (key, _) = do
showStart "whereis" file showStart "whereis" file
next $ perform key next $ perform key

24
Remote.hs
View file

@ -54,7 +54,7 @@ import qualified Remote.Rsync
import qualified Remote.Web import qualified Remote.Web
import qualified Remote.Hook import qualified Remote.Hook
remoteTypes :: [RemoteType Annex] remoteTypes :: [RemoteType]
remoteTypes = remoteTypes =
[ Remote.Git.remote [ Remote.Git.remote
, Remote.S3.remote , Remote.S3.remote
@ -67,7 +67,7 @@ remoteTypes =
{- Builds a list of all available Remotes. {- Builds a list of all available Remotes.
- Since doing so can be expensive, the list is cached. -} - Since doing so can be expensive, the list is cached. -}
remoteList :: Annex [Remote Annex] remoteList :: Annex [Remote]
remoteList = do remoteList = do
rs <- Annex.getState Annex.remotes rs <- Annex.getState Annex.remotes
if null rs if null rs
@ -87,7 +87,7 @@ remoteList = do
generate t r u (M.lookup u m) generate t r u (M.lookup u m)
{- All remotes that are not ignored. -} {- All remotes that are not ignored. -}
enabledRemoteList :: Annex [Remote Annex] enabledRemoteList :: Annex [Remote]
enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList
{- Map of UUIDs of Remotes and their names. -} {- Map of UUIDs of Remotes and their names. -}
@ -96,13 +96,13 @@ remoteMap = M.fromList . map (\r -> (uuid r, name r)) <$> remoteList
{- Looks up a remote by name. (Or by UUID.) Only finds currently configured {- Looks up a remote by name. (Or by UUID.) Only finds currently configured
- git remotes. -} - git remotes. -}
byName :: String -> Annex (Remote Annex) byName :: String -> Annex (Remote)
byName n = do byName n = do
res <- byName' n res <- byName' n
case res of case res of
Left e -> error e Left e -> error e
Right r -> return r Right r -> return r
byName' :: String -> Annex (Either String (Remote Annex)) byName' :: String -> Annex (Either String Remote)
byName' "" = return $ Left "no remote specified" byName' "" = return $ Left "no remote specified"
byName' n = do byName' n = do
match <- filter matching <$> remoteList match <- filter matching <$> remoteList
@ -168,16 +168,16 @@ prettyPrintUUIDs desc uuids = do
] ]
{- Filters a list of remotes to ones that have the listed uuids. -} {- Filters a list of remotes to ones that have the listed uuids. -}
remotesWithUUID :: [Remote Annex] -> [UUID] -> [Remote Annex] remotesWithUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs
{- Filters a list of remotes to ones that do not have the listed uuids. -} {- Filters a list of remotes to ones that do not have the listed uuids. -}
remotesWithoutUUID :: [Remote Annex] -> [UUID] -> [Remote Annex] remotesWithoutUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs
{- Cost ordered lists of remotes that the Logs.Location indicate may have a key. {- Cost ordered lists of remotes that the Logs.Location indicate may have a key.
-} -}
keyPossibilities :: Key -> Annex [Remote Annex] keyPossibilities :: Key -> Annex [Remote]
keyPossibilities key = fst <$> keyPossibilities' False key keyPossibilities key = fst <$> keyPossibilities' False key
{- Cost ordered lists of remotes that the Logs.Location indicate may have a key. {- Cost ordered lists of remotes that the Logs.Location indicate may have a key.
@ -185,10 +185,10 @@ keyPossibilities key = fst <$> keyPossibilities' False key
- Also returns a list of UUIDs that are trusted to have the key - Also returns a list of UUIDs that are trusted to have the key
- (some may not have configured remotes). - (some may not have configured remotes).
-} -}
keyPossibilitiesTrusted :: Key -> Annex ([Remote Annex], [UUID]) keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID])
keyPossibilitiesTrusted = keyPossibilities' True keyPossibilitiesTrusted = keyPossibilities' True
keyPossibilities' :: Bool -> Key -> Annex ([Remote Annex], [UUID]) keyPossibilities' :: Bool -> Key -> Annex ([Remote], [UUID])
keyPossibilities' withtrusted key = do keyPossibilities' withtrusted key = do
u <- getUUID u <- getUUID
trusted <- if withtrusted then trustGet Trusted else return [] trusted <- if withtrusted then trustGet Trusted else return []
@ -224,7 +224,7 @@ showLocations key exclude = do
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
message rs us = message rs [] ++ message [] us message rs us = message rs [] ++ message [] us
showTriedRemotes :: [Remote Annex] -> Annex () showTriedRemotes :: [Remote] -> Annex ()
showTriedRemotes [] = return () showTriedRemotes [] = return ()
showTriedRemotes remotes = showTriedRemotes remotes =
showLongNote $ "Unable to access these remotes: " ++ showLongNote $ "Unable to access these remotes: " ++
@ -240,7 +240,7 @@ forceTrust level remotename = do
- in the local repo, not on the remote. The process of transferring the - in the local repo, not on the remote. The process of transferring the
- key to the remote, or removing the key from it *may* log the change - key to the remote, or removing the key from it *may* log the change
- on the remote, but this cannot always be relied on. -} - on the remote, but this cannot always be relied on. -}
logStatus :: Remote Annex -> Key -> Bool -> Annex () logStatus :: Remote -> Key -> Bool -> Annex ()
logStatus remote key present = logChange key (uuid remote) status logStatus remote key present = logChange key (uuid remote) status
where where
status = if present then InfoPresent else InfoMissing status = if present then InfoPresent else InfoMissing

4
Remote/Bup.hs
View file

@ -26,7 +26,7 @@ import Crypto
type BupRepo = String type BupRepo = String
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "bup", typename = "bup",
enumerate = findSpecialRemotes "buprepo", enumerate = findSpecialRemotes "buprepo",
@ -34,7 +34,7 @@ remote = RemoteType {
setup = bupSetup setup = bupSetup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
buprepo <- getConfig r "buprepo" (error "missing buprepo") buprepo <- getConfig r "buprepo" (error "missing buprepo")
cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost) cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)

4
Remote/Directory.hs
View file

@ -20,7 +20,7 @@ import Remote.Helper.Special
import Remote.Helper.Encryptable import Remote.Helper.Encryptable
import Crypto import Crypto
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "directory", typename = "directory",
enumerate = findSpecialRemotes "directory", enumerate = findSpecialRemotes "directory",
@ -28,7 +28,7 @@ remote = RemoteType {
setup = directorySetup setup = directorySetup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
dir <- getConfig r "directory" (error "missing directory") dir <- getConfig r "directory" (error "missing directory")
cst <- remoteCost r cheapRemoteCost cst <- remoteCost r cheapRemoteCost

4
Remote/Git.hs
View file

@ -28,7 +28,7 @@ import Utility.TempFile
import Config import Config
import Init import Init
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "git", typename = "git",
enumerate = list, enumerate = list,
@ -50,7 +50,7 @@ list = do
Git.Construct.remoteNamed n $ Git.Construct.remoteNamed n $
Git.Construct.fromRemoteLocation url g Git.Construct.fromRemoteLocation url g
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u _ = do gen r u _ = do
{- It's assumed to be cheap to read the config of non-URL remotes, {- It's assumed to be cheap to read the config of non-URL remotes,
- so this is done each time git-annex is run. Conversely, - so this is done each time git-annex is run. Conversely,

4
Remote/Helper/Encryptable.hs
View file

@ -41,8 +41,8 @@ encryptableRemote
:: Maybe RemoteConfig :: Maybe RemoteConfig
-> ((Cipher, Key) -> Key -> Annex Bool) -> ((Cipher, Key) -> Key -> Annex Bool)
-> ((Cipher, Key) -> FilePath -> Annex Bool) -> ((Cipher, Key) -> FilePath -> Annex Bool)
-> Remote Annex -> Remote
-> Remote Annex -> Remote
encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
r { r {
storeKey = store, storeKey = store,

4
Remote/Hook.hs
View file

@ -20,7 +20,7 @@ import Remote.Helper.Special
import Remote.Helper.Encryptable import Remote.Helper.Encryptable
import Crypto import Crypto
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "hook", typename = "hook",
enumerate = findSpecialRemotes "hooktype", enumerate = findSpecialRemotes "hooktype",
@ -28,7 +28,7 @@ remote = RemoteType {
setup = hookSetup setup = hookSetup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
hooktype <- getConfig r "hooktype" (error "missing hooktype") hooktype <- getConfig r "hooktype" (error "missing hooktype")
cst <- remoteCost r expensiveRemoteCost cst <- remoteCost r expensiveRemoteCost

4
Remote/Rsync.hs
View file

@ -27,7 +27,7 @@ data RsyncOpts = RsyncOpts {
rsyncOptions :: [CommandParam] rsyncOptions :: [CommandParam]
} }
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "rsync", typename = "rsync",
enumerate = findSpecialRemotes "rsyncurl", enumerate = findSpecialRemotes "rsyncurl",
@ -35,7 +35,7 @@ remote = RemoteType {
setup = rsyncSetup setup = rsyncSetup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
o <- genRsyncOpts r o <- genRsyncOpts r
cst <- remoteCost r expensiveRemoteCost cst <- remoteCost r expensiveRemoteCost

26
Remote/S3real.hs
View file

@ -28,7 +28,7 @@ import Crypto
import Annex.Content import Annex.Content
import Utility.Base64 import Utility.Base64
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "S3", typename = "S3",
enumerate = findSpecialRemotes "s3", enumerate = findSpecialRemotes "s3",
@ -36,11 +36,11 @@ remote = RemoteType {
setup = s3Setup setup = s3Setup
} }
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r u c = do gen r u c = do
cst <- remoteCost r expensiveRemoteCost cst <- remoteCost r expensiveRemoteCost
return $ gen' r u c cst return $ gen' r u c cst
gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote Annex gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote
gen' r u c cst = gen' r u c cst =
encryptableRemote c encryptableRemote c
(storeEncrypted this) (storeEncrypted this)
@ -111,13 +111,13 @@ s3Setup u c = handlehost $ M.lookup "host" c
-- be human-readable -- be human-readable
M.delete "bucket" defaults M.delete "bucket" defaults
store :: Remote Annex -> Key -> Annex Bool store :: Remote -> Key -> Annex Bool
store r k = s3Action r False $ \(conn, bucket) -> do store r k = s3Action r False $ \(conn, bucket) -> do
dest <- inRepo $ gitAnnexLocation k dest <- inRepo $ gitAnnexLocation k
res <- liftIO $ storeHelper (conn, bucket) r k dest res <- liftIO $ storeHelper (conn, bucket) r k dest
s3Bool res s3Bool res
storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted :: Remote -> (Cipher, Key) -> Key -> Annex Bool
storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) -> storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) ->
-- To get file size of the encrypted content, have to use a temp file. -- To get file size of the encrypted content, have to use a temp file.
-- (An alternative would be chunking to to a constant size.) -- (An alternative would be chunking to to a constant size.)
@ -127,7 +127,7 @@ storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) ->
res <- liftIO $ storeHelper (conn, bucket) r enck tmp res <- liftIO $ storeHelper (conn, bucket) r enck tmp
s3Bool res s3Bool res
storeHelper :: (AWSConnection, String) -> Remote Annex -> Key -> FilePath -> IO (AWSResult ()) storeHelper :: (AWSConnection, String) -> Remote -> Key -> FilePath -> IO (AWSResult ())
storeHelper (conn, bucket) r k file = do storeHelper (conn, bucket) r k file = do
content <- liftIO $ L.readFile file content <- liftIO $ L.readFile file
-- size is provided to S3 so the whole content does not need to be -- size is provided to S3 so the whole content does not need to be
@ -149,7 +149,7 @@ storeHelper (conn, bucket) r k file = do
xheaders = filter isxheader $ M.assocs $ fromJust $ config r xheaders = filter isxheader $ M.assocs $ fromJust $ config r
isxheader (h, _) = "x-amz-" `isPrefixOf` h isxheader (h, _) = "x-amz-" `isPrefixOf` h
retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool retrieve :: Remote -> Key -> FilePath -> Annex Bool
retrieve r k f = s3Action r False $ \(conn, bucket) -> do retrieve r k f = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ getObject conn $ bucketKey r bucket k res <- liftIO $ getObject conn $ bucketKey r bucket k
case res of case res of
@ -158,7 +158,7 @@ retrieve r k f = s3Action r False $ \(conn, bucket) -> do
return True return True
Left e -> s3Warning e Left e -> s3Warning e
retrieveEncrypted :: Remote Annex -> (Cipher, Key) -> FilePath -> Annex Bool retrieveEncrypted :: Remote -> (Cipher, Key) -> FilePath -> Annex Bool
retrieveEncrypted r (cipher, enck) f = s3Action r False $ \(conn, bucket) -> do retrieveEncrypted r (cipher, enck) f = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ getObject conn $ bucketKey r bucket enck res <- liftIO $ getObject conn $ bucketKey r bucket enck
case res of case res of
@ -168,12 +168,12 @@ retrieveEncrypted r (cipher, enck) f = s3Action r False $ \(conn, bucket) -> do
return True return True
Left e -> s3Warning e Left e -> s3Warning e
remove :: Remote Annex -> Key -> Annex Bool remove :: Remote -> Key -> Annex Bool
remove r k = s3Action r False $ \(conn, bucket) -> do remove r k = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ deleteObject conn $ bucketKey r bucket k res <- liftIO $ deleteObject conn $ bucketKey r bucket k
s3Bool res s3Bool res
checkPresent :: Remote Annex -> Key -> Annex (Either String Bool) checkPresent :: Remote -> Key -> Annex (Either String Bool)
checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do
showAction $ "checking " ++ name r showAction $ "checking " ++ name r
res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k res <- liftIO $ getObjectInfo conn $ bucketKey r bucket k
@ -196,7 +196,7 @@ s3Bool :: AWSResult () -> Annex Bool
s3Bool (Right _) = return True s3Bool (Right _) = return True
s3Bool (Left e) = s3Warning e s3Bool (Left e) = s3Warning e
s3Action :: Remote Annex -> a -> ((AWSConnection, String) -> Annex a) -> Annex a s3Action :: Remote -> a -> ((AWSConnection, String) -> Annex a) -> Annex a
s3Action r noconn action = do s3Action r noconn action = do
when (isNothing $ config r) $ when (isNothing $ config r) $
error $ "Missing configuration for special remote " ++ name r error $ "Missing configuration for special remote " ++ name r
@ -206,14 +206,14 @@ s3Action r noconn action = do
(Just b, Just c) -> action (c, b) (Just b, Just c) -> action (c, b)
_ -> return noconn _ -> return noconn
bucketFile :: Remote Annex -> Key -> FilePath bucketFile :: Remote -> Key -> FilePath
bucketFile r = munge . show bucketFile r = munge . show
where where
munge s = case M.lookup "mungekeys" $ fromJust $ config r of munge s = case M.lookup "mungekeys" $ fromJust $ config r of
Just "ia" -> iaMunge s Just "ia" -> iaMunge s
_ -> s _ -> s
bucketKey :: Remote Annex -> String -> Key -> S3Object bucketKey :: Remote -> String -> Key -> S3Object
bucketKey r bucket k = S3Object bucket (bucketFile r k) "" [] L.empty bucketKey r bucket k = S3Object bucket (bucketFile r k) "" [] L.empty
{- Internet Archive limits filenames to a subset of ascii, {- Internet Archive limits filenames to a subset of ascii,

2
Remote/S3stub.hs
View file

@ -4,7 +4,7 @@ module Remote.S3 (remote) where
import Types.Remote import Types.Remote
import Types import Types
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "S3", typename = "S3",
enumerate = return [], enumerate = return [],

4
Remote/Web.hs
View file

@ -15,7 +15,7 @@ import Config
import Logs.Web import Logs.Web
import qualified Utility.Url as Url import qualified Utility.Url as Url
remote :: RemoteType Annex remote :: RemoteType
remote = RemoteType { remote = RemoteType {
typename = "web", typename = "web",
enumerate = list, enumerate = list,
@ -31,7 +31,7 @@ list = do
r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown
return [r] return [r]
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex) gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
gen r _ _ = gen r _ _ =
return Remote { return Remote {
uuid = webUUID, uuid = webUUID,

9
Types.hs
View file

@ -9,10 +9,17 @@ module Types (
Annex, Annex,
Backend, Backend,
Key, Key,
UUID(..) UUID(..),
Remote,
RemoteType
) where ) where
import Annex import Annex
import Types.Backend import Types.Backend
import Types.Key import Types.Key
import Types.UUID import Types.UUID
import Types.Remote
type Backend = BackendA Annex
type Remote = RemoteA Annex
type RemoteType = RemoteTypeA Annex

6
Types/Backend.hs
View file

@ -11,7 +11,7 @@ module Types.Backend where
import Types.Key import Types.Key
data Backend a = Backend { data BackendA a = 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
@ -20,8 +20,8 @@ data Backend a = Backend {
fsckKey :: Key -> a Bool fsckKey :: Key -> a Bool
} }
instance Show (Backend a) where instance Show (BackendA a) where
show backend = "Backend { name =\"" ++ name backend ++ "\" }" show backend = "Backend { name =\"" ++ name backend ++ "\" }"
instance Eq (Backend a) where instance Eq (BackendA a) where
a == b = name a == name b a == b = name a == name b

16
Types/Remote.hs
View file

@ -19,22 +19,22 @@ import Types.UUID
type RemoteConfig = M.Map String String type RemoteConfig = M.Map String String
{- There are different types of remotes. -} {- There are different types of remotes. -}
data RemoteType a = RemoteType { data RemoteTypeA a = RemoteType {
-- human visible type name -- human visible type name
typename :: String, typename :: String,
-- enumerates remotes of this type -- enumerates remotes of this type
enumerate :: a [Git.Repo], enumerate :: a [Git.Repo],
-- generates a remote of this type -- generates a remote of this type
generate :: Git.Repo -> UUID -> Maybe RemoteConfig -> a (Remote a), generate :: Git.Repo -> UUID -> Maybe RemoteConfig -> a (RemoteA a),
-- initializes or changes a remote -- initializes or changes a remote
setup :: UUID -> RemoteConfig -> a RemoteConfig setup :: UUID -> RemoteConfig -> a RemoteConfig
} }
instance Eq (RemoteType a) where instance Eq (RemoteTypeA a) where
x == y = typename x == typename y x == y = typename x == typename y
{- An individual remote. -} {- An individual remote. -}
data Remote a = Remote { data RemoteA a = Remote {
-- each Remote has a unique uuid -- each Remote has a unique uuid
uuid :: UUID, uuid :: UUID,
-- each Remote has a human visible name -- each Remote has a human visible name
@ -58,16 +58,16 @@ data Remote a = Remote {
-- git configuration for the remote -- git configuration for the remote
repo :: Git.Repo, repo :: Git.Repo,
-- the type of the remote -- the type of the remote
remotetype :: RemoteType a remotetype :: RemoteTypeA a
} }
instance Show (Remote a) where instance Show (RemoteA a) where
show remote = "Remote { name =\"" ++ name remote ++ "\" }" show remote = "Remote { name =\"" ++ name remote ++ "\" }"
-- two remotes are the same if they have the same uuid -- two remotes are the same if they have the same uuid
instance Eq (Remote a) where instance Eq (RemoteA a) where
x == y = uuid x == uuid y x == y = uuid x == uuid y
-- order remotes by cost -- order remotes by cost
instance Ord (Remote a) where instance Ord (RemoteA a) where
compare = comparing cost compare = comparing cost

2
Upgrade/V0.hs
View file

@ -33,7 +33,7 @@ keyFile0 :: Key -> FilePath
keyFile0 = Upgrade.V1.keyFile1 keyFile0 = Upgrade.V1.keyFile1
fileKey0 :: FilePath -> Key fileKey0 :: FilePath -> Key
fileKey0 = Upgrade.V1.fileKey1 fileKey0 = Upgrade.V1.fileKey1
lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile0 = Upgrade.V1.lookupFile1 lookupFile0 = Upgrade.V1.lookupFile1
getKeysPresent0 :: FilePath -> Annex [Key] getKeysPresent0 :: FilePath -> Annex [Key]

2
Upgrade/V1.hs
View file

@ -181,7 +181,7 @@ writeLog1 file ls = viaTmp writeFile file (showLog ls)
readLog1 :: FilePath -> IO [LogLine] readLog1 :: FilePath -> IO [LogLine]
readLog1 file = catchDefaultIO (parseLog <$> readFileStrict file) [] readLog1 file = catchDefaultIO (parseLog <$> readFileStrict file) []
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile1 file = do lookupFile1 file = do
tl <- liftIO $ try getsymlink tl <- liftIO $ try getsymlink
case tl of case tl of

10
test.hs
View file

@ -850,7 +850,7 @@ checklocationlog f expected = do
expected (thisuuid `elem` uuids) expected (thisuuid `elem` uuids)
_ -> assertFailure $ f ++ " failed to look up key" _ -> assertFailure $ f ++ " failed to look up key"
checkbackend :: FilePath -> Types.Backend Types.Annex -> Assertion checkbackend :: FilePath -> Types.Backend -> Assertion
checkbackend file expected = do checkbackend file expected = do
r <- annexeval $ Backend.lookupFile file r <- annexeval $ Backend.lookupFile file
let b = snd $ fromJust r let b = snd $ fromJust r
@ -936,14 +936,14 @@ changecontent f = writeFile f $ changedcontent f
changedcontent :: FilePath -> String changedcontent :: FilePath -> String
changedcontent f = (content f) ++ " (modified)" changedcontent f = (content f) ++ " (modified)"
backendSHA1 :: Types.Backend Types.Annex backendSHA1 :: Types.Backend
backendSHA1 = backend_ "SHA1" backendSHA1 = backend_ "SHA1"
backendSHA256 :: Types.Backend Types.Annex backendSHA256 :: Types.Backend
backendSHA256 = backend_ "SHA256" backendSHA256 = backend_ "SHA256"
backendWORM :: Types.Backend Types.Annex backendWORM :: Types.Backend
backendWORM = backend_ "WORM" backendWORM = backend_ "WORM"
backend_ :: String -> Types.Backend Types.Annex backend_ :: String -> Types.Backend
backend_ name = Backend.lookupBackendName name backend_ name = Backend.lookupBackendName name