reorder repo parameters last
Many functions took the repo as their first parameter. Changing it consistently to be the last parameter allows doing some useful things with currying, that reduce boilerplate. In particular, g <- gitRepo is almost never needed now, instead use inRepo to run an IO action in the repo, and fromRepo to get a value from the repo. This also provides more opportunities to use monadic and applicative combinators.
This commit is contained in:
parent
2ff8915365
commit
bf460a0a98
46 changed files with 338 additions and 390 deletions
|
@ -102,15 +102,13 @@ bupSplitParams r buprepo k src = do
|
|||
|
||||
store :: Git.Repo -> BupRepo -> Key -> Annex Bool
|
||||
store r buprepo k = do
|
||||
g <- gitRepo
|
||||
let src = gitAnnexLocation g k
|
||||
src <- fromRepo $ gitAnnexLocation k
|
||||
params <- bupSplitParams r buprepo k (File src)
|
||||
liftIO $ boolSystem "bup" params
|
||||
|
||||
storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> Annex Bool
|
||||
storeEncrypted r buprepo (cipher, enck) k = do
|
||||
g <- gitRepo
|
||||
let src = gitAnnexLocation g k
|
||||
src <- fromRepo $ gitAnnexLocation k
|
||||
params <- bupSplitParams r buprepo enck (Param "-")
|
||||
liftIO $ catchBool $
|
||||
withEncryptedHandle cipher (L.readFile src) $ \h ->
|
||||
|
@ -147,7 +145,7 @@ checkPresent r bupr k
|
|||
showAction $ "checking " ++ Git.repoDescribe r
|
||||
ok <- onBupRemote bupr boolSystem "git" params
|
||||
return $ Right ok
|
||||
| otherwise = liftIO $ try $ boolSystem "git" $ Git.gitCommandLine bupr params
|
||||
| otherwise = liftIO $ try $ boolSystem "git" $ Git.gitCommandLine params bupr
|
||||
where
|
||||
params =
|
||||
[ Params "show-ref --quiet --verify"
|
||||
|
@ -165,9 +163,10 @@ storeBupUUID u buprepo = do
|
|||
>>! error "ssh failed"
|
||||
else liftIO $ do
|
||||
r' <- Git.configRead r
|
||||
let olduuid = Git.configGet r' "annex.uuid" ""
|
||||
when (olduuid == "") $ Git.run r' "config"
|
||||
[Param "annex.uuid", Param v]
|
||||
let olduuid = Git.configGet "annex.uuid" "" r'
|
||||
when (olduuid == "") $
|
||||
Git.run "config"
|
||||
[Param "annex.uuid", Param v] r'
|
||||
where
|
||||
v = fromUUID u
|
||||
|
||||
|
@ -194,7 +193,7 @@ getBupUUID r u
|
|||
| otherwise = liftIO $ do
|
||||
ret <- try $ Git.configRead r
|
||||
case ret of
|
||||
Right r' -> return (toUUID $ Git.configGet r' "annex.uuid" "", r')
|
||||
Right r' -> return (toUUID $ Git.configGet "annex.uuid" "" r', r')
|
||||
Left _ -> return (NoUUID, r)
|
||||
|
||||
{- Converts a bup remote path spec into a Git.Repo. There are some
|
||||
|
|
|
@ -70,15 +70,13 @@ dirKey d k = d </> hashDirMixed k </> f </> f
|
|||
|
||||
store :: FilePath -> Key -> Annex Bool
|
||||
store d k = do
|
||||
g <- gitRepo
|
||||
let src = gitAnnexLocation g k
|
||||
src <- fromRepo $ gitAnnexLocation k
|
||||
let dest = dirKey d k
|
||||
liftIO $ catchBool $ storeHelper dest $ copyFileExternal src dest
|
||||
|
||||
storeEncrypted :: FilePath -> (Cipher, Key) -> Key -> Annex Bool
|
||||
storeEncrypted d (cipher, enck) k = do
|
||||
g <- gitRepo
|
||||
let src = gitAnnexLocation g k
|
||||
src <- fromRepo $ gitAnnexLocation k
|
||||
let dest = dirKey d enck
|
||||
liftIO $ catchBool $ storeHelper dest $ encrypt src dest
|
||||
where
|
||||
|
|
|
@ -35,19 +35,16 @@ remote = RemoteType {
|
|||
|
||||
list :: Annex [Git.Repo]
|
||||
list = do
|
||||
g <- gitRepo
|
||||
let c = Git.configMap g
|
||||
mapM (tweakurl c) $ Git.remotes g
|
||||
c <- fromRepo Git.configMap
|
||||
mapM (tweakurl c) =<< fromRepo Git.remotes
|
||||
where
|
||||
annexurl n = "remote." ++ n ++ ".annexurl"
|
||||
tweakurl c r = do
|
||||
let n = fromJust $ Git.repoRemoteName r
|
||||
case M.lookup (annexurl n) c of
|
||||
Nothing -> return r
|
||||
Just url -> do
|
||||
g <- gitRepo
|
||||
r' <- liftIO $ Git.genRemote g url
|
||||
return $ Git.repoRemoteNameSet r' n
|
||||
Just url -> Git.repoRemoteNameSet n <$>
|
||||
inRepo (Git.genRemote url)
|
||||
|
||||
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
|
||||
gen r u _ = do
|
||||
|
@ -178,7 +175,7 @@ copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
|||
copyFromRemote r key file
|
||||
| not $ Git.repoIsUrl r = do
|
||||
params <- rsyncParams r
|
||||
rsyncOrCopyFile params (gitAnnexLocation r key) file
|
||||
rsyncOrCopyFile params (gitAnnexLocation key r) file
|
||||
| Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file
|
||||
| Git.repoIsHttp r = liftIO $ Url.download (keyUrl r key) file
|
||||
| otherwise = error "copying from non-ssh, non-http repo not supported"
|
||||
|
@ -187,8 +184,7 @@ copyFromRemote r key file
|
|||
copyToRemote :: Git.Repo -> Key -> Annex Bool
|
||||
copyToRemote r key
|
||||
| not $ Git.repoIsUrl r = do
|
||||
g <- gitRepo
|
||||
let keysrc = gitAnnexLocation g key
|
||||
keysrc <- fromRepo $ gitAnnexLocation key
|
||||
params <- rsyncParams r
|
||||
-- run copy from perspective of remote
|
||||
liftIO $ onLocal r $ do
|
||||
|
@ -197,8 +193,7 @@ copyToRemote r key
|
|||
Annex.Content.saveState
|
||||
return ok
|
||||
| Git.repoIsSsh r = do
|
||||
g <- gitRepo
|
||||
let keysrc = gitAnnexLocation g key
|
||||
keysrc <- fromRepo $ gitAnnexLocation key
|
||||
rsyncHelper =<< rsyncParamsRemote r False key keysrc
|
||||
| otherwise = error "copying to non-ssh repo not supported"
|
||||
|
||||
|
|
|
@ -23,16 +23,16 @@ findSpecialRemotes s = do
|
|||
return $ map construct $ remotepairs g
|
||||
where
|
||||
remotepairs r = M.toList $ M.filterWithKey match $ Git.configMap r
|
||||
construct (k,_) = Git.repoRemoteNameFromKey Git.repoFromUnknown k
|
||||
construct (k,_) = Git.repoRemoteNameFromKey k Git.repoFromUnknown
|
||||
match k _ = startswith "remote." k && endswith (".annex-"++s) k
|
||||
|
||||
{- Sets up configuration for a special remote in .git/config. -}
|
||||
gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex ()
|
||||
gitConfigSpecialRemote u c k v = do
|
||||
g <- gitRepo
|
||||
liftIO $ do
|
||||
Git.run g "config" [Param (configsetting $ "annex-"++k), Param v]
|
||||
Git.run g "config" [Param (configsetting "annex-uuid"), Param $ fromUUID u]
|
||||
set ("annex-"++k) v
|
||||
set ("annex-uuid") (fromUUID u)
|
||||
where
|
||||
set a b = inRepo $ Git.run "config"
|
||||
[Param (configsetting a), Param b]
|
||||
remotename = fromJust (M.lookup "name" c)
|
||||
configsetting s = "remote." ++ remotename ++ "." ++ s
|
||||
|
|
|
@ -98,14 +98,13 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
|
|||
|
||||
store :: String -> Key -> Annex Bool
|
||||
store h k = do
|
||||
g <- gitRepo
|
||||
runHook h "store" k (Just $ gitAnnexLocation g k) $ return True
|
||||
src <- fromRepo $ gitAnnexLocation k
|
||||
runHook h "store" k (Just src) $ return True
|
||||
|
||||
storeEncrypted :: String -> (Cipher, Key) -> Key -> Annex Bool
|
||||
storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do
|
||||
g <- gitRepo
|
||||
let f = gitAnnexLocation g k
|
||||
liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
|
||||
src <- fromRepo $ gitAnnexLocation k
|
||||
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
|
||||
runHook h "store" enck (Just tmp) $ return True
|
||||
|
||||
retrieve :: String -> Key -> FilePath -> Annex Bool
|
||||
|
|
|
@ -90,15 +90,12 @@ rsyncKeyDir :: RsyncOpts -> Key -> String
|
|||
rsyncKeyDir o k = rsyncUrl o </> hashDirMixed k </> shellEscape (keyFile k)
|
||||
|
||||
store :: RsyncOpts -> Key -> Annex Bool
|
||||
store o k = do
|
||||
g <- gitRepo
|
||||
rsyncSend o k (gitAnnexLocation g k)
|
||||
store o k = rsyncSend o k =<< fromRepo (gitAnnexLocation k)
|
||||
|
||||
storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool
|
||||
storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
|
||||
g <- gitRepo
|
||||
let f = gitAnnexLocation g k
|
||||
liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
|
||||
src <- fromRepo $ gitAnnexLocation k
|
||||
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
|
||||
rsyncSend o enck tmp
|
||||
|
||||
retrieve :: RsyncOpts -> Key -> FilePath -> Annex Bool
|
||||
|
@ -151,9 +148,9 @@ partialParams = Params "--no-inplace --partial --partial-dir=.rsync-partial"
|
|||
- up trees for rsync. -}
|
||||
withRsyncScratchDir :: (FilePath -> Annex Bool) -> Annex Bool
|
||||
withRsyncScratchDir a = do
|
||||
g <- gitRepo
|
||||
pid <- liftIO getProcessID
|
||||
let tmp = gitAnnexTmpDir g </> "rsynctmp" </> show pid
|
||||
t <- fromRepo gitAnnexTmpDir
|
||||
let tmp = t </> "rsynctmp" </> show pid
|
||||
nuke tmp
|
||||
liftIO $ createDirectoryIfMissing True tmp
|
||||
res <- a tmp
|
||||
|
|
|
@ -112,8 +112,8 @@ s3Setup u c = handlehost $ M.lookup "host" c
|
|||
|
||||
store :: Remote Annex -> Key -> Annex Bool
|
||||
store r k = s3Action r False $ \(conn, bucket) -> do
|
||||
g <- gitRepo
|
||||
res <- liftIO $ storeHelper (conn, bucket) r k $ gitAnnexLocation g k
|
||||
dest <- fromRepo $ gitAnnexLocation k
|
||||
res <- liftIO $ storeHelper (conn, bucket) r k dest
|
||||
s3Bool res
|
||||
|
||||
storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool
|
||||
|
@ -121,8 +121,7 @@ storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) ->
|
|||
-- To get file size of the encrypted content, have to use a temp file.
|
||||
-- (An alternative would be chunking to to a constant size.)
|
||||
withTmp enck $ \tmp -> do
|
||||
g <- gitRepo
|
||||
let f = gitAnnexLocation g k
|
||||
f <- fromRepo $ gitAnnexLocation k
|
||||
liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
|
||||
res <- liftIO $ storeHelper (conn, bucket) r enck tmp
|
||||
s3Bool res
|
||||
|
|
|
@ -27,7 +27,7 @@ remote = RemoteType {
|
|||
-- (If the web should cease to exist, remove this module and redistribute
|
||||
-- a new release to the survivors by carrier pigeon.)
|
||||
list :: Annex [Git.Repo]
|
||||
list = return [Git.repoRemoteNameSet Git.repoFromUnknown "web"]
|
||||
list = return [Git.repoRemoteNameSet "web" Git.repoFromUnknown]
|
||||
|
||||
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
|
||||
gen r _ _ =
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue