summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-05-15 12:25:58 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-05-15 12:25:58 -0400
commit3e15a8a791d15c166557fa18f240639891a8754f (patch)
treee4aab63486d489a0c4e78c0d31da6406f7f7a515
parentcad0e1c8b7eb21f8dceca8dd9fa3bc1d1aa7eabd (diff)
Maybe reduction pass 2
-rw-r--r--Command.hs20
-rw-r--r--GitRepo.hs31
-rw-r--r--Messages.hs4
-rw-r--r--Remote/Encryptable.hs31
4 files changed, 34 insertions, 52 deletions
diff --git a/Command.hs b/Command.hs
index c6c1fe5c5..4f835a3ad 100644
--- a/Command.hs
+++ b/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
diff --git a/GitRepo.hs b/GitRepo.hs
index b20ff7db3..3c5a1e129 100644
--- a/GitRepo.hs
+++ b/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."
-
-seekUp :: FilePath -> (FilePath -> IO Bool) -> IO (Maybe FilePath)
-seekUp dir want = do
+repoFromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo
+ where
+ makerepo = return . newFrom . Dir
+ norepo = error "Not in a git repository."
+
+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
diff --git a/Messages.hs b/Messages.hs
index 733638ce1..c44e44eea 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -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
diff --git a/Remote/Encryptable.hs b/Remote/Encryptable.hs
index f9b388c8a..68ecfd01e 100644
--- a/Remote/Encryptable.hs
+++ b/Remote/Encryptable.hs
@@ -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