diff options
| -rw-r--r-- | Annex/Content.hs | 2 | ||||
| -rw-r--r-- | Backend/SHA.hs | 16 | ||||
| -rw-r--r-- | Command/ConfigList.hs | 3 | ||||
| -rw-r--r-- | Command/Fsck.hs | 2 | ||||
| -rw-r--r-- | Command/Init.hs | 3 | ||||
| -rw-r--r-- | Command/Move.hs | 6 | ||||
| -rw-r--r-- | Crypto.hs | 25 | ||||
| -rw-r--r-- | Init.hs | 6 | ||||
| -rw-r--r-- | Limit.hs | 7 | ||||
| -rw-r--r-- | Messages.hs | 27 | ||||
| -rw-r--r-- | Remote.hs | 12 | ||||
| -rw-r--r-- | Remote/Git.hs | 2 | ||||
| -rw-r--r-- | Remote/Helper/Encryptable.hs | 6 | ||||
| -rw-r--r-- | UUID.hs | 17 | ||||
| -rw-r--r-- | Utility.hs | 10 | ||||
| -rw-r--r-- | Utility/Path.hs | 21 | ||||
| -rw-r--r-- | Utility/Ssh.hs | 2 | ||||
| -rw-r--r-- | git-annex-shell.hs | 2 | ||||
| -rw-r--r-- | test.hs | 4 |
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 @@ -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) @@ -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" @@ -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 @@ -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) @@ -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 @@ -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 |