diff options
author | Joey Hess <joey@kitenet.net> | 2012-12-13 00:24:19 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-12-13 00:24:19 -0400 |
commit | 94554782894ec6c26da3b46312d5d1d16d596458 (patch) | |
tree | 78746106bfb153945ccbfd2bbae536081c005e91 /Annex | |
parent | 55bd61d8c42aaf36a3c57f8444c493f6b045f4cd (diff) |
finished where indentation changes
Diffstat (limited to 'Annex')
-rw-r--r-- | Annex/Branch.hs | 129 | ||||
-rw-r--r-- | Annex/CatFile.hs | 10 | ||||
-rw-r--r-- | Annex/CheckAttr.hs | 10 | ||||
-rw-r--r-- | Annex/Content.hs | 188 | ||||
-rw-r--r-- | Annex/Journal.hs | 20 | ||||
-rw-r--r-- | Annex/LockPool.hs | 24 | ||||
-rw-r--r-- | Annex/Perms.hs | 60 | ||||
-rw-r--r-- | Annex/Queue.hs | 4 | ||||
-rw-r--r-- | Annex/Ssh.hs | 96 | ||||
-rw-r--r-- | Annex/UUID.hs | 22 | ||||
-rw-r--r-- | Annex/Version.hs | 12 |
11 files changed, 287 insertions, 288 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index 243514fc9..d0a74c709 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -72,18 +72,18 @@ create = void getBranch {- Returns the ref of the branch, creating it first if necessary. -} getBranch :: Annex Git.Ref getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha - where - go True = do - inRepo $ Git.Command.run "branch" - [Param $ show name, Param $ show originname] - fromMaybe (error $ "failed to create " ++ show name) - <$> branchsha - go False = withIndex' True $ - inRepo $ Git.Branch.commit "branch created" fullname [] - use sha = do - setIndexSha sha - return sha - branchsha = inRepo $ Git.Ref.sha fullname + where + go True = do + inRepo $ Git.Command.run "branch" + [Param $ show name, Param $ show originname] + fromMaybe (error $ "failed to create " ++ show name) + <$> branchsha + go False = withIndex' True $ + inRepo $ Git.Branch.commit "branch created" fullname [] + use sha = do + setIndexSha sha + return sha + branchsha = inRepo $ Git.Ref.sha fullname {- Ensures that the branch and index are up-to-date; should be - called before data is read from it. Runs only once per git-annex run. -} @@ -128,26 +128,26 @@ updateTo pairs = do go branchref True [] [] else lockJournal $ go branchref dirty refs branches return $ not $ null refs - where - isnewer (r, _) = inRepo $ Git.Branch.changed fullname r - go branchref dirty refs branches = withIndex $ do - cleanjournal <- if dirty then stageJournal else return noop - let merge_desc = if null branches - then "update" - else "merging " ++ - unwords (map Git.Ref.describe branches) ++ - " into " ++ show name - unless (null branches) $ do - showSideAction merge_desc - mergeIndex refs - ff <- if dirty - then return False - else inRepo $ Git.Branch.fastForward fullname refs - if ff - then updateIndex branchref - else commitBranch branchref merge_desc - (nub $ fullname:refs) - liftIO cleanjournal + where + isnewer (r, _) = inRepo $ Git.Branch.changed fullname r + go branchref dirty refs branches = withIndex $ do + cleanjournal <- if dirty then stageJournal else return noop + let merge_desc = if null branches + then "update" + else "merging " ++ + unwords (map Git.Ref.describe branches) ++ + " into " ++ show name + unless (null branches) $ do + showSideAction merge_desc + mergeIndex refs + ff <- if dirty + then return False + else inRepo $ Git.Branch.fastForward fullname refs + if ff + then updateIndex branchref + else commitBranch branchref merge_desc + (nub $ fullname:refs) + liftIO cleanjournal {- Gets the content of a file, which may be in the journal, or committed - to the branch. Due to limitatons of git cat-file, does *not* get content @@ -168,15 +168,14 @@ getStale = get' True get' :: Bool -> FilePath -> Annex String get' staleok file = fromjournal =<< getJournalFile file - where - fromjournal (Just content) = return content - fromjournal Nothing - | staleok = withIndex frombranch - | otherwise = do - update - frombranch - frombranch = withIndex $ - L.unpack <$> catFile fullname file + where + fromjournal (Just content) = return content + fromjournal Nothing + | staleok = withIndex frombranch + | otherwise = do + update + frombranch + frombranch = withIndex $ L.unpack <$> catFile fullname file {- Applies a function to modifiy the content of a file. - @@ -228,27 +227,27 @@ commitBranch' branchref message parents = do parentrefs <- commitparents <$> catObject committedref when (racedetected branchref parentrefs) $ fixrace committedref parentrefs - where - -- look for "parent ref" lines and return the refs - commitparents = map (Git.Ref . snd) . filter isparent . - map (toassoc . L.unpack) . L.lines - toassoc = separate (== ' ') - isparent (k,_) = k == "parent" + where + -- look for "parent ref" lines and return the refs + commitparents = map (Git.Ref . snd) . filter isparent . + map (toassoc . L.unpack) . L.lines + toassoc = separate (== ' ') + isparent (k,_) = k == "parent" - {- The race can be detected by checking the commit's - - parent, which will be the newly pushed branch, - - instead of the expected ref that the index was updated to. -} - racedetected expectedref parentrefs - | expectedref `elem` parentrefs = False -- good parent - | otherwise = True -- race! + {- The race can be detected by checking the commit's + - parent, which will be the newly pushed branch, + - instead of the expected ref that the index was updated to. -} + racedetected expectedref parentrefs + | expectedref `elem` parentrefs = False -- good parent + | otherwise = True -- race! - {- To recover from the race, union merge the lost refs - - into the index, and recommit on top of the bad commit. -} - fixrace committedref lostrefs = do - mergeIndex lostrefs - commitBranch committedref racemessage [committedref] + {- To recover from the race, union merge the lost refs + - into the index, and recommit on top of the bad commit. -} + fixrace committedref lostrefs = do + mergeIndex lostrefs + commitBranch committedref racemessage [committedref] - racemessage = message ++ " (recovery from race)" + racemessage = message ++ " (recovery from race)" {- Lists all files on the branch. There may be duplicates in the list. -} files :: Annex [FilePath] @@ -345,9 +344,9 @@ stageJournal = withIndex $ do [genstream dir h fs] hashObjectStop h return $ liftIO $ mapM_ removeFile $ map (dir </>) fs - where - genstream dir h fs streamer = forM_ fs $ \file -> do - let path = dir </> file - sha <- hashFile h path - streamer $ Git.UpdateIndex.updateIndexLine - sha FileBlob (asTopFilePath $ fileJournal file) + where + genstream dir h fs streamer = forM_ fs $ \file -> do + let path = dir </> file + sha <- hashFile h path + streamer $ Git.UpdateIndex.updateIndexLine + sha FileBlob (asTopFilePath $ fileJournal file) diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs index 88c498d31..98d1a219f 100644 --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -37,8 +37,8 @@ catObjectDetails ref = do catFileHandle :: Annex Git.CatFile.CatFileHandle catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle - where - startup = do - h <- inRepo Git.CatFile.catFileStart - Annex.changeState $ \s -> s { Annex.catfilehandle = Just h } - return h + where + startup = do + h <- inRepo Git.CatFile.catFileStart + Annex.changeState $ \s -> s { Annex.catfilehandle = Just h } + return h diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs index 01779e813..8eed9e804 100644 --- a/Annex/CheckAttr.hs +++ b/Annex/CheckAttr.hs @@ -28,8 +28,8 @@ checkAttr attr file = do checkAttrHandle :: Annex Git.CheckAttrHandle checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle - where - startup = do - h <- inRepo $ Git.checkAttrStart annexAttrs - Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h } - return h + where + startup = do + h <- inRepo $ Git.checkAttrStart annexAttrs + Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h } + return h diff --git a/Annex/Content.hs b/Annex/Content.hs index e6afd5465..887729fee 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -62,19 +62,19 @@ inAnnex' a key = do - is not in the process of being removed. -} inAnnexSafe :: Key -> Annex (Maybe Bool) inAnnexSafe = inAnnex' $ \f -> openforlock f >>= check - where - openforlock f = catchMaybeIO $ - openFd f ReadOnly Nothing defaultFileFlags - check Nothing = return is_missing - check (Just h) = do - v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) - closeFd h - return $ case v of - Just _ -> is_locked - Nothing -> is_unlocked - is_locked = Nothing - is_unlocked = Just True - is_missing = Just False + where + openforlock f = catchMaybeIO $ + openFd f ReadOnly Nothing defaultFileFlags + check Nothing = return is_missing + check (Just h) = do + v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) + closeFd h + return $ case v of + Just _ -> is_locked + Nothing -> is_unlocked + is_locked = Nothing + is_unlocked = Just True + is_missing = Just False {- Content is exclusively locked while running an action that might remove - it. (If the content is not present, no locking is done.) -} @@ -82,25 +82,25 @@ lockContent :: Key -> Annex a -> Annex a lockContent key a = do file <- inRepo $ gitAnnexLocation key bracketIO (openforlock file >>= lock) unlock a - where - {- Since files are stored with the write bit disabled, have - - to fiddle with permissions to open for an exclusive lock. -} - openforlock f = catchMaybeIO $ ifM (doesFileExist f) - ( withModifiedFileMode f - (`unionFileModes` ownerWriteMode) - open - , open - ) - where - open = openFd f ReadWrite Nothing defaultFileFlags - lock Nothing = return Nothing - lock (Just fd) = do - v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) - case v of - Left _ -> error "content is locked" - Right _ -> return $ Just fd - unlock Nothing = noop - unlock (Just l) = closeFd l + where + {- Since files are stored with the write bit disabled, have + - to fiddle with permissions to open for an exclusive lock. -} + openforlock f = catchMaybeIO $ ifM (doesFileExist f) + ( withModifiedFileMode f + (`unionFileModes` ownerWriteMode) + open + , open + ) + where + open = openFd f ReadWrite Nothing defaultFileFlags + lock Nothing = return Nothing + lock (Just fd) = do + v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> error "content is locked" + Right _ -> return $ Just fd + unlock Nothing = noop + unlock (Just l) = closeFd l {- Calculates the relative path to use to link a file to a key. -} calcGitLink :: FilePath -> Key -> Annex FilePath @@ -109,8 +109,8 @@ calcGitLink file key = do let absfile = fromMaybe whoops $ absNormPath cwd file loc <- inRepo $ gitAnnexLocation key return $ relPathDirToFile (parentDir absfile) loc - where - whoops = error $ "unable to normalize " ++ file + where + whoops = error $ "unable to normalize " ++ file {- Updates the Logs.Location when a key's presence changes in the current - repository. -} @@ -186,13 +186,13 @@ checkDiskSpace destination key alreadythere = do needmorespace (need + reserve - have - alreadythere) return ok _ -> return True - where - dir = maybe (fromRepo gitAnnexDir) return destination - needmorespace n = - warning $ "not enough free space, need " ++ - roughSize storageUnits True n ++ - " more" ++ forcemsg - forcemsg = " (use --force to override this check or adjust annex.diskreserve)" + where + dir = maybe (fromRepo gitAnnexDir) return destination + needmorespace n = + warning $ "not enough free space, need " ++ + roughSize storageUnits True n ++ + " more" ++ forcemsg + forcemsg = " (use --force to override this check or adjust annex.diskreserve)" {- Moves a file into .git/annex/objects/ - @@ -237,12 +237,12 @@ cleanObjectLoc :: Key -> Annex () cleanObjectLoc key = do file <- inRepo $ gitAnnexLocation key liftIO $ removeparents file (3 :: Int) - where - removeparents _ 0 = noop - removeparents file n = do - let dir = parentDir file - maybe noop (const $ removeparents dir (n-1)) - <=< catchMaybeIO $ removeDirectory dir + where + removeparents _ 0 = noop + removeparents file n = do + let dir = parentDir file + maybe noop (const $ removeparents dir (n-1)) + <=< catchMaybeIO $ removeDirectory dir {- Removes a key's file from .git/annex/objects/ -} removeAnnex :: Key -> Annex () @@ -278,19 +278,19 @@ moveBad key = do {- List of keys whose content exists in .git/annex/objects/ -} getKeysPresent :: Annex [Key] getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir - where - traverse depth dir = do - contents <- catchDefaultIO [] (dirContents dir) - if depth == 0 - then continue (mapMaybe (fileKey . takeFileName) contents) [] - else do - let deeper = traverse (depth - 1) - continue [] (map deeper contents) - continue keys [] = return keys - continue keys (a:as) = do - {- Force lazy traversal with unsafeInterleaveIO. -} - morekeys <- unsafeInterleaveIO a - continue (morekeys++keys) as + where + traverse depth dir = do + contents <- catchDefaultIO [] (dirContents dir) + if depth == 0 + then continue (mapMaybe (fileKey . takeFileName) contents) [] + else do + let deeper = traverse (depth - 1) + continue [] (map deeper contents) + continue keys [] = return keys + continue keys (a:as) = do + {- Force lazy traversal with unsafeInterleaveIO. -} + morekeys <- unsafeInterleaveIO a + continue (morekeys++keys) as {- Things to do to record changes to content when shutting down. - @@ -303,9 +303,9 @@ saveState nocommit = doSideAction $ do unless nocommit $ whenM alwayscommit $ Annex.Branch.commit "update" - where - alwayscommit = fromMaybe True . Git.Config.isTrue - <$> getConfig (annexConfig "alwayscommit") "" + where + alwayscommit = fromMaybe True . Git.Config.isTrue + <$> getConfig (annexConfig "alwayscommit") "" {- Downloads content from any of a list of urls. -} downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool @@ -318,41 +318,41 @@ downloadUrl urls file = do - This is used to speed up some rsyncs. -} preseedTmp :: Key -> FilePath -> Annex Bool preseedTmp key file = go =<< inAnnex key - where - go False = return False - go True = do - ok <- copy - when ok $ thawContent file - return ok - copy = ifM (liftIO $ doesFileExist file) - ( return True - , do - s <- inRepo $ gitAnnexLocation key - liftIO $ copyFileExternal s file - ) + where + go False = return False + go True = do + ok <- copy + when ok $ thawContent file + return ok + copy = ifM (liftIO $ doesFileExist file) + ( return True + , do + s <- inRepo $ gitAnnexLocation key + liftIO $ copyFileExternal s file + ) {- Blocks writing to an annexed file. The file is made unwritable - to avoid accidental edits. core.sharedRepository may change - who can read it. -} freezeContent :: FilePath -> Annex () freezeContent file = liftIO . go =<< fromRepo getSharedRepository - where - go GroupShared = modifyFileMode file $ - removeModes writeModes . - addModes [ownerReadMode, groupReadMode] - go AllShared = modifyFileMode file $ - removeModes writeModes . - addModes readModes - go _ = preventWrite file + where + go GroupShared = modifyFileMode file $ + removeModes writeModes . + addModes [ownerReadMode, groupReadMode] + go AllShared = modifyFileMode file $ + removeModes writeModes . + addModes readModes + go _ = preventWrite file {- Allows writing to an annexed file that freezeContent was called on - before. -} thawContent :: FilePath -> Annex () thawContent file = liftIO . go =<< fromRepo getSharedRepository - where - go GroupShared = groupWriteRead file - go AllShared = groupWriteRead file - go _ = allowWrite file + where + go GroupShared = groupWriteRead file + go AllShared = groupWriteRead file + go _ = allowWrite file {- Blocks writing to the directory an annexed file is in, to prevent the - file accidentially being deleted. However, if core.sharedRepository @@ -361,11 +361,11 @@ thawContent file = liftIO . go =<< fromRepo getSharedRepository -} freezeContentDir :: FilePath -> Annex () freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository - where - dir = parentDir file - go GroupShared = groupWriteRead dir - go AllShared = groupWriteRead dir - go _ = preventWrite dir + where + dir = parentDir file + go GroupShared = groupWriteRead dir + go AllShared = groupWriteRead dir + go _ = preventWrite dir {- Makes the directory tree to store an annexed file's content, - with appropriate permissions on each level. -} @@ -375,5 +375,5 @@ createContentDir dest = do createAnnexDirectory dir -- might have already existed with restricted perms liftIO $ allowWrite dir - where - dir = parentDir dest + where + dir = parentDir dest diff --git a/Annex/Journal.hs b/Annex/Journal.hs index b6ed79272..2df5294ee 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -63,10 +63,10 @@ journalDirty = not . null <$> getJournalFiles -} journalFile :: FilePath -> Git.Repo -> FilePath journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file - where - mangle '/' = "_" - mangle '_' = "__" - mangle c = [c] + where + mangle '/' = "_" + mangle '_' = "__" + mangle c = [c] {- Converts a journal file (relative to the journal dir) back to the - filename on the branch. -} @@ -81,9 +81,9 @@ lockJournal a = do createAnnexDirectory $ takeDirectory file mode <- annexFileMode bracketIO (lock file mode) unlock a - where - lock file mode = do - l <- noUmask mode $ createFile file mode - waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0) - return l - unlock = closeFd + where + lock file mode = do + l <- noUmask mode $ createFile file mode + waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0) + return l + unlock = closeFd diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs index b99a8ec4d..45fc55b3c 100644 --- a/Annex/LockPool.hs +++ b/Annex/LockPool.hs @@ -17,21 +17,21 @@ import Annex.Perms {- Create a specified lock file, and takes a shared lock. -} lockFile :: FilePath -> Annex () lockFile file = go =<< fromPool file - where - go (Just _) = noop -- already locked - go Nothing = do - mode <- annexFileMode - fd <- liftIO $ noUmask mode $ - openFd file ReadOnly (Just mode) defaultFileFlags - liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0) - changePool $ M.insert file fd + where + go (Just _) = noop -- already locked + go Nothing = do + mode <- annexFileMode + fd <- liftIO $ noUmask mode $ + openFd file ReadOnly (Just mode) defaultFileFlags + liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0) + changePool $ M.insert file fd unlockFile :: FilePath -> Annex () unlockFile file = maybe noop go =<< fromPool file - where - go fd = do - liftIO $ closeFd fd - changePool $ M.delete file + where + go fd = do + liftIO $ closeFd fd + changePool $ M.delete file getPool :: Annex (M.Map FilePath Fd) getPool = getState lockpool diff --git a/Annex/Perms.hs b/Annex/Perms.hs index c54908b43..13deb20bd 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -21,11 +21,11 @@ import System.Posix.Types withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = maybe startup a =<< Annex.getState Annex.shared - where - startup = do - shared <- fromRepo getSharedRepository - Annex.changeState $ \s -> s { Annex.shared = Just shared } - a shared + where + startup = do + shared <- fromRepo getSharedRepository + Annex.changeState $ \s -> s { Annex.shared = Just shared } + a shared {- Sets appropriate file mode for a file or directory in the annex, - other than the content files and content directory. Normally, @@ -33,38 +33,38 @@ withShared a = maybe startup a =<< Annex.getState Annex.shared - allow the group to write, etc. -} setAnnexPerm :: FilePath -> Annex () setAnnexPerm file = withShared $ liftIO . go - where - go GroupShared = groupWriteRead file - go AllShared = modifyFileMode file $ addModes $ - [ ownerWriteMode, groupWriteMode ] ++ readModes - go _ = noop + where + go GroupShared = groupWriteRead file + go AllShared = modifyFileMode file $ addModes $ + [ ownerWriteMode, groupWriteMode ] ++ readModes + go _ = noop {- Gets the appropriate mode to use for creating a file in the annex - (other than content files, which are locked down more). -} annexFileMode :: Annex FileMode annexFileMode = withShared $ return . go - where - go GroupShared = sharedmode - go AllShared = combineModes (sharedmode:readModes) - go _ = stdFileMode - sharedmode = combineModes - [ ownerWriteMode, groupWriteMode - , ownerReadMode, groupReadMode - ] + where + go GroupShared = sharedmode + go AllShared = combineModes (sharedmode:readModes) + go _ = stdFileMode + sharedmode = combineModes + [ ownerWriteMode, groupWriteMode + , ownerReadMode, groupReadMode + ] {- Creates a directory inside the gitAnnexDir, including any parent - directories. Makes directories with appropriate permissions. -} createAnnexDirectory :: FilePath -> Annex () createAnnexDirectory dir = traverse dir [] =<< top - where - top = parentDir <$> fromRepo gitAnnexDir - traverse d below stop - | d `equalFilePath` stop = done - | otherwise = ifM (liftIO $ doesDirectoryExist d) - ( done - , traverse (parentDir d) (d:below) stop - ) - where - done = forM_ below $ \p -> do - liftIO $ createDirectory p - setAnnexPerm p + where + top = parentDir <$> fromRepo gitAnnexDir + traverse d below stop + | d `equalFilePath` stop = done + | otherwise = ifM (liftIO $ doesDirectoryExist d) + ( done + , traverse (parentDir d) (d:below) stop + ) + where + done = forM_ below $ \p -> do + liftIO $ createDirectory p + setAnnexPerm p diff --git a/Annex/Queue.hs b/Annex/Queue.hs index 97a759d10..64cc92897 100644 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -58,8 +58,8 @@ new = do q <- Git.Queue.new <$> queuesize store q return q - where - queuesize = readish <$> getConfig (annexConfig "queuesize") "" + where + queuesize = readish <$> getConfig (annexConfig "queuesize") "" store :: Git.Queue.Queue -> Annex () store q = changeState $ \s -> s { repoqueue = Just q } diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 5412491ca..cb46c06bc 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -27,19 +27,19 @@ import qualified Build.SysConfig as SysConfig - port, with connection caching. -} sshParams :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam] sshParams (host, port) opts = go =<< sshInfo (host, port) - where - go (Nothing, params) = ret params - go (Just socketfile, params) = do - cleanstale - liftIO $ createDirectoryIfMissing True $ parentDir socketfile - lockFile $ socket2lock socketfile - ret params - ret ps = return $ ps ++ opts ++ portParams port ++ [Param host] - -- If the lock pool is empty, this is the first ssh of this - -- run. There could be stale ssh connections hanging around - -- from a previous git-annex run that was interrupted. - cleanstale = whenM (not . any isLock . M.keys <$> getPool) $ - sshCleanup + where + go (Nothing, params) = ret params + go (Just socketfile, params) = do + cleanstale + liftIO $ createDirectoryIfMissing True $ parentDir socketfile + lockFile $ socket2lock socketfile + ret params + ret ps = return $ ps ++ opts ++ portParams port ++ [Param host] + -- If the lock pool is empty, this is the first ssh of this + -- run. There could be stale ssh connections hanging around + -- from a previous git-annex run that was interrupted. + cleanstale = whenM (not . any isLock . M.keys <$> getPool) $ + sshCleanup sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshInfo (host, port) = ifM caching @@ -55,13 +55,13 @@ sshInfo (host, port) = ifM caching else return (Nothing, []) , return (Nothing, []) ) - where + where #ifdef WITH_OLD_SSH - caching = return False + caching = return False #else - caching = fromMaybe SysConfig.sshconnectioncaching - . Git.Config.isTrue - <$> getConfig (annexConfig "sshcaching") "" + caching = fromMaybe SysConfig.sshconnectioncaching + . Git.Config.isTrue + <$> getConfig (annexConfig "sshcaching") "" #endif cacheParams :: FilePath -> [CommandParam] @@ -81,34 +81,34 @@ sshCleanup = do sockets <- filter (not . isLock) <$> liftIO (catchDefaultIO [] $ dirContents dir) forM_ sockets cleanup - where - cleanup socketfile = do - -- Drop any shared lock we have, and take an - -- exclusive lock, without blocking. If the lock - -- succeeds, nothing is using this ssh, and it can - -- be stopped. - let lockfile = socket2lock socketfile - unlockFile lockfile - mode <- annexFileMode - fd <- liftIO $ noUmask mode $ - openFd lockfile ReadWrite (Just mode) defaultFileFlags - v <- liftIO $ tryIO $ - setLock fd (WriteLock, AbsoluteSeek, 0, 0) - case v of - Left _ -> noop - Right _ -> stopssh socketfile - liftIO $ closeFd fd - stopssh socketfile = do - let (host, port) = socket2hostport socketfile - (_, params) <- sshInfo (host, port) - -- "ssh -O stop" is noisy on stderr even with -q - void $ liftIO $ catchMaybeIO $ - withQuietOutput createProcessSuccess $ - proc "ssh" $ toCommand $ - [ Params "-O stop" - ] ++ params ++ [Param host] - -- Cannot remove the lock file; other processes may - -- be waiting on our exclusive lock to use it. + where + cleanup socketfile = do + -- Drop any shared lock we have, and take an + -- exclusive lock, without blocking. If the lock + -- succeeds, nothing is using this ssh, and it can + -- be stopped. + let lockfile = socket2lock socketfile + unlockFile lockfile + mode <- annexFileMode + fd <- liftIO $ noUmask mode $ + openFd lockfile ReadWrite (Just mode) defaultFileFlags + v <- liftIO $ tryIO $ + setLock fd (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> noop + Right _ -> stopssh socketfile + liftIO $ closeFd fd + stopssh socketfile = do + let (host, port) = socket2hostport socketfile + (_, params) <- sshInfo (host, port) + -- "ssh -O stop" is noisy on stderr even with -q + void $ liftIO $ catchMaybeIO $ + withQuietOutput createProcessSuccess $ + proc "ssh" $ toCommand $ + [ Params "-O stop" + ] ++ params ++ [Param host] + -- Cannot remove the lock file; other processes may + -- be waiting on our exclusive lock to use it. hostport2socket :: String -> Maybe Integer -> FilePath hostport2socket host Nothing = host @@ -118,8 +118,8 @@ socket2hostport :: FilePath -> (String, Maybe Integer) socket2hostport socket | null p = (h, Nothing) | otherwise = (h, readish p) - where - (h, p) = separate (== '!') $ takeFileName socket + where + (h, p) = separate (== '!') $ takeFileName socket socket2lock :: FilePath -> FilePath socket2lock socket = socket ++ lockExt diff --git a/Annex/UUID.hs b/Annex/UUID.hs index 16c25c0ab..b20d94125 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -34,10 +34,10 @@ configkey = annexConfig "uuid" - so use the command line tool. -} genUUID :: IO UUID genUUID = gen . lines <$> readProcess command params - where - gen [] = error $ "no output from " ++ command - gen (l:_) = toUUID l - (command:params) = words SysConfig.uuid + where + gen [] = error $ "no output from " ++ command + gen (l:_) = toUUID l + (command:params) = words SysConfig.uuid {- Get current repository's UUID. -} getUUID :: Annex UUID @@ -54,19 +54,19 @@ getRepoUUID r = do updatecache u return u else return c - where - updatecache u = do - g <- gitRepo - when (g /= r) $ storeUUID cachekey u - cachekey = remoteConfig r "uuid" + where + updatecache u = do + g <- gitRepo + when (g /= r) $ storeUUID cachekey u + cachekey = remoteConfig r "uuid" removeRepoUUID :: Annex () removeRepoUUID = unsetConfig configkey getUncachedUUID :: Git.Repo -> UUID getUncachedUUID = toUUID . Git.Config.get key "" - where - (ConfigKey key) = configkey + where + (ConfigKey key) = configkey {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: Annex () diff --git a/Annex/Version.hs b/Annex/Version.hs index 00e574929..30ad957c3 100644 --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -26,9 +26,9 @@ versionField = annexConfig "version" getVersion :: Annex (Maybe Version) getVersion = handle <$> getConfig versionField "" - where - handle [] = Nothing - handle v = Just v + where + handle [] = Nothing + handle v = Just v setVersion :: Annex () setVersion = setConfig versionField defaultVersion @@ -41,6 +41,6 @@ checkVersion v | v `elem` supportedVersions = noop | v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade" | otherwise = err "Upgrade git-annex." - where - err msg = error $ "Repository version " ++ v ++ - " is not supported. " ++ msg + where + err msg = error $ "Repository version " ++ v ++ + " is not supported. " ++ msg |