mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Merge branch 'master' into desymlink

Browse source 
Conflicts:
	Annex/CatFile.hs
	Annex/Content.hs
	Git/LsFiles.hs
	Git/LsTree.hs
This commit is contained in:
Joey Hess 2012-12-13 00:29:06 -04:00
commit b080a58b76
108 changed files with 2031 additions and 1615 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

129
Annex/Branch.hs
View file

@ -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)

10
Annex/CatFile.hs
View file

@ -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)

10
Annex/CheckAttr.hs
View file

@ -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

190
Annex/Content.hs
View file

@ -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

20
Annex/Journal.hs
View file

@ -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

24
Annex/LockPool.hs
View file

@ -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

60
Annex/Perms.hs
View file

@ -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

4
Annex/Queue.hs
View file

@ -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 }

96
Annex/Ssh.hs
View file

@ -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

22
Annex/UUID.hs
View file

@ -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 ()

12
Annex/Version.hs
View file

@ -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

5
Build/OSXMkLibs.hs
View file

@ -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'

50
Git/AutoCorrect.hs
View file

@ -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

58
Git/Branch.hs
View file

@ -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

50
Git/CatFile.hs
View file

@ -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

58
Git/CheckAttr.hs
View file

@ -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 ++ ": "

22
Git/Command.hs
View file

@ -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]

42
Git/Config.hs
View file

@ -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

236
Git/Construct.hs
View file

@ -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

40
Git/CurrentRepo.hs
View file

@ -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 }

16
Git/HashObject.hs
View file

@ -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"]

8
Git/Index.hs
View file

@ -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

6
Git/LsFiles.hs
View file

@ -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)

16
Git/LsTree.hs
View file

@ -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

62
Git/Queue.hs
View file

@ -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

70
Git/Ref.hs
View file

@ -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)]

16
Git/Sha.hs
View file

@ -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

38
Git/UnionMerge.hs
View file

@ -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

16
Git/UpdateIndex.hs
View file

@ -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. -}

22
Git/Url.hs
View file

@ -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

20
Git/Version.hs
View file

@ -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

19
Makefile
View file

@ -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)

2
Types/StandardGroups.hs
View file

@ -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)"

2
Utility/Base64.hs
View file

@ -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"

12
Utility/CopyFile.hs
View file

@ -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")
]

16
Utility/DBus.hs
View file

@ -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 ()

70
Utility/Daemon.hs
View file

@ -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

74
Utility/DataUnits.hs
View file

@ -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
where
(number, rest) = head parsednum
multiplier = head parsedunit
unitname = takeWhile isAlpha $ dropWhile isSpace rest
parsednum = reads input :: [(Double, String)]
parsedunit = lookupUnit units unitname
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
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"

70
Utility/Directory.hs
View file

@ -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.
-

4
Utility/DiskFree.hs
View file

@ -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

28
Utility/Dot.hs
View file

@ -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

16
Utility/FileMode.hs
View file

@ -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

184
Utility/Format.hs
View file

@ -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
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
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
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)
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

21
Utility/FreeDesktop.hs
View file

@ -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

66
Utility/Gpg.hs
View file

@ -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

14
Utility/HumanTime.hs
View file

@ -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

194
Utility/INotify.hs
View file

@ -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)

8
Utility/JSONStream.hs
View file

@ -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']

178
Utility/Kqueue.hs
View file

@ -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
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
-- 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)
-- 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'
-- 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'
-- 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 }, [])
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'
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
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
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
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
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)))
withstatus change a = maybe noop (a change) =<<
(catchMaybeIO (getSymbolicLinkStatus (changedFile change)))

12
Utility/LogFile.hs
View file

@ -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

60
Utility/Lsof.hs
View file

@ -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)
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
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
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
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
parsemode ('r':_) = OpenReadOnly
parsemode ('w':_) = OpenWriteOnly
parsemode ('u':_) = OpenReadWrite
parsemode _ = OpenUnknown
splitnull = split "\0"
splitnull = split "\0"
parsefail = error $ "failed to parse lsof output: " ++ show s
parsefail = error $ "failed to parse lsof output: " ++ show s

48
Utility/Matcher.hs
View file

@ -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

34
Utility/Misc.hs
View file

@ -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.
-

30
Utility/Mounts.hsc
View file

@ -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;

5
Utility/Network.hs
View file

@ -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"]

18
Utility/NotificationBroadcaster.hs
View file

@ -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. -}

20
Utility/Parallel.hs
View file

@ -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

70
Utility/Path.hs
View file

@ -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

16
Utility/Percentage.hs
View file

@ -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)

84
Utility/Process.hs
View file

@ -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.
-

86
Utility/Rsync.hs
View file

@ -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

38
Utility/SRV.hs
View file

@ -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)

50
Utility/SafeCommand.hs
View file

@ -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

12
Utility/TSet.hs
View file

