simplified a bunch of Maybe handling
This commit is contained in:
parent
efa7f54405
commit
cad0e1c8b7
19 changed files with 81 additions and 140 deletions
29
Backend.hs
29
Backend.hs
|
@ -76,10 +76,9 @@ list = do
|
|||
|
||||
{- Looks up a backend in a list. May fail if unknown. -}
|
||||
lookupBackendName :: [Backend Annex] -> String -> Backend Annex
|
||||
lookupBackendName bs s =
|
||||
case maybeLookupBackendName bs s of
|
||||
Just b -> b
|
||||
Nothing -> error $ "unknown backend " ++ s
|
||||
lookupBackendName bs s = maybe unknown id $ maybeLookupBackendName bs s
|
||||
where
|
||||
unknown = error $ "unknown backend " ++ s
|
||||
maybeLookupBackendName :: [Backend Annex] -> String -> Maybe (Backend Annex)
|
||||
maybeLookupBackendName bs s =
|
||||
if 1 /= length matches
|
||||
|
@ -91,23 +90,18 @@ maybeLookupBackendName bs s =
|
|||
storeFileKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex))
|
||||
storeFileKey file trybackend = do
|
||||
bs <- list
|
||||
let bs' = case trybackend of
|
||||
Nothing -> bs
|
||||
Just backend -> backend:bs
|
||||
let bs' = maybe bs (:bs) trybackend
|
||||
storeFileKey' bs' file
|
||||
storeFileKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
|
||||
storeFileKey' [] _ = return Nothing
|
||||
storeFileKey' (b:bs) file = do
|
||||
result <- (B.getKey b) file
|
||||
case result of
|
||||
Nothing -> nextbackend
|
||||
Just key -> do
|
||||
storeFileKey' (b:bs) file = maybe nextbackend store =<< (B.getKey b) file
|
||||
where
|
||||
nextbackend = storeFileKey' bs file
|
||||
store key = do
|
||||
stored <- (B.storeFileKey b) file key
|
||||
if (not stored)
|
||||
then nextbackend
|
||||
else return $ Just (key, b)
|
||||
where
|
||||
nextbackend = storeFileKey' bs file
|
||||
|
||||
{- Attempts to retrieve an key from one of the backends, saving it to
|
||||
- a specified location. -}
|
||||
|
@ -148,11 +142,8 @@ lookupFile file = do
|
|||
getsymlink = do
|
||||
l <- readSymbolicLink file
|
||||
return $ takeFileName l
|
||||
makekey bs l =
|
||||
case fileKey l of
|
||||
Just k -> makeret k l bs
|
||||
Nothing -> return Nothing
|
||||
makeret k l bs =
|
||||
makekey bs l = maybe (return Nothing) (makeret bs l) (fileKey l)
|
||||
makeret bs l k =
|
||||
case maybeLookupBackendName bs bname of
|
||||
Just backend -> return $ Just (k, backend)
|
||||
Nothing -> do
|
||||
|
|
|
@ -14,7 +14,5 @@ toB64 :: String -> String
|
|||
toB64 = encode . s2w8
|
||||
|
||||
fromB64 :: String -> String
|
||||
fromB64 s =
|
||||
case decode s of
|
||||
Nothing -> error "bad base64 encoded data"
|
||||
Just ws -> w82s ws
|
||||
fromB64 s = maybe bad w82s $ decode s
|
||||
where bad = error "bad base64 encoded data"
|
||||
|
|
26
Command.hs
26
Command.hs
|
@ -14,6 +14,7 @@ import Control.Monad (filterM, liftM, when)
|
|||
import System.Path.WildMatch
|
||||
import Text.Regex.PCRE.Light.Char8
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
|
||||
import Types
|
||||
import qualified Backend
|
||||
|
@ -106,18 +107,10 @@ doCommand start = do
|
|||
return c
|
||||
|
||||
notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
|
||||
notAnnexed file a = do
|
||||
r <- Backend.lookupFile file
|
||||
case r of
|
||||
Just _ -> return Nothing
|
||||
Nothing -> a
|
||||
notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file
|
||||
|
||||
isAnnexed :: FilePath -> ((Key, Backend Annex) -> Annex (Maybe a)) -> Annex (Maybe a)
|
||||
isAnnexed file a = do
|
||||
r <- Backend.lookupFile file
|
||||
case r of
|
||||
Just v -> a v
|
||||
Nothing -> return Nothing
|
||||
isAnnexed file a = maybe (return Nothing) a =<< Backend.lookupFile file
|
||||
|
||||
notBareRepo :: Annex a -> Annex a
|
||||
notBareRepo a = do
|
||||
|
@ -183,9 +176,7 @@ withFilesUnlocked' typechanged a params = do
|
|||
withKeys :: CommandSeekKeys
|
||||
withKeys a params = return $ map a $ map parse params
|
||||
where
|
||||
parse p = case readKey p of
|
||||
Just k -> k
|
||||
Nothing -> error "bad key"
|
||||
parse p = maybe (error "bad key") id $ readKey p
|
||||
withTempFile :: CommandSeekStrings
|
||||
withTempFile a params = return $ map a params
|
||||
withNothing :: CommandSeekNothing
|
||||
|
@ -206,9 +197,7 @@ filterFiles l = do
|
|||
else return $ filter (notExcluded $ wildsRegex exclude) l'
|
||||
where
|
||||
notState f = not $ stateDir `isPrefixOf` f
|
||||
notExcluded r f = case match r f [] of
|
||||
Nothing -> True
|
||||
Just _ -> False
|
||||
notExcluded r f = isJust $ match r f []
|
||||
|
||||
wildsRegex :: [String] -> Regex
|
||||
wildsRegex ws = compile regex []
|
||||
|
@ -257,11 +246,10 @@ cmdlineKey = do
|
|||
case k of
|
||||
Nothing -> nokey
|
||||
Just "" -> nokey
|
||||
Just kstring -> case readKey kstring of
|
||||
Nothing -> error "bad key"
|
||||
Just key -> return key
|
||||
Just kstring -> maybe badkey return $ readKey kstring
|
||||
where
|
||||
nokey = error "please specify the key with --key"
|
||||
badkey = error "bad key"
|
||||
|
||||
{- Given an original list of files, and an expanded list derived from it,
|
||||
- ensures that the original list's ordering is preserved.
|
||||
|
|
|
@ -58,14 +58,13 @@ start (unused, unusedbad, unusedtmp) s = notBareRepo $ search
|
|||
next $ a key
|
||||
|
||||
perform :: Key -> CommandPerform
|
||||
perform key = do
|
||||
from <- Annex.getState Annex.fromremote
|
||||
case from of
|
||||
Just name -> do
|
||||
perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote
|
||||
where
|
||||
dropremote name = do
|
||||
r <- Remote.byName name
|
||||
showNote $ "from " ++ Remote.name r ++ "..."
|
||||
next $ Command.Move.fromCleanup r True key
|
||||
_ -> do
|
||||
droplocal = do
|
||||
backend <- keyBackend key
|
||||
Command.Drop.perform key backend (Just 0) -- force drop
|
||||
|
||||
|
|
|
@ -68,11 +68,11 @@ cleanup u c = do
|
|||
findByName :: String -> Annex (UUID, RemoteClass.RemoteConfig)
|
||||
findByName name = do
|
||||
m <- Remote.readRemoteLog
|
||||
case findByName' name m of
|
||||
Just i -> return i
|
||||
Nothing -> do
|
||||
maybe generate return $ findByName' name m
|
||||
where
|
||||
generate = do
|
||||
uuid <- liftIO $ genUUID
|
||||
return $ (uuid, M.insert nameKey name M.empty)
|
||||
return (uuid, M.insert nameKey name M.empty)
|
||||
|
||||
findByName' :: String -> M.Map UUID RemoteClass.RemoteConfig -> Maybe (UUID, RemoteClass.RemoteConfig)
|
||||
findByName' n m = if null matches then Nothing else Just $ head matches
|
||||
|
@ -86,12 +86,13 @@ findByName' n m = if null matches then Nothing else Just $ head matches
|
|||
|
||||
{- find the specified remote type -}
|
||||
findType :: RemoteClass.RemoteConfig -> Annex (RemoteClass.RemoteType Annex)
|
||||
findType config =
|
||||
case M.lookup typeKey config of
|
||||
Nothing -> error "Specify the type of remote with type="
|
||||
Just s -> case filter (\i -> RemoteClass.typename i == s) Remote.remoteTypes of
|
||||
findType config = maybe unspecified specified $ M.lookup typeKey config
|
||||
where
|
||||
unspecified = error "Specify the type of remote with type="
|
||||
specified s = case filter (findtype s) Remote.remoteTypes of
|
||||
[] -> error $ "Unknown remote type " ++ s
|
||||
(t:_) -> return t
|
||||
findtype s i = RemoteClass.typename i == s
|
||||
|
||||
{- The name of a configured remote is stored in its config using this key. -}
|
||||
nameKey :: String
|
||||
|
|
|
@ -84,10 +84,7 @@ repoName umap r
|
|||
| otherwise = M.findWithDefault fallback repouuid umap
|
||||
where
|
||||
repouuid = getUncachedUUID r
|
||||
fallback =
|
||||
case (Git.repoRemoteName r) of
|
||||
Just n -> n
|
||||
Nothing -> "unknown"
|
||||
fallback = maybe "unknown" id $ Git.repoRemoteName r
|
||||
|
||||
{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
|
||||
nodeId :: Git.Repo -> String
|
||||
|
@ -121,13 +118,10 @@ edge umap fullinfo from to =
|
|||
{- Only name an edge if the name is different than the name
|
||||
- that will be used for the destination node, and is
|
||||
- different from its hostname. (This reduces visual clutter.) -}
|
||||
edgename =
|
||||
case (Git.repoRemoteName to) of
|
||||
Nothing -> Nothing
|
||||
Just n ->
|
||||
if (n == repoName umap fullto || n == hostname fullto)
|
||||
then Nothing
|
||||
else Just n
|
||||
edgename = maybe Nothing calcname $ Git.repoRemoteName to
|
||||
calcname n
|
||||
| n == repoName umap fullto || n == hostname fullto = Nothing
|
||||
| otherwise = Just n
|
||||
|
||||
unreachable :: String -> String
|
||||
unreachable = Dot.fillColor "red"
|
||||
|
|
|
@ -41,12 +41,7 @@ start = notBareRepo $ do
|
|||
|
||||
perform :: CommandPerform
|
||||
perform = do
|
||||
from <- Annex.getState Annex.fromremote
|
||||
case from of
|
||||
Just name -> do
|
||||
r <- Remote.byName name
|
||||
checkRemoteUnused r
|
||||
_ -> checkUnused
|
||||
maybe checkUnused checkRemoteUnused =<< Annex.getState Annex.fromremote
|
||||
next $ return True
|
||||
|
||||
checkUnused :: Annex ()
|
||||
|
@ -63,8 +58,11 @@ checkUnused = do
|
|||
writeUnusedFile file unusedlist
|
||||
return $ length l
|
||||
|
||||
checkRemoteUnused :: Remote.Remote Annex -> Annex ()
|
||||
checkRemoteUnused r = do
|
||||
checkRemoteUnused :: String -> Annex ()
|
||||
checkRemoteUnused name = checkRemoteUnused' =<< Remote.byName name
|
||||
|
||||
checkRemoteUnused' :: Remote.Remote Annex -> Annex ()
|
||||
checkRemoteUnused' r = do
|
||||
g <- Annex.gitRepo
|
||||
showNote $ "checking for unused data on " ++ Remote.name r ++ "..."
|
||||
referenced <- getKeysReferenced
|
||||
|
|
10
Content.hs
10
Content.hs
|
@ -57,11 +57,11 @@ calcGitLink :: FilePath -> Key -> Annex FilePath
|
|||
calcGitLink file key = do
|
||||
g <- Annex.gitRepo
|
||||
cwd <- liftIO $ getCurrentDirectory
|
||||
let absfile = case absNormPath cwd file of
|
||||
Just f -> f
|
||||
Nothing -> error $ "unable to normalize " ++ file
|
||||
let absfile = maybe whoops id $ absNormPath cwd file
|
||||
return $ relPathDirToFile (parentDir absfile)
|
||||
(Git.workTree g) </> ".git" </> annexLocation key
|
||||
where
|
||||
whoops = error $ "unable to normalize " ++ file
|
||||
|
||||
{- Updates the LocationLog when a key's presence changes in the current
|
||||
- repository.
|
||||
|
@ -148,9 +148,7 @@ checkDiskSpace' :: Integer -> Key -> Annex ()
|
|||
checkDiskSpace' adjustment key = do
|
||||
g <- Annex.gitRepo
|
||||
r <- getConfig g "diskreserve" ""
|
||||
let reserve = case readSize dataUnits r of
|
||||
Nothing -> megabyte
|
||||
Just v -> v
|
||||
let reserve = maybe megabyte id $ readSize dataUnits r
|
||||
stats <- liftIO $ getFileSystemStats (gitAnnexDir g)
|
||||
case (stats, keySize key) of
|
||||
(Nothing, _) -> return ()
|
||||
|
|
|
@ -238,10 +238,8 @@ configKeyIds c = do
|
|||
keyIdField s = (split ":" s) !! 4
|
||||
|
||||
configGet :: RemoteConfig -> String -> String
|
||||
configGet c key =
|
||||
case M.lookup key c of
|
||||
Just v -> v
|
||||
Nothing -> error $ "missing " ++ key ++ " in remote config"
|
||||
configGet c key = maybe missing id $ M.lookup key c
|
||||
where missing = error $ "missing " ++ key ++ " in remote config"
|
||||
|
||||
hmacWithCipher :: Cipher -> String -> String
|
||||
hmacWithCipher c = hmacWithCipher' (cipherHmac c)
|
||||
|
|
5
Dot.hs
5
Dot.hs
|
@ -20,10 +20,7 @@ graphNode nodeid desc = label desc $ quote nodeid
|
|||
|
||||
{- an edge between two nodes -}
|
||||
graphEdge :: String -> String -> Maybe String -> String
|
||||
graphEdge fromid toid desc = indent $
|
||||
case desc of
|
||||
Nothing -> edge
|
||||
Just d -> label d edge
|
||||
graphEdge fromid toid desc = indent $ maybe edge (\d -> label d edge) desc
|
||||
where
|
||||
edge = quote fromid ++ " -> " ++ quote toid
|
||||
|
||||
|
|
13
GitRepo.hs
13
GitRepo.hs
|
@ -122,9 +122,8 @@ repoFromUrl url
|
|||
| startswith "file://" url = repoFromAbsPath $ uriPath u
|
||||
| otherwise = return $ newFrom $ Url u
|
||||
where
|
||||
u = case (parseURI url) of
|
||||
Just v -> v
|
||||
Nothing -> error $ "bad url " ++ url
|
||||
u = maybe bad id $ parseURI url
|
||||
bad = error $ "bad url " ++ url
|
||||
|
||||
{- Creates a repo that has an unknown location. -}
|
||||
repoFromUnknown :: Repo
|
||||
|
@ -264,9 +263,7 @@ workTreeFile repo@(Repo { location = Dir d }) file = do
|
|||
absrepo = case (absNormPath "/" d) of
|
||||
Just f -> addTrailingPathSeparator f
|
||||
Nothing -> error $ "bad repo" ++ repoDescribe repo
|
||||
absfile c = case (secureAbsNormPath c file) of
|
||||
Just f -> f
|
||||
Nothing -> file
|
||||
absfile c = maybe file id $ secureAbsNormPath c file
|
||||
inrepo f = absrepo `isPrefixOf` f
|
||||
workTreeFile repo _ = assertLocal repo $ error "internal"
|
||||
|
||||
|
@ -352,9 +349,7 @@ reap :: IO ()
|
|||
reap = do
|
||||
-- throws an exception when there are no child processes
|
||||
r <- catch (getAnyProcessStatus False True) (\_ -> return Nothing)
|
||||
case r of
|
||||
Nothing -> return ()
|
||||
Just _ -> reap
|
||||
maybe (return ()) (const reap) r
|
||||
|
||||
{- Scans for files that are checked into git at the specified locations. -}
|
||||
inRepo :: Repo -> [FilePath] -> IO [FilePath]
|
||||
|
|
|
@ -71,9 +71,7 @@ instance Read LogLine where
|
|||
-- Such lines have a status of Undefined.
|
||||
readsPrec _ string =
|
||||
if length w == 3
|
||||
then case pdate of
|
||||
Just v -> good v
|
||||
Nothing -> bad
|
||||
then maybe bad good pdate
|
||||
else bad
|
||||
where
|
||||
w = words string
|
||||
|
|
|
@ -68,9 +68,8 @@ gen r u c = do
|
|||
bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
bupSetup u c = do
|
||||
-- verify configuration is sane
|
||||
let buprepo = case M.lookup "buprepo" c of
|
||||
Nothing -> error "Specify buprepo="
|
||||
Just r -> r
|
||||
let buprepo = maybe (error "Specify buprepo=") id $
|
||||
M.lookup "buprepo" c
|
||||
c' <- encryptionSetup c
|
||||
|
||||
-- bup init will create the repository.
|
||||
|
|
|
@ -60,9 +60,8 @@ gen r u c = do
|
|||
directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
directorySetup u c = do
|
||||
-- verify configuration is sane
|
||||
let dir = case M.lookup "directory" c of
|
||||
Nothing -> error "Specify directory="
|
||||
Just d -> d
|
||||
let dir = maybe (error "Specify directory=") id $
|
||||
M.lookup "directory" c
|
||||
e <- liftIO $ doesDirectoryExist dir
|
||||
when (not e) $ error $ "Directory does not exist: " ++ dir
|
||||
c' <- encryptionSetup c
|
||||
|
|
|
@ -73,11 +73,10 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
|
|||
{- Gets encryption Cipher. The decrypted Cipher is cached in the Annex
|
||||
- state. -}
|
||||
remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
|
||||
remoteCipher c = do
|
||||
cache <- Annex.getState Annex.cipher
|
||||
case cache of
|
||||
Just cipher -> return $ Just cipher
|
||||
Nothing -> case extractCipher c of
|
||||
remoteCipher c = maybe expensive cached =<< Annex.getState Annex.cipher
|
||||
where
|
||||
cached cipher = return $ Just cipher
|
||||
expensive = case extractCipher c of
|
||||
Nothing -> return Nothing
|
||||
Just encipher -> do
|
||||
showNote "gpg"
|
||||
|
|
|
@ -61,9 +61,8 @@ gen r u c = do
|
|||
|
||||
hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
hookSetup u c = do
|
||||
let hooktype = case M.lookup "hooktype" c of
|
||||
Nothing -> error "Specify hooktype="
|
||||
Just r -> r
|
||||
let hooktype = maybe (error "Specify hooktype=") id $
|
||||
M.lookup "hooktype" c
|
||||
c' <- encryptionSetup c
|
||||
gitConfigSpecialRemote u c' "hooktype" hooktype
|
||||
return c'
|
||||
|
@ -94,14 +93,12 @@ lookupHook hooktype hook =do
|
|||
hookname = hooktype ++ "-" ++ hook ++ "-hook"
|
||||
|
||||
runHook :: String -> String -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool
|
||||
runHook hooktype hook k f a = do
|
||||
command <- lookupHook hooktype hook
|
||||
case command of
|
||||
Nothing -> return False
|
||||
Just c -> do
|
||||
runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype hook
|
||||
where
|
||||
run command = do
|
||||
showProgress -- make way for hook output
|
||||
res <- liftIO $ boolSystemEnv
|
||||
"sh" [Param "-c", Param c] $ hookEnv k f
|
||||
"sh" [Param "-c", Param command] $ hookEnv k f
|
||||
if res
|
||||
then a
|
||||
else do
|
||||
|
|
|
@ -82,9 +82,8 @@ genRsyncOpts r = do
|
|||
rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
rsyncSetup u c = do
|
||||
-- verify configuration is sane
|
||||
let url = case M.lookup "rsyncurl" c of
|
||||
Nothing -> error "Specify rsyncurl="
|
||||
Just d -> d
|
||||
let url = maybe (error "Specify rsyncurl=") id $
|
||||
M.lookup "rsyncurl" c
|
||||
c' <- encryptionSetup c
|
||||
|
||||
-- The rsyncurl is stored in git config, not only in this remote's
|
||||
|
|
|
@ -123,11 +123,7 @@ storeHelper (conn, bucket) r k file = do
|
|||
content <- liftIO $ L.readFile file
|
||||
-- size is provided to S3 so the whole content does not need to be
|
||||
-- buffered to calculate it
|
||||
size <- case keySize k of
|
||||
Just s -> return $ fromIntegral s
|
||||
Nothing -> do
|
||||
s <- liftIO $ getFileStatus file
|
||||
return $ fileSize s
|
||||
size <- maybe getsize (return . fromIntegral) $ keySize k
|
||||
let object = setStorageClass storageclass $
|
||||
S3Object bucket (show k) ""
|
||||
[("Content-Length",(show size))] content
|
||||
|
@ -137,6 +133,9 @@ storeHelper (conn, bucket) r k file = do
|
|||
case fromJust $ M.lookup "storageclass" $ fromJust $ config r of
|
||||
"REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY
|
||||
_ -> STANDARD
|
||||
getsize = do
|
||||
s <- liftIO $ getFileStatus file
|
||||
return $ fileSize s
|
||||
|
||||
retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
|
||||
retrieve r k f = s3Action r False $ \(conn, bucket) -> do
|
||||
|
@ -201,11 +200,8 @@ bucketKey :: String -> Key -> S3Object
|
|||
bucketKey bucket k = S3Object bucket (show k) "" [] L.empty
|
||||
|
||||
s3ConnectionRequired :: RemoteConfig -> Annex AWSConnection
|
||||
s3ConnectionRequired c = do
|
||||
conn <- s3Connection c
|
||||
case conn of
|
||||
Nothing -> error "Cannot connect to S3"
|
||||
Just conn' -> return conn'
|
||||
s3ConnectionRequired c =
|
||||
maybe (error "Cannot connect to S3") return =<< s3Connection c
|
||||
|
||||
s3Connection :: RemoteConfig -> Annex (Maybe AWSConnection)
|
||||
s3Connection c = do
|
||||
|
|
11
Utility.hs
11
Utility.hs
|
@ -165,9 +165,7 @@ prop_parentDir_basics dir
|
|||
dirContains :: FilePath -> FilePath -> Bool
|
||||
dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
|
||||
where
|
||||
norm p = case (absNormPath p ".") of
|
||||
Just r -> r
|
||||
Nothing -> ""
|
||||
norm p = maybe "" id $ absNormPath p "."
|
||||
a' = norm a
|
||||
b' = norm b
|
||||
|
||||
|
@ -180,10 +178,9 @@ absPath file = do
|
|||
{- Converts a filename into a normalized, absolute path
|
||||
- from the specified cwd. -}
|
||||
absPathFrom :: FilePath -> FilePath -> FilePath
|
||||
absPathFrom cwd file =
|
||||
case absNormPath cwd file of
|
||||
Just f -> f
|
||||
Nothing -> error $ "unable to normalize " ++ file
|
||||
absPathFrom cwd file = maybe bad id $ absNormPath cwd file
|
||||
where
|
||||
bad = error $ "unable to normalize " ++ file
|
||||
|
||||
{- Constructs a relative path from the CWD to a file.
|
||||
-
|
||||
|
|
Loading…
Add table
Reference in a new issue