diff options
-rw-r--r-- | Backend.hs | 10 | ||||
-rw-r--r-- | Backend/SHA.hs | 2 | ||||
-rw-r--r-- | Backend/WORM.hs | 2 | ||||
-rw-r--r-- | Branch.hs | 6 | ||||
-rw-r--r-- | CmdLine.hs | 22 | ||||
-rw-r--r-- | Command.hs | 6 | ||||
-rw-r--r-- | Content.hs | 71 | ||||
-rw-r--r-- | Crypto.hs | 29 | ||||
-rw-r--r-- | Git.hs | 51 | ||||
-rw-r--r-- | Git/LsFiles.hs | 8 | ||||
-rw-r--r-- | Git/Queue.hs | 4 | ||||
-rw-r--r-- | Git/UnionMerge.hs | 2 | ||||
-rw-r--r-- | LocationLog.hs | 3 | ||||
-rw-r--r-- | Locations.hs | 2 | ||||
-rw-r--r-- | Messages.hs | 2 | ||||
-rw-r--r-- | PresenceLog.hs | 4 | ||||
-rw-r--r-- | Remote.hs | 7 | ||||
-rw-r--r-- | RemoteLog.hs | 10 | ||||
-rw-r--r-- | TestConfig.hs | 23 | ||||
-rw-r--r-- | Types/Key.hs | 4 | ||||
-rw-r--r-- | Types/Remote.hs | 3 | ||||
-rw-r--r-- | UUID.hs | 4 | ||||
-rw-r--r-- | Upgrade/V0.hs | 2 | ||||
-rw-r--r-- | Upgrade/V1.hs | 25 | ||||
-rw-r--r-- | Upgrade/V2.hs | 12 | ||||
-rw-r--r-- | Utility.hs | 4 | ||||
-rw-r--r-- | Version.hs | 3 | ||||
-rw-r--r-- | configure.hs | 5 | ||||
-rw-r--r-- | git-annex-shell.hs | 4 | ||||
-rw-r--r-- | git-annex.cabal | 2 | ||||
-rw-r--r-- | git-union-merge.hs | 5 | ||||
-rw-r--r-- | test.hs | 14 |
32 files changed, 172 insertions, 179 deletions
diff --git a/Backend.hs b/Backend.hs index cf976d2b8..3429e8f42 100644 --- a/Backend.hs +++ b/Backend.hs @@ -19,6 +19,7 @@ import Control.Monad.State (liftIO, when) import System.IO.Error (try) import System.FilePath import System.Posix.Files +import Data.Maybe import Locations import qualified Git @@ -33,10 +34,7 @@ import qualified Backend.WORM import qualified Backend.SHA list :: [Backend Annex] -list = concat - [ Backend.WORM.backends - , Backend.SHA.backends - ] +list = Backend.WORM.backends ++ Backend.SHA.backends {- List of backends in the order to try them when storing a new key. -} orderedList :: Annex [Backend Annex] @@ -54,7 +52,7 @@ orderedList = do handle Nothing s = return s handle (Just "") s = return s handle (Just name) s = do - let l' = (lookupBackendName name):s + let l' = lookupBackendName name : s Annex.changeState $ \state -> state { Annex.backends = l' } return l' getstandard = do @@ -119,7 +117,7 @@ chooseBackends fs = do {- Looks up a backend by name. May fail if unknown. -} lookupBackendName :: String -> Backend Annex -lookupBackendName s = maybe unknown id $ maybeLookupBackendName s +lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s where unknown = error $ "unknown backend " ++ s maybeLookupBackendName :: String -> Maybe (Backend Annex) diff --git a/Backend/SHA.hs b/Backend/SHA.hs index bd6e411a0..dc27b3000 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -114,7 +114,7 @@ checkKeyChecksum size key = do fast <- Annex.getState Annex.fast let file = gitAnnexLocation g key present <- liftIO $ doesFileExist file - if (not present || fast) + if not present || fast then return True else do s <- shaN size file diff --git a/Backend/WORM.hs b/Backend/WORM.hs index 036d0564c..831c9e8ce 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -35,7 +35,7 @@ backend = Types.Backend.Backend { keyValue :: FilePath -> Annex (Maybe Key) keyValue file = do stat <- liftIO $ getFileStatus file - return $ Just $ Key { + return $ Just Key { keyName = takeFileName file, keyBackendName = name backend, keySize = Just $ fromIntegral $ fileSize stat, @@ -87,7 +87,7 @@ withIndex' bootstrapping a = do e <- liftIO $ doesFileExist f unless e $ do - unless bootstrapping $ create + unless bootstrapping create liftIO $ createDirectoryIfMissing True $ takeDirectory f liftIO $ unless bootstrapping $ genIndex g @@ -187,7 +187,7 @@ updateRef ref Param (name++".."++ref), Params "--oneline -n1" ] - if (null diffs) + if null diffs then return Nothing else do showSideAction $ "merging " ++ shortref ref ++ " into " ++ name ++ "..." @@ -305,7 +305,7 @@ getJournalFile file = do {- List of journal files. -} getJournalFiles :: Annex [FilePath] -getJournalFiles = getJournalFilesRaw >>= return . map fileJournal +getJournalFiles = fmap (map fileJournal) getJournalFilesRaw getJournalFilesRaw :: Annex [FilePath] getJournalFilesRaw = do diff --git a/CmdLine.hs b/CmdLine.hs index b807046df..c33c49785 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -39,14 +39,13 @@ dispatch args cmds options header gitrepo = do - list of actions to be run in the Annex monad. -} parseCmd :: [String] -> String -> [Command] -> [Option] -> Annex [Annex Bool] parseCmd argv header cmds options = do - (flags, params) <- liftIO $ getopt + (flags, params) <- liftIO getopt when (null params) $ error $ "missing command" ++ usagemsg case lookupCmd (head params) of [] -> error $ "unknown command" ++ usagemsg [command] -> do _ <- sequence flags - when (cmdusesrepo command) $ - checkVersion + when (cmdusesrepo command) checkVersion prepCommand command (drop 1 params) _ -> error "internal error: multiple matching commands" where @@ -78,9 +77,9 @@ usage header cmds options = - (but explicitly thrown errors terminate the whole command). -} tryRun :: Annex.AnnexState -> [Annex Bool] -> IO () -tryRun state actions = tryRun' state 0 actions -tryRun' :: Annex.AnnexState -> Integer -> [Annex Bool] -> IO () -tryRun' state errnum (a:as) = do +tryRun = tryRun' 0 +tryRun' :: Integer -> Annex.AnnexState -> [Annex Bool] -> IO () +tryRun' errnum state (a:as) = do result <- try $ Annex.run state $ do AnnexQueue.flushWhenFull a @@ -89,11 +88,10 @@ tryRun' state errnum (a:as) = do Annex.eval state $ do showEndFail showErr err - tryRun' state (errnum + 1) as - Right (True,state') -> tryRun' state' errnum as - Right (False,state') -> tryRun' state' (errnum + 1) as -tryRun' _ errnum [] = do - when (errnum > 0) $ error $ show errnum ++ " failed" + tryRun' (errnum + 1) state as + Right (True,state') -> tryRun' errnum state' as + Right (False,state') -> tryRun' (errnum + 1) state' as +tryRun' errnum _ [] = when (errnum > 0) $ error $ show errnum ++ " failed" {- Actions to perform each time ran. -} startup :: Annex Bool @@ -105,5 +103,5 @@ startup = do shutdown :: Annex Bool shutdown = do saveState - liftIO $ Git.reap + liftIO Git.reap return True diff --git a/Command.hs b/Command.hs index c666ddbd2..729e442fc 100644 --- a/Command.hs +++ b/Command.hs @@ -115,7 +115,7 @@ isAnnexed file a = maybe (return Nothing) a =<< Backend.lookupFile file notBareRepo :: Annex a -> Annex a notBareRepo a = do g <- Annex.gitRepo - when (Git.repoIsLocalBare g) $ do + when (Git.repoIsLocalBare g) $ error "You cannot run this subcommand in a bare repository." a @@ -175,9 +175,9 @@ withFilesUnlocked' typechanged a params = do unlockedfiles' <- filterFiles unlockedfiles backendPairs a unlockedfiles' withKeys :: CommandSeekKeys -withKeys a params = return $ map a $ map parse params +withKeys a params = return $ map (a . parse) params where - parse p = maybe (error "bad key") id $ readKey p + parse p = fromMaybe (error "bad key") $ readKey p withTempFile :: CommandSeekStrings withTempFile a params = return $ map a params withNothing :: CommandSeekNothing diff --git a/Content.hs b/Content.hs index 94f8b8c2a..c63042dfb 100644 --- a/Content.hs +++ b/Content.hs @@ -57,8 +57,8 @@ inAnnex key = do calcGitLink :: FilePath -> Key -> Annex FilePath calcGitLink file key = do g <- Annex.gitRepo - cwd <- liftIO $ getCurrentDirectory - let absfile = maybe whoops id $ absNormPath cwd file + cwd <- liftIO getCurrentDirectory + let absfile = fromMaybe whoops $ absNormPath cwd file return $ relPathDirToFile (parentDir absfile) (Git.workTree g) </> ".git" </> annexLocation key where @@ -94,15 +94,19 @@ getViaTmp key action = do getViaTmpUnchecked key action +prepTmp :: Key -> Annex FilePath +prepTmp key = do + g <- Annex.gitRepo + let tmp = gitAnnexTmpLocation g key + liftIO $ createDirectoryIfMissing True (parentDir tmp) + return tmp + {- Like getViaTmp, but does not check that there is enough disk space - for the incoming key. For use when the key content is already on disk - and not being copied into place. -} getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmpUnchecked key action = do - g <- Annex.gitRepo - let tmp = gitAnnexTmpLocation g key - - liftIO $ createDirectoryIfMissing True (parentDir tmp) + tmp <- prepTmp key success <- action tmp if success then do @@ -117,9 +121,7 @@ getViaTmpUnchecked key action = do {- Creates a temp file, runs an action on it, and cleans up the temp file. -} withTmp :: Key -> (FilePath -> Annex a) -> Annex a withTmp key action = do - g <- Annex.gitRepo - let tmp = gitAnnexTmpLocation g key - liftIO $ createDirectoryIfMissing True (parentDir tmp) + tmp <- prepTmp key res <- action tmp liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp return res @@ -133,23 +135,21 @@ checkDiskSpace' :: Integer -> Key -> Annex () checkDiskSpace' adjustment key = do g <- Annex.gitRepo r <- getConfig g "diskreserve" "" - let reserve = maybe megabyte id $ readSize dataUnits r + let reserve = fromMaybe megabyte $ readSize dataUnits r stats <- liftIO $ getFileSystemStats (gitAnnexDir g) case (stats, keySize key) of (Nothing, _) -> return () (_, Nothing) -> return () (Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) -> - if (need + reserve > have + adjustment) - then needmorespace (need + reserve - have - adjustment) - else return () + when (need + reserve > have + adjustment) $ + needmorespace (need + reserve - have - adjustment) where megabyte :: Integer megabyte = 1000000 - needmorespace n = do - unlessM (Annex.getState Annex.force) $ - error $ "not enough free space, need " ++ - roughSize storageUnits True n ++ - " more (use --force to override this check or adjust annex.diskreserve)" + needmorespace n = unlessM (Annex.getState Annex.force) $ + error $ "not enough free space, need " ++ + roughSize storageUnits True n ++ + " more (use --force to override this check or adjust annex.diskreserve)" {- Removes the write bits from a file. -} preventWrite :: FilePath -> IO () @@ -200,28 +200,27 @@ moveAnnex key src = do preventWrite dest preventWrite dir -{- Removes a key's file from .git/annex/objects/ -} -removeAnnex :: Key -> Annex () -removeAnnex key = do +withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a +withObjectLoc key a = do g <- Annex.gitRepo let file = gitAnnexLocation g key let dir = parentDir file - liftIO $ do - allowWrite dir - removeFile file - removeDirectory dir + a (dir, file) + +{- Removes a key's file from .git/annex/objects/ -} +removeAnnex :: Key -> Annex () +removeAnnex key = withObjectLoc key $ \(dir, file) -> liftIO $ do + allowWrite dir + removeFile file + removeDirectory dir {- Moves a key's file out of .git/annex/objects/ -} fromAnnex :: Key -> FilePath -> Annex () -fromAnnex key dest = do - g <- Annex.gitRepo - let file = gitAnnexLocation g key - let dir = parentDir file - liftIO $ do - allowWrite dir - allowWrite file - renameFile file dest - removeDirectory dir +fromAnnex key dest = withObjectLoc key $ \(dir, file) -> liftIO $ do + allowWrite dir + allowWrite file + renameFile file dest + removeDirectory dir {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and - returns the file it was moved to. -} @@ -246,7 +245,7 @@ getKeysPresent = do getKeysPresent' :: FilePath -> Annex [Key] getKeysPresent' dir = do exists <- liftIO $ doesDirectoryExist dir - if (not exists) + if not exists then return [] else liftIO $ do -- 2 levels of hashing @@ -254,7 +253,7 @@ getKeysPresent' dir = do levelb <- mapM dirContents levela contents <- mapM dirContents (concat levelb) files <- filterM present (concat contents) - return $ catMaybes $ map (fileKey . takeFileName) files + return $ mapMaybe (fileKey . takeFileName) files where present d = do result <- try $ @@ -33,6 +33,7 @@ import Data.Digest.Pure.SHA import System.Cmd.Utils import Data.String.Utils import Data.List +import Data.Maybe import System.IO import System.Posix.IO import System.Posix.Types @@ -125,11 +126,11 @@ encryptCipher (Cipher c) (KeyIds ks) = do return $ EncryptedCipher encipher (KeyIds ks') where encrypt = [ Params "--encrypt" ] - recipients l = - -- Force gpg to only encrypt to the specified - -- recipients, not configured defaults. - [ Params "--no-encrypt-to --no-default-recipient"] ++ - (concat $ map (\k -> [Param "--recipient", Param k]) l) + recipients l = force_recipients : + concatMap (\k -> [Param "--recipient", Param k]) l + -- Force gpg to only encrypt to the specified + -- recipients, not configured defaults. + force_recipients = Params "--no-encrypt-to --no-default-recipient" {- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -} decryptCipher :: RemoteConfig -> EncryptedCipher -> IO Cipher @@ -152,24 +153,24 @@ encryptKey c k = {- Runs an action, passing it a handle from which it can - stream encrypted content. -} -withEncryptedHandle :: Cipher -> (IO L.ByteString) -> (Handle -> IO a) -> IO a +withEncryptedHandle :: Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a withEncryptedHandle = gpgCipherHandle [Params "--symmetric --force-mdc"] {- Runs an action, passing it a handle from which it can - stream decrypted content. -} -withDecryptedHandle :: Cipher -> (IO L.ByteString) -> (Handle -> IO a) -> IO a +withDecryptedHandle :: Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a withDecryptedHandle = gpgCipherHandle [Param "--decrypt"] {- Streams encrypted content to an action. -} -withEncryptedContent :: Cipher -> (IO L.ByteString) -> (L.ByteString -> IO a) -> IO a +withEncryptedContent :: Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a withEncryptedContent = pass withEncryptedHandle {- Streams decrypted content to an action. -} -withDecryptedContent :: Cipher -> (IO L.ByteString) -> (L.ByteString -> IO a) -> IO a +withDecryptedContent :: Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a withDecryptedContent = pass withDecryptedHandle -pass :: (Cipher -> (IO L.ByteString) -> (Handle -> IO a) -> IO a) - -> Cipher -> (IO L.ByteString) -> (L.ByteString -> IO a) -> IO a +pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a) + -> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a pass to c i a = to c i $ \h -> a =<< L.hGetContents h gpgParams :: [CommandParam] -> IO [String] @@ -202,7 +203,7 @@ gpgPipeStrict params input = do - - Note that to avoid deadlock with the cleanup stage, - the action must fully consume gpg's input before returning. -} -gpgCipherHandle :: [CommandParam] -> Cipher -> (IO L.ByteString) -> (Handle -> IO a) -> IO a +gpgCipherHandle :: [CommandParam] -> Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a gpgCipherHandle params c a b = do -- pipe the passphrase into gpg on a fd (frompipe, topipe) <- createPipe @@ -235,10 +236,10 @@ configKeyIds c = do where parseWithColons s = map keyIdField $ filter pubKey $ lines s pubKey = isPrefixOf "pub:" - keyIdField s = (split ":" s) !! 4 + keyIdField s = split ":" s !! 4 configGet :: RemoteConfig -> String -> String -configGet c key = maybe missing id $ M.lookup key c +configGet c key = fromMaybe missing $ M.lookup key c where missing = error $ "missing " ++ key ++ " in remote config" hmacWithCipher :: Cipher -> String -> String @@ -69,11 +69,10 @@ import System.Posix.User import System.Posix.Process import System.Path import System.Cmd.Utils -import IO (bracket_) +import IO (bracket_, try) import Data.String.Utils import System.IO -import IO (try) -import qualified Data.Map as Map hiding (map, split) +import qualified Data.Map as M hiding (map, split) import Network.URI import Data.Maybe import Data.Char @@ -93,7 +92,7 @@ data RepoLocation = Dir FilePath | Url URI | Unknown data Repo = Repo { location :: RepoLocation, - config :: Map.Map String String, + config :: M.Map String String, remotes :: [Repo], -- remoteName holds the name used for this repo in remotes remoteName :: Maybe String @@ -103,7 +102,7 @@ newFrom :: RepoLocation -> Repo newFrom l = Repo { location = l, - config = Map.empty, + config = M.empty, remotes = [], remoteName = Nothing } @@ -140,7 +139,7 @@ repoFromUrl url | startswith "file://" url = repoFromAbsPath $ uriPath u | otherwise = return $ newFrom $ Url u where - u = maybe bad id $ parseURI url + u = fromMaybe bad $ parseURI url bad = error $ "bad url " ++ url {- Creates a repo that has an unknown location. -} @@ -208,7 +207,7 @@ repoIsSsh Repo { location = Url url } repoIsSsh _ = False configAvail ::Repo -> Bool -configAvail Repo { config = c } = c /= Map.empty +configAvail Repo { config = c } = c /= M.empty repoIsLocalBare :: Repo -> Bool repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r @@ -228,7 +227,7 @@ assertUrl repo action = " not supported" configBare :: Repo -> Bool -configBare repo = maybe unknown configTrue $ Map.lookup "core.bare" $ config repo +configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo where unknown = error $ "it is not known if git repo " ++ repoDescribe repo ++ @@ -272,14 +271,14 @@ workTreeFile repo@(Repo { location = Dir d }) file = do let file' = absfile cwd unless (inrepo file') $ error $ file ++ " is not located inside git repository " ++ absrepo - if (inrepo $ addTrailingPathSeparator cwd) + if inrepo $ addTrailingPathSeparator cwd then return $ relPathDirToFile cwd file' else return $ drop (length absrepo) file' where -- normalize both repo and file, so that repo -- will be substring of file absrepo = maybe bad addTrailingPathSeparator $ absNormPath "/" d - absfile c = maybe file id $ secureAbsNormPath c file + absfile c = fromMaybe file $ secureAbsNormPath c file inrepo f = absrepo `isPrefixOf` f bad = error $ "bad repo" ++ repoDescribe repo workTreeFile repo _ = assertLocal repo $ error "internal" @@ -303,7 +302,7 @@ uriRegName' a = fixup $ uriRegName a | rest !! len == ']' = take len rest | otherwise = x where - len = (length rest) - 1 + len = length rest - 1 fixup x = x {- Hostname of an URL repo. -} @@ -348,7 +347,7 @@ gitCommandLine repo _ = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} runBool :: Repo -> String -> [CommandParam] -> IO Bool runBool repo subcommand params = assertLocal repo $ - boolSystem "git" (gitCommandLine repo ((Param subcommand):params)) + boolSystem "git" $ gitCommandLine repo $ Param subcommand : params {- Runs git in the specified repo, throwing an error if it fails. -} run :: Repo -> String -> [CommandParam] -> IO () @@ -471,13 +470,13 @@ hConfigRead repo h = do - can be updated inrementally. -} configStore :: Repo -> String -> IO Repo configStore repo s = do - let repo' = repo { config = Map.union (configParse s) (config repo) } + let repo' = repo { config = configParse s `M.union` config repo } rs <- configRemotes repo' return $ repo' { remotes = rs } {- Parses git config --list output into a config map. -} -configParse :: String -> Map.Map String String -configParse s = Map.fromList $ map pair $ lines s +configParse :: String -> M.Map String String +configParse s = M.fromList $ map pair $ lines s where pair l = (key l, val l) key l = head $ keyval l @@ -489,8 +488,8 @@ configParse s = Map.fromList $ map pair $ lines s configRemotes :: Repo -> IO [Repo] configRemotes repo = mapM construct remotepairs where - remotepairs = Map.toList $ filterremotes $ config repo - filterremotes = Map.filterWithKey (\k _ -> isremote k) + remotepairs = M.toList $ filterremotes $ config repo + filterremotes = M.filterWithKey (\k _ -> isremote k) isremote k = startswith "remote." k && endswith ".url" k construct (k,v) = do r <- gen v @@ -499,15 +498,15 @@ configRemotes repo = mapM construct remotepairs | isURI v = repoFromUrl v | otherwise = repoFromRemotePath v repo -- git remotes can be written scp style -- [user@]host:dir - scpstyle v = ":" `isInfixOf` v && (not $ "//" `isInfixOf` v) + scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v) scptourl v = "ssh://" ++ host ++ slash dir where bits = split ":" v - host = bits !! 0 + host = head bits dir = join ":" $ drop 1 bits slash d | d == "" = "/~/" ++ dir - | d !! 0 == '/' = dir - | d !! 0 == '~' = '/':dir + | head d == '/' = dir + | head d == '~' = '/':dir | otherwise = "/~/" ++ dir {- Checks if a string from git config is a true value. -} @@ -517,11 +516,11 @@ configTrue s = map toLower s == "true" {- Returns a single git config setting, or a default value if not set. -} configGet :: Repo -> String -> String -> String configGet repo key defaultValue = - Map.findWithDefault defaultValue key (config repo) + M.findWithDefault defaultValue key (config repo) {- Access to raw config Map -} -configMap :: Repo -> Map.Map String String -configMap repo = config repo +configMap :: Repo -> M.Map String String +configMap = config {- Efficiently looks up a gitattributes value for each file in a list. -} checkAttr :: Repo -> String -> [FilePath] -> IO [(FilePath, String)] @@ -680,8 +679,8 @@ 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 + then return $ Just dir + else case parentDir dir of "" -> return Nothing d -> seekUp want d diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index b88c9144e..23b383a09 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -21,7 +21,7 @@ import Utility {- Scans for files that are checked into git at the specified locations. -} inRepo :: Repo -> [FilePath] -> IO [FilePath] inRepo repo l = pipeNullSplit repo $ - [Params "ls-files --cached -z --"] ++ map File l + Params "ls-files --cached -z --" : map File l {- Scans for files at the specified locations that are not checked into - git. -} @@ -44,12 +44,12 @@ staged' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath] staged' repo l middle = pipeNullSplit repo $ start ++ middle ++ end where start = [Params "diff --cached --name-only -z"] - end = [Param "--"] ++ map File l + end = Param "--" : map File l {- Returns a list of files that have unstaged changes. -} changedUnstaged :: Repo -> [FilePath] -> IO [FilePath] changedUnstaged repo l = pipeNullSplit repo $ - [Params "diff --name-only -z --"] ++ map File l + Params "diff --name-only -z --" : map File l {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} @@ -65,4 +65,4 @@ typeChanged' :: Repo -> [FilePath] -> [CommandParam] -> IO [FilePath] typeChanged' repo l middle = pipeNullSplit repo $ start ++ middle ++ end where start = [Params "diff --name-only --diff-filter=T -z"] - end = [Param "--"] ++ map File l + end = Param "--" : map File l diff --git a/Git/Queue.hs b/Git/Queue.hs index e080476b7..0016be472 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -18,7 +18,7 @@ import qualified Data.Map as M import System.IO import System.Cmd.Utils import Data.String.Utils -import Control.Monad (unless, forM_) +import Control.Monad (forM_) import Utility import Git @@ -61,7 +61,7 @@ add (Queue n m) subcommand params files = Queue (n + 1) m' -- can be a lot of files per item. So, optimise adding -- files. m' = M.insertWith' const action fs m - fs = files ++ (M.findWithDefault [] action m) + fs = files ++ M.findWithDefault [] action m {- Number of items in a queue. -} size :: Queue -> Int diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index 4e0361b85..b0da07170 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -91,5 +91,5 @@ mergeFile g (info, file) = case filter (/= nullsha) [asha, bsha] of return $ Just $ update_index_line sha file where [_colonamode, _bmode, asha, bsha, _status] = words info - nullsha = take shaSize $ repeat '0' + nullsha = replicate shaSize '0' unionmerge = unlines . nub . lines diff --git a/LocationLog.hs b/LocationLog.hs index fe09482b9..768483fa1 100644 --- a/LocationLog.hs +++ b/LocationLog.hs @@ -49,8 +49,7 @@ keyLocations key = currentLog $ logFile key {- Finds all keys that have location log information. - (There may be duplicate keys in the list.) -} loggedKeys :: Annex [Key] -loggedKeys = - return . catMaybes . map (logFileKey . takeFileName) =<< Branch.files +loggedKeys = return . mapMaybe (logFileKey . takeFileName) =<< Branch.files {- The filename of the log file for a given key. -} logFile :: Key -> String diff --git a/Locations.hs b/Locations.hs index 347b08ce1..2dbf2f55e 100644 --- a/Locations.hs +++ b/Locations.hs @@ -52,7 +52,7 @@ import qualified Git {- The directory git annex uses for local state, relative to the .git - directory -} annexDir :: FilePath -annexDir = addTrailingPathSeparator $ "annex" +annexDir = addTrailingPathSeparator "annex" {- The directory git annex uses for locally available object content, - relative to the .git directory -} diff --git a/Messages.hs b/Messages.hs index 038e4c0bc..5f150aafb 100644 --- a/Messages.hs +++ b/Messages.hs @@ -37,7 +37,7 @@ showProgress :: Annex () showProgress = verbose $ liftIO $ putStr "\n" showLongNote :: String -> Annex () -showLongNote s = verbose $ liftIO $ putStr $ "\n" ++ indent s +showLongNote s = verbose $ liftIO $ putStr $ '\n' : indent s showEndOk :: Annex () showEndOk = verbose $ liftIO $ putStrLn "ok" diff --git a/PresenceLog.hs b/PresenceLog.hs index 0777db209..9c516a8db 100644 --- a/PresenceLog.hs +++ b/PresenceLog.hs @@ -94,7 +94,7 @@ writeLog file ls = Branch.change file (unlines $ map show ls) {- Generates a new LogLine with the current date. -} logNow :: LogStatus -> String -> Annex LogLine logNow s i = do - now <- liftIO $ getPOSIXTime + now <- liftIO getPOSIXTime return $ LogLine now s i {- Reads a log and returns only the info that is still in effect. -} @@ -112,7 +112,7 @@ type LogMap = Map.Map String LogLine {- Compacts a set of logs, returning a subset that contains the current - status. -} compactLog :: [LogLine] -> [LogLine] -compactLog ls = compactLog' Map.empty ls +compactLog = compactLog' Map.empty compactLog' :: LogMap -> [LogLine] -> [LogLine] compactLog' m [] = Map.elems m compactLog' m (l:ls) = compactLog' (mapLog m l) ls @@ -33,6 +33,7 @@ import Control.Monad (filterM, liftM2) import Data.List import qualified Data.Map as M import Data.String.Utils +import Data.Maybe import Types import Types.Remote @@ -97,7 +98,7 @@ byName' "" = return $ Left "no remote specified" byName' n = do allremotes <- genList let match = filter matching allremotes - if (null match) + if null match then return $ Left $ "there is no git remote named \"" ++ n ++ "\"" else return $ Right $ head match where @@ -110,7 +111,7 @@ nameToUUID "." = getUUID =<< Annex.gitRepo -- special case for current repo nameToUUID n = do res <- byName' n case res of - Left e -> return . (maybe (error e) id) =<< byDescription + Left e -> return . fromMaybe (error e) =<< byDescription Right r -> return $ uuid r where byDescription = return . M.lookup n . invertMap =<< uuidMap @@ -122,7 +123,7 @@ prettyPrintUUIDs :: [UUID] -> Annex String prettyPrintUUIDs uuids = do here <- getUUID =<< Annex.gitRepo -- Show descriptions from the uuid log, falling back to remote names, - -- as some remotes may not be in the uuid log. + -- as some remotes may not be in the uuid log m <- liftM2 M.union uuidMap $ return . M.fromList . map (\r -> (uuid r, name r)) =<< genList return $ unwords $ map (\u -> "\t" ++ prettify m u here ++ "\n") uuids diff --git a/RemoteLog.hs b/RemoteLog.hs index c2065db9d..69a82f498 100644 --- a/RemoteLog.hs +++ b/RemoteLog.hs @@ -36,7 +36,7 @@ configSet u c = do Branch.change remoteLog $ unlines $ sort $ map toline $ M.toList $ M.insert u c m where - toline (u', c') = u' ++ " " ++ (unwords $ configToKeyVal c') + toline (u', c') = u' ++ " " ++ unwords (configToKeyVal c') {- Map of remotes by uuid containing key/value config maps. -} readRemoteLog :: Annex (M.Map UUID RemoteConfig) @@ -44,14 +44,14 @@ readRemoteLog = return . remoteLogParse =<< Branch.get remoteLog remoteLogParse :: String -> M.Map UUID RemoteConfig remoteLogParse s = - M.fromList $ catMaybes $ map parseline $ filter (not . null) $ lines s + M.fromList $ mapMaybe parseline $ filter (not . null) $ lines s where parseline l | length w > 2 = Just (u, c) | otherwise = Nothing where w = words l - u = w !! 0 + u = head w c = keyValToConfig $ tail w {- Given Strings like "key=value", generates a RemoteConfig. -} @@ -90,8 +90,8 @@ configUnEscape = unescape r = drop (length num) s rest = drop 1 r ok = not (null num) && - not (null r) && r !! 0 == ';' + not (null r) && head r == ';' {- for quickcheck -} prop_idempotent_configEscape :: String -> Bool -prop_idempotent_configEscape s = s == (configUnEscape $ configEscape s) +prop_idempotent_configEscape s = s == (configUnEscape . configEscape) s diff --git a/TestConfig.hs b/TestConfig.hs index bab297003..8cfae7f0c 100644 --- a/TestConfig.hs +++ b/TestConfig.hs @@ -45,7 +45,7 @@ writeSysConfig config = writeFile "SysConfig.hs" body runTests :: [TestCase] -> IO [Config] runTests [] = return [] -runTests ((TestCase tname t):ts) = do +runTests (TestCase tname t : ts) = do testStart tname c <- t testEnd c @@ -62,7 +62,7 @@ requireCmd k cmdline = do handle r = do testEnd r error $ "** the " ++ c ++ " command is required" - c = (words cmdline) !! 0 + c = head $ words cmdline {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test @@ -74,7 +74,7 @@ testCmd k cmdline = do - turn. The Config is set to the first one found. -} selectCmd :: ConfigKey -> [String] -> String -> Test selectCmd k = searchCmd - (\match -> return $ Config k $ StringConfig match) + (return . Config k . StringConfig) (\cmds -> do testEnd $ Config k $ BoolConfig False error $ "* need one of these commands, but none are available: " ++ show cmds @@ -82,7 +82,7 @@ selectCmd k = searchCmd maybeSelectCmd :: ConfigKey -> [String] -> String -> Test maybeSelectCmd k = searchCmd - (\match -> return $ Config k $ MaybeStringConfig $ Just match) + (return . Config k . MaybeStringConfig . Just) (\_ -> return $ Config k $ MaybeStringConfig Nothing) searchCmd :: (String -> Test) -> ([String] -> Test) -> [String] -> String -> Test @@ -91,7 +91,7 @@ searchCmd success failure cmds param = search cmds search [] = failure cmds search (c:cs) = do ret <- system $ quiet c ++ " " ++ param - if (ret == ExitSuccess) + if ret == ExitSuccess then success c else search cs @@ -104,8 +104,11 @@ testStart s = do hFlush stdout testEnd :: Config -> IO () -testEnd (Config _ (BoolConfig True)) = putStrLn $ " yes" -testEnd (Config _ (BoolConfig False)) = putStrLn $ " no" -testEnd (Config _ (StringConfig s)) = putStrLn $ " " ++ s -testEnd (Config _ (MaybeStringConfig (Just s))) = putStrLn $ " " ++ s -testEnd (Config _ (MaybeStringConfig Nothing)) = putStrLn $ " not available" +testEnd (Config _ (BoolConfig True)) = status "yes" +testEnd (Config _ (BoolConfig False)) = status "no" +testEnd (Config _ (StringConfig s)) = status s +testEnd (Config _ (MaybeStringConfig (Just s))) = status s +testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available" + +status :: String -> IO () +status s = putStrLn $ ' ':s diff --git a/Types/Key.hs b/Types/Key.hs index 1d9bf8e11..b26bb8989 100644 --- a/Types/Key.hs +++ b/Types/Key.hs @@ -48,7 +48,7 @@ instance Show Key where "" +++ y = y x +++ "" = x x +++ y = x ++ fieldSep:y - c ?: (Just v) = c:(show v) + c ?: (Just v) = c : show v _ ?: _ = "" readKey :: String -> Maybe Key @@ -73,4 +73,4 @@ readKey s = if key == Just stubKey then Nothing else key addfield _ _ _ = Nothing prop_idempotent_key_read_show :: Key -> Bool -prop_idempotent_key_read_show k = Just k == (readKey $ show k) +prop_idempotent_key_read_show k = Just k == (readKey . show) k diff --git a/Types/Remote.hs b/Types/Remote.hs index 1d67ad5cd..8d9622c51 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -11,6 +11,7 @@ module Types.Remote where import Control.Exception import Data.Map as M +import Data.Ord import qualified Git import Types.Key @@ -62,4 +63,4 @@ instance Eq (Remote a) where -- order remotes by cost instance Ord (Remote a) where - compare x y = compare (cost x) (cost y) + compare = comparing cost @@ -49,7 +49,7 @@ genUUID :: IO UUID genUUID = liftIO $ pOpen ReadFromPipe command params $ \h -> hGetLine h where command = SysConfig.uuid - params = if (command == "uuid") + params = if command == "uuid" -- request a random uuid be generated then ["-m"] -- uuidgen generates random uuid by default @@ -82,7 +82,7 @@ prepUUID :: Annex () prepUUID = do u <- getUUID =<< Annex.gitRepo when ("" == u) $ do - uuid <- liftIO $ genUUID + uuid <- liftIO genUUID setConfig configkey uuid {- Records a description for a uuid in the uuidLog. -} diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index eabd03009..071fd12ee 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -48,7 +48,7 @@ lookupFile0 = Upgrade.V1.lookupFile1 getKeysPresent0 :: FilePath -> Annex [Key] getKeysPresent0 dir = do exists <- liftIO $ doesDirectoryExist dir - if (not exists) + if not exists then return [] else do contents <- liftIO $ getDirectoryContents dir diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 165a48262..8a3d37a64 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -94,7 +94,7 @@ updateSymlinks = do showNote "updating symlinks..." g <- Annex.gitRepo files <- liftIO $ LsFiles.inRepo g [Git.workTree g] - forM_ files $ fixlink + forM_ files fixlink where fixlink f = do r <- lookupFile1 f @@ -119,7 +119,7 @@ moveLocationLogs = do if exists then do contents <- liftIO $ getDirectoryContents dir - return $ catMaybes $ map oldlog2key contents + return $ mapMaybe oldlog2key contents else return [] move (l, k) = do g <- Annex.gitRepo @@ -196,17 +196,14 @@ lookupFile1 file = do Left _ -> return Nothing Right l -> makekey l where - getsymlink = do - l <- readSymbolicLink file - return $ takeFileName l - makekey l = do - case maybeLookupBackendName bname of - Nothing -> do - unless (null kname || null bname || - not (isLinkToAnnex l)) $ - warning skip - return Nothing - Just backend -> return $ Just (k, backend) + getsymlink = return . takeFileName =<< readSymbolicLink file + makekey l = case maybeLookupBackendName bname of + Nothing -> do + unless (null kname || null bname || + not (isLinkToAnnex l)) $ + warning skip + return Nothing + Just backend -> return $ Just (k, backend) where k = fileKey1 l bname = keyBackendName k @@ -221,7 +218,7 @@ getKeyFilesPresent1 = do getKeyFilesPresent1' :: FilePath -> Annex [FilePath] getKeyFilesPresent1' dir = do exists <- liftIO $ doesDirectoryExist dir - if (not exists) + if not exists then return [] else do dirs <- liftIO $ getDirectoryContents dir diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index 4824f4bba..99c7806d2 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -10,7 +10,7 @@ module Upgrade.V2 where import System.Directory import System.FilePath import Control.Monad.State (unless, when, liftIO) -import List +import Data.List import Data.Maybe import Types.Key @@ -61,7 +61,7 @@ upgrade = do Git.run g "rm" [Param "-r", Param "-f", Param "-q", File (olddir g)] unless bare $ gitAttributesUnWrite g - unless bare $ push + unless bare push return True @@ -70,11 +70,11 @@ locationLogs repo = liftIO $ do levela <- dirContents dir levelb <- mapM tryDirContents levela files <- mapM tryDirContents (concat levelb) - return $ catMaybes $ map islogfile (concat files) + return $ mapMaybe islogfile (concat files) where tryDirContents d = catch (dirContents d) (return . const []) dir = gitStateDir repo - islogfile f = maybe Nothing (\k -> Just $ (k, f)) $ + islogfile f = maybe Nothing (\k -> Just (k, f)) $ logFileKey $ takeFileName f inject :: FilePath -> FilePath -> Annex () @@ -131,10 +131,10 @@ gitAttributesUnWrite repo = do whenM (doesFileExist attributes) $ do c <- readFileStrict attributes liftIO $ viaTmp writeFile attributes $ unlines $ - filter (\l -> not $ l `elem` attrLines) $ lines c + filter (`notElem` attrLines) $ lines c Git.run repo "add" [File attributes] stateDir :: FilePath -stateDir = addTrailingPathSeparator $ ".git-annex" +stateDir = addTrailingPathSeparator ".git-annex" gitStateDir :: Git.Repo -> FilePath gitStateDir repo = addTrailingPathSeparator $ Git.workTree repo </> stateDir diff --git a/Utility.hs b/Utility.hs index 63fa6eda3..786c6a177 100644 --- a/Utility.hs +++ b/Utility.hs @@ -141,9 +141,9 @@ shellUnEscape s = word : shellUnEscape rest {- For quickcheck. -} prop_idempotent_shellEscape :: String -> Bool -prop_idempotent_shellEscape s = [s] == (shellUnEscape $ shellEscape s) +prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s prop_idempotent_shellEscape_multiword :: [String] -> Bool -prop_idempotent_shellEscape_multiword s = s == (shellUnEscape $ unwords $ map shellEscape s) +prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} diff --git a/Version.hs b/Version.hs index 7e7a4c7ce..7e6910fbe 100644 --- a/Version.hs +++ b/Version.hs @@ -43,8 +43,7 @@ checkVersion :: Annex () checkVersion = getVersion >>= handle where handle Nothing = error "First run: git-annex init" - handle (Just v) = do - unless (v `elem` supportedVersions) $ do + handle (Just v) = unless (v `elem` supportedVersions) $ error $ "Repository version " ++ v ++ " is not supported. " ++ msg v diff --git a/configure.hs b/configure.hs index 8639af44b..bfdfa32dd 100644 --- a/configure.hs +++ b/configure.hs @@ -7,7 +7,7 @@ import TestConfig tests :: [TestCase] tests = - [ TestCase "version" $ getVersion + [ TestCase "version" getVersion , testCp "cp_a" "-a" , testCp "cp_p" "-p" , testCp "cp_reflink_auto" "--reflink=auto" @@ -77,8 +77,7 @@ setup = do writeFile testFile "test file contents" cleanup :: IO () -cleanup = do - removeDirectoryRecursive tmpDir +cleanup = removeDirectoryRecursive tmpDir main :: IO () main = do diff --git a/git-annex-shell.hs b/git-annex-shell.hs index a64552c72..29ac63aea 100644 --- a/git-annex-shell.hs +++ b/git-annex-shell.hs @@ -58,10 +58,10 @@ builtins = map cmdname cmds builtin :: String -> String -> [String] -> IO () builtin cmd dir params = Git.repoAbsPath dir >>= Git.repoFromAbsPath >>= - dispatch (cmd:(filterparams params)) cmds commonOptions header + dispatch (cmd : filterparams params) cmds commonOptions header external :: [String] -> IO () -external params = do +external params = unlessM (boolSystem "git-shell" $ map Param $ "-c":filterparams params) $ error "git-shell failed" diff --git a/git-annex.cabal b/git-annex.cabal index 29ad80a58..bbbcbf9fb 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 3.20110707 +Version: 3.20110708 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net> diff --git a/git-union-merge.hs b/git-union-merge.hs index 38df0df6a..e76337607 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -23,8 +23,7 @@ tmpIndex :: Git.Repo -> FilePath tmpIndex g = Git.workTree g </> Git.gitDir g </> "index.git-union-merge" setup :: Git.Repo -> IO () -setup g = do - cleanup g -- idempotency +setup g = cleanup g -- idempotency cleanup :: Git.Repo -> IO () cleanup g = do @@ -34,7 +33,7 @@ cleanup g = do parseArgs :: IO [String] parseArgs = do args <- getArgs - if (length args /= 3) + if length args /= 3 then usage else return args @@ -19,7 +19,7 @@ import System.IO.Error import System.Posix.Env import qualified Control.Exception.Extensible as E import Control.Exception (throw) -import Maybe +import Data.Maybe import qualified Data.Map as M import System.Path (recurseDir) import System.IO.HVFS (SystemFS(..)) @@ -48,7 +48,7 @@ instance Arbitrary Types.Key.Key where arbitrary = do n <- arbitrary b <- elements ['A'..'Z'] - return $ Types.Key.Key { + return Types.Key.Key { Types.Key.keyName = n, Types.Key.keyBackendName = [b], Types.Key.keySize = Nothing, @@ -278,7 +278,7 @@ test_lock = "git-annex unlock/lock" ~: intmpclonerepo $ do -- write different content, to verify that lock -- throws it away changecontent annexedfile - writeFile annexedfile $ (content annexedfile) ++ "foo" + writeFile annexedfile $ content annexedfile ++ "foo" git_annex "lock" ["-q", annexedfile] @? "lock failed" annexed_present annexedfile git_annex "unlock" ["-q", annexedfile] @? "unlock failed" @@ -287,7 +287,7 @@ test_lock = "git-annex unlock/lock" ~: intmpclonerepo $ do git_annex "add" ["-q", annexedfile] @? "add of modified file failed" runchecks [checklink, checkunwritable] annexedfile c <- readFile annexedfile - assertEqual ("content of modified file") c (changedcontent annexedfile) + assertEqual "content of modified file" c (changedcontent annexedfile) r' <- git_annex "drop" ["-q", annexedfile] not r' @? "drop wrongly succeeded with no known copy of modified file" @@ -312,9 +312,9 @@ test_edit = "git-annex edit/commit" ~: TestList [t False, t True] @? "git commit of edited file failed" runchecks [checklink, checkunwritable] annexedfile c <- readFile annexedfile - assertEqual ("content of modified file") c (changedcontent annexedfile) + assertEqual "content of modified file" c (changedcontent annexedfile) r <- git_annex "drop" ["-q", annexedfile] - (not r) @? "drop wrongly succeeded with no known copy of modified file" + not r @? "drop wrongly succeeded with no known copy of modified file" test_fix :: Test test_fix = "git-annex fix" ~: intmpclonerepo $ do @@ -331,7 +331,7 @@ test_fix = "git-annex fix" ~: intmpclonerepo $ do git_annex "fix" ["-q", newfile] @? "fix of moved file failed" runchecks [checklink, checkunwritable] newfile c <- readFile newfile - assertEqual ("content of moved file") c (content annexedfile) + assertEqual "content of moved file" c (content annexedfile) where subdir = "s" newfile = subdir ++ "/" ++ annexedfile |