@ -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 ()

24
Utility/Tense.hs
View file

@ -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]

10
Utility/ThreadScheduler.hs
View file

@ -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

22
Utility/Touch.hsc
View file

@ -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"

84
Utility/Url.hs
View file

@ -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

8
Utility/UserInfo.hs
View file

@ -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

4
Utility/Verifiable.hs
View file

@ -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

66
Utility/WebApp.hs
View file

@ -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

4
debian/changelog vendored
View file

@ -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

2
debian/rules vendored
View file

@ -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

35
doc/assistant/release_notes.mdwn
View file

@ -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.

2
doc/bugs/OSX_app_issues.mdwn
View file

@ -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]]

41
doc/bugs/OSX_app_issues/comment_14_5783a4716cd104e1f1c276aa0b9cb153._comment Normal file
View file

@ -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.
"""]]

23
doc/bugs/OSX_app_issues/comment_15_56c7fcafc7dca8be28ebf9e37a8f6b71._comment Normal file
View file

@ -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
"""]]

1
doc/bugs/OSX_app_issues/old.mdwn Normal file
View file

@ -0,0 +1 @@
These issues should be fixed now.

0
doc/bugs/OSX_app_issues/comment_11_a30e69fed14b0809184ffe05358ab871._comment → doc/bugs/OSX_app_issues/old/comment_11_a30e69fed14b0809184ffe05358ab871._comment
View file

0
doc/bugs/OSX_app_issues/comment_3_08613b2e2318680508483d204a43da76._comment → doc/bugs/OSX_app_issues/old/comment_3_08613b2e2318680508483d204a43da76._comment
View file

0
doc/bugs/OSX_app_issues/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment → doc/bugs/OSX_app_issues/old/comment_6_12bd83e7e2327c992448e87bdb85d17e._comment
View file

0
doc/bugs/OSX_app_issues/comment_6_cea97dbbfb566a9fe463365ca4511119._comment → doc/bugs/OSX_app_issues/old/comment_6_cea97dbbfb566a9fe463365ca4511119._comment
View file

0
doc/bugs/OSX_app_issues/comment_7_911f187d46890093a54859032ada2442._comment → doc/bugs/OSX_app_issues/old/comment_7_911f187d46890093a54859032ada2442._comment
View file

0
doc/bugs/OSX_app_issues/comment_8_08b091a58106ca6050ac669579ed9ff4._comment → doc/bugs/OSX_app_issues/old/comment_8_08b091a58106ca6050ac669579ed9ff4._comment
View file

5
doc/bugs/__91__webapp__93___pause_syncing_with_specific_repository.mdwn Normal file
View file

@ -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).

33
doc/bugs/git-annex_fix_not_noticing_file_renames.mdwn Normal file
View file

@ -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.

20
doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform.mdwn Normal file
View file

@ -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.

8
doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_1_20a6fe046111e9ae56fd4d9c9f41f536._comment Normal file
View file

@ -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>
"""]]

45
doc/bugs/tests_failed_to_build_-_after_an_update_of_haskell_platform/comment_2_6fdc5f8b07908c6eda8a97690408f44e._comment Normal file
View file

@ -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>
"""]]

7
doc/design/assistant.mdwn
View file

@ -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]]

16
doc/design/assistant/blog/day_147__direct_mode/comment_1_0bd69532afce9dc04e3d88bfd0aed4b2._comment Normal file
View file

@ -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?
"""]]

8
doc/design/assistant/blog/day_147__direct_mode/comment_2_3b26f0d081c3bf1037bb872d529ce825._comment Normal file
View file

@ -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.
"""]]

15
doc/design/assistant/blog/day_149__rainy_day.mdwn Normal file
View file

@ -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.

53
doc/design/assistant/blog/day_150__12:12.mdwn Normal file
View file

@ -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.

4
doc/design/assistant/desymlink.mdwn
View file

@ -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

10
doc/forum/How_to_set_up_two_assistants_with_one_shared_transfer_repository__63__/comment_4_bfbcc041db472f4808979e6b3d7c4be2._comment Normal file
View file

@ -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.
"""]]

8
doc/forum/Managing_multiple_annexes_with_assistant__63__/comment_5_e94d33be83b45918d1a39d6e16fba4b4._comment Normal file
View file

@ -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.
"""]]

8
doc/forum/gadu_-_git-annex_disk_usage/comment_4_1bcc94f9982c6cfd0888f3dba0f9221e._comment Normal file
View file

@ -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.
"""]]

18
doc/forum/gadu_-_git-annex_disk_usage/comment_5_4365cd3031456fac1b563ee72984638e._comment Normal file
View file

@ -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.
"""]]

8
doc/install/OSX/comment_4_bbe99673033e4c48c8bb3db24ee419f9._comment Normal file
View file

@ -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.
"""]]

Some files were not shown because too many files have changed in this diff Show more