summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex/Content.hs2
-rw-r--r--Backend/SHA.hs16
-rw-r--r--Command/ConfigList.hs3
-rw-r--r--Command/Fsck.hs2
-rw-r--r--Command/Init.hs3
-rw-r--r--Command/Move.hs6
-rw-r--r--Crypto.hs25
-rw-r--r--Init.hs6
-rw-r--r--Limit.hs7
-rw-r--r--Messages.hs27
-rw-r--r--Remote.hs12
-rw-r--r--Remote/Git.hs2
-rw-r--r--Remote/Helper/Encryptable.hs6
-rw-r--r--UUID.hs17
-rw-r--r--Utility.hs10
-rw-r--r--Utility/Path.hs21
-rw-r--r--Utility/Ssh.hs2
-rw-r--r--git-annex-shell.hs2
-rw-r--r--test.hs4
19 files changed, 78 insertions, 95 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 21403954a..3827154a6 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -57,7 +57,7 @@ calcGitLink file key = do
logStatus :: Key -> LogStatus -> Annex ()
logStatus key status = do
g <- gitRepo
- u <- getUUID g
+ u <- getUUID
logChange g key u status
{- Runs an action, passing it a temporary filename to download,
diff --git a/Backend/SHA.hs b/Backend/SHA.hs
index 4b5b14cc3..3a54a8871 100644
--- a/Backend/SHA.hs
+++ b/Backend/SHA.hs
@@ -104,11 +104,11 @@ checkKeyChecksum size key = do
present <- liftIO $ doesFileExist file
if not present || fast
then return True
- else do
- s <- shaN size file
- if s == dropExtension (keyName key)
- then return True
- else do
- dest <- moveBad key
- warning $ "Bad file content; moved to " ++ dest
- return False
+ else check =<< shaN size file
+ where
+ check s
+ | s == dropExtension (keyName key) = return True
+ | otherwise = do
+ dest <- moveBad key
+ warning $ "Bad file content; moved to " ++ dest
+ return False
diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs
index d52c33f3b..60f71eee6 100644
--- a/Command/ConfigList.hs
+++ b/Command/ConfigList.hs
@@ -20,7 +20,6 @@ seek = [withNothing start]
start :: CommandStart
start = do
- g <- gitRepo
- u <- getUUID g
+ u <- getUUID
liftIO $ putStrLn $ "annex.uuid=" ++ u
stop
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 689271dd7..16e834fbf 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -55,7 +55,7 @@ verifyLocationLog key file = do
preventWrite f
preventWrite (parentDir f)
- u <- getUUID g
+ u <- getUUID
uuids <- keyLocations key
case (present, u `elem` uuids) of
diff --git a/Command/Init.hs b/Command/Init.hs
index ace06c2c3..b9dffb5cd 100644
--- a/Command/Init.hs
+++ b/Command/Init.hs
@@ -29,7 +29,6 @@ start ws = do
perform :: String -> CommandPerform
perform description = do
initialize
- g <- gitRepo
- u <- getUUID g
+ u <- getUUID
describeUUID u description
next $ return True
diff --git a/Command/Move.hs b/Command/Move.hs
index d650c5251..52eb49da1 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -72,8 +72,7 @@ remoteHasKey remote key present = do
-}
toStart :: Remote.Remote Annex -> Bool -> FilePath -> CommandStart
toStart dest move file = isAnnexed file $ \(key, _) -> do
- g <- gitRepo
- u <- getUUID g
+ u <- getUUID
ishere <- inAnnex key
if not ishere || u == Remote.uuid dest
then stop -- not here, so nothing to do
@@ -122,8 +121,7 @@ toCleanup dest move key = do
-}
fromStart :: Remote.Remote Annex -> Bool -> FilePath -> CommandStart
fromStart src move file = isAnnexed file $ \(key, _) -> do
- g <- gitRepo
- u <- getUUID g
+ u <- getUUID
remotes <- Remote.keyPossibilities key
if u == Remote.uuid src || not (any (== src) remotes)
then stop
diff --git a/Crypto.hs b/Crypto.hs
index 21e4d7560..ced7c144c 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -135,13 +135,12 @@ decryptCipher _ (EncryptedCipher encipher _) =
{- Generates an encrypted form of a Key. The encryption does not need to be
- reversable, nor does it need to be the same type of encryption used
- on content. It does need to be repeatable. -}
-encryptKey :: Cipher -> Key -> IO Key
-encryptKey c k =
- return Key {
- keyName = hmacWithCipher c (show k),
- keyBackendName = "GPGHMACSHA1",
- keySize = Nothing, -- size and mtime omitted
- keyMtime = Nothing -- to avoid leaking data
+encryptKey :: Cipher -> Key -> Key
+encryptKey c k = Key
+ { keyName = hmacWithCipher c (show k)
+ , keyBackendName = "GPGHMACSHA1"
+ , keySize = Nothing -- size and mtime omitted
+ , keyMtime = Nothing -- to avoid leaking data
}
{- Runs an action, passing it a handle from which it can
@@ -223,18 +222,18 @@ gpgCipherHandle params c a b = do
return ret
configKeyIds :: RemoteConfig -> IO KeyIds
-configKeyIds c = do
- let k = configGet c "encryption"
- s <- gpgRead [Params "--with-colons --list-public-keys", Param k]
- return $ KeyIds $ parseWithColons s
+configKeyIds c = parse <$> gpgRead params
where
- parseWithColons s = map keyIdField $ filter pubKey $ lines s
+ params = [Params "--with-colons --list-public-keys",
+ Param $ configGet c "encryption"]
+ parse = KeyIds . map keyIdField . filter pubKey . lines
pubKey = isPrefixOf "pub:"
keyIdField s = split ":" s !! 4
configGet :: RemoteConfig -> String -> String
configGet c key = fromMaybe missing $ M.lookup key c
- where missing = error $ "missing " ++ key ++ " in remote config"
+ where
+ missing = error $ "missing " ++ key ++ " in remote config"
hmacWithCipher :: Cipher -> String -> String
hmacWithCipher c = hmacWithCipher' (cipherHmac c)
diff --git a/Init.hs b/Init.hs
index 145413e8d..509cbca15 100644
--- a/Init.hs
+++ b/Init.hs
@@ -75,6 +75,6 @@ preCommitHook = do
preCommitScript :: String
preCommitScript =
- "#!/bin/sh\n" ++
- "# automatically configured by git-annex\n" ++
- "git annex pre-commit .\n"
+ "#!/bin/sh\n" ++
+ "# automatically configured by git-annex\n" ++
+ "git annex pre-commit .\n"
diff --git a/Limit.hs b/Limit.hs
index 3812ceea4..8dd88e72b 100644
--- a/Limit.hs
+++ b/Limit.hs
@@ -65,14 +65,13 @@ addExclude glob = addLimit $ return . notExcluded
{- Adds a limit to skip files not believed to be present
- in a specfied repository. -}
addIn :: String -> Annex ()
-addIn name = do
- u <- Remote.nameToUUID name
- addLimit $ if name == "." then check inAnnex else check (remote u)
+addIn name = addLimit $ check $ if name == "." then inAnnex else inremote
where
check a f = Backend.lookupFile f >>= handle a
handle _ Nothing = return False
handle a (Just (key, _)) = a key
- remote u key = do
+ inremote key = do
+ u <- Remote.nameToUUID name
us <- keyLocations key
return $ u `elem` us
diff --git a/Messages.hs b/Messages.hs
index e029c5072..6f4880e2d 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -31,31 +31,31 @@ import qualified Annex
import qualified Messages.JSON as JSON
showStart :: String -> String -> Annex ()
-showStart command file = handle (JSON.start command file) $ do
- putStr $ command ++ " " ++ file ++ " "
- hFlush stdout
+showStart command file = handle (JSON.start command file) $
+ flushed $ putStr $ command ++ " " ++ file ++ " "
showNote :: String -> Annex ()
-showNote s = handle (JSON.note s) $ do
- putStr $ "(" ++ s ++ ") "
- hFlush stdout
+showNote s = handle (JSON.note s) $
+ flushed $ putStr $ "(" ++ s ++ ") "
showAction :: String -> Annex ()
showAction s = showNote $ s ++ "..."
showProgress :: Annex ()
-showProgress = handle q $ do
- putStr "."
- hFlush stdout
+showProgress = handle q $
+ flushed $ putStr "."
showSideAction :: String -> Annex ()
-showSideAction s = handle q $ putStrLn $ "(" ++ s ++ "...)"
+showSideAction s = handle q $
+ putStrLn $ "(" ++ s ++ "...)"
showOutput :: Annex ()
-showOutput = handle q $ putStr "\n"
+showOutput = handle q $
+ putStr "\n"
showLongNote :: String -> Annex ()
-showLongNote s = handle (JSON.note s) $ putStrLn $ '\n' : indent s
+showLongNote s = handle (JSON.note s) $
+ putStrLn $ '\n' : indent s
showEndOk :: Annex ()
showEndOk = showEndResult True
@@ -113,3 +113,6 @@ maybeShowJSON v = handle (JSON.add v) q
q :: Monad m => m ()
q = return ()
+
+flushed :: IO () -> IO ()
+flushed a = a >> hFlush stdout
diff --git a/Remote.hs b/Remote.hs
index 27ebd724a..b1305b9e0 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -78,7 +78,7 @@ genList = do
enumerate t >>=
mapM (gen m t)
gen m t r = do
- u <- getUUID r
+ u <- getRepoUUID r
generate t r u (M.lookup u m)
{- Looks up a remote by name. (Or by UUID.) Only finds currently configured
@@ -104,7 +104,7 @@ byName' n = do
- and returns its UUID. Finds even remotes that are not configured in
- .git/config. -}
nameToUUID :: String -> Annex UUID
-nameToUUID "." = getUUID =<< gitRepo -- special case for current repo
+nameToUUID "." = getUUID -- special case for current repo
nameToUUID n = do
res <- byName' n
case res of
@@ -129,7 +129,7 @@ nameToUUID n = do
- of the UUIDs. -}
prettyPrintUUIDs :: String -> [UUID] -> Annex String
prettyPrintUUIDs desc uuids = do
- here <- getUUID =<< gitRepo
+ here <- getUUID
m <- M.unionWith addname <$> uuidMap <*> remoteMap
maybeShowJSON [(desc, map (jsonify m here) uuids)]
return $ unwords $ map (\u -> "\t" ++ prettify m here u ++ "\n") uuids
@@ -178,8 +178,7 @@ keyPossibilitiesTrusted = keyPossibilities' True
keyPossibilities' :: Bool -> Key -> Annex ([Remote Annex], [UUID])
keyPossibilities' withtrusted key = do
- g <- gitRepo
- u <- getUUID g
+ u <- getUUID
trusted <- if withtrusted then trustGet Trusted else return []
-- get uuids of all remotes that are recorded to have the key
@@ -198,8 +197,7 @@ keyPossibilities' withtrusted key = do
{- Displays known locations of a key. -}
showLocations :: Key -> [UUID] -> Annex ()
showLocations key exclude = do
- g <- gitRepo
- u <- getUUID g
+ u <- getUUID
uuids <- keyLocations key
untrusteduuids <- trustGet UnTrusted
let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids)
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 704bdc04d..183fcd854 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -48,7 +48,7 @@ gen r u _ = do
(False, "") -> tryGitConfigRead r
_ -> return r
- u' <- getUUID r'
+ u' <- getRepoUUID r'
let defcst = if cheap then cheapRemoteCost else expensiveRemoteCost
cst <- remoteCost r' defcst
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index 004b70408..85d269a21 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -78,8 +78,6 @@ 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 = remoteCipher c >>= maybe (return Nothing) encrypt
+cipherKey (Just c) k = maybe Nothing encrypt <$> remoteCipher c
where
- encrypt ciphertext = do
- k' <- liftIO $ encryptKey ciphertext k
- return $ Just (ciphertext, k')
+ encrypt ciphertext = Just (ciphertext, encryptKey ciphertext k)
diff --git a/UUID.hs b/UUID.hs
index c4b870f39..63ce87f03 100644
--- a/UUID.hs
+++ b/UUID.hs
@@ -16,6 +16,7 @@
module UUID (
UUID,
getUUID,
+ getRepoUUID,
getUncachedUUID,
prepUUID,
genUUID,
@@ -44,7 +45,7 @@ logfile = "uuid.log"
{- Generates a UUID. There is a library for this, but it's not packaged,
- so use the command line tool. -}
genUUID :: IO UUID
-genUUID = liftIO $ pOpen ReadFromPipe command params $ \h -> hGetLine h
+genUUID = pOpen ReadFromPipe command params hGetLine
where
command = SysConfig.uuid
params = if command == "uuid"
@@ -53,9 +54,12 @@ genUUID = liftIO $ pOpen ReadFromPipe command params $ \h -> hGetLine h
-- uuidgen generates random uuid by default
else []
+getUUID :: Annex UUID
+getUUID = getRepoUUID =<< gitRepo
+
{- Looks up a repo's UUID. May return "" if none is known. -}
-getUUID :: Git.Repo -> Annex UUID
-getUUID r = do
+getRepoUUID :: Git.Repo -> Annex UUID
+getRepoUUID r = do
g <- gitRepo
let c = cached g
@@ -76,11 +80,8 @@ getUncachedUUID r = Git.configGet r configkey ""
{- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex ()
-prepUUID = do
- u <- getUUID =<< gitRepo
- when (null u) $ do
- uuid <- liftIO genUUID
- setConfig configkey uuid
+prepUUID = whenM (null <$> getUUID) $
+ setConfig configkey =<< liftIO genUUID
{- Records a description for a uuid in the log. -}
describeUUID :: UUID -> String -> Annex ()
diff --git a/Utility.hs b/Utility.hs
index 4e82e63c9..8ef60a081 100644
--- a/Utility.hs
+++ b/Utility.hs
@@ -19,6 +19,7 @@ module Utility (
anyM
) where
+import Control.Applicative
import IO (bracket)
import System.IO
import System.Posix.Process hiding (executeFile)
@@ -69,9 +70,7 @@ withTempFile template a = bracket create remove use
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: FilePath -> IO [FilePath]
-dirContents d = do
- c <- getDirectoryContents d
- return $ map (d </>) $ filter notcruft c
+dirContents d = map (d </>) . filter notcruft <$> getDirectoryContents d
where
notcruft "." = False
notcruft ".." = False
@@ -79,10 +78,7 @@ dirContents d = do
{- Current user's home directory. -}
myHomeDir :: IO FilePath
-myHomeDir = do
- uid <- getEffectiveUserID
- u <- getUserEntryForID uid
- return $ homeDirectory u
+myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID)
{- Catches IO errors and returns a Bool -}
catchBool :: IO Bool -> IO Bool
diff --git a/Utility/Path.hs b/Utility/Path.hs
index ce54fb369..1c68b87bb 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -17,10 +17,9 @@ import Control.Applicative
{- Returns the parent directory of a path. Parent of / is "" -}
parentDir :: FilePath -> FilePath
-parentDir dir =
- if not $ null dirs
- then slash ++ join s (init dirs)
- else ""
+parentDir dir
+ | not $ null dirs = slash ++ join s (init dirs)
+ | otherwise = ""
where
dirs = filter (not . null) $ split s dir
slash = if isAbsolute dir then s else ""
@@ -72,7 +71,7 @@ relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
- Both must be absolute, and normalized (eg with absNormpath).
-}
relPathDirToFile :: FilePath -> FilePath -> FilePath
-relPathDirToFile from to = path
+relPathDirToFile from to = join s $ dotdots ++ uncommon
where
s = [pathSeparator]
pfrom = split s from
@@ -82,7 +81,6 @@ relPathDirToFile from to = path
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
- path = join s $ dotdots ++ uncommon
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
@@ -99,14 +97,11 @@ prop_relPathDirToFile_basics from to
- appear at the same position as it did in the input list.
-}
preserveOrder :: [FilePath] -> [FilePath] -> [FilePath]
--- optimisation, only one item in original list, so no reordering needed
-preserveOrder [_] new = new
-preserveOrder orig new = collect orig new
+preserveOrder [] new = new
+preserveOrder [_] new = new -- optimisation
+preserveOrder (l:ls) new = found ++ preserveOrder ls rest
where
- collect [] n = n
- collect [_] n = n -- optimisation
- collect (l:ls) n = found ++ collect ls rest
- where (found, rest)=partition (l `dirContains`) n
+ (found, rest)=partition (l `dirContains`) new
{- Runs an action that takes a list of FilePaths, and ensures that
- its return list preserves order.
diff --git a/Utility/Ssh.hs b/Utility/Ssh.hs
index 4d17a47ba..a0e52507d 100644
--- a/Utility/Ssh.hs
+++ b/Utility/Ssh.hs
@@ -34,7 +34,7 @@ git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePat
git_annex_shell r command params
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
| Git.repoIsSsh r = do
- uuid <- getUUID r
+ uuid <- getRepoUUID r
sshparams <- sshToRepo r [Param $ sshcmd uuid ]
return $ Just ("ssh", sshparams)
| otherwise = return Nothing
diff --git a/git-annex-shell.hs b/git-annex-shell.hs
index 79b5da69a..a4d8dd65b 100644
--- a/git-annex-shell.hs
+++ b/git-annex-shell.hs
@@ -37,7 +37,7 @@ options = uuid : commonOptions
where
uuid = Option [] ["uuid"] (ReqArg check paramUUID) "repository uuid"
check expected = do
- u <- getUUID =<< gitRepo
+ u <- getUUID
when (u /= expected) $ error $
"expected repository UUID " ++ expected
++ " but found UUID " ++ u
diff --git a/test.hs b/test.hs
index 16f2a2bdf..1c511b4d4 100644
--- a/test.hs
+++ b/test.hs
@@ -609,9 +609,7 @@ checkdangling f = do
checklocationlog :: FilePath -> Bool -> Assertion
checklocationlog f expected = do
- thisuuid <- annexeval $ do
- g <- Annex.gitRepo
- UUID.getUUID g
+ thisuuid <- annexeval UUID.getUUID
r <- annexeval $ Backend.lookupFile f
case r of
Just (k, _) -> do