summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-12-13 00:29:06 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-12-13 00:29:06 -0400
commitde6406afce6de0cf8a48bc2ecf9be1e7de93e40e (patch)
tree08705fab60c11d4073734a8c2500a88b1aab7852
parent3e55a8f164d67d5bd1ef86ae2f38fb2c6c3a51b2 (diff)
parent94554782894ec6c26da3b46312d5d1d16d596458 (diff)
Merge branch 'master' into desymlink
Conflicts: Annex/CatFile.hs Annex/Content.hs Git/LsFiles.hs Git/LsTree.hs
-rw-r--r--Annex/Branch.hs129
-rw-r--r--Annex/CatFile.hs10
-rw-r--r--Annex/CheckAttr.hs10
-rw-r--r--Annex/Content.hs190
-rw-r--r--Annex/Journal.hs20
-rw-r--r--Annex/LockPool.hs24
-rw-r--r--Annex/Perms.hs60
-rw-r--r--Annex/Queue.hs4
-rw-r--r--Annex/Ssh.hs96
-rw-r--r--Annex/UUID.hs22
-rw-r--r--Annex/Version.hs12
-rw-r--r--Build/OSXMkLibs.hs5
-rw-r--r--Git/AutoCorrect.hs50
-rw-r--r--Git/Branch.hs58
-rw-r--r--Git/CatFile.hs50
-rw-r--r--Git/CheckAttr.hs58
-rw-r--r--Git/Command.hs22
-rw-r--r--Git/Config.hs42
-rw-r--r--Git/Construct.hs236
-rw-r--r--Git/CurrentRepo.hs40
-rw-r--r--Git/HashObject.hs16
-rw-r--r--Git/Index.hs8
-rw-r--r--Git/LsFiles.hs6
-rw-r--r--Git/LsTree.hs16
-rw-r--r--Git/Queue.hs62
-rw-r--r--Git/Ref.hs70
-rw-r--r--Git/Sha.hs16
-rw-r--r--Git/UnionMerge.hs38
-rw-r--r--Git/UpdateIndex.hs16
-rw-r--r--Git/Url.hs22
-rw-r--r--Git/Version.hs20
-rw-r--r--Makefile19
-rw-r--r--Types/StandardGroups.hs2
-rw-r--r--Utility/Base64.hs2
-rw-r--r--Utility/CopyFile.hs12
-rw-r--r--Utility/DBus.hs16
-rw-r--r--Utility/Daemon.hs70
-rw-r--r--Utility/DataUnits.hs78
-rw-r--r--Utility/Directory.hs70
-rw-r--r--Utility/DiskFree.hs4
-rw-r--r--Utility/Dot.hs28
-rw-r--r--Utility/FileMode.hs16
-rw-r--r--Utility/Format.hs190
-rw-r--r--Utility/FreeDesktop.hs21
-rw-r--r--Utility/Gpg.hs66
-rw-r--r--Utility/HumanTime.hs14
-rw-r--r--Utility/INotify.hs194
-rw-r--r--Utility/JSONStream.hs8
-rw-r--r--Utility/Kqueue.hs196
-rw-r--r--Utility/LogFile.hs12
-rw-r--r--Utility/Lsof.hs72
-rw-r--r--Utility/Matcher.hs48
-rw-r--r--Utility/Misc.hs34
-rw-r--r--Utility/Mounts.hsc30
-rw-r--r--Utility/Network.hs5
-rw-r--r--Utility/NotificationBroadcaster.hs18
-rw-r--r--Utility/Parallel.hs20
-rw-r--r--Utility/Path.hs70
-rw-r--r--Utility/Percentage.hs16
-rw-r--r--Utility/Process.hs84
-rw-r--r--Utility/Rsync.hs86
-rw-r--r--Utility/SRV.hs38
-rw-r--r--Utility/SafeCommand.hs50
-rw-r--r--Utility/TSet.hs12
-rw-r--r--Utility/Tense.hs24
-rw-r--r--Utility/ThreadScheduler.hs10
-rw-r--r--Utility/Touch.hsc22
-rw-r--r--Utility/Url.hs84
-rw-r--r--Utility/UserInfo.hs8
-rw-r--r--Utility/Verifiable.hs4
-rw-r--r--Utility/WebApp.hs66
-rw-r--r--debian/changelog4
-rwxr-xr-xdebian/rules2
-rw-r--r--doc/assistant/release_notes.mdwn35
-rw-r--r--doc/bugs/OSX_app_issues.mdwn2
-rw-r--r--doc/bugs/OSX_app_issues/comment_14_5783a4716cd104e1f1c276aa0b9cb153._comment41
-rw-r--r--doc/bugs/OSX_app_issues/comment_15_56c7fcafc7dca8be28ebf9e37a8f6b71._comment23
-rw-r--r--doc/bugs/OSX_app_issues/old.mdwn1
-rw-r--r--doc/bugs/OSX_app_issues/old/comment_11_a30e69fed14b0809184ffe05358ab871._comment (renamed from doc/bugs/OSX_app_issues/comment_11_a30e69fed14b0809184ffe05358ab871._comment)0
-rw-r--r--doc/bugs/OSX_app_issues/old/comment_3_08613b2e2318680508483d204a43da76._comment (renamed from doc/bugs/OSX_app_issues/comment_3_08613b2e2318680508483d204a43da76._comment)0
-rw-r--r--doc/bugs/OSX_app_issues/old/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment (renamed from doc/bugs/OSX_app_issues/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment)0
-rw-r--r--doc/bugs/OSX_app_issues/old/comment_6_cea97dbbfb566a9fe463365ca4511119._comment (renamed from doc/bugs/OSX_app_issues/comment_6_cea97dbbfb566a9fe463365ca4511119._comment)0
-rw-r--r--doc/bugs/OSX_app_issues/old/comment_7_911f187d46890093a54859032ada2442._comment (renamed from doc/bugs/OSX_app_issues/comment_7_911f187d46890093a54859032ada2442._comment)0
-rw-r--r--doc/bugs/OSX_app_issues/old/comment_8_08b091a58106ca6050ac669579ed9ff4._comment (renamed from doc/bugs/OSX_app_issues/comment_8_08b091a58106ca6050ac669579ed9ff4._comment)0
-rw-r--r--doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn5
-rw-r--r--doc/bugs/git-annex_fix_not_noticing_file_renames.mdwn33
-rw-r--r--doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform.mdwn20
-rw-r--r--doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_1_20a6fe046111e9ae56fd4d9c9f41f536._comment8
-rw-r--r--doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_2_6fdc5f8b07908c6eda8a97690408f44e._comment45
-rw-r--r--doc/design/assistant.mdwn7
-rw-r--r--doc/design/assistant/blog/day_147__direct_mode/comment_1_0bd69532afce9dc04e3d88bfd0aed4b2._comment16
-rw-r--r--doc/design/assistant/blog/day_147__direct_mode/comment_2_3b26f0d081c3bf1037bb872d529ce825._comment8
-rw-r--r--doc/design/assistant/blog/day_149__rainy_day.mdwn15
-rw-r--r--doc/design/assistant/blog/day_150__12:12.mdwn53
-rw-r--r--doc/design/assistant/desymlink.mdwn4
-rw-r--r--doc/forum/How_to_set_up_two_assistants_with_one_shared_transfer_repository__63__/comment_4_bfbcc041db472f4808979e6b3d7c4be2._comment10
-rw-r--r--doc/forum/Managing_multiple_annexes_with_assistant__63__/comment_5_e94d33be83b45918d1a39d6e16fba4b4._comment8
-rw-r--r--doc/forum/gadu_-_git-annex_disk_usage/comment_4_1bcc94f9982c6cfd0888f3dba0f9221e._comment8
-rw-r--r--doc/forum/gadu_-_git-annex_disk_usage/comment_5_4365cd3031456fac1b563ee72984638e._comment18
-rw-r--r--doc/install/OSX/comment_4_bbe99673033e4c48c8bb3db24ee419f9._comment8
-rw-r--r--doc/news/version_3.20121017.mdwn4
-rw-r--r--doc/news/version_3.20121211.mdwn32
-rw-r--r--doc/preferred_content.mdwn2
-rw-r--r--doc/preferred_content/comment_4_384025b5fa23a3f175985a081438149f._comment8
-rw-r--r--doc/preferred_content/comment_5_f0a957e67297c4bb5a8778c11b3c9fd4._comment9
-rw-r--r--doc/scalability.mdwn6
-rw-r--r--git-annex.cabal2
-rwxr-xr-xstandalone/osx/git-annex.app/Contents/MacOS/runshell2
108 files changed, 2051 insertions, 1635 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 cde9d5170..161554f29 100644
--- a/Annex/CatFile.hs
+++ b/Annex/CatFile.hs
@@ -38,11 +38,11 @@ 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
{- From the Sha of a symlink back to the key. -}
catKey :: Sha -> Annex (Maybe Key)
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 980321721..5c902e8a9 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -79,20 +79,20 @@ inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
- is not in the process of being removed. -}
inAnnexSafe :: Key -> Annex (Maybe Bool)
inAnnexSafe = inAnnex' (maybe False id) (Just False) go
- where
- go f = liftIO $ openforlock f >>= check
- 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
+ go f = liftIO $ openforlock f >>= check
+ 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.) -}
@@ -100,25 +100,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
@@ -127,8 +127,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
{- Runs an action, passing it a temporary filename to get,
- and if the action succeeds, moves the temp file into
@@ -197,13 +197,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 key's content into .git/annex/objects/
-
@@ -313,12 +313,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/
-
@@ -371,19 +371,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.
-
@@ -396,9 +396,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
@@ -411,41 +411,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
@@ -454,11 +454,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. -}
@@ -468,5 +468,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
diff --git a/Build/OSXMkLibs.hs b/Build/OSXMkLibs.hs
index a3448b563..6e0670d79 100644
--- a/Build/OSXMkLibs.hs
+++ b/Build/OSXMkLibs.hs
@@ -62,11 +62,12 @@ otool appbase libmap = do
files <- filterM doesFileExist =<< dirContentsRecursive appbase
process [] files libmap
where
- unprocessed s = not ("@executable_path" `isInfixOf` s)
+ want s = not ("@executable_path" `isInfixOf` s)
+ && not (".framework" `isInfixOf` s)
process c [] m = return (nub $ concat c, m)
process c (file:rest) m = do
_ <- boolSystem "chmod" [Param "755", File file]
- libs <- filter unprocessed . parseOtool
+ libs <- filter want . parseOtool
<$> readProcess "otool" ["-L", file]
m' <- install_name_tool file libs m
process (libs:c) rest m'
diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs
index a1ef14779..325632de9 100644
--- a/Git/AutoCorrect.hs
+++ b/Git/AutoCorrect.hs
@@ -33,11 +33,11 @@ similarityFloor = 7
fuzzymatches :: String -> (c -> String) -> [c] -> [c]
fuzzymatches input showchoice choices = fst $ unzip $
sortBy comparecost $ filter similarEnough $ zip choices costs
- where
- distance = restrictedDamerauLevenshteinDistance gitEditCosts input
- costs = map (distance . showchoice) choices
- comparecost a b = compare (snd a) (snd b)
- similarEnough (_, cst) = cst < similarityFloor
+ where
+ distance = restrictedDamerauLevenshteinDistance gitEditCosts input
+ costs = map (distance . showchoice) choices
+ comparecost a b = compare (snd a) (snd b)
+ similarEnough (_, cst) = cst < similarityFloor
{- Takes action based on git's autocorrect configuration, in preparation for
- an autocorrected command being run. -}
@@ -49,23 +49,23 @@ prepare input showmatch matches r =
| n < 0 -> warn
| otherwise -> sleep n
Nothing -> list
- where
- list = error $ unlines $
- [ "Unknown command '" ++ input ++ "'"
- , ""
- , "Did you mean one of these?"
- ] ++ map (\m -> "\t" ++ showmatch m) matches
- warn =
- hPutStr stderr $ unlines
- [ "WARNING: You called a command named '" ++
- input ++ "', which does not exist."
- , "Continuing under the assumption that you meant '" ++
- showmatch (Prelude.head matches) ++ "'"
- ]
- sleep n = do
- warn
- hPutStrLn stderr $ unwords
- [ "in"
- , show (fromIntegral n / 10 :: Float)
- , "seconds automatically..."]
- threadDelay (n * 100000) -- deciseconds to microseconds
+ where
+ list = error $ unlines $
+ [ "Unknown command '" ++ input ++ "'"
+ , ""
+ , "Did you mean one of these?"
+ ] ++ map (\m -> "\t" ++ showmatch m) matches
+ warn =
+ hPutStr stderr $ unlines
+ [ "WARNING: You called a command named '" ++
+ input ++ "', which does not exist."
+ , "Continuing under the assumption that you meant '" ++
+ showmatch (Prelude.head matches) ++ "'"
+ ]
+ sleep n = do
+ warn
+ hPutStrLn stderr $ unwords
+ [ "in"
+ , show (fromIntegral n / 10 :: Float)
+ , "seconds automatically..."]
+ threadDelay (n * 100000) -- deciseconds to microseconds
diff --git a/Git/Branch.hs b/Git/Branch.hs
index 3407845d1..736c4c6e8 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -36,10 +36,10 @@ current r = do
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
currentUnsafe r = parse . firstLine
<$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r
- where
- parse l
- | null l = Nothing
- | otherwise = Just $ Git.Ref l
+ where
+ parse l
+ | null l = Nothing
+ | otherwise = Just $ Git.Ref l
{- Checks if the second branch has any commits not present on the first
- branch. -}
@@ -47,12 +47,12 @@ changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo
| origbranch == newbranch = return False
| otherwise = not . null <$> diffs
- where
- diffs = pipeReadStrict
- [ Param "log"
- , Param (show origbranch ++ ".." ++ show newbranch)
- , Params "--oneline -n1"
- ] repo
+ where
+ diffs = pipeReadStrict
+ [ Param "log"
+ , Param (show origbranch ++ ".." ++ show newbranch)
+ , Params "--oneline -n1"
+ ] repo
{- Given a set of refs that are all known to have commits not
- on the branch, tries to update the branch by a fast-forward.
@@ -70,23 +70,23 @@ fastForward branch (first:rest) repo =
( no_ff
, maybe no_ff do_ff =<< findbest first rest
)
- where
- no_ff = return False
- do_ff to = do
- run "update-ref"
- [Param $ show branch, Param $ show to] repo
- return True
- findbest c [] = return $ Just c
- findbest c (r:rs)
- | c == r = findbest c rs
- | otherwise = do
- better <- changed c r repo
- worse <- changed r c repo
- case (better, worse) of
- (True, True) -> return Nothing -- divergent fail
- (True, False) -> findbest r rs -- better
- (False, True) -> findbest c rs -- worse
- (False, False) -> findbest c rs -- same
+ where
+ no_ff = return False
+ do_ff to = do
+ run "update-ref"
+ [Param $ show branch, Param $ show to] repo
+ return True
+ findbest c [] = return $ Just c
+ findbest c (r:rs)
+ | c == r = findbest c rs
+ | otherwise = do
+ better <- changed c r repo
+ worse <- changed r c repo
+ case (better, worse) of
+ (True, True) -> return Nothing -- divergent fail
+ (True, False) -> findbest r rs -- better
+ (False, True) -> findbest c rs -- worse
+ (False, False) -> findbest c rs -- same
{- Commits the index into the specified branch (or other ref),
- with the specified parent refs, and returns the committed sha -}
@@ -99,5 +99,5 @@ commit message branch parentrefs repo = do
message repo
run "update-ref" [Param $ show branch, Param $ show sha] repo
return sha
- where
- ps = concatMap (\r -> ["-p", show r]) parentrefs
+ where
+ ps = concatMap (\r -> ["-p", show r]) parentrefs
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index cd531e68f..704724211 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -48,28 +48,28 @@ catObject h object = maybe L.empty fst <$> catObjectDetails h object
{- Gets both the content of an object, and its Sha. -}
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))
catObjectDetails h object = CoProcess.query h send receive
- where
- send to = do
- fileEncoding to
- hPutStrLn to $ show object
- receive from = do
- fileEncoding from
- header <- hGetLine from
- case words header of
- [sha, objtype, size]
- | length sha == shaSize &&
- isJust (readObjectType objtype) ->
- case reads size of
- [(bytes, "")] -> readcontent bytes from sha
- _ -> dne
- | otherwise -> dne
- _
- | header == show object ++ " missing" -> dne
- | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
- readcontent bytes from sha = do
- content <- S.hGet from bytes
- c <- hGetChar from
- when (c /= '\n') $
- error "missing newline from git cat-file"
- return $ Just (L.fromChunks [content], Ref sha)
- dne = return Nothing
+ where
+ send to = do
+ fileEncoding to
+ hPutStrLn to $ show object
+ receive from = do
+ fileEncoding from
+ header <- hGetLine from
+ case words header of
+ [sha, objtype, size]
+ | length sha == shaSize &&
+ isJust (readObjectType objtype) ->
+ case reads size of
+ [(bytes, "")] -> readcontent bytes from sha
+ _ -> dne
+ | otherwise -> dne
+ _
+ | header == show object ++ " missing" -> dne
+ | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
+ readcontent bytes from sha = do
+ content <- S.hGet from bytes
+ c <- hGetChar from
+ when (c /= '\n') $
+ error "missing newline from git cat-file"
+ return $ Just (L.fromChunks [content], Ref sha)
+ dne = return Nothing
diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs
index 13a7287b1..f9279d460 100644
--- a/Git/CheckAttr.hs
+++ b/Git/CheckAttr.hs
@@ -24,12 +24,12 @@ checkAttrStart attrs repo = do
cwd <- getCurrentDirectory
h <- gitCoProcessStart params repo
return (h, attrs, cwd)
- where
- params =
- [ Param "check-attr"
- , Params "-z --stdin"
- ] ++ map Param attrs ++
- [ Param "--" ]
+ where
+ params =
+ [ Param "check-attr"
+ , Params "-z --stdin"
+ ] ++ map Param attrs ++
+ [ Param "--" ]
checkAttrStop :: CheckAttrHandle -> IO ()
checkAttrStop (h, _, _) = CoProcess.stop h
@@ -42,26 +42,26 @@ checkAttr (h, attrs, cwd) want file = do
case vals of
[v] -> return v
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
- where
- send to = do
- fileEncoding to
- hPutStr to $ file' ++ "\0"
- receive from = forM attrs $ \attr -> do
- fileEncoding from
- l <- hGetLine from
- return (attr, attrvalue attr l)
- {- Before git 1.7.7, git check-attr worked best with
- - absolute filenames; using them worked around some bugs
- - with relative filenames.
- -
- - With newer git, git check-attr chokes on some absolute
- - filenames, and the bugs that necessitated them were fixed,
- - so use relative filenames. -}
- oldgit = Git.Version.older "1.7.7"
- file'
- | oldgit = absPathFrom cwd file
- | otherwise = relPathDirToFile cwd $ absPathFrom cwd file
- attrvalue attr l = end bits !! 0
- where
- bits = split sep l
- sep = ": " ++ attr ++ ": "
+ where
+ send to = do
+ fileEncoding to
+ hPutStr to $ file' ++ "\0"
+ receive from = forM attrs $ \attr -> do
+ fileEncoding from
+ l <- hGetLine from
+ return (attr, attrvalue attr l)
+ {- Before git 1.7.7, git check-attr worked best with
+ - absolute filenames; using them worked around some bugs
+ - with relative filenames.
+ -
+ - With newer git, git check-attr chokes on some absolute
+ - filenames, and the bugs that necessitated them were fixed,
+ - so use relative filenames. -}
+ oldgit = Git.Version.older "1.7.7"
+ file'
+ | oldgit = absPathFrom cwd file
+ | otherwise = relPathDirToFile cwd $ absPathFrom cwd file
+ attrvalue attr l = end bits !! 0
+ where
+ bits = split sep l
+ sep = ": " ++ attr ++ ": "
diff --git a/Git/Command.hs b/Git/Command.hs
index 37df44713..88fed56e8 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -17,11 +17,11 @@ import qualified Utility.CoProcess as CoProcess
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params
- where
- setdir = Param $ "--git-dir=" ++ gitdir l
- settree = case worktree l of
- Nothing -> []
- Just t -> [Param $ "--work-tree=" ++ t]
+ where
+ setdir = Param $ "--git-dir=" ++ gitdir l
+ settree = case worktree l of
+ Nothing -> []
+ Just t -> [Param $ "--work-tree=" ++ t]
gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -}
@@ -49,8 +49,8 @@ pipeReadLazy params repo = assertLocal repo $ do
fileEncoding h
c <- hGetContents h
return (c, checkSuccessProcess pid)
- where
- p = gitCreateProcess params repo
+ where
+ p = gitCreateProcess params repo
{- Runs a git subcommand, and returns its output, strictly.
-
@@ -63,8 +63,8 @@ pipeReadStrict params repo = assertLocal repo $
output <- hGetContentsStrict h
hClose h
return output
- where
- p = gitCreateProcess params repo
+ where
+ p = gitCreateProcess params repo
{- Runs a git subcommand, feeding it input, and returning its output,
- which is expected to be fairly small, since it's all read into memory
@@ -85,8 +85,8 @@ pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)
pipeNullSplit params repo = do
(s, cleanup) <- pipeReadLazy params repo
return (filter (not . null) $ split sep s, cleanup)
- where
- sep = "\0"
+ where
+ sep = "\0"
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]
diff --git a/Git/Config.hs b/Git/Config.hs
index 0d6d67fc0..52a9dafb5 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -48,18 +48,18 @@ reRead r = read' $ r
-}
read' :: Repo -> IO Repo
read' repo = go repo
- where
- go Repo { location = Local { gitdir = d } } = git_config d
- go Repo { location = LocalUnknown d } = git_config d
- go _ = assertLocal repo $ error "internal"
- git_config d = withHandle StdoutHandle createProcessSuccess p $
- hRead repo
- where
- params = ["config", "--null", "--list"]
- p = (proc "git" params)
- { cwd = Just d
- , env = gitEnv repo
- }
+ where
+ go Repo { location = Local { gitdir = d } } = git_config d
+ go Repo { location = LocalUnknown d } = git_config d
+ go _ = assertLocal repo $ error "internal"
+ git_config d = withHandle StdoutHandle createProcessSuccess p $
+ hRead repo
+ where
+ params = ["config", "--null", "--list"]
+ p = (proc "git" params)
+ { cwd = Just d
+ , env = gitEnv repo
+ }
{- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo)
@@ -73,9 +73,9 @@ global = do
return $ Just repo'
, return Nothing
)
- where
- params = ["config", "--null", "--list", "--global"]
- p = (proc "git" params)
+ where
+ params = ["config", "--null", "--list", "--global"]
+ p = (proc "git" params)
{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo
@@ -133,10 +133,10 @@ parse s
| all ('=' `elem`) (take 1 ls) = sep '=' ls
-- --null --list output separates keys from values with newlines
| otherwise = sep '\n' $ split "\0" s
- where
- ls = lines s
- sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
- map (separate (== c))
+ where
+ ls = lines s
+ sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
+ map (separate (== c))
{- Checks if a string from git config is a true value. -}
isTrue :: String -> Maybe Bool
@@ -144,8 +144,8 @@ isTrue s
| s' == "true" = Just True
| s' == "false" = Just False
| otherwise = Nothing
- where
- s' = map toLower s
+ where
+ s' = map toLower s
isBare :: Repo -> Bool
isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r
diff --git a/Git/Construct.hs b/Git/Construct.hs
index e367c096b..4f6a63d86 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -33,15 +33,15 @@ import Utility.UserInfo
- directory. -}
fromCwd :: IO Repo
fromCwd = getCurrentDirectory >>= seekUp checkForRepo
- where
- norepo = error "Not in a git repository."
- seekUp check dir = do
- r <- check dir
- case r of
- Nothing -> case parentDir dir of
- "" -> norepo
- d -> seekUp check d
- Just loc -> newFrom loc
+ where
+ norepo = error "Not in a git repository."
+ seekUp check dir = do
+ r <- check dir
+ case r of
+ Nothing -> case parentDir dir of
+ "" -> norepo
+ d -> seekUp check d
+ Just loc -> newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo
@@ -55,21 +55,21 @@ fromAbsPath dir
ifM (doesDirectoryExist dir') ( ret dir' , hunt )
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
- where
- ret = newFrom . LocalUnknown
- {- Git always looks for "dir.git" in preference to
- - to "dir", even if dir ends in a "/". -}
- canondir = dropTrailingPathSeparator dir
- dir' = canondir ++ ".git"
- {- When dir == "foo/.git", git looks for "foo/.git/.git",
- - and failing that, uses "foo" as the repository. -}
- hunt
- | "/.git" `isSuffixOf` canondir =
- ifM (doesDirectoryExist $ dir </> ".git")
- ( ret dir
- , ret $ takeDirectory canondir
- )
- | otherwise = ret dir
+ where
+ ret = newFrom . LocalUnknown
+ {- Git always looks for "dir.git" in preference to
+ - to "dir", even if dir ends in a "/". -}
+ canondir = dropTrailingPathSeparator dir
+ dir' = canondir ++ ".git"
+ {- When dir == "foo/.git", git looks for "foo/.git/.git",
+ - and failing that, uses "foo" as the repository. -}
+ hunt
+ | "/.git" `isSuffixOf` canondir =
+ ifM (doesDirectoryExist $ dir </> ".git")
+ ( ret dir
+ , ret $ takeDirectory canondir
+ )
+ | otherwise = ret dir
{- Remote Repo constructor. Throws exception on invalid url.
-
@@ -85,9 +85,9 @@ fromUrlStrict :: String -> IO Repo
fromUrlStrict url
| startswith "file://" url = fromAbsPath $ uriPath u
| otherwise = newFrom $ Url u
- where
- u = fromMaybe bad $ parseURI url
- bad = error $ "bad url " ++ url
+ where
+ u = fromMaybe bad $ parseURI url
+ bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -}
fromUnknown :: IO Repo
@@ -100,21 +100,23 @@ localToUrl reference r
| not $ repoIsUrl reference = error "internal error; reference repo not url"
| repoIsUrl r = r
| otherwise = r { location = Url $ fromJust $ parseURI absurl }
- where
- absurl =
- Url.scheme reference ++ "//" ++
- Url.authority reference ++
- repoPath r
+ where
+ absurl = concat
+ [ Url.scheme reference
+ , "//"
+ , Url.authority reference
+ , repoPath r
+ ]
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
fromRemotes :: Repo -> IO [Repo]
fromRemotes repo = mapM construct remotepairs
- where
- filterconfig f = filter f $ M.toList $ config repo
- filterkeys f = filterconfig (\(k,_) -> f k)
- remotepairs = filterkeys isremote
- isremote k = startswith "remote." k && endswith ".url" k
- construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
+ where
+ filterconfig f = filter f $ M.toList $ config repo
+ filterkeys f = filterconfig (\(k,_) -> f k)
+ remotepairs = filterkeys isremote
+ isremote k = startswith "remote." k && endswith ".url" k
+ construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
{- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo
@@ -126,50 +128,48 @@ remoteNamed n constructor = do
"remote.foo.url". -}
remoteNamedFromKey :: String -> IO Repo -> IO Repo
remoteNamedFromKey k = remoteNamed basename
- where
- basename = join "." $ reverse $ drop 1 $
- reverse $ drop 1 $ split "." k
+ where
+ basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k
{- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -}
fromRemoteLocation :: String -> Repo -> IO Repo
fromRemoteLocation s repo = gen $ calcloc s
- where
- gen v
- | scpstyle v = fromUrl $ scptourl v
- | urlstyle v = fromUrl v
- | otherwise = fromRemotePath v repo
- -- insteadof config can rewrite remote location
- calcloc l
- | null insteadofs = l
- | otherwise = replacement ++ drop (length bestvalue) l
- where
- replacement = drop (length prefix) $
- take (length bestkey - length suffix) bestkey
- (bestkey, bestvalue) = maximumBy longestvalue insteadofs
- longestvalue (_, a) (_, b) = compare b a
- insteadofs = filterconfig $ \(k, v) ->
- startswith prefix k &&
- endswith suffix k &&
- startswith v l
- filterconfig f = filter f $
- concatMap splitconfigs $
- M.toList $ fullconfig repo
- splitconfigs (k, vs) = map (\v -> (k, v)) vs
- (prefix, suffix) = ("url." , ".insteadof")
- urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
- -- git remotes can be written scp style -- [user@]host:dir
- -- but foo::bar is a git-remote-helper location instead
- scpstyle v = ":" `isInfixOf` v
- && not ("//" `isInfixOf` v)
- && not ("::" `isInfixOf` v)
- scptourl v = "ssh://" ++ host ++ slash dir
- where
- (host, dir) = separate (== ':') v
- slash d | d == "" = "/~/" ++ d
- | "/" `isPrefixOf` d = d
- | "~" `isPrefixOf` d = '/':d
- | otherwise = "/~/" ++ d
+ where
+ gen v
+ | scpstyle v = fromUrl $ scptourl v
+ | urlstyle v = fromUrl v
+ | otherwise = fromRemotePath v repo
+ -- insteadof config can rewrite remote location
+ calcloc l
+ | null insteadofs = l
+ | otherwise = replacement ++ drop (length bestvalue) l
+ where
+ replacement = drop (length prefix) $
+ take (length bestkey - length suffix) bestkey
+ (bestkey, bestvalue) = maximumBy longestvalue insteadofs
+ longestvalue (_, a) (_, b) = compare b a
+ insteadofs = filterconfig $ \(k, v) ->
+ startswith prefix k &&
+ endswith suffix k &&
+ startswith v l
+ filterconfig f = filter f $
+ concatMap splitconfigs $ M.toList $ fullconfig repo
+ splitconfigs (k, vs) = map (\v -> (k, v)) vs
+ (prefix, suffix) = ("url." , ".insteadof")
+ urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
+ -- git remotes can be written scp style -- [user@]host:dir
+ -- but foo::bar is a git-remote-helper location instead
+ scpstyle v = ":" `isInfixOf` v
+ && not ("//" `isInfixOf` v)
+ && not ("::" `isInfixOf` v)
+ scptourl v = "ssh://" ++ host ++ slash dir
+ where
+ (host, dir) = separate (== ':') v
+ slash d | d == "" = "/~/" ++ d
+ | "/" `isPrefixOf` d = d
+ | "~" `isPrefixOf` d = '/':d
+ | otherwise = "/~/" ++ d
{- Constructs a Repo from the path specified in the git remotes of
- another Repo. -}
@@ -191,25 +191,25 @@ repoAbsPath d = do
expandTilde :: FilePath -> IO FilePath
expandTilde = expandt True
- where
- expandt _ [] = return ""
- expandt _ ('/':cs) = do
- v <- expandt True cs
- return ('/':v)
- expandt True ('~':'/':cs) = do
- h <- myHomeDir
- return $ h </> cs
- expandt True ('~':cs) = do
- let (name, rest) = findname "" cs
- u <- getUserEntryForName name
- return $ homeDirectory u </> rest
- expandt _ (c:cs) = do
- v <- expandt False cs
- return (c:v)
- findname n [] = (n, "")
- findname n (c:cs)
- | c == '/' = (n, cs)
- | otherwise = findname (n++[c]) cs
+ where
+ expandt _ [] = return ""
+ expandt _ ('/':cs) = do
+ v <- expandt True cs
+ return ('/':v)
+ expandt True ('~':'/':cs) = do
+ h <- myHomeDir
+ return $ h </> cs
+ expandt True ('~':cs) = do
+ let (name, rest) = findname "" cs
+ u <- getUserEntryForName name
+ return $ homeDirectory u </> rest
+ expandt _ (c:cs) = do
+ v <- expandt False cs
+ return (c:v)
+ findname n [] = (n, "")
+ findname n (c:cs)
+ | c == '/' = (n, cs)
+ | otherwise = findname (n++[c]) cs
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
checkForRepo dir =
@@ -217,28 +217,28 @@ checkForRepo dir =
check gitDirFile $
check isBareRepo $
return Nothing
- where
- check test cont = maybe cont (return . Just) =<< test
- checkdir c = ifM c
- ( return $ Just $ LocalUnknown dir
- , return Nothing
- )
- isRepo = checkdir $ gitSignature $ ".git" </> "config"
- isBareRepo = checkdir $ gitSignature "config"
- <&&> doesDirectoryExist (dir </> "objects")
- gitDirFile = do
- c <- firstLine <$>
- catchDefaultIO "" (readFile $ dir </> ".git")
- return $ if gitdirprefix `isPrefixOf` c
- then Just $ Local
- { gitdir = absPathFrom dir $
- drop (length gitdirprefix) c
- , worktree = Just dir
- }
- else Nothing
- where
- gitdirprefix = "gitdir: "
- gitSignature file = doesFileExist $ dir </> file
+ where
+ check test cont = maybe cont (return . Just) =<< test
+ checkdir c = ifM c
+ ( return $ Just $ LocalUnknown dir
+ , return Nothing
+ )
+ isRepo = checkdir $ gitSignature $ ".git" </> "config"
+ isBareRepo = checkdir $ gitSignature "config"
+ <&&> doesDirectoryExist (dir </> "objects")
+ gitDirFile = do
+ c <- firstLine <$>
+ catchDefaultIO "" (readFile $ dir </> ".git")
+ return $ if gitdirprefix `isPrefixOf` c
+ then Just $ Local
+ { gitdir = absPathFrom dir $
+ drop (length gitdirprefix) c
+ , worktree = Just dir
+ }
+ else Nothing
+ where
+ gitdirprefix = "gitdir: "
+ gitSignature file = doesFileExist $ dir </> file
newFrom :: RepoLocation -> IO Repo
newFrom l = return Repo
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 29bb28177..e309bf2f6 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -39,23 +39,23 @@ get = do
unless (d `dirContains` cwd) $
changeWorkingDirectory d
return $ addworktree wt r
- where
- pathenv s = do
- v <- getEnv s
- case v of
- Just d -> do
- unsetEnv s
- Just <$> absPath d
- Nothing -> return Nothing
- configure Nothing r = Git.Config.read r
- configure (Just d) r = do
- r' <- Git.Config.read r
- -- Let GIT_DIR override the default gitdir.
- absd <- absPath d
- return $ changelocation r' $ Local
- { gitdir = absd
- , worktree = worktree (location r')
- }
- addworktree w r = changelocation r $
- Local { gitdir = gitdir (location r), worktree = w }
- changelocation r l = r { location = l }
+ where
+ pathenv s = do
+ v <- getEnv s
+ case v of
+ Just d -> do
+ unsetEnv s
+ Just <$> absPath d
+ Nothing -> return Nothing
+ configure Nothing r = Git.Config.read r
+ configure (Just d) r = do
+ r' <- Git.Config.read r
+ -- Let GIT_DIR override the default gitdir.
+ absd <- absPath d
+ return $ changelocation r' $ Local
+ { gitdir = absd
+ , worktree = worktree (location r')
+ }
+ addworktree w r = changelocation r $
+ Local { gitdir = gitdir (location r), worktree = w }
+ changelocation r l = r { location = l }
diff --git a/Git/HashObject.hs b/Git/HashObject.hs
index e048ce8e5..b4a32ef1c 100644
--- a/Git/HashObject.hs
+++ b/Git/HashObject.hs
@@ -29,17 +29,17 @@ hashObjectStop = CoProcess.stop
{- Injects a file into git, returning the Sha of the object. -}
hashFile :: HashObjectHandle -> FilePath -> IO Sha
hashFile h file = CoProcess.query h send receive
- where
- send to = do
- fileEncoding to
- hPutStrLn to file
- receive from = getSha "hash-object" $ hGetLine from
+ where
+ send to = do
+ fileEncoding to
+ hPutStrLn to file
+ receive from = getSha "hash-object" $ hGetLine from
{- Injects some content into git, returning its Sha. -}
hashObject :: ObjectType -> String -> Repo -> IO Sha
hashObject objtype content repo = getSha subcmd $ do
s <- pipeWriteRead (map Param params) content repo
return s
- where
- subcmd = "hash-object"
- params = [subcmd, "-t", show objtype, "-w", "--stdin"]
+ where
+ subcmd = "hash-object"
+ params = [subcmd, "-t", show objtype, "-w", "--stdin"]
diff --git a/Git/Index.hs b/Git/Index.hs
index d6fa4ee6c..80196ef78 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -21,7 +21,7 @@ override index = do
res <- getEnv var
setEnv var index True
return $ reset res
- where
- var = "GIT_INDEX_FILE"
- reset (Just v) = setEnv var v True
- reset _ = unsetEnv var
+ where
+ var = "GIT_INDEX_FILE"
+ reset (Just v) = setEnv var v True
+ reset _ = unsetEnv var
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 45c830cd6..45e105a3b 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -69,6 +69,12 @@ stagedDetails l repo = do
where
(metadata, file) = separate (== '\t') s
+{- Returns a list of files that have unstaged changes. -}
+changedUnstaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
+changedUnstaged l = pipeNullSplit params
+ where
+ params = 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. -}
typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index 373bf0006..c61ae7fab 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -48,11 +48,11 @@ parseLsTree l = TreeItem
, sha = s
, file = Git.Filename.decode f
}
- where
- -- l = <mode> SP <type> SP <sha> TAB <file>
- -- All fields are fixed, so we can pull them out of
- -- specific positions in the line.
- (m, past_m) = splitAt 7 l
- (t, past_t) = splitAt 4 past_m
- (s, past_s) = splitAt shaSize $ Prelude.tail past_t
- f = Prelude.tail past_s
+ where
+ -- l = <mode> SP <type> SP <sha> TAB <file>
+ -- All fields are fixed, so we can pull them out of
+ -- specific positions in the line.
+ (m, past_m) = splitAt 7 l
+ (t, past_t) = splitAt 4 past_m
+ (s, past_s) = splitAt shaSize $ Prelude.tail past_t
+ f = Prelude.tail past_s
diff --git a/Git/Queue.hs b/Git/Queue.hs
index 9f7a44882..712d476cd 100644
--- a/Git/Queue.hs
+++ b/Git/Queue.hs
@@ -86,30 +86,30 @@ new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
addCommand subcommand params files q repo =
updateQueue action different (length newfiles) q repo
- where
- key = actionKey action
- action = CommandAction
- { getSubcommand = subcommand
- , getParams = params
- , getFiles = newfiles
- }
- newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)
+ where
+ key = actionKey action
+ action = CommandAction
+ { getSubcommand = subcommand
+ , getParams = params
+ , getFiles = newfiles
+ }
+ newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)
- different (CommandAction { getSubcommand = s }) = s /= subcommand
- different _ = True
+ different (CommandAction { getSubcommand = s }) = s /= subcommand
+ different _ = True
{- Adds an update-index streamer to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
addUpdateIndex streamer q repo =
updateQueue action different 1 q repo
- where
- key = actionKey action
- -- the list is built in reverse order
- action = UpdateIndexAction $ streamer : streamers
- streamers = maybe [] getStreamers $ M.lookup key $ items q
+ where
+ key = actionKey action
+ -- the list is built in reverse order
+ action = UpdateIndexAction $ streamer : streamers
+ streamers = maybe [] getStreamers $ M.lookup key $ items q
- different (UpdateIndexAction _) = False
- different _ = True
+ different (UpdateIndexAction _) = False
+ different _ = True
{- Updates or adds an action in the queue. If the queue already contains a
- different action, it will be flushed; this is to ensure that conflicting
@@ -118,15 +118,15 @@ updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue
updateQueue !action different sizeincrease q repo
| null (filter different (M.elems (items q))) = return $ go q
| otherwise = go <$> flush q repo
- where
- go q' = newq
- where
- !newq = q'
- { size = newsize
- , items = newitems
- }
- !newsize = size q' + sizeincrease
- !newitems = M.insertWith' const (actionKey action) action (items q')
+ where
+ go q' = newq
+ where
+ !newq = q'
+ { size = newsize
+ , items = newitems
+ }
+ !newsize = size q' + sizeincrease
+ !newitems = M.insertWith' const (actionKey action) action (items q')
{- Is a queue large enough that it should be flushed? -}
full :: Queue -> Bool
@@ -153,8 +153,8 @@ runAction repo action@(CommandAction {}) =
fileEncoding h
hPutStr h $ join "\0" $ getFiles action
hClose h
- where
- p = (proc "xargs" params) { env = gitEnv repo }
- params = "-0":"git":baseparams
- baseparams = toCommand $ gitCommandLine
- (Param (getSubcommand action):getParams action) repo
+ where
+ p = (proc "xargs" params) { env = gitEnv repo }
+ params = "-0":"git":baseparams
+ baseparams = toCommand $ gitCommandLine
+ (Param (getSubcommand action):getParams action) repo
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 6fec46c22..02adf0547 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -21,10 +21,10 @@ describe = show . base
- Converts such a fully qualified ref into a base ref (eg: master). -}
base :: Ref -> Ref
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
- where
- remove prefix s
- | prefix `isPrefixOf` s = drop (length prefix) s
- | otherwise = s
+ where
+ remove prefix s
+ | prefix `isPrefixOf` s = drop (length prefix) s
+ | otherwise = s
{- Given a directory such as "refs/remotes/origin", and a ref such as
- refs/heads/master, yields a version of that ref under the directory,
@@ -40,51 +40,51 @@ exists ref = runBool "show-ref"
{- Get the sha of a fully qualified git ref, if it exists. -}
sha :: Branch -> Repo -> IO (Maybe Sha)
sha branch repo = process <$> showref repo
- where
- showref = pipeReadStrict [Param "show-ref",
- Param "--hash", -- get the hash
- Param $ show branch]
- process [] = Nothing
- process s = Just $ Ref $ firstLine s
+ where
+ showref = pipeReadStrict [Param "show-ref",
+ Param "--hash", -- get the hash
+ Param $ show branch]
+ process [] = Nothing
+ process s = Just $ Ref $ firstLine s
{- List of (refs, branches) matching a given ref spec. -}
matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = map gen . lines <$>
pipeReadStrict [Param "show-ref", Param $ show ref] repo
- where
- gen l = let (r, b) = separate (== ' ') l in
- (Ref r, Ref b)
+ where
+ gen l = let (r, b) = separate (== ' ') l
+ in (Ref r, Ref b)
{- List of (refs, branches) matching a given ref spec.
- Duplicate refs are filtered out. -}
matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]
matchingUniq ref repo = nubBy uniqref <$> matching ref repo
- where
- uniqref (a, _) (b, _) = a == b
+ where
+ uniqref (a, _) (b, _) = a == b
{- Checks if a String is a legal git ref name.
-
- The rules for this are complex; see git-check-ref-format(1) -}
legal :: Bool -> String -> Bool
legal allowonelevel s = all (== False) illegal
- where
- illegal =
- [ any ("." `isPrefixOf`) pathbits
- , any (".lock" `isSuffixOf`) pathbits
- , not allowonelevel && length pathbits < 2
- , contains ".."
- , any (\c -> contains [c]) illegalchars
- , begins "/"
- , ends "/"
- , contains "//"
- , ends "."
- , contains "@{"
- , null s
- ]
- contains v = v `isInfixOf` s
- ends v = v `isSuffixOf` s
- begins v = v `isPrefixOf` s
+ where
+ illegal =
+ [ any ("." `isPrefixOf`) pathbits
+ , any (".lock" `isSuffixOf`) pathbits
+ , not allowonelevel && length pathbits < 2
+ , contains ".."
+ , any (\c -> contains [c]) illegalchars
+ , begins "/"
+ , ends "/"
+ , contains "//"
+ , ends "."
+ , contains "@{"
+ , null s
+ ]
+ contains v = v `isInfixOf` s
+ ends v = v `isSuffixOf` s
+ begins v = v `isPrefixOf` s
- pathbits = split "/" s
- illegalchars = " ~^:?*[\\" ++ controlchars
- controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
+ pathbits = split "/" s
+ illegalchars = " ~^:?*[\\" ++ controlchars
+ controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
diff --git a/Git/Sha.hs b/Git/Sha.hs
index 2a01ede83..e62b29dab 100644
--- a/Git/Sha.hs
+++ b/Git/Sha.hs
@@ -14,8 +14,8 @@ import Git.Types
any trailing newline, returning the sha. -}
getSha :: String -> IO String -> IO Sha
getSha subcommand a = maybe bad return =<< extractSha <$> a
- where
- bad = error $ "failed to read sha from git " ++ subcommand
+ where
+ bad = error $ "failed to read sha from git " ++ subcommand
{- Extracts the Sha from a string. There can be a trailing newline after
- it, but nothing else. -}
@@ -24,12 +24,12 @@ extractSha s
| len == shaSize = val s
| len == shaSize + 1 && length s' == shaSize = val s'
| otherwise = Nothing
- where
- len = length s
- s' = firstLine s
- val v
- | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
- | otherwise = Nothing
+ where
+ len = length s
+ s' = firstLine s
+ val v
+ | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
+ | otherwise = Nothing
{- Size of a git sha. -}
shaSize :: Int
diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs
index 55eff0f1e..05d512df3 100644
--- a/Git/UnionMerge.hs
+++ b/Git/UnionMerge.hs
@@ -62,11 +62,11 @@ doMerge ch differ repo streamer = do
(diff, cleanup) <- pipeNullSplit (map Param differ) repo
go diff
void $ cleanup
- where
- go [] = noop
- go (info:file:rest) = mergeFile info file ch repo >>=
- maybe (go rest) (\l -> streamer l >> go rest)
- go (_:[]) = error $ "parse error " ++ show differ
+ where
+ go [] = noop
+ go (info:file:rest) = mergeFile info file ch repo >>=
+ maybe (go rest) (\l -> streamer l >> go rest)
+ go (_:[]) = error $ "parse error " ++ show differ
{- Given an info line from a git raw diff, and the filename, generates
- a line suitable for update-index that union merges the two sides of the
@@ -78,16 +78,16 @@ mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of
shas -> use
=<< either return (\s -> hashObject BlobObject (unlines s) repo)
=<< calcMerge . zip shas <$> mapM getcontents shas
- where
- [_colonmode, _bmode, asha, bsha, _status] = words info
- use sha = return $ Just $
- updateIndexLine sha FileBlob $ asTopFilePath file
- -- We don't know how the file is encoded, but need to
- -- split it into lines to union merge. Using the
- -- FileSystemEncoding for this is a hack, but ensures there
- -- are no decoding errors. Note that this works because
- -- hashObject sets fileEncoding on its write handle.
- getcontents s = lines . encodeW8 . L.unpack <$> catObject h s
+ where
+ [_colonmode, _bmode, asha, bsha, _status] = words info
+ use sha = return $ Just $
+ updateIndexLine sha FileBlob $ asTopFilePath file
+ -- We don't know how the file is encoded, but need to
+ -- split it into lines to union merge. Using the
+ -- FileSystemEncoding for this is a hack, but ensures there
+ -- are no decoding errors. Note that this works because
+ -- hashObject sets fileEncoding on its write handle.
+ getcontents s = lines . encodeW8 . L.unpack <$> catObject h s
{- Calculates a union merge between a list of refs, with contents.
-
@@ -98,7 +98,7 @@ calcMerge :: [(Ref, [String])] -> Either Ref [String]
calcMerge shacontents
| null reuseable = Right $ new
| otherwise = Left $ fst $ Prelude.head reuseable
- where
- reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
- new = sorteduniq $ concat $ map snd shacontents
- sorteduniq = S.toList . S.fromList
+ where
+ reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
+ new = sorteduniq $ concat $ map snd shacontents
+ sorteduniq = S.toList . S.fromList
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index bc96570de..aa65b4429 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -38,12 +38,12 @@ streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
fileEncoding h
forM_ as (stream h)
hClose h
- where
- params = map Param ["update-index", "-z", "--index-info"]
- stream h a = a (streamer h)
- streamer h s = do
- hPutStr h s
- hPutStr h "\0"
+ where
+ params = map Param ["update-index", "-z", "--index-info"]
+ stream h a = a (streamer h)
+ streamer h s = do
+ hPutStr h s
+ hPutStr h "\0"
{- A streamer that adds the current tree for a ref. Useful for eg, copying
- and modifying branches. -}
@@ -52,8 +52,8 @@ lsTree (Ref x) repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
- where
- params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
+ where
+ params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}
diff --git a/Git/Url.hs b/Git/Url.hs
index 21b69dc7c..7befc4669 100644
--- a/Git/Url.hs
+++ b/Git/Url.hs
@@ -28,13 +28,13 @@ scheme repo = notUrl repo
- <http://trac.haskell.org/network/ticket/40> -}
uriRegName' :: URIAuth -> String
uriRegName' a = fixup $ uriRegName a
- where
- fixup x@('[':rest)
- | rest !! len == ']' = take len rest
- | otherwise = x
- where
- len = length rest - 1
- fixup x = x
+ where
+ fixup x@('[':rest)
+ | rest !! len == ']' = take len rest
+ | otherwise = x
+ where
+ len = length rest - 1
+ fixup x = x
{- Hostname of an URL repo. -}
host :: Repo -> String
@@ -55,14 +55,14 @@ hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r
{- The full authority portion an URL repo. (ie, "user@host:port") -}
authority :: Repo -> String
authority = authpart assemble
- where
- assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
+ where
+ assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
{- Applies a function to extract part of the uriAuthority of an URL repo. -}
authpart :: (URIAuth -> a) -> Repo -> a
authpart a Repo { location = Url u } = a auth
- where
- auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
+ where
+ auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
authpart _ repo = notUrl repo
notUrl :: Repo -> a
diff --git a/Git/Version.hs b/Git/Version.hs
index c8bc121d6..44385d9b8 100644
--- a/Git/Version.hs
+++ b/Git/Version.hs
@@ -26,13 +26,13 @@ normalize :: String -> Integer
normalize = sum . mult 1 . reverse .
extend precision . take precision .
map readi . split "."
- where
- extend n l = l ++ replicate (n - length l) 0
- mult _ [] = []
- mult n (x:xs) = (n*x) : mult (n*10^width) xs
- readi :: String -> Integer
- readi s = case reads s of
- ((x,_):_) -> x
- _ -> 0
- precision = 10 -- number of segments of the version to compare
- width = length "yyyymmddhhmmss" -- maximum width of a segment
+ where
+ extend n l = l ++ replicate (n - length l) 0
+ mult _ [] = []
+ mult n (x:xs) = (n*x) : mult (n*10^width) xs
+ readi :: String -> Integer
+ readi s = case reads s of
+ ((x,_):_) -> x
+ _ -> 0
+ precision = 10 -- number of segments of the version to compare
+ width = length "yyyymmddhhmmss" -- maximum width of a segment
diff --git a/Makefile b/Makefile
index b6c0bc674..4196a1167 100644
--- a/Makefile
+++ b/Makefile
@@ -7,7 +7,7 @@ BASEFLAGS=-Wall -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility
#
# If you're using an old version of yesod, enable -DWITH_OLD_YESOD
# Or with an old version of the uri library, enable -DWITH_OLD_URI
-FEATURES?=$(GIT_ANNEX_LOCAL_FEATURES) -DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBDAV -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP -DWITH_HOST
+FEATURES?=$(GIT_ANNEX_LOCAL_FEATURES) -DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBDAV -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP -DWITH_DNS
bins=git-annex
mans=git-annex.1 git-annex-shell.1
@@ -160,8 +160,15 @@ linuxstandalone:
ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-annex-shell"
zcat standalone/licences.gz > $(LINUXSTANDALONE_DEST)/LICENSE
+ set -e; \
for bin in $(THIRDPARTY_BINS); do \
- cp "$$(which "$$bin")" "$(LINUXSTANDALONE_DEST)/bin/" || echo "failed to install $$bin"; \
+ p="$$(PATH=$$PATH:/usr/sbin:/sbin:/usr/local/sbin which "$$bin")"; \
+ if [ -z "$$p" ]; then \
+ echo "** missing $$bin" >&2; \
+ exit 1; \
+ else \
+ cp "$$p" "$(LINUXSTANDALONE_DEST)/bin/"; \
+ fi; \
done
install -d "$(LINUXSTANDALONE_DEST)/git-core"
@@ -200,7 +207,13 @@ osxapp:
cp $(OSXAPP_BASE)/LICENSE $(GIT_ANNEX_TMP_BUILD_DIR)/build-dmg/LICENSE.txt
for bin in $(THIRDPARTY_BINS); do \
- cp "$$(which "$$bin")" "$(OSXAPP_BASE)" || echo "failed to install $$bin"; \
+ p="$$(PATH=$$PATH:/usr/sbin:/sbin:/usr/local/sbin which "$$bin")"; \
+ if [ -z "$$p" ]; then \
+ echo "** missing $$bin" >&2; \
+ exit 1; \
+ else \
+ cp "$$p" "$(OSXAPP_BASE)"; \
+ fi; \
done
(cd "$(shell git --exec-path)" && tar c .) | (cd "$(OSXAPP_BASE)" && tar x)
diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs
index c1ea1fd99..bdc8c4b66 100644
--- a/Types/StandardGroups.hs
+++ b/Types/StandardGroups.hs
@@ -36,6 +36,6 @@ descStandardGroup FullArchiveGroup = "full archive: archives all files not archi
preferredContent :: StandardGroup -> String
preferredContent ClientGroup = "exclude=*/archive/* and exclude=archive/*"
preferredContent TransferGroup = "not (inallgroup=client and copies=client:2) and " ++ preferredContent ClientGroup
-preferredContent BackupGroup = "" -- all content is preferred
+preferredContent BackupGroup = "include=*"
preferredContent SmallArchiveGroup = "(include=*/archive/* or include=archive/*) and " ++ preferredContent FullArchiveGroup
preferredContent FullArchiveGroup = "not (copies=archive:1 or copies=smallarchive:1)"
diff --git a/Utility/Base64.hs b/Utility/Base64.hs
index dd739fd4f..ed803a00a 100644
--- a/Utility/Base64.hs
+++ b/Utility/Base64.hs
@@ -15,4 +15,4 @@ toB64 = encode . s2w8
fromB64 :: String -> String
fromB64 s = maybe bad w82s $ decode s
- where bad = error "bad base64 encoded data"
+ where bad = error "bad base64 encoded data"
diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs
index 66b88e4f0..18290669d 100644
--- a/Utility/CopyFile.hs
+++ b/Utility/CopyFile.hs
@@ -17,9 +17,9 @@ copyFileExternal src dest = do
whenM (doesFileExist dest) $
removeFile dest
boolSystem "cp" $ params ++ [File src, File dest]
- where
- params = map snd $ filter fst
- [ (SysConfig.cp_reflink_auto, Param "--reflink=auto")
- , (SysConfig.cp_a, Param "-a")
- , (SysConfig.cp_p && not SysConfig.cp_a, Param "-p")
- ]
+ where
+ params = map snd $ filter fst
+ [ (SysConfig.cp_reflink_auto, Param "--reflink=auto")
+ , (SysConfig.cp_a, Param "-a")
+ , (SysConfig.cp_p && not SysConfig.cp_a, Param "-p")
+ ]
diff --git a/Utility/DBus.hs b/Utility/DBus.hs
index d31c20d54..3523a3aa3 100644
--- a/Utility/DBus.hs
+++ b/Utility/DBus.hs
@@ -57,10 +57,10 @@ runClient getaddr clientaction = do
e <- takeMVar mv
disconnect client
throw e
- where
- threadrunner storeerr io = loop
- where
- loop = catchClientError (io >> loop) storeerr
+ where
+ threadrunner storeerr io = loop
+ where
+ loop = catchClientError (io >> loop) storeerr
{- Connects to the bus, and runs the client action.
-
@@ -73,10 +73,10 @@ persistentClient getaddr v onretry clientaction =
{- runClient can fail with not just ClientError, but also other
- things, if dbus is not running. Let async exceptions through. -}
runClient getaddr clientaction `catchNonAsync` retry
- where
- retry e = do
- v' <- onretry e v
- persistentClient getaddr v' onretry clientaction
+ where
+ retry e = do
+ v' <- onretry e v
+ persistentClient getaddr v' onretry clientaction
{- Catches only ClientError -}
catchClientError :: IO () -> (ClientError -> IO ()) -> IO ()
diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index 3417cb5c6..16245268e 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -22,27 +22,27 @@ daemonize logfd pidfile changedirectory a = do
maybe noop checkalreadyrunning pidfile
_ <- forkProcess child1
out
- where
- checkalreadyrunning f = maybe noop (const $ alreadyRunning)
- =<< checkDaemon f
- child1 = do
- _ <- createSession
- _ <- forkProcess child2
- out
- child2 = do
- maybe noop lockPidFile pidfile
- when changedirectory $
- setCurrentDirectory "/"
- nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
- _ <- redir nullfd stdInput
- mapM_ (redir logfd) [stdOutput, stdError]
- closeFd logfd
- a
- out
- redir newh h = do
- closeFd h
- dupTo newh h
- out = exitImmediately ExitSuccess
+ where
+ checkalreadyrunning f = maybe noop (const $ alreadyRunning)
+ =<< checkDaemon f
+ child1 = do
+ _ <- createSession
+ _ <- forkProcess child2
+ out
+ child2 = do
+ maybe noop lockPidFile pidfile
+ when changedirectory $
+ setCurrentDirectory "/"
+ nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
+ _ <- redir nullfd stdInput
+ mapM_ (redir logfd) [stdOutput, stdError]
+ closeFd logfd
+ a
+ out
+ redir newh h = do
+ closeFd h
+ dupTo newh h
+ out = exitImmediately ExitSuccess
{- Locks the pid file, with an exclusive, non-blocking lock.
- Writes the pid to the file, fully atomically.
@@ -62,8 +62,8 @@ lockPidFile file = do
_ <- fdWrite fd' =<< show <$> getProcessID
renameFile newfile file
closeFd fd
- where
- newfile = file ++ ".new"
+ where
+ newfile = file ++ ".new"
alreadyRunning :: IO ()
alreadyRunning = error "Daemon is already running."
@@ -82,19 +82,19 @@ checkDaemon pidfile = do
p <- readish <$> readFile pidfile
return $ check locked p
Nothing -> return Nothing
- where
- check Nothing _ = Nothing
- check _ Nothing = Nothing
- check (Just (pid, _)) (Just pid')
- | pid == pid' = Just pid
- | otherwise = error $
- "stale pid in " ++ pidfile ++
- " (got " ++ show pid' ++
- "; expected " ++ show pid ++ " )"
+ where
+ check Nothing _ = Nothing
+ check _ Nothing = Nothing
+ check (Just (pid, _)) (Just pid')
+ | pid == pid' = Just pid
+ | otherwise = error $
+ "stale pid in " ++ pidfile ++
+ " (got " ++ show pid' ++
+ "; expected " ++ show pid ++ " )"
{- Stops the daemon, safely. -}
stopDaemon :: FilePath -> IO ()
stopDaemon pidfile = go =<< checkDaemon pidfile
- where
- go Nothing = noop
- go (Just pid) = signalProcess sigTERM pid
+ where
+ go Nothing = noop
+ go (Just pid) = signalProcess sigTERM pid
diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs
index 101d64c5a..c6990fdfb 100644
--- a/Utility/DataUnits.hs
+++ b/Utility/DataUnits.hs
@@ -72,9 +72,9 @@ storageUnits =
, Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe
, Unit (p 0) "B" "byte"
]
- where
- p :: Integer -> Integer
- p n = 1000^n
+ where
+ p :: Integer -> Integer
+ p n = 1000^n
{- Memory units are (stupidly named) powers of 2. -}
memoryUnits :: [Unit]
@@ -89,9 +89,9 @@ memoryUnits =
, Unit (p 1) "KiB" "kibibyte"
, Unit (p 0) "B" "byte"
]
- where
- p :: Integer -> Integer
- p n = 2^(n*10)
+ where
+ p :: Integer -> Integer
+ p n = 2^(n*10)
{- Bandwidth units are only measured in bits if you're some crazy telco. -}
bandwidthUnits :: [Unit]
@@ -100,32 +100,32 @@ bandwidthUnits = error "stop trying to rip people off"
{- Do you yearn for the days when men were men and megabytes were megabytes? -}
oldSchoolUnits :: [Unit]
oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
- where
- mingle (Unit _ a n, Unit s' _ _) = Unit s' a n
+ where
+ mingle (Unit _ a n, Unit s' _ _) = Unit s' a n
{- approximate display of a particular number of bytes -}
roughSize :: [Unit] -> Bool -> ByteSize -> String
roughSize units abbrev i
| i < 0 = '-' : findUnit units' (negate i)
| otherwise = findUnit units' i
- where
- units' = reverse $ sort units -- largest first
+ where
+ units' = reverse $ sort units -- largest first
- findUnit (u@(Unit s _ _):us) i'
- | i' >= s = showUnit i' u
- | otherwise = findUnit us i'
- findUnit [] i' = showUnit i' (last units') -- bytes
+ findUnit (u@(Unit s _ _):us) i'
+ | i' >= s = showUnit i' u
+ | otherwise = findUnit us i'
+ findUnit [] i' = showUnit i' (last units') -- bytes
- showUnit i' (Unit s a n) = let num = chop i' s in
- show num ++ " " ++
- (if abbrev then a else plural num n)
+ showUnit i' (Unit s a n) = let num = chop i' s in
+ show num ++ " " ++
+ (if abbrev then a else plural num n)
- chop :: Integer -> Integer -> Integer
- chop i' d = round $ (fromInteger i' :: Double) / fromInteger d
+ chop :: Integer -> Integer -> Integer
+ chop i' d = round $ (fromInteger i' :: Double) / fromInteger d
- plural n u
- | n == 1 = u
- | otherwise = u ++ "s"
+ plural n u
+ | n == 1 = u
+ | otherwise = u ++ "s"
{- displays comparison of two sizes -}
compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String
@@ -139,22 +139,22 @@ readSize :: [Unit] -> String -> Maybe ByteSize
readSize units input
| null parsednum || null parsedunit = Nothing
| otherwise = Just $ round $ number * fromIntegral multiplier
- where
- (number, rest) = head parsednum
- multiplier = head parsedunit
- unitname = takeWhile isAlpha $ dropWhile isSpace rest
-
- parsednum = reads input :: [(Double, String)]
- parsedunit = lookupUnit units unitname
-
- lookupUnit _ [] = [1] -- no unit given, assume bytes
- lookupUnit [] _ = []
- lookupUnit (Unit s a n:us) v
- | a ~~ v || n ~~ v = [s]
- | plural n ~~ v || a ~~ byteabbrev v = [s]
- | otherwise = lookupUnit us v
+ where
+ (number, rest) = head parsednum
+ multiplier = head parsedunit
+ unitname = takeWhile isAlpha $ dropWhile isSpace rest
+
+ parsednum = reads input :: [(Double, String)]
+ parsedunit = lookupUnit units unitname
+
+ lookupUnit _ [] = [1] -- no unit given, assume bytes
+ lookupUnit [] _ = []
+ lookupUnit (Unit s a n:us) v
+ | a ~~ v || n ~~ v = [s]
+ | plural n ~~ v || a ~~ byteabbrev v = [s]
+ | otherwise = lookupUnit us v
- a ~~ b = map toLower a == map toLower b
+ a ~~ b = map toLower a == map toLower b
- plural n = n ++ "s"
- byteabbrev a = a ++ "b"
+ plural n = n ++ "s"
+ byteabbrev a = a ++ "b"
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 5ca39b8b5..7cce4a68f 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -44,46 +44,46 @@ dirContentsRecursive' (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir)
files' <- dirContentsRecursive' (dirs' ++ dirs)
return (files ++ files')
- where
- collect files dirs' [] = return (reverse files, reverse dirs')
- collect files dirs' (entry:entries)
- | dirCruft entry = collect files dirs' entries
- | otherwise = do
- ifM (doesDirectoryExist entry)
- ( collect files (entry:dirs') entries
- , collect (entry:files) dirs' entries
- )
+ where
+ collect files dirs' [] = return (reverse files, reverse dirs')
+ collect files dirs' (entry:entries)
+ | dirCruft entry = collect files dirs' entries
+ | otherwise = do
+ ifM (doesDirectoryExist entry)
+ ( collect files (entry:dirs') entries
+ , collect (entry:files) dirs' entries
+ )
{- Moves one filename to another.
- First tries a rename, but falls back to moving across devices if needed. -}
moveFile :: FilePath -> FilePath -> IO ()
moveFile src dest = tryIO (rename src dest) >>= onrename
- where
- onrename (Right _) = noop
- onrename (Left e)
- | isPermissionError e = rethrow
- | isDoesNotExistError e = rethrow
- | otherwise = do
- -- copyFile is likely not as optimised as
- -- the mv command, so we'll use the latter.
- -- But, mv will move into a directory if
- -- dest is one, which is not desired.
- whenM (isdir dest) rethrow
- viaTmp mv dest undefined
- where
- rethrow = throw e
- mv tmp _ = do
- ok <- boolSystem "mv" [Param "-f",
- Param src, Param tmp]
- unless ok $ do
- -- delete any partial
- _ <- tryIO $ removeFile tmp
- rethrow
- isdir f = do
- r <- tryIO $ getFileStatus f
- case r of
- (Left _) -> return False
- (Right s) -> return $ isDirectory s
+ where
+ onrename (Right _) = noop
+ onrename (Left e)
+ | isPermissionError e = rethrow
+ | isDoesNotExistError e = rethrow
+ | otherwise = do
+ -- copyFile is likely not as optimised as
+ -- the mv command, so we'll use the latter.
+ -- But, mv will move into a directory if
+ -- dest is one, which is not desired.
+ whenM (isdir dest) rethrow
+ viaTmp mv dest undefined
+ where
+ rethrow = throw e
+ mv tmp _ = do
+ ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
+ unless ok $ do
+ -- delete any partial
+ _ <- tryIO $ removeFile tmp
+ rethrow
+
+ isdir f = do
+ r <- tryIO $ getFileStatus f
+ case r of
+ (Left _) -> return False
+ (Right s) -> return $ isDirectory s
{- Removes a file, which may or may not exist.
-
diff --git a/Utility/DiskFree.hs b/Utility/DiskFree.hs
index 18c7f2ee6..453244175 100644
--- a/Utility/DiskFree.hs
+++ b/Utility/DiskFree.hs
@@ -25,5 +25,5 @@ getDiskFree path = withFilePath path $ \c_path -> do
( return $ Just $ toInteger free
, return Nothing
)
- where
- safeErrno (Errno v) = v == 0
+ where
+ safeErrno (Errno v) = v == 0
diff --git a/Utility/Dot.hs b/Utility/Dot.hs
index 83f52a3cc..e57bf009f 100644
--- a/Utility/Dot.hs
+++ b/Utility/Dot.hs
@@ -10,9 +10,9 @@ module Utility.Dot where -- import qualified
{- generates a graph description from a list of lines -}
graph :: [String] -> String
graph s = unlines $ [header] ++ map indent s ++ [footer]
- where
- header = "digraph map {"
- footer= "}"
+ where
+ header = "digraph map {"
+ footer= "}"
{- a node in the graph -}
graphNode :: String -> String -> String
@@ -21,8 +21,8 @@ graphNode nodeid desc = label desc $ quote nodeid
{- an edge between two nodes -}
graphEdge :: String -> String -> Maybe String -> String
graphEdge fromid toid desc = indent $ maybe edge (`label` edge) desc
- where
- edge = quote fromid ++ " -> " ++ quote toid
+ where
+ edge = quote fromid ++ " -> " ++ quote toid
{- adds a label to a node or edge -}
label :: String -> String -> String
@@ -46,18 +46,18 @@ subGraph subid l color s =
ii setcolor ++
ii s ++
indent "}"
- where
- -- the "cluster_" makes dot draw a box
- name = quote ("cluster_" ++ subid)
- setlabel = "label=" ++ quote l
- setfilled = "style=" ++ quote "filled"
- setcolor = "fillcolor=" ++ quote color
- ii x = indent (indent x) ++ "\n"
+ where
+ -- the "cluster_" makes dot draw a box
+ name = quote ("cluster_" ++ subid)
+ setlabel = "label=" ++ quote l
+ setfilled = "style=" ++ quote "filled"
+ setcolor = "fillcolor=" ++ quote color
+ ii x = indent (indent x) ++ "\n"
indent ::String -> String
indent s = '\t' : s
quote :: String -> String
quote s = "\"" ++ s' ++ "\""
- where
- s' = filter (/= '"') s
+ where
+ s' = filter (/= '"') s
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index 7109c1403..ddb89b2aa 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -37,10 +37,10 @@ removeModes ms m = m `intersectFileModes` complement (combineModes ms)
{- Runs an action after changing a file's mode, then restores the old mode. -}
withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode file convert a = bracket setup cleanup go
- where
- setup = modifyFileMode' file convert
- cleanup oldmode = modifyFileMode file (const oldmode)
- go _ = a
+ where
+ setup = modifyFileMode' file convert
+ cleanup oldmode = modifyFileMode file (const oldmode)
+ go _ = a
writeModes :: [FileMode]
writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
@@ -83,10 +83,10 @@ noUmask :: FileMode -> IO a -> IO a
noUmask mode a
| mode == stdFileMode = a
| otherwise = bracket setup cleanup go
- where
- setup = setFileCreationMask nullFileMode
- cleanup = setFileCreationMask
- go _ = a
+ where
+ setup = setFileCreationMask nullFileMode
+ cleanup = setFileCreationMask
+ go _ = a
combineModes :: [FileMode] -> FileMode
combineModes [] = undefined
diff --git a/Utility/Format.hs b/Utility/Format.hs
index 1d96695ed..97a966ac1 100644
--- a/Utility/Format.hs
+++ b/Utility/Format.hs
@@ -43,19 +43,19 @@ type Variables = M.Map String String
- This can be repeatedly called, efficiently. -}
format :: Format -> Variables -> String
format f vars = concatMap expand f
- where
- expand (Const s) = s
- expand (Var name j)
- | "escaped_" `isPrefixOf` name =
- justify j $ encode_c_strict $
- getvar $ drop (length "escaped_") name
- | otherwise = justify j $ getvar name
- getvar name = fromMaybe "" $ M.lookup name vars
- justify UnJustified s = s
- justify (LeftJustified i) s = s ++ pad i s
- justify (RightJustified i) s = pad i s ++ s
- pad i s = take (i - length s) spaces
- spaces = repeat ' '
+ where
+ expand (Const s) = s
+ expand (Var name j)
+ | "escaped_" `isPrefixOf` name =
+ justify j $ encode_c_strict $
+ getvar $ drop (length "escaped_") name
+ | otherwise = justify j $ getvar name
+ getvar name = fromMaybe "" $ M.lookup name vars
+ justify UnJustified s = s
+ justify (LeftJustified i) s = s ++ pad i s
+ justify (RightJustified i) s = pad i s ++ s
+ pad i s = take (i - length s) spaces
+ spaces = repeat ' '
{- Generates a Format that can be used to expand variables in a
- format string, such as "${foo} ${bar;10} ${baz;-10}\n"
@@ -64,37 +64,37 @@ format f vars = concatMap expand f
-}
gen :: FormatString -> Format
gen = filter (not . empty) . fuse [] . scan [] . decode_c
- where
- -- The Format is built up in reverse, for efficiency,
- -- and can have many adjacent Consts. Fusing it fixes both
- -- problems.
- fuse f [] = f
- fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs
- fuse f (v:vs) = fuse (v:f) vs
-
- scan f (a:b:cs)
- | a == '$' && b == '{' = invar f [] cs
- | otherwise = scan (Const [a] : f ) (b:cs)
- scan f v = Const v : f
-
- invar f var [] = Const (novar var) : f
- invar f var (c:cs)
- | c == '}' = foundvar f var UnJustified cs
- | isAlphaNum c || c == '_' = invar f (c:var) cs
- | c == ';' = inpad "" f var cs
- | otherwise = scan ((Const $ novar $ c:var):f) cs
-
- inpad p f var (c:cs)
- | c == '}' = foundvar f var (readjustify $ reverse p) cs
- | otherwise = inpad (c:p) f var cs
- inpad p f var [] = Const (novar $ p++";"++var) : f
- readjustify = getjustify . fromMaybe 0 . readish
- getjustify i
- | i == 0 = UnJustified
- | i < 0 = LeftJustified (-1 * i)
- | otherwise = RightJustified i
- novar v = "${" ++ reverse v
- foundvar f v p = scan (Var (reverse v) p : f)
+ where
+ -- The Format is built up in reverse, for efficiency,
+ -- and can have many adjacent Consts. Fusing it fixes both
+ -- problems.
+ fuse f [] = f
+ fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs
+ fuse f (v:vs) = fuse (v:f) vs
+
+ scan f (a:b:cs)
+ | a == '$' && b == '{' = invar f [] cs
+ | otherwise = scan (Const [a] : f ) (b:cs)
+ scan f v = Const v : f
+
+ invar f var [] = Const (novar var) : f
+ invar f var (c:cs)
+ | c == '}' = foundvar f var UnJustified cs
+ | isAlphaNum c || c == '_' = invar f (c:var) cs
+ | c == ';' = inpad "" f var cs
+ | otherwise = scan ((Const $ novar $ c:var):f) cs
+
+ inpad p f var (c:cs)
+ | c == '}' = foundvar f var (readjustify $ reverse p) cs
+ | otherwise = inpad (c:p) f var cs
+ inpad p f var [] = Const (novar $ p++";"++var) : f
+ readjustify = getjustify . fromMaybe 0 . readish
+ getjustify i
+ | i == 0 = UnJustified
+ | i < 0 = LeftJustified (-1 * i)
+ | otherwise = RightJustified i
+ novar v = "${" ++ reverse v
+ foundvar f v p = scan (Var (reverse v) p : f)
empty :: Frag -> Bool
empty (Const "") = True
@@ -106,36 +106,34 @@ empty _ = False
decode_c :: FormatString -> FormatString
decode_c [] = []
decode_c s = unescape ("", s)
- where
- e = '\\'
- unescape (b, []) = b
- -- look for escapes starting with '\'
- unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)
- where
- pair = span (/= e) v
- isescape x = x == e
- -- \NNN is an octal encoded character
- handle (x:n1:n2:n3:rest)
- | isescape x && alloctal = (fromoctal, rest)
- where
- alloctal = isOctDigit n1 &&
- isOctDigit n2 &&
- isOctDigit n3
- fromoctal = [chr $ readoctal [n1, n2, n3]]
- readoctal o = Prelude.read $ "0o" ++ o :: Int
- -- \C is used for a few special characters
- handle (x:nc:rest)
- | isescape x = ([echar nc], rest)
- where
- echar 'a' = '\a'
- echar 'b' = '\b'
- echar 'f' = '\f'
- echar 'n' = '\n'
- echar 'r' = '\r'
- echar 't' = '\t'
- echar 'v' = '\v'
- echar a = a
- handle n = ("", n)
+ where
+ e = '\\'
+ unescape (b, []) = b
+ -- look for escapes starting with '\'
+ unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)
+ where
+ pair = span (/= e) v
+ isescape x = x == e
+ -- \NNN is an octal encoded character
+ handle (x:n1:n2:n3:rest)
+ | isescape x && alloctal = (fromoctal, rest)
+ where
+ alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3
+ fromoctal = [chr $ readoctal [n1, n2, n3]]
+ readoctal o = Prelude.read $ "0o" ++ o :: Int
+ -- \C is used for a few special characters
+ handle (x:nc:rest)
+ | isescape x = ([echar nc], rest)
+ where
+ echar 'a' = '\a'
+ echar 'b' = '\b'
+ echar 'f' = '\f'
+ echar 'n' = '\n'
+ echar 'r' = '\r'
+ echar 't' = '\t'
+ echar 'v' = '\v'
+ echar a = a
+ handle n = ("", n)
{- Inverse of decode_c. -}
encode_c :: FormatString -> FormatString
@@ -147,28 +145,28 @@ encode_c_strict = encode_c' isSpace
encode_c' :: (Char -> Bool) -> FormatString -> FormatString
encode_c' p = concatMap echar
- where
- e c = '\\' : [c]
- echar '\a' = e 'a'
- echar '\b' = e 'b'
- echar '\f' = e 'f'
- echar '\n' = e 'n'
- echar '\r' = e 'r'
- echar '\t' = e 't'
- echar '\v' = e 'v'
- echar '\\' = e '\\'
- echar '"' = e '"'
- echar c
- | ord c < 0x20 = e_asc c -- low ascii
- | ord c >= 256 = e_utf c -- unicode
- | ord c > 0x7E = e_asc c -- high ascii
- | p c = e_asc c -- unprintable ascii
- | otherwise = [c] -- printable ascii
- -- unicode character is decomposed to individual Word8s,
- -- and each is shown in octal
- e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])
- e_asc c = showoctal $ ord c
- showoctal i = '\\' : printf "%03o" i
+ where
+ e c = '\\' : [c]
+ echar '\a' = e 'a'
+ echar '\b' = e 'b'
+ echar '\f' = e 'f'
+ echar '\n' = e 'n'
+ echar '\r' = e 'r'
+ echar '\t' = e 't'
+ echar '\v' = e 'v'
+ echar '\\' = e '\\'
+ echar '"' = e '"'
+ echar c
+ | ord c < 0x20 = e_asc c -- low ascii
+ | ord c >= 256 = e_utf c -- unicode
+ | ord c > 0x7E = e_asc c -- high ascii
+ | p c = e_asc c -- unprintable ascii
+ | otherwise = [c] -- printable ascii
+ -- unicode character is decomposed to individual Word8s,
+ -- and each is shown in octal
+ e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])
+ e_asc c = showoctal $ ord c
+ showoctal i = '\\' : printf "%03o" i
{- for quickcheck -}
prop_idempotent_deencode :: String -> Bool
diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs
index 7aba1f272..e3ced6d74 100644
--- a/Utility/FreeDesktop.hs
+++ b/Utility/FreeDesktop.hs
@@ -51,8 +51,8 @@ toString(NumericV f) = show f
toString (ListV l)
| null l = ""
| otherwise = (intercalate ";" $ map (escapesemi . toString) l) ++ ";"
- where
- escapesemi = join "\\;" . split ";"
+ where
+ escapesemi = join "\\;" . split ";"
genDesktopEntry :: String -> String -> Bool -> FilePath -> [String] -> DesktopEntry
genDesktopEntry name comment terminal program categories =
@@ -64,13 +64,13 @@ genDesktopEntry name comment terminal program categories =
, item "Exec" StringV program
, item "Categories" ListV (map StringV categories)
]
- where
- item x c y = (x, c y)
+ where
+ item x c y = (x, c y)
buildDesktopMenuFile :: DesktopEntry -> String
buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n"
- where
- keyvalue (k, v) = k ++ "=" ++ toString v
+ where
+ keyvalue (k, v) = k ++ "=" ++ toString v
writeDesktopMenuFile :: DesktopEntry -> String -> IO ()
writeDesktopMenuFile d file = do
@@ -115,11 +115,10 @@ userConfigDir = xdgEnvHome "CONFIG_HOME" ".config"
- to ~/Desktop. -}
userDesktopDir :: IO FilePath
userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir)
- where
- parse = maybe Nothing (headMaybe . lines)
- xdg_user_dir = catchMaybeIO $
- readProcess "xdg-user-dir" ["DESKTOP"]
- fallback = xdgEnvHome "DESKTOP_DIR" "Desktop"
+ where
+ parse = maybe Nothing (headMaybe . lines)
+ xdg_user_dir = catchMaybeIO $ readProcess "xdg-user-dir" ["DESKTOP"]
+ fallback = xdgEnvHome "DESKTOP_DIR" "Desktop"
xdgEnvHome :: String -> String -> IO String
xdgEnvHome envbase homedef = do
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index 054e6ca17..8c7a3ac38 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -29,9 +29,9 @@ stdParams params = do
then []
else ["--batch", "--no-tty", "--use-agent"]
return $ batch ++ defaults ++ toCommand params
- where
- -- be quiet, even about checking the trustdb
- defaults = ["--quiet", "--trust-model", "always"]
+ where
+ -- be quiet, even about checking the trustdb
+ defaults = ["--quiet", "--trust-model", "always"]
{- Runs gpg with some params and returns its stdout, strictly. -}
readStrict :: [CommandParam] -> IO String
@@ -74,22 +74,22 @@ feedRead params passphrase feeder reader = do
params' <- stdParams $ passphrasefd ++ params
closeFd frompipe `after`
withBothHandles createProcessSuccess (proc "gpg" params') go
- where
- go (to, from) = do
- void $ forkIO $ do
- feeder to
- hClose to
- reader from
+ where
+ go (to, from) = do
+ void $ forkIO $ do
+ feeder to
+ hClose to
+ reader from
{- Finds gpg public keys matching some string. (Could be an email address,
- a key id, or a name. -}
findPubKeys :: String -> IO KeyIds
findPubKeys for = KeyIds . parse <$> readStrict params
- where
- params = [Params "--with-colons --list-public-keys", Param for]
- parse = catMaybes . map (keyIdField . split ":") . lines
- keyIdField ("pub":_:_:_:f:_) = Just f
- keyIdField _ = Nothing
+ where
+ params = [Params "--with-colons --list-public-keys", Param for]
+ parse = catMaybes . map (keyIdField . split ":") . lines
+ keyIdField ("pub":_:_:_:f:_) = Just f
+ keyIdField _ = Nothing
{- Creates a block of high-quality random data suitable to use as a cipher.
- It is armored, to avoid newlines, since gpg only reads ciphers up to the
@@ -100,9 +100,9 @@ genRandom size = readStrict
, Param $ show randomquality
, Param $ show size
]
- where
- -- 1 is /dev/urandom; 2 is /dev/random
- randomquality = 1 :: Int
+ where
+ -- 1 is /dev/urandom; 2 is /dev/random
+ randomquality = 1 :: Int
{- A test key. This is provided pre-generated since generating a new gpg
- key is too much work (requires too much entropy) for a test suite to
@@ -173,10 +173,10 @@ keyBlock public ls = unlines
, unlines ls
, "-----END PGP "++t++" KEY BLOCK-----"
]
- where
- t
- | public = "PUBLIC"
- | otherwise = "PRIVATE"
+ where
+ t
+ | public = "PUBLIC"
+ | otherwise = "PRIVATE"
{- Runs an action using gpg in a test harness, in which gpg does
- not use ~/.gpg/, but a directory with the test key set up to be used. -}
@@ -184,20 +184,20 @@ testHarness :: IO a -> IO a
testHarness a = do
orig <- getEnv var
bracket setup (cleanup orig) (const a)
- where
- var = "GNUPGHOME"
+ where
+ var = "GNUPGHOME"
- setup = do
- base <- getTemporaryDirectory
- dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
- setEnv var dir True
- _ <- pipeStrict [Params "--import -q"] $ unlines
- [testSecretKey, testKey]
- return dir
+ setup = do
+ base <- getTemporaryDirectory
+ dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
+ setEnv var dir True
+ _ <- pipeStrict [Params "--import -q"] $ unlines
+ [testSecretKey, testKey]
+ return dir
- cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig
- reset (Just v) = setEnv var v True
- reset _ = unsetEnv var
+ cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig
+ reset (Just v) = setEnv var v True
+ reset _ = unsetEnv var
{- Tests the test harness. -}
testTestHarness :: IO Bool
diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs
index ca631dbb1..038d1228e 100644
--- a/Utility/HumanTime.hs
+++ b/Utility/HumanTime.hs
@@ -17,10 +17,10 @@ parseDuration s = do
num <- readish s :: Maybe Integer
units <- findUnits =<< lastMaybe s
return $ fromIntegral num * units
- where
- findUnits 's' = Just 1
- findUnits 'm' = Just 60
- findUnits 'h' = Just $ 60 * 60
- findUnits 'd' = Just $ 60 * 60 * 24
- findUnits 'y' = Just $ 60 * 60 * 24 * 365
- findUnits _ = Nothing
+ where
+ findUnits 's' = Just 1
+ findUnits 'm' = Just 60
+ findUnits 'h' = Just $ 60 * 60
+ findUnits 'd' = Just $ 60 * 60 * 24
+ findUnits 'y' = Just $ 60 * 60 * 24 * 365
+ findUnits _ = Nothing
diff --git a/Utility/INotify.hs b/Utility/INotify.hs
index b55fbc953..2b5789479 100644
--- a/Utility/INotify.hs
+++ b/Utility/INotify.hs
@@ -59,116 +59,116 @@ watchDir i dir ignored hooks
withLock lock $
mapM_ scan =<< filter (not . dirCruft) <$>
getDirectoryContents dir
- where
- recurse d = watchDir i d ignored hooks
+ where
+ recurse d = watchDir i d ignored hooks
- -- Select only inotify events required by the enabled
- -- hooks, but always include Create so new directories can
- -- be scanned.
- watchevents = Create : addevents ++ delevents ++ modifyevents
- addevents
- | hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]
- | otherwise = []
- delevents
- | hashook delHook || hashook delDirHook = [MoveOut, Delete]
- | otherwise = []
- modifyevents
- | hashook modifyHook = [Modify]
- | otherwise = []
+ -- Select only inotify events required by the enabled
+ -- hooks, but always include Create so new directories can
+ -- be scanned.
+ watchevents = Create : addevents ++ delevents ++ modifyevents
+ addevents
+ | hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]
+ | otherwise = []
+ delevents
+ | hashook delHook || hashook delDirHook = [MoveOut, Delete]
+ | otherwise = []
+ modifyevents
+ | hashook modifyHook = [Modify]
+ | otherwise = []
- scan f = unless (ignored f) $ do
- ms <- getstatus f
- case ms of
- Nothing -> return ()
- Just s
- | Files.isDirectory s ->
- recurse $ indir f
- | Files.isSymbolicLink s ->
- runhook addSymlinkHook f ms
- | Files.isRegularFile s ->
- runhook addHook f ms
- | otherwise ->
- noop
+ scan f = unless (ignored f) $ do
+ ms <- getstatus f
+ case ms of
+ Nothing -> return ()
+ Just s
+ | Files.isDirectory s ->
+ recurse $ indir f
+ | Files.isSymbolicLink s ->
+ runhook addSymlinkHook f ms
+ | Files.isRegularFile s ->
+ runhook addHook f ms
+ | otherwise ->
+ noop
- -- Ignore creation events for regular files, which won't be
- -- done being written when initially created, but handle for
- -- directories and symlinks.
- go (Created { isDirectory = isd, filePath = f })
- | isd = recurse $ indir f
- | hashook addSymlinkHook =
- checkfiletype Files.isSymbolicLink addSymlinkHook f
- | otherwise = noop
- -- Closing a file is assumed to mean it's done being written.
- go (Closed { isDirectory = False, maybeFilePath = Just f }) =
- checkfiletype Files.isRegularFile addHook f
- -- When a file or directory is moved in, scan it to add new
- -- stuff.
- go (MovedIn { filePath = f }) = scan f
- go (MovedOut { isDirectory = isd, filePath = f })
- | isd = runhook delDirHook f Nothing
- | otherwise = runhook delHook f Nothing
- -- Verify that the deleted item really doesn't exist,
- -- since there can be spurious deletion events for items
- -- in a directory that has been moved out, but is still
- -- being watched.
- go (Deleted { isDirectory = isd, filePath = f })
- | isd = guarded $ runhook delDirHook f Nothing
- | otherwise = guarded $ runhook delHook f Nothing
- where
- guarded = unlessM (filetype (const True) f)
- go (Modified { isDirectory = isd, maybeFilePath = Just f })
- | isd = noop
- | otherwise = runhook modifyHook f Nothing
- go _ = noop
+ -- Ignore creation events for regular files, which won't be
+ -- done being written when initially created, but handle for
+ -- directories and symlinks.
+ go (Created { isDirectory = isd, filePath = f })
+ | isd = recurse $ indir f
+ | hashook addSymlinkHook =
+ checkfiletype Files.isSymbolicLink addSymlinkHook f
+ | otherwise = noop
+ -- Closing a file is assumed to mean it's done being written.
+ go (Closed { isDirectory = False, maybeFilePath = Just f }) =
+ checkfiletype Files.isRegularFile addHook f
+ -- When a file or directory is moved in, scan it to add new
+ -- stuff.
+ go (MovedIn { filePath = f }) = scan f
+ go (MovedOut { isDirectory = isd, filePath = f })
+ | isd = runhook delDirHook f Nothing
+ | otherwise = runhook delHook f Nothing
+ -- Verify that the deleted item really doesn't exist,
+ -- since there can be spurious deletion events for items
+ -- in a directory that has been moved out, but is still
+ -- being watched.
+ go (Deleted { isDirectory = isd, filePath = f })
+ | isd = guarded $ runhook delDirHook f Nothing
+ | otherwise = guarded $ runhook delHook f Nothing
+ where
+ guarded = unlessM (filetype (const True) f)
+ go (Modified { isDirectory = isd, maybeFilePath = Just f })
+ | isd = noop
+ | otherwise = runhook modifyHook f Nothing
+ go _ = noop
- hashook h = isJust $ h hooks
+ hashook h = isJust $ h hooks
- runhook h f s
- | ignored f = noop
- | otherwise = maybe noop (\a -> a (indir f) s) (h hooks)
+ runhook h f s
+ | ignored f = noop
+ | otherwise = maybe noop (\a -> a (indir f) s) (h hooks)
- indir f = dir </> f
+ indir f = dir </> f
- getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f
- checkfiletype check h f = do
- ms <- getstatus f
- case ms of
- Just s
- | check s -> runhook h f ms
- _ -> noop
- filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)
+ getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f
+ checkfiletype check h f = do
+ ms <- getstatus f
+ case ms of
+ Just s
+ | check s -> runhook h f ms
+ _ -> noop
+ filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)
- -- Inotify fails when there are too many watches with a
- -- disk full error.
- failedaddwatch e
- | isFullError e =
- case errHook hooks of
- Nothing -> throw e
- Just hook -> tooManyWatches hook dir
- | otherwise = throw e
+ -- Inotify fails when there are too many watches with a
+ -- disk full error.
+ failedaddwatch e
+ | isFullError e =
+ case errHook hooks of
+ Nothing -> throw e
+ Just hook -> tooManyWatches hook dir
+ | otherwise = throw e
tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO ()
tooManyWatches hook dir = do
sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)
hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing
- where
- maxwatches = "fs.inotify.max_user_watches"
- basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"
- withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]
- withsysctl n = let new = n * 10 in
- [ "Increase the limit permanently by running:"
- , " echo " ++ maxwatches ++ "=" ++ show new ++
- " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"
- , "Or temporarily by running:"
- , " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new
- ]
+ where
+ maxwatches = "fs.inotify.max_user_watches"
+ basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"
+ withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]
+ withsysctl n = let new = n * 10 in
+ [ "Increase the limit permanently by running:"
+ , " echo " ++ maxwatches ++ "=" ++ show new ++
+ " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"
+ , "Or temporarily by running:"
+ , " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new
+ ]
querySysctl :: Read a => [CommandParam] -> IO (Maybe a)
querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"]
- where
- go p = do
- v <- catchMaybeIO $ readProcess p (toCommand ps)
- case v of
- Nothing -> return Nothing
- Just s -> return $ parsesysctl s
- parsesysctl s = readish =<< lastMaybe (words s)
+ where
+ go p = do
+ v <- catchMaybeIO $ readProcess p (toCommand ps)
+ case v of
+ Nothing -> return Nothing
+ Just s -> return $ parsesysctl s
+ parsesysctl s = readish =<< lastMaybe (words s)
diff --git a/Utility/JSONStream.hs b/Utility/JSONStream.hs
index 7910c1194..aaa332bca 100644
--- a/Utility/JSONStream.hs
+++ b/Utility/JSONStream.hs
@@ -21,15 +21,15 @@ start :: JSON a => [(String, a)] -> String
start l
| last s == endchar = init s
| otherwise = bad s
- where
- s = encodeStrict $ toJSObject l
+ where
+ s = encodeStrict $ toJSObject l
add :: JSON a => [(String, a)] -> String
add l
| head s == startchar = ',' : drop 1 s
| otherwise = bad s
- where
- s = start l
+ where
+ s = start l
end :: String
end = [endchar, '\n']
diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs
index 4b72961b2..f9f965f6f 100644
--- a/Utility/Kqueue.hs
+++ b/Utility/Kqueue.hs
@@ -78,44 +78,44 @@ getDirInfo dir = do
l <- filter (not . dirCruft) <$> getDirectoryContents dir
contents <- S.fromList . catMaybes <$> mapM getDirEnt l
return $ DirInfo dir contents
- where
- getDirEnt f = catchMaybeIO $ do
- s <- getFileStatus (dir </> f)
- return $ DirEnt f (fileID s) (isDirectory s)
+ where
+ getDirEnt f = catchMaybeIO $ do
+ s <- getFileStatus (dir </> f)
+ return $ DirEnt f (fileID s) (isDirectory s)
{- Difference between the dirCaches of two DirInfos. -}
(//) :: DirInfo -> DirInfo -> [Change]
oldc // newc = deleted ++ added
- where
- deleted = calc gendel oldc newc
- added = calc genadd newc oldc
- gendel x = (if isSubDir x then DeletedDir else Deleted) $
- dirName oldc </> dirEnt x
- genadd x = Added $ dirName newc </> dirEnt x
- calc a x y = map a $ S.toList $
- S.difference (dirCache x) (dirCache y)
+ where
+ deleted = calc gendel oldc newc
+ added = calc genadd newc oldc
+ gendel x = (if isSubDir x then DeletedDir else Deleted) $
+ dirName oldc </> dirEnt x
+ genadd x = Added $ dirName newc </> dirEnt x
+ calc a x y = map a $ S.toList $
+ S.difference (dirCache x) (dirCache y)
{- Builds a map of directories in a tree, possibly pruning some.
- Opens each directory in the tree, and records its current contents. -}
scanRecursive :: FilePath -> Pruner -> IO DirMap
scanRecursive topdir prune = M.fromList <$> walk [] [topdir]
- where
- walk c [] = return c
- walk c (dir:rest)
- | prune dir = walk c rest
- | otherwise = do
- minfo <- catchMaybeIO $ getDirInfo dir
- case minfo of
- Nothing -> walk c rest
- Just info -> do
- mfd <- catchMaybeIO $
- openFd dir ReadOnly Nothing defaultFileFlags
- case mfd of
- Nothing -> walk c rest
- Just fd -> do
- let subdirs = map (dir </>) . map dirEnt $
- S.toList $ dirCache info
- walk ((fd, info):c) (subdirs ++ rest)
+ where
+ walk c [] = return c
+ walk c (dir:rest)
+ | prune dir = walk c rest
+ | otherwise = do
+ minfo <- catchMaybeIO $ getDirInfo dir
+ case minfo of
+ Nothing -> walk c rest
+ Just info -> do
+ mfd <- catchMaybeIO $
+ openFd dir ReadOnly Nothing defaultFileFlags
+ case mfd of
+ Nothing -> walk c rest
+ Just fd -> do
+ let subdirs = map (dir </>) . map dirEnt $
+ S.toList $ dirCache info
+ walk ((fd, info):c) (subdirs ++ rest)
{- Adds a list of subdirectories (and all their children), unless pruned to a
- directory map. Adding a subdirectory that's already in the map will
@@ -131,16 +131,16 @@ removeSubDir :: DirMap -> FilePath -> IO DirMap
removeSubDir dirmap dir = do
mapM_ closeFd $ M.keys toremove
return rest
- where
- (toremove, rest) = M.partition (dirContains dir . dirName) dirmap
+ where
+ (toremove, rest) = M.partition (dirContains dir . dirName) dirmap
findDirContents :: DirMap -> FilePath -> [FilePath]
findDirContents dirmap dir = concatMap absolutecontents $ search
- where
- absolutecontents i = map (dirName i </>)
- (map dirEnt $ S.toList $ dirCache i)
- search = map snd $ M.toList $
- M.filter (\i -> dirName i == dir) dirmap
+ where
+ absolutecontents i = map (dirName i </>)
+ (map dirEnt $ S.toList $ dirCache i)
+ search = map snd $ M.toList $
+ M.filter (\i -> dirName i == dir) dirmap
foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue
:: IO Fd
@@ -181,8 +181,8 @@ waitChange kq@(Kqueue h _ dirmap _) = do
else case M.lookup changedfd dirmap of
Nothing -> nochange
Just info -> handleChange kq changedfd info
- where
- nochange = return (kq, [])
+ where
+ nochange = return (kq, [])
{- The kqueue interface does not tell what type of change took place in
- the directory; it could be an added file, a deleted file, a renamed
@@ -196,36 +196,36 @@ waitChange kq@(Kqueue h _ dirmap _) = do
handleChange :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change])
handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo =
go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo)
- where
- go (Just newdirinfo) = do
- let changes = filter (not . pruner . changedFile) $
- olddirinfo // newdirinfo
- let (added, deleted) = partition isAdd changes
-
- -- Scan newly added directories to add to the map.
- -- (Newly added files will fail getDirInfo.)
- newdirinfos <- catMaybes <$>
- mapM (catchMaybeIO . getDirInfo . changedFile) added
- newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos
-
- -- Remove deleted directories from the map.
- newmap' <- foldM removeSubDir newmap (map changedFile deleted)
-
- -- Update the cached dirinfo just looked up.
- let newmap'' = M.insertWith' const fd newdirinfo newmap'
-
- -- When new directories were added, need to update
- -- the kqueue to watch them.
- let kq' = kq { kqueueMap = newmap'' }
- unless (null newdirinfos) $
- updateKqueue kq'
-
- return (kq', changes)
- go Nothing = do
- -- The directory has been moved or deleted, so
- -- remove it from our map.
- newmap <- removeSubDir dirmap (dirName olddirinfo)
- return (kq { kqueueMap = newmap }, [])
+ where
+ go (Just newdirinfo) = do
+ let changes = filter (not . pruner . changedFile) $
+ olddirinfo // newdirinfo
+ let (added, deleted) = partition isAdd changes
+
+ -- Scan newly added directories to add to the map.
+ -- (Newly added files will fail getDirInfo.)
+ newdirinfos <- catMaybes <$>
+ mapM (catchMaybeIO . getDirInfo . changedFile) added
+ newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos
+
+ -- Remove deleted directories from the map.
+ newmap' <- foldM removeSubDir newmap (map changedFile deleted)
+
+ -- Update the cached dirinfo just looked up.
+ let newmap'' = M.insertWith' const fd newdirinfo newmap'
+
+ -- When new directories were added, need to update
+ -- the kqueue to watch them.
+ let kq' = kq { kqueueMap = newmap'' }
+ unless (null newdirinfos) $
+ updateKqueue kq'
+
+ return (kq', changes)
+ go Nothing = do
+ -- The directory has been moved or deleted, so
+ -- remove it from our map.
+ newmap <- removeSubDir dirmap (dirName olddirinfo)
+ return (kq { kqueueMap = newmap }, [])
{- Processes changes on the Kqueue, calling the hooks as appropriate.
- Never returns. -}
@@ -235,35 +235,33 @@ runHooks kq hooks = do
-- to catch any files created beforehand.
recursiveadd (kqueueMap kq) (Added $ kqueueTop kq)
loop kq
- where
- loop q = do
- (q', changes) <- waitChange q
- forM_ changes $ dispatch (kqueueMap q')
- loop q'
-
- dispatch _ change@(Deleted _) =
- callhook delHook Nothing change
- dispatch _ change@(DeletedDir _) =
- callhook delDirHook Nothing change
- dispatch dirmap change@(Added _) =
- withstatus change $ dispatchadd dirmap
+ where
+ loop q = do
+ (q', changes) <- waitChange q
+ forM_ changes $ dispatch (kqueueMap q')
+ loop q'
+
+ dispatch _ change@(Deleted _) =
+ callhook delHook Nothing change
+ dispatch _ change@(DeletedDir _) =
+ callhook delDirHook Nothing change
+ dispatch dirmap change@(Added _) =
+ withstatus change $ dispatchadd dirmap
- dispatchadd dirmap change s
- | Files.isSymbolicLink s =
- callhook addSymlinkHook (Just s) change
- | Files.isDirectory s = recursiveadd dirmap change
- | Files.isRegularFile s =
- callhook addHook (Just s) change
- | otherwise = noop
-
- recursiveadd dirmap change = do
- let contents = findDirContents dirmap $ changedFile change
- forM_ contents $ \f ->
- withstatus (Added f) $ dispatchadd dirmap
-
- callhook h s change = case h hooks of
- Nothing -> noop
- Just a -> a (changedFile change) s
-
- withstatus change a = maybe noop (a change) =<<
- (catchMaybeIO (getSymbolicLinkStatus (changedFile change)))
+ dispatchadd dirmap change s
+ | Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change
+ | Files.isDirectory s = recursiveadd dirmap change
+ | Files.isRegularFile s = callhook addHook (Just s) change
+ | otherwise = noop
+
+ recursiveadd dirmap change = do
+ let contents = findDirContents dirmap $ changedFile change
+ forM_ contents $ \f ->
+ withstatus (Added f) $ dispatchadd dirmap
+
+ callhook h s change = case h hooks of
+ Nothing -> noop
+ Just a -> a (changedFile change) s
+
+ withstatus change a = maybe noop (a change) =<<
+ (catchMaybeIO (getSymbolicLinkStatus (changedFile change)))
diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs
index 7ffb63f52..c45a1d405 100644
--- a/Utility/LogFile.hs
+++ b/Utility/LogFile.hs
@@ -23,9 +23,9 @@ rotateLog logfile num
| otherwise = whenM (doesFileExist currfile) $ do
rotateLog logfile (num + 1)
renameFile currfile nextfile
- where
- currfile = filename num
- nextfile = filename (num + 1)
- filename n
- | n == 0 = logfile
- | otherwise = logfile ++ "." ++ show n
+ where
+ currfile = filename num
+ nextfile = filename (num + 1)
+ filename n
+ | n == 0 = logfile
+ | otherwise = logfile ++ "." ++ show n
diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs
index ce6a16283..72f3e5815 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -36,8 +36,8 @@ query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
query opts =
withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do
parse <$> hGetContentsStrict h
- where
- p = proc "lsof" ("-F0can" : opts)
+ where
+ p = proc "lsof" ("-F0can" : opts)
{- Parsing null-delimited output like:
-
@@ -51,38 +51,36 @@ query opts =
-}
parse :: String -> [(FilePath, LsofOpenMode, ProcessInfo)]
parse s = bundle $ go [] $ lines s
- where
- bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs)
-
- go c [] = c
- go c ((t:r):ls)
- | t == 'p' =
- let (fs, ls') = parsefiles [] ls
- in go ((fs, parseprocess r):c) ls'
- | otherwise = parsefail
- go _ _ = parsefail
-
- parseprocess l =
- case splitnull l of
- [pid, 'c':cmdline, ""] ->
- case readish pid of
- (Just n) -> ProcessInfo n cmdline
- Nothing -> parsefail
- _ -> parsefail
-
- parsefiles c [] = (c, [])
- parsefiles c (l:ls) =
- case splitnull l of
- ['a':mode, 'n':file, ""] ->
- parsefiles ((file, parsemode mode):c) ls
- (('p':_):_) -> (c, l:ls)
- _ -> parsefail
-
- parsemode ('r':_) = OpenReadOnly
- parsemode ('w':_) = OpenWriteOnly
- parsemode ('u':_) = OpenReadWrite
- parsemode _ = OpenUnknown
-
- splitnull = split "\0"
-
- parsefail = error $ "failed to parse lsof output: " ++ show s
+ where
+ bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs)
+
+ go c [] = c
+ go c ((t:r):ls)
+ | t == 'p' =
+ let (fs, ls') = parsefiles [] ls
+ in go ((fs, parseprocess r):c) ls'
+ | otherwise = parsefail
+ go _ _ = parsefail
+
+ parseprocess l = case splitnull l of
+ [pid, 'c':cmdline, ""] ->
+ case readish pid of
+ (Just n) -> ProcessInfo n cmdline
+ Nothing -> parsefail
+ _ -> parsefail
+
+ parsefiles c [] = (c, [])
+ parsefiles c (l:ls) = case splitnull l of
+ ['a':mode, 'n':file, ""] ->
+ parsefiles ((file, parsemode mode):c) ls
+ (('p':_):_) -> (c, l:ls)
+ _ -> parsefail
+
+ parsemode ('r':_) = OpenReadOnly
+ parsemode ('w':_) = OpenWriteOnly
+ parsemode ('u':_) = OpenReadWrite
+ parsemode _ = OpenUnknown
+
+ splitnull = split "\0"
+
+ parsefail = error $ "failed to parse lsof output: " ++ show s
diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs
index 3d525e2af..89a4e7d0c 100644
--- a/Utility/Matcher.hs
+++ b/Utility/Matcher.hs
@@ -58,36 +58,36 @@ tokens = words "and or not ( )"
{- Converts a list of Tokens into a Matcher. -}
generate :: [Token op] -> Matcher op
generate = go MAny
- where
- go m [] = m
- go m ts = uncurry go $ consume m ts
+ where
+ go m [] = m
+ go m ts = uncurry go $ consume m ts
{- Consumes one or more Tokens, constructs a new Matcher,
- and returns unconsumed Tokens. -}
consume :: Matcher op -> [Token op] -> (Matcher op, [Token op])
consume m [] = (m, [])
consume m (t:ts) = go t
- where
- go And = cont $ m `MAnd` next
- go Or = cont $ m `MOr` next
- go Not = cont $ m `MAnd` MNot next
- go Open = let (n, r) = consume next rest in (m `MAnd` n, r)
- go Close = (m, ts)
- go (Operation o) = (m `MAnd` MOp o, ts)
+ where
+ go And = cont $ m `MAnd` next
+ go Or = cont $ m `MOr` next
+ go Not = cont $ m `MAnd` MNot next
+ go Open = let (n, r) = consume next rest in (m `MAnd` n, r)
+ go Close = (m, ts)
+ go (Operation o) = (m `MAnd` MOp o, ts)
- (next, rest) = consume MAny ts
- cont v = (v, rest)
+ (next, rest) = consume MAny ts
+ cont v = (v, rest)
{- Checks if a Matcher matches, using a supplied function to check
- the value of Operations. -}
match :: (op -> v -> Bool) -> Matcher op -> v -> Bool
match a m v = go m
- where
- go MAny = True
- go (MAnd m1 m2) = go m1 && go m2
- go (MOr m1 m2) = go m1 || go m2
- go (MNot m1) = not $ go m1
- go (MOp o) = a o v
+ where
+ go MAny = True
+ go (MAnd m1 m2) = go m1 && go m2
+ go (MOr m1 m2) = go m1 || go m2
+ go (MNot m1) = not $ go m1
+ go (MOp o) = a o v
{- Runs a monadic Matcher, where Operations are actions in the monad. -}
matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool
@@ -98,12 +98,12 @@ matchM m v = matchMrun m $ \o -> o v
- parameter. -}
matchMrun :: forall o (m :: * -> *). Monad m => Matcher o -> (o -> m Bool) -> m Bool
matchMrun m run = go m
- where
- go MAny = return True
- go (MAnd m1 m2) = go m1 <&&> go m2
- go (MOr m1 m2) = go m1 <||> go m2
- go (MNot m1) = liftM not (go m1)
- go (MOp o) = run o
+ where
+ go MAny = return True
+ go (MAnd m1 m2) = go m1 <&&> go m2
+ go (MOr m1 m2) = go m1 <||> go m2
+ go (MNot m1) = liftM not (go m1)
+ go (MOp o) = run o
{- Checks if a matcher contains no limits. -}
isEmpty :: Matcher a -> Bool
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 7c81f56fd..c04409563 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -33,10 +33,10 @@ readFileStrict = readFile >=> \s -> length s `seq` return s
-}
separate :: (a -> Bool) -> [a] -> ([a], [a])
separate c l = unbreak $ break c l
- where
- unbreak r@(a, b)
- | null b = r
- | otherwise = (a, tail b)
+ where
+ unbreak r@(a, b)
+ | null b = r
+ | otherwise = (a, tail b)
{- Breaks out the first line. -}
firstLine :: String -> String
@@ -47,11 +47,11 @@ firstLine = takeWhile (/= '\n')
- Segments may be empty. -}
segment :: (a -> Bool) -> [a] -> [[a]]
segment p l = map reverse $ go [] [] l
- where
- go c r [] = reverse $ c:r
- go c r (i:is)
- | p i = go [] (c:r) is
- | otherwise = go (i:c) r is
+ where
+ go c r [] = reverse $ c:r
+ go c r (i:is)
+ | p i = go [] (c:r) is
+ | otherwise = go (i:c) r is
prop_segment_regressionTest :: Bool
prop_segment_regressionTest = all id
@@ -64,11 +64,11 @@ prop_segment_regressionTest = all id
{- Includes the delimiters as segments of their own. -}
segmentDelim :: (a -> Bool) -> [a] -> [[a]]
segmentDelim p l = map reverse $ go [] [] l
- where
- go c r [] = reverse $ c:r
- go c r (i:is)
- | p i = go [] ([i]:c:r) is
- | otherwise = go (i:c) r is
+ where
+ go c r [] = reverse $ c:r
+ go c r (i:is)
+ | p i = go [] ([i]:c:r) is
+ | otherwise = go (i:c) r is
{- Given two orderings, returns the second if the first is EQ and returns
- the first otherwise.
@@ -96,9 +96,9 @@ hGetSomeString h sz = do
fp <- mallocForeignPtrBytes sz
len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz
map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)
- where
- peekbytes :: Int -> Ptr Word8 -> IO [Word8]
- peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
+ where
+ peekbytes :: Int -> Ptr Word8 -> IO [Word8]
+ peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
{- Reaps any zombie git processes.
-
diff --git a/Utility/Mounts.hsc b/Utility/Mounts.hsc
index 0b1468521..c21a68032 100644
--- a/Utility/Mounts.hsc
+++ b/Utility/Mounts.hsc
@@ -41,21 +41,21 @@ getMounts = do
_ <- c_mounts_end h
return mntent
- where
- getmntent h c = do
- ptr <- c_mounts_next h
- if (ptr == nullPtr)
- then return $ reverse c
- else do
- mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString
- mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString
- mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString
- let ent = Mntent
- { mnt_fsname = mnt_fsname_str
- , mnt_dir = mnt_dir_str
- , mnt_type = mnt_type_str
- }
- getmntent h (ent:c)
+ where
+ getmntent h c = do
+ ptr <- c_mounts_next h
+ if (ptr == nullPtr)
+ then return $ reverse c
+ else do
+ mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString
+ mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString
+ mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString
+ let ent = Mntent
+ { mnt_fsname = mnt_fsname_str
+ , mnt_dir = mnt_dir_str
+ , mnt_type = mnt_type_str
+ }
+ getmntent h (ent:c)
{- Using unsafe imports because the C functions are belived to never block.
- Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking;
diff --git a/Utility/Network.hs b/Utility/Network.hs
index bedb37dc9..62523c9e9 100644
--- a/Utility/Network.hs
+++ b/Utility/Network.hs
@@ -17,6 +17,5 @@ import Control.Applicative
- use uname -n when available. -}
getHostname :: IO (Maybe String)
getHostname = catchMaybeIO uname_node
- where
- uname_node = takeWhile (/= '\n') <$>
- readProcess "uname" ["-n"]
+ where
+ uname_node = takeWhile (/= '\n') <$> readProcess "uname" ["-n"]
diff --git a/Utility/NotificationBroadcaster.hs b/Utility/NotificationBroadcaster.hs
index 4bbbc544a..413ec2d75 100644
--- a/Utility/NotificationBroadcaster.hs
+++ b/Utility/NotificationBroadcaster.hs
@@ -45,13 +45,13 @@ newNotificationHandle :: NotificationBroadcaster -> IO NotificationHandle
newNotificationHandle b = NotificationHandle
<$> pure b
<*> addclient
- where
- addclient = do
- s <- newEmptySV
- atomically $ do
- l <- takeTMVar b
- putTMVar b $ l ++ [s]
- return $ NotificationId $ length l
+ where
+ addclient = do
+ s <- newEmptySV
+ atomically $ do
+ l <- takeTMVar b
+ putTMVar b $ l ++ [s]
+ return $ NotificationId $ length l
{- Extracts the identifier from a notification handle.
- This can be used to eg, pass the identifier through to a WebApp. -}
@@ -66,8 +66,8 @@ sendNotification :: NotificationBroadcaster -> IO ()
sendNotification b = do
l <- atomically $ readTMVar b
mapM_ notify l
- where
- notify s = writeSV s ()
+ where
+ notify s = writeSV s ()
{- Used by a client to block until a new notification is available since
- the last time it tried. -}
diff --git a/Utility/Parallel.hs b/Utility/Parallel.hs
index 373a0ece5..b39880355 100644
--- a/Utility/Parallel.hs
+++ b/Utility/Parallel.hs
@@ -23,13 +23,13 @@ inParallel a l = do
mvars <- mapM thread l
statuses <- mapM takeMVar mvars
return $ reduce $ partition snd $ zip l statuses
- where
- reduce (x,y) = (map fst x, map fst y)
- thread v = do
- mvar <- newEmptyMVar
- _ <- forkIO $ do
- r <- try (a v) :: IO (Either SomeException Bool)
- case r of
- Left _ -> putMVar mvar False
- Right b -> putMVar mvar b
- return mvar
+ where
+ reduce (x,y) = (map fst x, map fst y)
+ thread v = do
+ mvar <- newEmptyMVar
+ _ <- forkIO $ do
+ r <- try (a v) :: IO (Either SomeException Bool)
+ case r of
+ Left _ -> putMVar mvar False
+ Right b -> putMVar mvar b
+ return mvar
diff --git a/Utility/Path.hs b/Utility/Path.hs
index 272d2e85b..4bab297da 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -23,18 +23,18 @@ parentDir :: FilePath -> FilePath
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 ""
- s = [pathSeparator]
+ where
+ dirs = filter (not . null) $ split s dir
+ slash = if isAbsolute dir then s else ""
+ s = [pathSeparator]
prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir
| null dir = True
| dir == "/" = parentDir dir == ""
| otherwise = p /= dir
- where
- p = parentDir dir
+ where
+ p = parentDir dir
{- Checks if the first FilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
@@ -42,10 +42,10 @@ prop_parentDir_basics dir
-}
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
- where
- norm p = fromMaybe "" $ absNormPath p "."
- a' = norm a
- b' = norm b
+ where
+ norm p = fromMaybe "" $ absNormPath p "."
+ a' = norm a
+ b' = norm b
{- Converts a filename into a normalized, absolute path.
-
@@ -60,8 +60,8 @@ absPath file = do
- from the specified cwd. -}
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
- where
- bad = error $ "unable to normalize " ++ file
+ where
+ bad = error $ "unable to normalize " ++ file
{- Constructs a relative path from the CWD to a file.
-
@@ -78,31 +78,31 @@ relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
-}
relPathDirToFile :: FilePath -> FilePath -> FilePath
relPathDirToFile from to = join s $ dotdots ++ uncommon
- where
- s = [pathSeparator]
- pfrom = split s from
- pto = split s to
- common = map fst $ takeWhile same $ zip pfrom pto
- same (c,d) = c == d
- uncommon = drop numcommon pto
- dotdots = replicate (length pfrom - numcommon) ".."
- numcommon = length common
+ where
+ s = [pathSeparator]
+ pfrom = split s from
+ pto = split s to
+ common = map fst $ takeWhile same $ zip pfrom pto
+ same (c,d) = c == d
+ uncommon = drop numcommon pto
+ dotdots = replicate (length pfrom - numcommon) ".."
+ numcommon = length common
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
| from == to = null r
| otherwise = not (null r)
- where
- r = relPathDirToFile from to
+ where
+ r = relPathDirToFile from to
prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
- where
- {- Two paths have the same directory component at the same
- - location, but it's not really the same directory.
- - Code used to get this wrong. -}
- same_dir_shortcurcuits_at_difference =
- relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo"
+ where
+ {- Two paths have the same directory component at the same
+ - location, but it's not really the same directory.
+ - Code used to get this wrong. -}
+ same_dir_shortcurcuits_at_difference =
+ relPathDirToFile "/tmp/r/lll/xxx/yyy/18" "/tmp/r/.git/annex/objects/18/gk/SHA256-foo/SHA256-foo" == "../../../../.git/annex/objects/18/gk/SHA256-foo/SHA256-foo"
{- Given an original list of paths, and an expanded list derived from it,
- generates a list of lists, where each sublist corresponds to one of the
@@ -114,8 +114,8 @@ segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest
- where
- (found, rest)=partition (l `dirContains`) new
+ where
+ (found, rest)=partition (l `dirContains`) new
{- This assumes that it's cheaper to call segmentPaths on the result,
- than it would be to run the action separately with each path. In
@@ -135,8 +135,8 @@ relHome path = do
{- Checks if a command is available in PATH. -}
inPath :: String -> IO Bool
inPath command = getSearchPath >>= anyM indir
- where
- indir d = doesFileExist $ d </> command
+ where
+ indir d = doesFileExist $ d </> command
{- Checks if a filename is a unix dotfile. All files inside dotdirs
- count as dotfiles. -}
@@ -146,5 +146,5 @@ dotfile file
| f == ".." = False
| f == "" = False
| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
- where
- f = takeFileName file
+ where
+ f = takeFileName file
diff --git a/Utility/Percentage.hs b/Utility/Percentage.hs
index 309e00181..1c6b50062 100644
--- a/Utility/Percentage.hs
+++ b/Utility/Percentage.hs
@@ -28,11 +28,11 @@ showPercentage :: Int -> Percentage -> String
showPercentage precision (Percentage p)
| precision == 0 || remainder == 0 = go $ show int
| otherwise = go $ show int ++ "." ++ strip0s (show remainder)
- where
- go v = v ++ "%"
- int :: Integer
- (int, frac) = properFraction (fromRational p)
- remainder = floor (frac * multiplier) :: Integer
- strip0s = reverse . dropWhile (== '0') . reverse
- multiplier :: Float
- multiplier = 10 ** (fromIntegral precision)
+ where
+ go v = v ++ "%"
+ int :: Integer
+ (int, frac) = properFraction (fromRational p)
+ remainder = floor (frac * multiplier) :: Integer
+ strip0s = reverse . dropWhile (== '0') . reverse
+ multiplier :: Float
+ multiplier = 10 ** (fromIntegral precision)
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 14d40f0c4..11a9a4f38 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -59,11 +59,11 @@ readProcessEnv cmd args environ =
output <- hGetContentsStrict h
hClose h
return output
- where
- p = (proc cmd args)
- { std_out = CreatePipe
- , env = environ
- }
+ where
+ p = (proc cmd args)
+ { std_out = CreatePipe
+ , env = environ
+ }
{- Writes a string to a process on its stdin,
- returns its output, and also allows specifying the environment.
@@ -99,13 +99,13 @@ writeReadProcessEnv cmd args environ input adjusthandle = do
return output
- where
- p = (proc cmd args)
- { std_in = CreatePipe
- , std_out = CreatePipe
- , std_err = Inherit
- , env = environ
- }
+ where
+ p = (proc cmd args)
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ , env = environ
+ }
{- Waits for a ProcessHandle, and throws an IOError if the process
- did not exit successfully. -}
@@ -156,19 +156,19 @@ withHandle
-> (Handle -> IO a)
-> IO a
withHandle h creator p a = creator p' $ a . select
- where
- base = p
- { std_in = Inherit
- , std_out = Inherit
- , std_err = Inherit
- }
- (select, p')
- | h == StdinHandle =
- (stdinHandle, base { std_in = CreatePipe })
- | h == StdoutHandle =
- (stdoutHandle, base { std_out = CreatePipe })
- | h == StderrHandle =
- (stderrHandle, base { std_err = CreatePipe })
+ where
+ base = p
+ { std_in = Inherit
+ , std_out = Inherit
+ , std_err = Inherit
+ }
+ (select, p')
+ | h == StdinHandle =
+ (stdinHandle, base { std_in = CreatePipe })
+ | h == StdoutHandle =
+ (stdoutHandle, base { std_out = CreatePipe })
+ | h == StderrHandle =
+ (stderrHandle, base { std_err = CreatePipe })
{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
withBothHandles
@@ -177,12 +177,12 @@ withBothHandles
-> ((Handle, Handle) -> IO a)
-> IO a
withBothHandles creator p a = creator p' $ a . bothHandles
- where
- p' = p
- { std_in = CreatePipe
- , std_out = CreatePipe
- , std_err = Inherit
- }
+ where
+ p' = p
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ }
{- Forces the CreateProcessRunner to run quietly;
- both stdout and stderr are discarded. -}
@@ -223,21 +223,21 @@ debugProcess p = do
[ action ++ ":"
, showCmd p
]
- where
- action
- | piped (std_in p) && piped (std_out p) = "chat"
- | piped (std_in p) = "feed"
- | piped (std_out p) = "read"
- | otherwise = "call"
- piped Inherit = False
- piped _ = True
+ where
+ action
+ | piped (std_in p) && piped (std_out p) = "chat"
+ | piped (std_in p) = "feed"
+ | piped (std_out p) = "read"
+ | otherwise = "call"
+ piped Inherit = False
+ piped _ = True
{- Shows the command that a CreateProcess will run. -}
showCmd :: CreateProcess -> String
showCmd = go . cmdspec
- where
- go (ShellCommand s) = s
- go (RawCommand c ps) = c ++ " " ++ show ps
+ where
+ go (ShellCommand s) = s
+ go (RawCommand c ps) = c ++ " " ++ show ps
{- Wrappers for System.Process functions that do debug logging.
-
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 68d27550c..09e7d8282 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -15,11 +15,11 @@ import Data.Char
- shell. -}
rsyncShell :: [CommandParam] -> [CommandParam]
rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)]
- where
- {- rsync requires some weird, non-shell like quoting in
- - here. A doubled single quote inside the single quoted
- - string is a single quote. -}
- escape s = "'" ++ join "''" (split "'" s) ++ "'"
+ where
+ {- rsync requires some weird, non-shell like quoting in
+ - here. A doubled single quote inside the single quoted
+ - string is a single quote. -}
+ escape s = "'" ++ join "''" (split "'" s) ++ "'"
{- Runs rsync in server mode to send a file. -}
rsyncServerSend :: FilePath -> IO Bool
@@ -60,22 +60,22 @@ rsyncProgress callback params = do
- on. Reap the resulting zombie. -}
reapZombies
return r
- where
- p = proc "rsync" (toCommand params)
- feedprogress prev buf h = do
- s <- hGetSomeString h 80
- if null s
- then return True
- else do
- putStr s
- hFlush stdout
- let (mbytes, buf') = parseRsyncProgress (buf++s)
- case mbytes of
- Nothing -> feedprogress prev buf' h
- (Just bytes) -> do
- when (bytes /= prev) $
- callback bytes
- feedprogress bytes buf' h
+ where
+ p = proc "rsync" (toCommand params)
+ feedprogress prev buf h = do
+ s <- hGetSomeString h 80
+ if null s
+ then return True
+ else do
+ putStr s
+ hFlush stdout
+ let (mbytes, buf') = parseRsyncProgress (buf++s)
+ case mbytes of
+ Nothing -> feedprogress prev buf' h
+ (Just bytes) -> do
+ when (bytes /= prev) $
+ callback bytes
+ feedprogress bytes buf' h
{- Checks if an rsync url involves the remote shell (ssh or rsh).
- Use of such urls with rsync requires additional shell
@@ -84,13 +84,13 @@ rsyncUrlIsShell :: String -> Bool
rsyncUrlIsShell s
| "rsync://" `isPrefixOf` s = False
| otherwise = go s
- where
- -- host::dir is rsync protocol, while host:dir is ssh/rsh
- go [] = False
- go (c:cs)
- | c == '/' = False -- got to directory with no colon
- | c == ':' = not $ ":" `isPrefixOf` cs
- | otherwise = go cs
+ where
+ -- host::dir is rsync protocol, while host:dir is ssh/rsh
+ go [] = False
+ go (c:cs)
+ | c == '/' = False -- got to directory with no colon
+ | c == ':' = not $ ":" `isPrefixOf` cs
+ | otherwise = go cs
{- Checks if a rsync url is really just a local path. -}
rsyncUrlIsPath :: String -> Bool
@@ -113,19 +113,19 @@ rsyncUrlIsPath s
-}
parseRsyncProgress :: String -> (Maybe Integer, String)
parseRsyncProgress = go [] . reverse . progresschunks
- where
- go remainder [] = (Nothing, remainder)
- go remainder (x:xs) = case parsebytes (findbytesstart x) of
- Nothing -> go (delim:x++remainder) xs
- Just b -> (Just b, remainder)
+ where
+ go remainder [] = (Nothing, remainder)
+ go remainder (x:xs) = case parsebytes (findbytesstart x) of
+ Nothing -> go (delim:x++remainder) xs
+ Just b -> (Just b, remainder)
- delim = '\r'
- {- Find chunks that each start with delim.
- - The first chunk doesn't start with it
- - (it's empty when delim is at the start of the string). -}
- progresschunks = drop 1 . split [delim]
- findbytesstart s = dropWhile isSpace s
- parsebytes s = case break isSpace s of
- ([], _) -> Nothing
- (_, []) -> Nothing
- (b, _) -> readish b
+ delim = '\r'
+ {- Find chunks that each start with delim.
+ - The first chunk doesn't start with it
+ - (it's empty when delim is at the start of the string). -}
+ progresschunks = drop 1 . split [delim]
+ findbytesstart s = dropWhile isSpace s
+ parsebytes s = case break isSpace s of
+ ([], _) -> Nothing
+ (_, []) -> Nothing
+ (b, _) -> readish b
diff --git a/Utility/SRV.hs b/Utility/SRV.hs
index bbfc7276d..9a099089e 100644
--- a/Utility/SRV.hs
+++ b/Utility/SRV.hs
@@ -74,11 +74,11 @@ lookupSRV (SRV srv) = do
r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv
print r
return $ maybe [] (orderHosts . map tohosts) r
- where
- tohosts (priority, weight, port, hostname) =
- ( (priority, weight)
- , (B8.toString hostname, PortNumber $ fromIntegral port)
- )
+ where
+ tohosts (priority, weight, port, hostname) =
+ ( (priority, weight)
+ , (B8.toString hostname, PortNumber $ fromIntegral port)
+ )
#else
lookupSRV = lookupSRVHost
#endif
@@ -93,21 +93,21 @@ lookupSRVHost (SRV srv) = catchDefaultIO [] $
parseSrvHost :: String -> [HostPort]
parseSrvHost = orderHosts . catMaybes . map parse . lines
- where
- parse l = case words l of
- [_, _, _, _, spriority, sweight, sport, hostname] -> do
- let v =
- ( readish sport :: Maybe Int
- , readish spriority :: Maybe Int
- , readish sweight :: Maybe Int
+ where
+ parse l = case words l of
+ [_, _, _, _, spriority, sweight, sport, hostname] -> do
+ let v =
+ ( readish sport :: Maybe Int
+ , readish spriority :: Maybe Int
+ , readish sweight :: Maybe Int
+ )
+ case v of
+ (Just port, Just priority, Just weight) -> Just
+ ( (priority, weight)
+ , (hostname, PortNumber $ fromIntegral port)
)
- case v of
- (Just port, Just priority, Just weight) -> Just
- ( (priority, weight)
- , (hostname, PortNumber $ fromIntegral port)
- )
- _ -> Nothing
- _ -> Nothing
+ _ -> Nothing
+ _ -> Nothing
orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort]
orderHosts = map snd . sortBy (compare `on` fst)
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index fbea7b6b2..026456327 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -25,13 +25,13 @@ data CommandParam = Params String | Param String | File FilePath
- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
toCommand = (>>= unwrap)
- where
- unwrap (Param s) = [s]
- unwrap (Params s) = filter (not . null) (split " " s)
- -- Files that start with a dash are modified to avoid
- -- the command interpreting them as options.
- unwrap (File s@('-':_)) = ["./" ++ s]
- unwrap (File s) = [s]
+ where
+ unwrap (Param s) = [s]
+ unwrap (Params s) = filter (not . null) (split " " s)
+ -- Files that start with a dash are modified to avoid
+ -- the command interpreting them as options.
+ unwrap (File s@('-':_)) = ["./" ++ s]
+ unwrap (File s) = [s]
{- Run a system command, and returns True or False
- if it succeeded or failed.
@@ -41,9 +41,9 @@ boolSystem command params = boolSystemEnv command params Nothing
boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
- where
- dispatch ExitSuccess = True
- dispatch _ = False
+ where
+ dispatch ExitSuccess = True
+ dispatch _ = False
{- Runs a system command, returning the exit status. -}
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
@@ -59,26 +59,26 @@ safeSystemEnv command params environ = do
- the shell. -}
shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
- where
- -- replace ' with '"'"'
- escaped = join "'\"'\"'" $ split "'" f
+ where
+ -- replace ' with '"'"'
+ escaped = join "'\"'\"'" $ split "'" f
{- Unescapes a set of shellEscaped words or filenames. -}
shellUnEscape :: String -> [String]
shellUnEscape [] = []
shellUnEscape s = word : shellUnEscape rest
- where
- (word, rest) = findword "" s
- findword w [] = (w, "")
- findword w (c:cs)
- | c == ' ' = (w, cs)
- | c == '\'' = inquote c w cs
- | c == '"' = inquote c w cs
- | otherwise = findword (w++[c]) cs
- inquote _ w [] = (w, "")
- inquote q w (c:cs)
- | c == q = findword w cs
- | otherwise = inquote q (w++[c]) cs
+ where
+ (word, rest) = findword "" s
+ findword w [] = (w, "")
+ findword w (c:cs)
+ | c == ' ' = (w, cs)
+ | c == '\'' = inquote c w cs
+ | c == '"' = inquote c w cs
+ | otherwise = findword (w++[c]) cs
+ inquote _ w [] = (w, "")
+ inquote q w (c:cs)
+ | c == q = findword w cs
+ | otherwise = inquote q (w++[c]) cs
{- For quickcheck. -}
prop_idempotent_shellEscape :: String -> Bool
diff --git a/Utility/TSet.hs b/Utility/TSet.hs
index 24d345477..bb711a4fb 100644
--- a/Utility/TSet.hs
+++ b/Utility/TSet.hs
@@ -23,12 +23,12 @@ getTSet :: TSet a -> IO [a]
getTSet tset = runTSet $ do
c <- readTChan tset
go [c]
- where
- go l = do
- v <- tryReadTChan tset
- case v of
- Nothing -> return l
- Just c -> go (c:l)
+ where
+ go l = do
+ v <- tryReadTChan tset
+ case v of
+ Nothing -> return l
+ Just c -> go (c:l)
{- Puts items into a TSet. -}
putTSet :: TSet a -> [a] -> IO ()
diff --git a/Utility/Tense.hs b/Utility/Tense.hs
index 135a90af2..60b3fa513 100644
--- a/Utility/Tense.hs
+++ b/Utility/Tense.hs
@@ -32,11 +32,11 @@ instance IsString TenseText where
renderTense :: Tense -> TenseText -> Text
renderTense tense (TenseText chunks) = T.concat $ map render chunks
- where
- render (Tensed present past)
- | tense == Present = present
- | otherwise = past
- render (UnTensed s) = s
+ where
+ render (Tensed present past)
+ | tense == Present = present
+ | otherwise = past
+ render (UnTensed s) = s
{- Builds up a TenseText, separating chunks with spaces.
-
@@ -45,13 +45,13 @@ renderTense tense (TenseText chunks) = T.concat $ map render chunks
-}
tenseWords :: [TenseChunk] -> TenseText
tenseWords = TenseText . go []
- where
- go c [] = reverse c
- go c (w:[]) = reverse (w:c)
- go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws
- go c ((Tensed w1 w2):ws) =
- go (Tensed (addspace w1) (addspace w2) : c) ws
- addspace w = T.append w " "
+ where
+ go c [] = reverse c
+ go c (w:[]) = reverse (w:c)
+ go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws
+ go c ((Tensed w1 w2):ws) =
+ go (Tensed (addspace w1) (addspace w2) : c) ws
+ addspace w = T.append w " "
unTensed :: Text -> TenseText
unTensed t = TenseText [UnTensed t]
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
index 6557398fd..96bccbe70 100644
--- a/Utility/ThreadScheduler.hs
+++ b/Utility/ThreadScheduler.hs
@@ -26,8 +26,8 @@ runEvery n a = forever $ do
threadDelaySeconds :: Seconds -> IO ()
threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
- where
- oneSecond = 1000000 -- microseconds
+ where
+ oneSecond = 1000000 -- microseconds
{- Like threadDelay, but not bounded by an Int.
-
@@ -52,6 +52,6 @@ waitForTermination = do
whenM (queryTerminal stdInput) $
check keyboardSignal lock
takeMVar lock
- where
- check sig lock = void $
- installHandler sig (CatchOnce $ putMVar lock ()) Nothing
+ where
+ check sig lock = void $
+ installHandler sig (CatchOnce $ putMVar lock ()) Nothing
diff --git a/Utility/Touch.hsc b/Utility/Touch.hsc
index 0b1ca3d9b..53dd719fb 100644
--- a/Utility/Touch.hsc
+++ b/Utility/Touch.hsc
@@ -48,9 +48,9 @@ at_symlink_nofollow = #const AT_SYMLINK_NOFOLLOW
instance Storable TimeSpec where
-- use the larger alignment of the two types in the struct
alignment _ = max sec_alignment nsec_alignment
- where
- sec_alignment = alignment (undefined::CTime)
- nsec_alignment = alignment (undefined::CLong)
+ where
+ sec_alignment = alignment (undefined::CTime)
+ nsec_alignment = alignment (undefined::CLong)
sizeOf _ = #{size struct timespec}
peek ptr = do
sec <- #{peek struct timespec, tv_sec} ptr
@@ -70,10 +70,10 @@ touchBoth file atime mtime follow =
pokeArray ptr [atime, mtime]
r <- c_utimensat at_fdcwd f ptr flags
when (r /= 0) $ throwErrno "touchBoth"
- where
- flags = if follow
- then 0
- else at_symlink_nofollow
+ where
+ flags
+ | follow = 0
+ | otherwise = at_symlink_nofollow
#else
#if 0
@@ -108,10 +108,10 @@ touchBoth file atime mtime follow =
r <- syscall f ptr
when (r /= 0) $
throwErrno "touchBoth"
- where
- syscall = if follow
- then c_lutimes
- else c_utimes
+ where
+ syscall
+ | follow = c_lutimes
+ | otherwise = c_utimes
#else
#warning "utimensat and lutimes not available; building without symlink timestamp preservation support"
diff --git a/Utility/Url.hs b/Utility/Url.hs
index e47cb9dee..67efdb558 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -29,10 +29,10 @@ type Headers = [String]
- also checking that its size, if available, matches a specified size. -}
check :: URLString -> Headers -> Maybe Integer -> IO Bool
check url headers expected_size = handle <$> exists url headers
- where
- handle (False, _) = False
- handle (True, Nothing) = True
- handle (True, s) = expected_size == s
+ where
+ handle (False, _) = False
+ handle (True, Nothing) = True
+ handle (True, s) = expected_size == s
{- Checks that an url exists and could be successfully downloaded,
- also returning its size if available. -}
@@ -50,8 +50,8 @@ exists url headers = case parseURI url of
case rspCode r of
(2,_,_) -> return (True, size r)
_ -> return (False, Nothing)
- where
- size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders
+ where
+ size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders
{- Used to download large files, such as the contents of keys.
-
@@ -66,17 +66,17 @@ download :: URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool
download url headers options file
| "file://" `isPrefixOf` url = curl
| otherwise = ifM (inPath "wget") (wget , curl)
- where
- headerparams = map (\h -> Param $ "--header=" ++ h) headers
- wget = go "wget" $ headerparams ++ [Params "-c -O"]
- {- Uses the -# progress display, because the normal
- - one is very confusing when resuming, showing
- - the remainder to download as the whole file,
- - and not indicating how much percent was
- - downloaded before the resume. -}
- curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"]
- go cmd opts = boolSystem cmd $
- options++opts++[File file, File url]
+ where
+ headerparams = map (\h -> Param $ "--header=" ++ h) headers
+ wget = go "wget" $ headerparams ++ [Params "-c -O"]
+ {- Uses the -# progress display, because the normal
+ - one is very confusing when resuming, showing
+ - the remainder to download as the whole file,
+ - and not indicating how much percent was
+ - downloaded before the resume. -}
+ curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"]
+ go cmd opts = boolSystem cmd $
+ options++opts++[File file, File url]
{- Downloads a small file. -}
get :: URLString -> Headers -> IO String
@@ -98,36 +98,36 @@ get url headers =
-}
request :: URI -> Headers -> RequestMethod -> IO (Response String)
request url headers requesttype = go 5 url
- where
- go :: Int -> URI -> IO (Response String)
- go 0 _ = error "Too many redirects "
- go n u = do
- rsp <- Browser.browse $ do
- Browser.setErrHandler ignore
- Browser.setOutHandler ignore
- Browser.setAllowRedirects False
- let req = mkRequest requesttype u :: Request_String
- snd <$> Browser.request (addheaders req)
- case rspCode rsp of
- (3,0,x) | x /= 5 -> redir (n - 1) u rsp
- _ -> return rsp
- ignore = const noop
- redir n u rsp = case retrieveHeaders HdrLocation rsp of
- [] -> return rsp
- (Header _ newu:_) ->
- case parseURIReference newu of
- Nothing -> return rsp
- Just newURI -> go n newURI_abs
- where
+ where
+ go :: Int -> URI -> IO (Response String)
+ go 0 _ = error "Too many redirects "
+ go n u = do
+ rsp <- Browser.browse $ do
+ Browser.setErrHandler ignore
+ Browser.setOutHandler ignore
+ Browser.setAllowRedirects False
+ let req = mkRequest requesttype u :: Request_String
+ snd <$> Browser.request (addheaders req)
+ case rspCode rsp of
+ (3,0,x) | x /= 5 -> redir (n - 1) u rsp
+ _ -> return rsp
+ ignore = const noop
+ redir n u rsp = case retrieveHeaders HdrLocation rsp of
+ [] -> return rsp
+ (Header _ newu:_) ->
+ case parseURIReference newu of
+ Nothing -> return rsp
+ Just newURI -> go n newURI_abs
+ where
#if defined VERSION_network
#if ! MIN_VERSION_network(2,4,0)
#define WITH_OLD_URI
#endif
#endif
#ifdef WITH_OLD_URI
- newURI_abs = fromMaybe newURI (newURI `relativeTo` u)
+ newURI_abs = fromMaybe newURI (newURI `relativeTo` u)
#else
- newURI_abs = newURI `relativeTo` u
+ newURI_abs = newURI `relativeTo` u
#endif
- addheaders req = setHeaders req (rqHeaders req ++ userheaders)
- userheaders = rights $ map parseHeader headers
+ addheaders req = setHeaders req (rqHeaders req ++ userheaders)
+ userheaders = rights $ map parseHeader headers
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index 6e757548a..bdddf4f8e 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -26,7 +26,7 @@ myUserName = myVal ["USER", "LOGNAME"] userName
myVal :: [String] -> (UserEntry -> String) -> IO String
myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars
- where
- check [] = return Nothing
- check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
- getpwent = getUserEntryForID =<< getEffectiveUserID
+ where
+ check [] = return Nothing
+ check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
+ getpwent = getUserEntryForID =<< getEffectiveUserID
diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs
index d586d7453..4f88cb9f2 100644
--- a/Utility/Verifiable.hs
+++ b/Utility/Verifiable.hs
@@ -33,5 +33,5 @@ calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v
{- for quickcheck -}
prop_verifiable_sane :: String -> String -> Bool
prop_verifiable_sane a s = verify (mkVerifiable a secret) secret
- where
- secret = fromString s
+ where
+ secret = fromString s
diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs
index 0c3f6040d..6f64b2bdf 100644
--- a/Utility/WebApp.hs
+++ b/Utility/WebApp.hs
@@ -43,11 +43,11 @@ localhost = "localhost"
- Note: The url *will* be visible to an attacker. -}
runBrowser :: String -> (Maybe [(String, String)]) -> IO Bool
runBrowser url env = boolSystemEnv cmd [Param url] env
- where
+ where
#ifdef darwin_HOST_OS
- cmd = "open"
+ cmd = "open"
#else
- cmd = "xdg-open"
+ cmd = "xdg-open"
#endif
{- Binds to a socket on localhost, and runs a webapp on it.
@@ -75,25 +75,25 @@ localSocket = do
(v4addr:_, _) -> go v4addr
(_, v6addr:_) -> go v6addr
_ -> error "unable to bind to a local socket"
- where
- hints = defaultHints
- { addrFlags = [AI_ADDRCONFIG]
- , addrSocketType = Stream
- }
- {- Repeated attempts because bind sometimes fails for an
- - unknown reason on OSX. -}
- go addr = go' 100 addr
- go' :: Int -> AddrInfo -> IO Socket
- go' 0 _ = error "unable to bind to local socket"
- go' n addr = do
- r <- tryIO $ bracketOnError (open addr) sClose (use addr)
- either (const $ go' (pred n) addr) return r
- open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
- use addr sock = do
- setSocketOption sock ReuseAddr 1
- bindSocket sock (addrAddress addr)
- listen sock maxListenQueue
- return sock
+ where
+ hints = defaultHints
+ { addrFlags = [AI_ADDRCONFIG]
+ , addrSocketType = Stream
+ }
+ {- Repeated attempts because bind sometimes fails for an
+ - unknown reason on OSX. -}
+ go addr = go' 100 addr
+ go' :: Int -> AddrInfo -> IO Socket
+ go' 0 _ = error "unable to bind to local socket"
+ go' n addr = do
+ r <- tryIO $ bracketOnError (open addr) sClose (use addr)
+ either (const $ go' (pred n) addr) return r
+ open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+ use addr sock = do
+ setSocketOption sock ReuseAddr 1
+ bindSocket sock (addrAddress addr)
+ listen sock maxListenQueue
+ return sock
{- Checks if debugging is actually enabled. -}
debugEnabled :: IO Bool
@@ -121,8 +121,8 @@ logRequest req = do
--, frombs $ lookupRequestField "referer" req
, frombs $ lookupRequestField "user-agent" req
]
- where
- frombs v = toString $ L.fromChunks [v]
+ where
+ frombs v = toString $ L.fromChunks [v]
lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString
lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
@@ -179,12 +179,12 @@ insertAuthToken :: forall y. (y -> T.Text)
-> Builder
insertAuthToken extractToken predicate webapp root pathbits params =
fromText root `mappend` encodePath pathbits' encodedparams
- where
- pathbits' = if null pathbits then [T.empty] else pathbits
- encodedparams = map (TE.encodeUtf8 *** go) params'
- go "" = Nothing
- go x = Just $ TE.encodeUtf8 x
- authparam = (T.pack "auth", extractToken webapp)
- params'
- | predicate pathbits = authparam:params
- | otherwise = params
+ where
+ pathbits' = if null pathbits then [T.empty] else pathbits
+ encodedparams = map (TE.encodeUtf8 *** go) params'
+ go "" = Nothing
+ go x = Just $ TE.encodeUtf8 x
+ authparam = (T.pack "auth", extractToken webapp)
+ params'
+ | predicate pathbits = authparam:params
+ | otherwise = params
diff --git a/debian/changelog b/debian/changelog
index a0ad1b0ad..ec9b9f6e3 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,4 +1,4 @@
-git-annex (3.20121128) UNRELEASED; urgency=low
+git-annex (3.20121211) unstable; urgency=low
* webapp: Defaults to sharing box.com account info with friends, allowing
one-click enabling of the repository.
@@ -31,7 +31,7 @@ git-annex (3.20121128) UNRELEASED; urgency=low
* assistant: Fix syncing to just created ssh remotes.
* Enable WebDAV support in Debian package. Closes: #695532
- -- Joey Hess <joeyh@debian.org> Wed, 28 Nov 2012 13:31:07 -0400
+ -- Joey Hess <joeyh@debian.org> Tue, 11 Dec 2012 11:25:03 -0400
git-annex (3.20121127) unstable; urgency=low
diff --git a/debian/rules b/debian/rules
index c080ae506..1b8927957 100755
--- a/debian/rules
+++ b/debian/rules
@@ -2,7 +2,7 @@
ARCH = $(shell dpkg-architecture -qDEB_BUILD_ARCH)
ifeq (install ok installed,$(shell dpkg-query -W -f '$${Status}' libghc-yesod-dev 2>/dev/null))
-export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBDAV -DWITH_HOST -DWITH_OLD_URI -DWITH_OLD_YESOD -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP
+export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBDAV -DWITH_HOST -DWITH_OLD_URI -DWITH_PAIRING -DWITH_XMPP -DWITH_WEBAPP -DWITH_OLD_YESOD
else
export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBDAV -DWITH_HOST -DWITH_OLD_URI -DWITH_PAIRING -DWITH_XMPP
endif
diff --git a/doc/assistant/release_notes.mdwn b/doc/assistant/release_notes.mdwn
index ee2faefba..1b39c5086 100644
--- a/doc/assistant/release_notes.mdwn
+++ b/doc/assistant/release_notes.mdwn
@@ -1,3 +1,38 @@
+## version 3.20121211
+
+This release of the git-annex assistant (which is still in beta)
+consists of mostly bugfixes, user interface improvements, and improvements
+to existing features.
+
+In general, anything you can configure with the assistant's web app
+will work. Some examples of use cases supported by this release include:
+
+* Using Box.com's 5 gigabytes of free storage space as a cloud transfer
+ point between between repositories that cannot directly contact
+ one-another. (Many other cloud providers are also supported, from Rsync.net
+ to Amazon S3, to your own ssh server.)
+* Archiving or backing up files to Amazon Glacier. See [[archival_walkthrough]].
+* [[Sharing repositories with friends|share_with_a_friend_walkthrough]]
+ contacted through a Jabber server (such as Google Talk).
+* [[Pairing|pairing_walkthrough]] two computers that are on the same local
+ network (or VPN) and automatically keeping the files in the annex in
+ sync as changes are made to them.
+* Cloning your repository to removable drives, USB keys, etc. The assistant
+ will notice when the drive is mounted and keep it in sync.
+ Such a drive can be stored as an offline backup, or transported between
+ computers to keep them in sync.
+
+The following are known limitations of this release of the git-annex
+assistant:
+
+* The Max OSX standalone app may not work on all versions of Max OSX.
+ Please test!
+* On Mac OSX and BSD operating systems, the assistant uses kqueue to watch
+ files. Kqueue has to open every directory it watches, so too many
+ directories will run it out of the max number of open files (typically
+ 1024), and fail. See [[bugs/Issue_on_OSX_with_some_system_limits]]
+ for a workaround.
+
## version 3.20121126
This adds several features to the git-annex assistant, which is still in beta.
diff --git a/doc/bugs/OSX_app_issues.mdwn b/doc/bugs/OSX_app_issues.mdwn
index 8af06b15f..95a34eff4 100644
--- a/doc/bugs/OSX_app_issues.mdwn
+++ b/doc/bugs/OSX_app_issues.mdwn
@@ -1,4 +1,6 @@
This is a collection of problem reports for the standalone OSX app.
If you have a problem using it, post it here. --[[Joey]]
+(Some things that should be fixed now have been moved to [[old]].)
+
[[!tag /design/assistant/OSX]]
diff --git a/doc/bugs/OSX_app_issues/comment_14_5783a4716cd104e1f1c276aa0b9cb153._comment b/doc/bugs/OSX_app_issues/comment_14_5783a4716cd104e1f1c276aa0b9cb153._comment
new file mode 100644
index 000000000..a88a0047e
--- /dev/null
+++ b/doc/bugs/OSX_app_issues/comment_14_5783a4716cd104e1f1c276aa0b9cb153._comment
@@ -0,0 +1,41 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawkfHTPsiAcHEEN7Xl7WxiZmYq-vX7azxFY"
+ nickname="Vincent"
+ subject="OS/X build 2012-12-12"
+ date="2012-12-13T00:59:51Z"
+ content="""
+I installed this today from the .dmg.bz2, md5sum 1bb50b3ee5eda3cd7f4b4a70cdae1855 on OS/X 10.8.2
+
+uname -a
+Darwin foo 12.2.0 Darwin Kernel Version 12.2.0: Sat Aug 25 00:48:52 PDT 2012; root:xnu-2050.18.24~1/RELEASE_X86_64 x86_64
+
+I installed the app to the Applications folder.
+
+I had chrome and firefox running, recent versions.
+
+Double-click and it opens a new chrome window. This came up behind the existing (iconified) window. A nit, but just so you know.
+
+The configuration part of the app is shown, so far so good.
+I type in the path I want it to use (~/work/annex) and press the create button.
+It hangs forever trying to access localhost:55163
+
+ $ ps aux|grep git
+ me 85291 100.0 0.0 2460884 4160 ?? R 11:42am 12:03.72 git init --quiet /Users/me/work/annex/
+ me 85233 0.0 0.3 2687204 44064 ?? S 11:42am 0:00.44 git-annex webapp -psn_0_50204638
+ me 85226 0.0 0.0 2433432 868 ?? S 11:42am 0:00.00 /bin/sh /Applications/git-annex.app/Contents/MacOS/git-annex-webapp -psn_0_50204638
+ me 85515 0.0 0.0 2432768 620 s000 S+ 11:54am 0:00.00 grep git
+
+ $ netstat -an |grep 55163
+ tcp4 0 0 127.0.0.1.55163 127.0.0.1.55207 CLOSE_WAIT
+ tcp4 0 0 127.0.0.1.55163 127.0.0.1.55206 CLOSE_WAIT
+ tcp4 0 0 127.0.0.1.55163 127.0.0.1.55205 CLOSE_WAIT
+ tcp4 0 0 127.0.0.1.55163 127.0.0.1.55201 ESTABLISHED
+ tcp4 0 0 127.0.0.1.55201 127.0.0.1.55163 ESTABLISHED
+ tcp4 0 0 127.0.0.1.55163 127.0.0.1.55199 CLOSE_WAIT
+ tcp4 0 0 127.0.0.1.55163 127.0.0.1.55197 CLOSE_WAIT
+ tcp4 0 0 127.0.0.1.55163 *.* LISTEN
+
+I was plugged into wired ethernet, no other interfaces up, no VPN.
+
+I have macports but no haskell packages, which ghc returns nothing.
+"""]]
diff --git a/doc/bugs/OSX_app_issues/comment_15_56c7fcafc7dca8be28ebf9e37a8f6b71._comment b/doc/bugs/OSX_app_issues/comment_15_56c7fcafc7dca8be28ebf9e37a8f6b71._comment
new file mode 100644
index 000000000..1cf4916f5
--- /dev/null
+++ b/doc/bugs/OSX_app_issues/comment_15_56c7fcafc7dca8be28ebf9e37a8f6b71._comment
@@ -0,0 +1,23 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawkfHTPsiAcHEEN7Xl7WxiZmYq-vX7azxFY"
+ nickname="Vincent"
+ subject="comment 15"
+ date="2012-12-13T01:04:44Z"
+ content="""
+following up to #14.
+
+ dtruss -p <git --init process>
+
+shows the same symptom as reported earlier
+ SYSCALL(args) = return
+ workq_kernreturn(0x1, 0x10F31E000, 0x0) = -1 Err#22
+ workq_kernreturn(0x1, 0x10F31E000, 0x0) = -1 Err#22
+ workq_kernreturn(0x1, 0x10F31E000, 0x0) = -1 Err#22
+ workq_kernreturn(0x1, 0x10F31E000, 0x0) = -1 Err#22
+ workq_kernreturn(0x1, 0x10F31E000, 0x0) = -1 Err#22
+ workq_kernreturn(0x1, 0x10F31E000, 0x0) = -1 Err#22
+ ...
+ workq_kernreturn(0x1, 0x10F31E000, 0x0) = -1 Err#22
+ dtrace: 339527 drops on CPU 0
+
+"""]]
diff --git a/doc/bugs/OSX_app_issues/old.mdwn b/doc/bugs/OSX_app_issues/old.mdwn
new file mode 100644
index 000000000..42f77125d
--- /dev/null
+++ b/doc/bugs/OSX_app_issues/old.mdwn
@@ -0,0 +1 @@
+These issues should be fixed now.
diff --git a/doc/bugs/OSX_app_issues/comment_11_a30e69fed14b0809184ffe05358ab871._comment b/doc/bugs/OSX_app_issues/old/comment_11_a30e69fed14b0809184ffe05358ab871._comment
index a25514ba9..a25514ba9 100644
--- a/doc/bugs/OSX_app_issues/comment_11_a30e69fed14b0809184ffe05358ab871._comment
+++ b/doc/bugs/OSX_app_issues/old/comment_11_a30e69fed14b0809184ffe05358ab871._comment
diff --git a/doc/bugs/OSX_app_issues/comment_3_08613b2e2318680508483d204a43da76._comment b/doc/bugs/OSX_app_issues/old/comment_3_08613b2e2318680508483d204a43da76._comment
index 24b6bde51..24b6bde51 100644
--- a/doc/bugs/OSX_app_issues/comment_3_08613b2e2318680508483d204a43da76._comment
+++ b/doc/bugs/OSX_app_issues/old/comment_3_08613b2e2318680508483d204a43da76._comment
diff --git a/doc/bugs/OSX_app_issues/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment b/doc/bugs/OSX_app_issues/old/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment
index 62851c15b..62851c15b 100644
--- a/doc/bugs/OSX_app_issues/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment
+++ b/doc/bugs/OSX_app_issues/old/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment
diff --git a/doc/bugs/OSX_app_issues/comment_6_cea97dbbfb566a9fe463365ca4511119._comment b/doc/bugs/OSX_app_issues/old/comment_6_cea97dbbfb566a9fe463365ca4511119._comment
index 6c968aa1e..6c968aa1e 100644
--- a/doc/bugs/OSX_app_issues/comment_6_cea97dbbfb566a9fe463365ca4511119._comment
+++ b/doc/bugs/OSX_app_issues/old/comment_6_cea97dbbfb566a9fe463365ca4511119._comment
diff --git a/doc/bugs/OSX_app_issues/comment_7_911f187d46890093a54859032ada2442._comment b/doc/bugs/OSX_app_issues/old/comment_7_911f187d46890093a54859032ada2442._comment
index 636627959..636627959 100644
--- a/doc/bugs/OSX_app_issues/comment_7_911f187d46890093a54859032ada2442._comment
+++ b/doc/bugs/OSX_app_issues/old/comment_7_911f187d46890093a54859032ada2442._comment
diff --git a/doc/bugs/OSX_app_issues/comment_8_08b091a58106ca6050ac669579ed9ff4._comment b/doc/bugs/OSX_app_issues/old/comment_8_08b091a58106ca6050ac669579ed9ff4._comment
index d32d9a024..d32d9a024 100644
--- a/doc/bugs/OSX_app_issues/comment_8_08b091a58106ca6050ac669579ed9ff4._comment
+++ b/doc/bugs/OSX_app_issues/old/comment_8_08b091a58106ca6050ac669579ed9ff4._comment
diff --git a/doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn b/doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn
new file mode 100644
index 000000000..dad961d9f
--- /dev/null
+++ b/doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn
@@ -0,0 +1,5 @@
+[Due to some stupid issue on my and AT&T's part] one of my remote repositories is currently unreachable. I would like to tell the webapp/assistant to not attempt to sync with it, or, at least, modify this error message to be more specific (by telling me which repository is unreachable).
+
+In a red bubble it says: "Synced with rose 60justin"
+
+That verbage is the same if they all succeed. The only difference is the red instead of green. Would be nice to know exactly which machine to kick (if I didn't already know, eg I was syncing only with repositories not under my control).
diff --git a/doc/bugs/git-annex_fix_not_noticing_file_renames.mdwn b/doc/bugs/git-annex_fix_not_noticing_file_renames.mdwn
new file mode 100644
index 000000000..4a7a965d1
--- /dev/null
+++ b/doc/bugs/git-annex_fix_not_noticing_file_renames.mdwn
@@ -0,0 +1,33 @@
+What steps will reproduce the problem?
+
+ ~$ mkdir testannex
+ ~$ cd testannex/
+ testannex$ git init
+ Initialized empty Git repository in /Users/ed/testannex/.git/
+ testannex$ git annex init "test annex"
+ init test annex ok
+ (Recording state in git...)
+ testannex$ echo "file1" > file1
+ testannex$ git annex add file1
+ add file1 (checksum...) ok
+ (Recording state in git...)
+ testannex$ mkdir directory
+ testannex$ mv file1 directory/
+ testannex$ cat directory/file1
+ cat: directory/file1: No such file or directory
+ testannex$ git annex fix directory/file1
+ git-annex: directory/file1 not found
+
+
+What is the expected output? What do you see instead?
+
+ git annex fix should fix the symlink. It looks like maybe it's *following* the symlink?
+
+What version of git-annex are you using? On what operating system?
+
+ checkout: 20d195f compiled on OS X 10.7 using cabal.
+
+Please provide any additional information below.
+
+ git annex assistant is not noticing file renames either.
+
diff --git a/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform.mdwn b/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform.mdwn
new file mode 100644
index 000000000..cd3e54144
--- /dev/null
+++ b/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform.mdwn
@@ -0,0 +1,20 @@
+I updated haskell platform, and now
+
+<pre>
+[jtang@x00 git-annex (master)]$ make test
+
+Assistant/Threads/NetWatcher.hs:26:2:
+ warning: #warning Building without dbus support; will poll for network connection changes [-Wcpp]
+
+Assistant/Threads/MountWatcher.hs:33:2:
+ warning: #warning Building without dbus support; will use mtab polling [-Wcpp]
+
+test.hs:11:8:
+ Could not find module `Test.HUnit.Tools'
+ Perhaps you meant Test.HUnit.Text (from HUnit-1.2.5.1)
+ Use -v to see a list of the files searched for.
+** failed to build the test suite
+make: *** [test] Error 1
+</pre>
+
+Looks like a missing dep somewhere with testpack or quickcheck... I haven't had time to figure it out yet, its not git-annex specific but I thought I might log it as a reminder for myself just in case if the osxapp is more borked than usual, I probably need to flush my .cabal directory of installed userland dependancies.
diff --git a/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_1_20a6fe046111e9ae56fd4d9c9f41f536._comment b/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_1_20a6fe046111e9ae56fd4d9c9f41f536._comment
new file mode 100644
index 000000000..cff4254c9
--- /dev/null
+++ b/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_1_20a6fe046111e9ae56fd4d9c9f41f536._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="4.153.8.117"
+ subject="comment 1"
+ date="2012-12-10T19:18:59Z"
+ content="""
+Test.HUnit.Tools is part of testpack: <http://hackage.haskell.org/package/testpack>
+"""]]
diff --git a/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_2_6fdc5f8b07908c6eda8a97690408f44e._comment b/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_2_6fdc5f8b07908c6eda8a97690408f44e._comment
new file mode 100644
index 000000000..a8ed998cd
--- /dev/null
+++ b/doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_2_6fdc5f8b07908c6eda8a97690408f44e._comment
@@ -0,0 +1,45 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawkSq2FDpK2n66QRUxtqqdbyDuwgbQmUWus"
+ nickname="Jimmy"
+ subject="comment 2"
+ date="2012-12-11T08:29:07Z"
+ content="""
+yea its a problem with testpack rather than git-annex's test suite,
+
+<pre>
+[jtang@laplace git-annex (master)]$ cabal install testpack
+Resolving dependencies...
+Configuring testpack-2.1.2...
+Building testpack-2.1.2...
+Preprocessing library testpack-2.1.2...
+[1 of 3] Compiling Test.QuickCheck.Instances ( src/Test/QuickCheck/Instances.hs, dist/build/Test/QuickCheck/Instances.o )
+[2 of 3] Compiling Test.QuickCheck.Tools ( src/Test/QuickCheck/Tools.hs, dist/build/Test/QuickCheck/Tools.o )
+
+src/Test/QuickCheck/Tools.hs:33:9:
+ Warning: Fields of `MkResult' not initialised: abort
+ In the expression:
+ MkResult
+ {ok = Just (expected == actual), expect = True,
+ interrupted = False,
+ reason = \"Result: expected \"
+ ++ show expected ++ \", got \" ++ show actual,
+ stamp = [], callbacks = []}
+ In an equation for `@=?':
+ expected @=? actual
+ = MkResult
+ {ok = Just (expected == actual), expect = True,
+ interrupted = False,
+ reason = \"Result: expected \"
+ ++ show expected ++ \", got \" ++ show actual,
+ stamp = [], callbacks = []}
+[3 of 3] Compiling Test.HUnit.Tools ( src/Test/HUnit/Tools.hs, dist/build/Test/HUnit/Tools.o )
+
+src/Test/HUnit/Tools.hs:131:57:
+ `maxDiscard' is not a (visible) constructor field name
+
+src/Test/HUnit/Tools.hs:177:40: Not in scope: `maxDiscard'
+cabal: Error: some packages failed to install:
+testpack-2.1.2 failed during the building phase. The exception was:
+ExitFailure 1
+</pre>
+"""]]
diff --git a/doc/design/assistant.mdwn b/doc/design/assistant.mdwn
index 26f298e1a..6e04ca1f7 100644
--- a/doc/design/assistant.mdwn
+++ b/doc/design/assistant.mdwn
@@ -13,9 +13,10 @@ and use cases to add. Feel free to chip in with comments! --[[Joey]]
We are, approximately, here:
-* Month 6 "9k bonus round": [[!traillink Android]] or [[!traillink desymlink]]
-* Month 7: user-driven features and polishing
-* Month 8: whatever I don't get to in month 6
+* Month 6 "9k bonus round": [[!traillink desymlink]]
+* Month 7: user-driven features and polishing;
+ [presentation at LCA2013](https://lca2013.linux.org.au/schedule/30059/view_talk)
+* Month 8: [[!traillink Android]]
* Months 9-11: more user-driven features and polishing (see remaining TODO items in all pages above)
* Month 12: "Windows purgatory" [[Windows]]
diff --git a/doc/design/assistant/blog/day_147__direct_mode/comment_1_0bd69532afce9dc04e3d88bfd0aed4b2._comment b/doc/design/assistant/blog/day_147__direct_mode/comment_1_0bd69532afce9dc04e3d88bfd0aed4b2._comment
new file mode 100644
index 000000000..567c094c9
--- /dev/null
+++ b/doc/design/assistant/blog/day_147__direct_mode/comment_1_0bd69532afce9dc04e3d88bfd0aed4b2._comment
@@ -0,0 +1,16 @@
+[[!comment format=mdwn
+ username="http://lj.rossia.org/users/imz/"
+ ip="79.165.59.119"
+ subject="&quot;removing&quot; vs drop"
+ date="2012-12-12T13:20:42Z"
+ content="""
+I don't understand the difference behind:
+
+> Removing objects also works (and puts back a broken symlink)
+
+and
+
+> \"drop\" won't work because they rely on the symlink to map back to the key.
+
+If a file is removed (its content, which is replaced by a symlink), then it's not present there, so effectively it should be counted as \"dropped\" at this place. So, removing a file without counting it as dropped is something inconsistent, isn't it? Do I misunderstand something?
+"""]]
diff --git a/doc/design/assistant/blog/day_147__direct_mode/comment_2_3b26f0d081c3bf1037bb872d529ce825._comment b/doc/design/assistant/blog/day_147__direct_mode/comment_2_3b26f0d081c3bf1037bb872d529ce825._comment
new file mode 100644
index 000000000..b29d45390
--- /dev/null
+++ b/doc/design/assistant/blog/day_147__direct_mode/comment_2_3b26f0d081c3bf1037bb872d529ce825._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="4.153.8.117"
+ subject="comment 2"
+ date="2012-12-12T23:45:42Z"
+ content="""
+`git annex drop` is a user-level operation built on top of lower-level object removal functions that are also used by other things.
+"""]]
diff --git a/doc/design/assistant/blog/day_149__rainy_day.mdwn b/doc/design/assistant/blog/day_149__rainy_day.mdwn
new file mode 100644
index 000000000..eb4210884
--- /dev/null
+++ b/doc/design/assistant/blog/day_149__rainy_day.mdwn
@@ -0,0 +1,15 @@
+Made `git annex sync` update the file mappings in direct mode.
+To do this efficiently, it uses `git diff-tree` to find files that are
+changed by the sync, and only updates those mappings. I'm rather happy
+with this, as a first step to fully supporting sync in direct mode.
+
+Finished the overhaul of the OSX app's library handling. It seems to work
+well, and will fix a whole class of ways the OSX app could break.
+
+Fixed a bug in the preferred content settings for backup repositories,
+introduced by some changes I made to preferred content handling 4 days ago.
+
+Fixed the Debian package to build with WebDAV support, which I forgot to
+turn on before.
+
+Planning a release tomorrow.
diff --git a/doc/design/assistant/blog/day_150__12:12.mdwn b/doc/design/assistant/blog/day_150__12:12.mdwn
new file mode 100644
index 000000000..8e1f192db
--- /dev/null
+++ b/doc/design/assistant/blog/day_150__12:12.mdwn
@@ -0,0 +1,53 @@
+Yesterday I cut another release. However, getting an OSX build took until
+12:12 pm today because of a confusion about the location of lsof on OSX. The
+OSX build is now available, and I'm looking forward to hearing if it's working!
+
+----
+
+Today I've been working on making `git annex sync` commit in direct mode.
+
+For this I needed to find all new, modified, and deleted files, and I also
+need the git SHA from the index for all non-new files. There's not really
+an ideal git command to use to query this. For now I'm using
+`git ls-files --others --stage`, which works but lists more files than I
+really need to look at. It might be worth using one of the Haskell libraries
+that can directly read git's index.. but for now I'll stick with `ls-files`.
+
+It has to check all direct mode files whose content is present, which means
+one stat per file (on top of the stat that git already does), as well as one
+retrieval of the key per file (using the single `git cat-file` process that
+git-annex talks to).
+
+This is about as efficient as I can make it, except that unmodified
+annexed files whose content is not present are listed due to --stage,
+and so it has to stat those too, and currently also feeds them into `git add`.
+
+The assistant will be able to avoid all this work, except once at startup.
+
+Anyway, direct mode committing is working!
+
+For now, `git annex sync` in direct mode also adds new files. This because
+`git annex add` doesn't work yet in direct mode.
+
+It's possible for a direct mode file to be changed during a commit,
+which would be a problem since committing involves things like calculating
+the key and caching the mtime/etc, that would be screwed up. I took
+care to handle that case; it checks the mtime/etc cache before and after
+generating a key for the file, and if it detects the file has changed,
+avoids committing anything. It could retry, but if the file is a VM disk
+image or something else that's constantly modified, commit retrying forever
+would not be good.
+
+----
+
+For `git annex sync` to be usable in direct mode, it still needs
+to handle merging. It looks like I may be able to just enhance the automatic
+conflict resolution code to know about typechanged direct mode files.
+
+The other missing piece before this can really be used is that currently
+the key to file mapping is only maintained for files added locally, or
+that come in via `git annex sync`. Something needs to set up that mapping
+for files present when the repo is initally cloned. Maybe the thing
+to do is to have a `git annex directmode` command that enables/disables
+direct mode and can setup the the mapping, as well as any necessary unlocks
+and setting the trust level to untrusted.
diff --git a/doc/design/assistant/desymlink.mdwn b/doc/design/assistant/desymlink.mdwn
index 7e62d5fc9..5498b3691 100644
--- a/doc/design/assistant/desymlink.mdwn
+++ b/doc/design/assistant/desymlink.mdwn
@@ -89,8 +89,8 @@ is converted to a real file when it becomes present.
* `git annex sync` updates the key to files mappings for files changed,
but needs much other work to handle direct mode:
* Generate git commit, without running `git commit`, because it will
- want to stage the full files.
- * Update location logs for any files deleted by a commit.
+ want to stage the full files. **done**
+ * Update location logs for any files deleted by a commit. **done**
* Generate a git merge, without running `git merge` (or possibly running
it in a scratch repo?), because it will stumble over the direct files.
* Drop contents of files deleted by a merge (including updating the
diff --git a/doc/forum/How_to_set_up_two_assistants_with_one_shared_transfer_repository__63__/comment_4_bfbcc041db472f4808979e6b3d7c4be2._comment b/doc/forum/How_to_set_up_two_assistants_with_one_shared_transfer_repository__63__/comment_4_bfbcc041db472f4808979e6b3d7c4be2._comment
new file mode 100644
index 000000000..7bd4870a3
--- /dev/null
+++ b/doc/forum/How_to_set_up_two_assistants_with_one_shared_transfer_repository__63__/comment_4_bfbcc041db472f4808979e6b3d7c4be2._comment
@@ -0,0 +1,10 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawniCRkhl_W87gOK5eElfsef3FoUsUFpAr4"
+ nickname="Alexandre"
+ subject="Simplifying this kind of setup"
+ date="2012-12-10T14:33:08Z"
+ content="""
+Maybe it is possible to avoid the XMPP account setup and transferring via XMPP, maybe getting notifications through the SSH connection is possible.
+
+I'm thinking about a \"git-annex-shell server\" unix socket to which clients would connect using the SSH connection and get update notifications from other clients.
+"""]]
diff --git a/doc/forum/Managing_multiple_annexes_with_assistant__63__/comment_5_e94d33be83b45918d1a39d6e16fba4b4._comment b/doc/forum/Managing_multiple_annexes_with_assistant__63__/comment_5_e94d33be83b45918d1a39d6e16fba4b4._comment
new file mode 100644
index 000000000..ae9c5c5b6
--- /dev/null
+++ b/doc/forum/Managing_multiple_annexes_with_assistant__63__/comment_5_e94d33be83b45918d1a39d6e16fba4b4._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawkk3K0AUduAybbBO_LRRGKOe2zcGeezbzI"
+ nickname="Nathan"
+ subject="comment 5"
+ date="2012-12-11T04:15:49Z"
+ content="""
+Thanks, Joey; I was using the standalone build, and it seems to be behaving better now.
+"""]]
diff --git a/doc/forum/gadu_-_git-annex_disk_usage/comment_4_1bcc94f9982c6cfd0888f3dba0f9221e._comment b/doc/forum/gadu_-_git-annex_disk_usage/comment_4_1bcc94f9982c6cfd0888f3dba0f9221e._comment
new file mode 100644
index 000000000..807dac1b3
--- /dev/null
+++ b/doc/forum/gadu_-_git-annex_disk_usage/comment_4_1bcc94f9982c6cfd0888f3dba0f9221e._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="http://sunny256.sunbase.org/"
+ nickname="sunny256"
+ subject="comment 4"
+ date="2012-12-09T20:13:47Z"
+ content="""
+Thanks a lot, Steve. Awesome, got everything on my wishlist. :) A very useful utility, and works perfectly. Will be using this a lot. git-annex-utils is a good name for this, I'm sure if you place it on GitHub or somewhere else you'll get lots of contributions and this could grow to be a project containing many useful utilities for git-annex.
+"""]]
diff --git a/doc/forum/gadu_-_git-annex_disk_usage/comment_5_4365cd3031456fac1b563ee72984638e._comment b/doc/forum/gadu_-_git-annex_disk_usage/comment_5_4365cd3031456fac1b563ee72984638e._comment
new file mode 100644
index 000000000..e2611dbaa
--- /dev/null
+++ b/doc/forum/gadu_-_git-annex_disk_usage/comment_5_4365cd3031456fac1b563ee72984638e._comment
@@ -0,0 +1,18 @@
+[[!comment format=mdwn
+ username="Steve"
+ ip="92.104.175.136"
+ subject="comment 5"
+ date="2012-12-10T04:07:53Z"
+ content="""
+I pay attention to feedback ;)
+
+I'm not done with it yet, I want to add in some options to limit what gets counted.
+
+For example: If you have two annexed files that contain the same content using the same backend, they will be stored only once in the .git/annex/objects directory but be counted twice by gadu.
+
+I want to fix that, but I'll leave an option to keep that behavior if you want. I also want to add options to count or not count files that exist in a certain repo. It will be very easy to add options to only count files that you have or don't have locally as well.
+
+Making it pay attention to environment variables that git and git-annex do would also be a good idea. (like GIT_DIR, etc...)
+
+I'm open to good ideas that anybody has, unfortunately I can only work on it on the weekends for now.
+"""]]
diff --git a/doc/install/OSX/comment_4_bbe99673033e4c48c8bb3db24ee419f9._comment b/doc/install/OSX/comment_4_bbe99673033e4c48c8bb3db24ee419f9._comment
new file mode 100644
index 000000000..f3838e890
--- /dev/null
+++ b/doc/install/OSX/comment_4_bbe99673033e4c48c8bb3db24ee419f9._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="https://www.google.com/accounts/o8/id?id=AItOawkSq2FDpK2n66QRUxtqqdbyDuwgbQmUWus"
+ nickname="Jimmy"
+ subject="comment 4"
+ date="2012-12-10T17:00:43Z"
+ content="""
+For those that care, I've updated my autobuilder to the latest version of haskell-platform 2012.4.0.0 and it appears to be building correctly.
+"""]]
diff --git a/doc/news/version_3.20121017.mdwn b/doc/news/version_3.20121017.mdwn
deleted file mode 100644
index 077a612bd..000000000
--- a/doc/news/version_3.20121017.mdwn
+++ /dev/null
@@ -1,4 +0,0 @@
-git-annex 3.20121017 released with [[!toggle text="these changes"]]
-[[!toggleable text="""
- * Fix zombie cleanup reversion introduced in 3.20121009.
- * Additional fix to support git submodules."""]] \ No newline at end of file
diff --git a/doc/news/version_3.20121211.mdwn b/doc/news/version_3.20121211.mdwn
new file mode 100644
index 000000000..9ec40840e
--- /dev/null
+++ b/doc/news/version_3.20121211.mdwn
@@ -0,0 +1,32 @@
+git-annex 3.20121211 released with [[!toggle text="these changes"]]
+[[!toggleable text="""
+ * webapp: Defaults to sharing box.com account info with friends, allowing
+ one-click enabling of the repository.
+ * Fix broken .config/git-annex/program installed by standalone tarball.
+ * assistant: Retrival from glacier now handled.
+ * Include ssh in standalone tarball and OSX app.
+ * watch: Avoid leaving hard links to files behind in .git/annex/tmp
+ if a file is deleted or moved while it's being quarantined in preparation
+ to being added to the annex.
+ * Allow `git annex drop --from web`; of course this does not remove
+ any file from the web, but it does make git-annex remove all urls
+ associated with a file.
+ * webapp: S3 and Glacier forms now have a select list of all
+ currently-supported AWS regions.
+ * webdav: Avoid trying to set props, avoiding incompatability with
+ livedrive.com. Needs DAV version 0.3.
+ * webapp: Prettify error display.
+ * webapp: Fix bad interaction between required fields and modals.
+ * webapp: Added help buttons and links next to fields that require
+ explanations.
+ * webapp: Encryption can be disabled when setting up remotes.
+ * assistant: Avoid trying to drop content from remotes that don't have it.
+ * assistant: Allow periods in ssh key comments.
+ * get/copy --auto: Transfer data even if it would exceed numcopies,
+ when preferred content settings want it.
+ * drop --auto: Fix dropping content when there are no preferred content
+ settings.
+ * webapp: Allow user to specify the port when setting up a ssh or rsync
+ remote.
+ * assistant: Fix syncing to just created ssh remotes.
+ * Enable WebDAV support in Debian package. Closes: #[695532](http://bugs.debian.org/695532)"""]] \ No newline at end of file
diff --git a/doc/preferred_content.mdwn b/doc/preferred_content.mdwn
index 499cf628e..6408656e4 100644
--- a/doc/preferred_content.mdwn
+++ b/doc/preferred_content.mdwn
@@ -116,6 +116,8 @@ will be added later.
All content is preferred.
+`include=*`
+
### small archive
Only prefers content that's located in an "archive" directory, and
diff --git a/doc/preferred_content/comment_4_384025b5fa23a3f175985a081438149f._comment b/doc/preferred_content/comment_4_384025b5fa23a3f175985a081438149f._comment
new file mode 100644
index 000000000..e6d13ca04
--- /dev/null
+++ b/doc/preferred_content/comment_4_384025b5fa23a3f175985a081438149f._comment
@@ -0,0 +1,8 @@
+[[!comment format=mdwn
+ username="http://joeyh.name/"
+ ip="4.153.8.117"
+ subject="comment 4"
+ date="2012-12-10T19:46:01Z"
+ content="""
+It was a bug in the backup group's preferred content pagespec, introduced by the changes I made to fix the previous problem. Now fixed.
+"""]]
diff --git a/doc/preferred_content/comment_5_f0a957e67297c4bb5a8778c11b3c9fd4._comment b/doc/preferred_content/comment_5_f0a957e67297c4bb5a8778c11b3c9fd4._comment
new file mode 100644
index 000000000..7074541eb
--- /dev/null
+++ b/doc/preferred_content/comment_5_f0a957e67297c4bb5a8778c11b3c9fd4._comment
@@ -0,0 +1,9 @@
+[[!comment format=mdwn
+ username="http://edheil.wordpress.com/"
+ ip="173.162.44.162"
+ subject="comment 5"
+ date="2012-12-11T16:03:04Z"
+ content="""
+thanks!
+
+"""]]
diff --git a/doc/scalability.mdwn b/doc/scalability.mdwn
index 232a84cc6..9a4ff95ef 100644
--- a/doc/scalability.mdwn
+++ b/doc/scalability.mdwn
@@ -23,9 +23,9 @@ git-annex is designed for scalability. The key points are:
improves this will improve. Scaling to hundreds of thousands of files
is not a problem, scaling beyond that and git will start to get slow.
- To some degree, git-annex works around innefficiencies in git; for
- example it batches input sent to certian git commands that are slow
- when run in an emormous repository.
+ To some degree, git-annex works around inefficiencies in git; for
+ example it batches input sent to certain git commands that are slow
+ when run in an enormous repository.
* It can use as much, or as little bandwidth as is available. In
particular, any interrupted file transfer can be resumed by git-annex.
diff --git a/git-annex.cabal b/git-annex.cabal
index 6f06d8581..67b7658d7 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
Name: git-annex
-Version: 3.20121128
+Version: 3.20121211
Cabal-Version: >= 1.8
License: GPL
Maintainer: Joey Hess <joey@kitenet.net>
diff --git a/standalone/osx/git-annex.app/Contents/MacOS/runshell b/standalone/osx/git-annex.app/Contents/MacOS/runshell
index 03b6befdf..40c1be615 100755
--- a/standalone/osx/git-annex.app/Contents/MacOS/runshell
+++ b/standalone/osx/git-annex.app/Contents/MacOS/runshell
@@ -43,7 +43,7 @@ fi
# system binaries.
ORIG_PATH="$PATH"
export ORIG_PATH
-PATH=$base/bin:$PATH
+PATH=$base:$PATH
export PATH
ORIG_GIT_EXEC_PATH="$GIT_EXEC_PATH"