Maybe reduction pass 2
This commit is contained in:
parent
cad0e1c8b7
commit
3e15a8a791
4 changed files with 33 additions and 51 deletions
20
Command.hs
20
Command.hs
|
@ -91,20 +91,12 @@ prepCommand Command { cmdseek = seek } params = do
|
|||
|
||||
{- Runs a command through the start, perform and cleanup stages -}
|
||||
doCommand :: CommandStart -> CommandCleanup
|
||||
doCommand start = do
|
||||
s <- start
|
||||
case s of
|
||||
Nothing -> return True
|
||||
Just perform -> do
|
||||
p <- perform
|
||||
case p of
|
||||
Nothing -> do
|
||||
showEndFail
|
||||
return False
|
||||
Just cleanup -> do
|
||||
c <- cleanup
|
||||
if c then showEndOk else showEndFail
|
||||
return c
|
||||
doCommand = start
|
||||
where
|
||||
start = stage $ maybe (return True) perform
|
||||
perform = stage $ maybe (showEndFail >> return False) cleanup
|
||||
cleanup = stage $ \r -> showEndResult r >> return r
|
||||
stage a b = b >>= a
|
||||
|
||||
notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
|
||||
notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file
|
||||
|
|
29
GitRepo.hs
29
GitRepo.hs
|
@ -210,9 +210,9 @@ assertUrl repo action =
|
|||
" not supported"
|
||||
|
||||
configBare :: Repo -> Bool
|
||||
configBare repo = case Map.lookup "core.bare" $ config repo of
|
||||
Just v -> configTrue v
|
||||
Nothing -> error $ "it is not known if git repo " ++
|
||||
configBare repo = maybe unknown configTrue $ Map.lookup "core.bare" $ config repo
|
||||
where
|
||||
unknown = error $ "it is not known if git repo " ++
|
||||
repoDescribe repo ++
|
||||
" is a bare repository; config not read"
|
||||
|
||||
|
@ -260,11 +260,10 @@ workTreeFile repo@(Repo { location = Dir d }) file = do
|
|||
where
|
||||
-- normalize both repo and file, so that repo
|
||||
-- will be substring of file
|
||||
absrepo = case (absNormPath "/" d) of
|
||||
Just f -> addTrailingPathSeparator f
|
||||
Nothing -> error $ "bad repo" ++ repoDescribe repo
|
||||
absrepo = maybe bad addTrailingPathSeparator $ absNormPath "/" d
|
||||
absfile c = maybe file id $ secureAbsNormPath c file
|
||||
inrepo f = absrepo `isPrefixOf` f
|
||||
bad = error $ "bad repo" ++ repoDescribe repo
|
||||
workTreeFile repo _ = assertLocal repo $ error "internal"
|
||||
|
||||
{- Path of an URL repo. -}
|
||||
|
@ -627,23 +626,19 @@ expandTilde = expandt True
|
|||
|
||||
{- Finds the current git repository, which may be in a parent directory. -}
|
||||
repoFromCwd :: IO Repo
|
||||
repoFromCwd = do
|
||||
cwd <- getCurrentDirectory
|
||||
top <- seekUp cwd isRepoTop
|
||||
case top of
|
||||
-- repoFromAbsPath is not used to avoid looking for
|
||||
-- "dir.git" directories.
|
||||
(Just dir) -> return $ newFrom $ Dir dir
|
||||
Nothing -> error "Not in a git repository."
|
||||
repoFromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo
|
||||
where
|
||||
makerepo = return . newFrom . Dir
|
||||
norepo = error "Not in a git repository."
|
||||
|
||||
seekUp :: FilePath -> (FilePath -> IO Bool) -> IO (Maybe FilePath)
|
||||
seekUp dir want = do
|
||||
seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath)
|
||||
seekUp want dir = do
|
||||
ok <- want dir
|
||||
if ok
|
||||
then return (Just dir)
|
||||
else case (parentDir dir) of
|
||||
"" -> return Nothing
|
||||
d -> seekUp d want
|
||||
d -> seekUp want d
|
||||
|
||||
isRepoTop :: FilePath -> IO Bool
|
||||
isRepoTop dir = do
|
||||
|
|
|
@ -45,6 +45,10 @@ showEndOk = verbose $ liftIO $ putStrLn "ok"
|
|||
showEndFail :: Annex ()
|
||||
showEndFail = verbose $ liftIO $ putStrLn "\nfailed"
|
||||
|
||||
showEndResult :: Bool -> Annex ()
|
||||
showEndResult True = showEndOk
|
||||
showEndResult False = showEndFail
|
||||
|
||||
showErr :: (Show a) => a -> Annex ()
|
||||
showErr e = warning $ "git-annex: " ++ show e
|
||||
|
||||
|
|
|
@ -54,21 +54,14 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
|
|||
cost = cost r + encryptedRemoteCostAdj
|
||||
}
|
||||
where
|
||||
store k = do
|
||||
v <- cipherKey c k
|
||||
case v of
|
||||
Nothing -> (storeKey r) k
|
||||
Just x -> storeKeyEncrypted x k
|
||||
retrieve k f = do
|
||||
v <- cipherKey c k
|
||||
case v of
|
||||
Nothing -> (retrieveKeyFile r) k f
|
||||
Just x -> retrieveKeyFileEncrypted x f
|
||||
withkey a k = do
|
||||
v <- cipherKey c k
|
||||
case v of
|
||||
Nothing -> a k
|
||||
Just (_, k') -> a k'
|
||||
store k = cip k >>= maybe
|
||||
(storeKey r k)
|
||||
(\x -> storeKeyEncrypted x k)
|
||||
retrieve k f = cip k >>= maybe
|
||||
(retrieveKeyFile r k f)
|
||||
(\x -> retrieveKeyFileEncrypted x f)
|
||||
withkey a k = cip k >>= maybe (a k) (a . snd)
|
||||
cip = cipherKey c
|
||||
|
||||
{- Gets encryption Cipher. The decrypted Cipher is cached in the Annex
|
||||
- state. -}
|
||||
|
@ -87,10 +80,8 @@ remoteCipher c = maybe expensive cached =<< Annex.getState Annex.cipher
|
|||
{- Gets encryption Cipher, and encrypted version of Key. -}
|
||||
cipherKey :: Maybe RemoteConfig -> Key -> Annex (Maybe (Cipher, Key))
|
||||
cipherKey Nothing _ = return Nothing
|
||||
cipherKey (Just c) k = do
|
||||
cipher <- remoteCipher c
|
||||
case cipher of
|
||||
Just ciphertext -> do
|
||||
cipherKey (Just c) k = remoteCipher c >>= maybe (return Nothing) encrypt
|
||||
where
|
||||
encrypt ciphertext = do
|
||||
k' <- liftIO $ encryptKey ciphertext k
|
||||
return $ Just (ciphertext, k')
|
||||
Nothing -> return Nothing
|
||||
|
|
Loading…
Reference in a new issue