Merge branch 'master' into desymlink

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

View file

@ -72,18 +72,18 @@ create = void getBranch
{- Returns the ref of the branch, creating it first if necessary. -} {- Returns the ref of the branch, creating it first if necessary. -}
getBranch :: Annex Git.Ref getBranch :: Annex Git.Ref
getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
where where
go True = do go True = do
inRepo $ Git.Command.run "branch" inRepo $ Git.Command.run "branch"
[Param $ show name, Param $ show originname] [Param $ show name, Param $ show originname]
fromMaybe (error $ "failed to create " ++ show name) fromMaybe (error $ "failed to create " ++ show name)
<$> branchsha <$> branchsha
go False = withIndex' True $ go False = withIndex' True $
inRepo $ Git.Branch.commit "branch created" fullname [] inRepo $ Git.Branch.commit "branch created" fullname []
use sha = do use sha = do
setIndexSha sha setIndexSha sha
return sha return sha
branchsha = inRepo $ Git.Ref.sha fullname branchsha = inRepo $ Git.Ref.sha fullname
{- Ensures that the branch and index are up-to-date; should be {- 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. -} - called before data is read from it. Runs only once per git-annex run. -}
@ -128,26 +128,26 @@ updateTo pairs = do
go branchref True [] [] go branchref True [] []
else lockJournal $ go branchref dirty refs branches else lockJournal $ go branchref dirty refs branches
return $ not $ null refs return $ not $ null refs
where where
isnewer (r, _) = inRepo $ Git.Branch.changed fullname r isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
go branchref dirty refs branches = withIndex $ do go branchref dirty refs branches = withIndex $ do
cleanjournal <- if dirty then stageJournal else return noop cleanjournal <- if dirty then stageJournal else return noop
let merge_desc = if null branches let merge_desc = if null branches
then "update" then "update"
else "merging " ++ else "merging " ++
unwords (map Git.Ref.describe branches) ++ unwords (map Git.Ref.describe branches) ++
" into " ++ show name " into " ++ show name
unless (null branches) $ do unless (null branches) $ do
showSideAction merge_desc showSideAction merge_desc
mergeIndex refs mergeIndex refs
ff <- if dirty ff <- if dirty
then return False then return False
else inRepo $ Git.Branch.fastForward fullname refs else inRepo $ Git.Branch.fastForward fullname refs
if ff if ff
then updateIndex branchref then updateIndex branchref
else commitBranch branchref merge_desc else commitBranch branchref merge_desc
(nub $ fullname:refs) (nub $ fullname:refs)
liftIO cleanjournal liftIO cleanjournal
{- Gets the content of a file, which may be in the journal, or committed {- 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 - 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' :: Bool -> FilePath -> Annex String
get' staleok file = fromjournal =<< getJournalFile file get' staleok file = fromjournal =<< getJournalFile file
where where
fromjournal (Just content) = return content fromjournal (Just content) = return content
fromjournal Nothing fromjournal Nothing
| staleok = withIndex frombranch | staleok = withIndex frombranch
| otherwise = do | otherwise = do
update update
frombranch frombranch
frombranch = withIndex $ frombranch = withIndex $ L.unpack <$> catFile fullname file
L.unpack <$> catFile fullname file
{- Applies a function to modifiy the content of a file. {- Applies a function to modifiy the content of a file.
- -
@ -228,27 +227,27 @@ commitBranch' branchref message parents = do
parentrefs <- commitparents <$> catObject committedref parentrefs <- commitparents <$> catObject committedref
when (racedetected branchref parentrefs) $ when (racedetected branchref parentrefs) $
fixrace committedref parentrefs fixrace committedref parentrefs
where where
-- look for "parent ref" lines and return the refs -- look for "parent ref" lines and return the refs
commitparents = map (Git.Ref . snd) . filter isparent . commitparents = map (Git.Ref . snd) . filter isparent .
map (toassoc . L.unpack) . L.lines map (toassoc . L.unpack) . L.lines
toassoc = separate (== ' ') toassoc = separate (== ' ')
isparent (k,_) = k == "parent" isparent (k,_) = k == "parent"
{- The race can be detected by checking the commit's {- The race can be detected by checking the commit's
- parent, which will be the newly pushed branch, - parent, which will be the newly pushed branch,
- instead of the expected ref that the index was updated to. -} - instead of the expected ref that the index was updated to. -}
racedetected expectedref parentrefs racedetected expectedref parentrefs
| expectedref `elem` parentrefs = False -- good parent | expectedref `elem` parentrefs = False -- good parent
| otherwise = True -- race! | otherwise = True -- race!
{- To recover from the race, union merge the lost refs {- To recover from the race, union merge the lost refs
- into the index, and recommit on top of the bad commit. -} - into the index, and recommit on top of the bad commit. -}
fixrace committedref lostrefs = do fixrace committedref lostrefs = do
mergeIndex lostrefs mergeIndex lostrefs
commitBranch committedref racemessage [committedref] 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. -} {- Lists all files on the branch. There may be duplicates in the list. -}
files :: Annex [FilePath] files :: Annex [FilePath]
@ -345,9 +344,9 @@ stageJournal = withIndex $ do
[genstream dir h fs] [genstream dir h fs]
hashObjectStop h hashObjectStop h
return $ liftIO $ mapM_ removeFile $ map (dir </>) fs return $ liftIO $ mapM_ removeFile $ map (dir </>) fs
where where
genstream dir h fs streamer = forM_ fs $ \file -> do genstream dir h fs streamer = forM_ fs $ \file -> do
let path = dir </> file let path = dir </> file
sha <- hashFile h path sha <- hashFile h path
streamer $ Git.UpdateIndex.updateIndexLine streamer $ Git.UpdateIndex.updateIndexLine
sha FileBlob (asTopFilePath $ fileJournal file) sha FileBlob (asTopFilePath $ fileJournal file)

View file

@ -38,11 +38,11 @@ catObjectDetails ref = do
catFileHandle :: Annex Git.CatFile.CatFileHandle catFileHandle :: Annex Git.CatFile.CatFileHandle
catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle
where where
startup = do startup = do
h <- inRepo Git.CatFile.catFileStart h <- inRepo Git.CatFile.catFileStart
Annex.changeState $ \s -> s { Annex.catfilehandle = Just h } Annex.changeState $ \s -> s { Annex.catfilehandle = Just h }
return h return h
{- From the Sha of a symlink back to the key. -} {- From the Sha of a symlink back to the key. -}
catKey :: Sha -> Annex (Maybe Key) catKey :: Sha -> Annex (Maybe Key)

View file

@ -28,8 +28,8 @@ checkAttr attr file = do
checkAttrHandle :: Annex Git.CheckAttrHandle checkAttrHandle :: Annex Git.CheckAttrHandle
checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle
where where
startup = do startup = do
h <- inRepo $ Git.checkAttrStart annexAttrs h <- inRepo $ Git.checkAttrStart annexAttrs
Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h } Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }
return h return h

View file

@ -79,20 +79,20 @@ inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
- is not in the process of being removed. -} - is not in the process of being removed. -}
inAnnexSafe :: Key -> Annex (Maybe Bool) inAnnexSafe :: Key -> Annex (Maybe Bool)
inAnnexSafe = inAnnex' (maybe False id) (Just False) go inAnnexSafe = inAnnex' (maybe False id) (Just False) go
where where
go f = liftIO $ openforlock f >>= check go f = liftIO $ openforlock f >>= check
openforlock f = catchMaybeIO $ openforlock f = catchMaybeIO $
openFd f ReadOnly Nothing defaultFileFlags openFd f ReadOnly Nothing defaultFileFlags
check Nothing = return is_missing check Nothing = return is_missing
check (Just h) = do check (Just h) = do
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
closeFd h closeFd h
return $ case v of return $ case v of
Just _ -> is_locked Just _ -> is_locked
Nothing -> is_unlocked Nothing -> is_unlocked
is_locked = Nothing is_locked = Nothing
is_unlocked = Just True is_unlocked = Just True
is_missing = Just False is_missing = Just False
{- Content is exclusively locked while running an action that might remove {- Content is exclusively locked while running an action that might remove
- it. (If the content is not present, no locking is done.) -} - 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 lockContent key a = do
file <- inRepo $ gitAnnexLocation key file <- inRepo $ gitAnnexLocation key
bracketIO (openforlock file >>= lock) unlock a bracketIO (openforlock file >>= lock) unlock a
where where
{- Since files are stored with the write bit disabled, have {- Since files are stored with the write bit disabled, have
- to fiddle with permissions to open for an exclusive lock. -} - to fiddle with permissions to open for an exclusive lock. -}
openforlock f = catchMaybeIO $ ifM (doesFileExist f) openforlock f = catchMaybeIO $ ifM (doesFileExist f)
( withModifiedFileMode f ( withModifiedFileMode f
(`unionFileModes` ownerWriteMode) (`unionFileModes` ownerWriteMode)
open open
, open , open
) )
where where
open = openFd f ReadWrite Nothing defaultFileFlags open = openFd f ReadWrite Nothing defaultFileFlags
lock Nothing = return Nothing lock Nothing = return Nothing
lock (Just fd) = do lock (Just fd) = do
v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of case v of
Left _ -> error "content is locked" Left _ -> error "content is locked"
Right _ -> return $ Just fd Right _ -> return $ Just fd
unlock Nothing = noop unlock Nothing = noop
unlock (Just l) = closeFd l unlock (Just l) = closeFd l
{- Calculates the relative path to use to link a file to a key. -} {- Calculates the relative path to use to link a file to a key. -}
calcGitLink :: FilePath -> Key -> Annex FilePath calcGitLink :: FilePath -> Key -> Annex FilePath
@ -127,8 +127,8 @@ calcGitLink file key = do
let absfile = fromMaybe whoops $ absNormPath cwd file let absfile = fromMaybe whoops $ absNormPath cwd file
loc <- inRepo $ gitAnnexLocation key loc <- inRepo $ gitAnnexLocation key
return $ relPathDirToFile (parentDir absfile) loc return $ relPathDirToFile (parentDir absfile) loc
where where
whoops = error $ "unable to normalize " ++ file whoops = error $ "unable to normalize " ++ file
{- Runs an action, passing it a temporary filename to get, {- Runs an action, passing it a temporary filename to get,
- and if the action succeeds, moves the temp file into - and if the action succeeds, moves the temp file into
@ -197,13 +197,13 @@ checkDiskSpace destination key alreadythere = do
needmorespace (need + reserve - have - alreadythere) needmorespace (need + reserve - have - alreadythere)
return ok return ok
_ -> return True _ -> return True
where where
dir = maybe (fromRepo gitAnnexDir) return destination dir = maybe (fromRepo gitAnnexDir) return destination
needmorespace n = needmorespace n =
warning $ "not enough free space, need " ++ warning $ "not enough free space, need " ++
roughSize storageUnits True n ++ roughSize storageUnits True n ++
" more" ++ forcemsg " more" ++ forcemsg
forcemsg = " (use --force to override this check or adjust annex.diskreserve)" forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
{- Moves a key's content into .git/annex/objects/ {- Moves a key's content into .git/annex/objects/
- -
@ -313,12 +313,12 @@ cleanObjectLoc :: Key -> Annex ()
cleanObjectLoc key = do cleanObjectLoc key = do
file <- inRepo $ gitAnnexLocation key file <- inRepo $ gitAnnexLocation key
liftIO $ removeparents file (3 :: Int) liftIO $ removeparents file (3 :: Int)
where where
removeparents _ 0 = noop removeparents _ 0 = noop
removeparents file n = do removeparents file n = do
let dir = parentDir file let dir = parentDir file
maybe noop (const $ removeparents dir (n-1)) maybe noop (const $ removeparents dir (n-1))
<=< catchMaybeIO $ removeDirectory dir <=< catchMaybeIO $ removeDirectory dir
{- Removes a key's file from .git/annex/objects/ {- 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/ -} {- List of keys whose content exists in .git/annex/objects/ -}
getKeysPresent :: Annex [Key] getKeysPresent :: Annex [Key]
getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir getKeysPresent = liftIO . traverse (2 :: Int) =<< fromRepo gitAnnexObjectDir
where where
traverse depth dir = do traverse depth dir = do
contents <- catchDefaultIO [] (dirContents dir) contents <- catchDefaultIO [] (dirContents dir)
if depth == 0 if depth == 0
then continue (mapMaybe (fileKey . takeFileName) contents) [] then continue (mapMaybe (fileKey . takeFileName) contents) []
else do else do
let deeper = traverse (depth - 1) let deeper = traverse (depth - 1)
continue [] (map deeper contents) continue [] (map deeper contents)
continue keys [] = return keys continue keys [] = return keys
continue keys (a:as) = do continue keys (a:as) = do
{- Force lazy traversal with unsafeInterleaveIO. -} {- Force lazy traversal with unsafeInterleaveIO. -}
morekeys <- unsafeInterleaveIO a morekeys <- unsafeInterleaveIO a
continue (morekeys++keys) as continue (morekeys++keys) as
{- Things to do to record changes to content when shutting down. {- Things to do to record changes to content when shutting down.
- -
@ -396,9 +396,9 @@ saveState nocommit = doSideAction $ do
unless nocommit $ unless nocommit $
whenM alwayscommit $ whenM alwayscommit $
Annex.Branch.commit "update" Annex.Branch.commit "update"
where where
alwayscommit = fromMaybe True . Git.Config.isTrue alwayscommit = fromMaybe True . Git.Config.isTrue
<$> getConfig (annexConfig "alwayscommit") "" <$> getConfig (annexConfig "alwayscommit") ""
{- Downloads content from any of a list of urls. -} {- Downloads content from any of a list of urls. -}
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
@ -411,41 +411,41 @@ downloadUrl urls file = do
- This is used to speed up some rsyncs. -} - This is used to speed up some rsyncs. -}
preseedTmp :: Key -> FilePath -> Annex Bool preseedTmp :: Key -> FilePath -> Annex Bool
preseedTmp key file = go =<< inAnnex key preseedTmp key file = go =<< inAnnex key
where where
go False = return False go False = return False
go True = do go True = do
ok <- copy ok <- copy
when ok $ thawContent file when ok $ thawContent file
return ok return ok
copy = ifM (liftIO $ doesFileExist file) copy = ifM (liftIO $ doesFileExist file)
( return True ( return True
, do , do
s <- inRepo $ gitAnnexLocation key s <- inRepo $ gitAnnexLocation key
liftIO $ copyFileExternal s file liftIO $ copyFileExternal s file
) )
{- Blocks writing to an annexed file. The file is made unwritable {- Blocks writing to an annexed file. The file is made unwritable
- to avoid accidental edits. core.sharedRepository may change - to avoid accidental edits. core.sharedRepository may change
- who can read it. -} - who can read it. -}
freezeContent :: FilePath -> Annex () freezeContent :: FilePath -> Annex ()
freezeContent file = liftIO . go =<< fromRepo getSharedRepository freezeContent file = liftIO . go =<< fromRepo getSharedRepository
where where
go GroupShared = modifyFileMode file $ go GroupShared = modifyFileMode file $
removeModes writeModes . removeModes writeModes .
addModes [ownerReadMode, groupReadMode] addModes [ownerReadMode, groupReadMode]
go AllShared = modifyFileMode file $ go AllShared = modifyFileMode file $
removeModes writeModes . removeModes writeModes .
addModes readModes addModes readModes
go _ = preventWrite file go _ = preventWrite file
{- Allows writing to an annexed file that freezeContent was called on {- Allows writing to an annexed file that freezeContent was called on
- before. -} - before. -}
thawContent :: FilePath -> Annex () thawContent :: FilePath -> Annex ()
thawContent file = liftIO . go =<< fromRepo getSharedRepository thawContent file = liftIO . go =<< fromRepo getSharedRepository
where where
go GroupShared = groupWriteRead file go GroupShared = groupWriteRead file
go AllShared = groupWriteRead file go AllShared = groupWriteRead file
go _ = allowWrite file go _ = allowWrite file
{- Blocks writing to the directory an annexed file is in, to prevent the {- Blocks writing to the directory an annexed file is in, to prevent the
- file accidentially being deleted. However, if core.sharedRepository - file accidentially being deleted. However, if core.sharedRepository
@ -454,11 +454,11 @@ thawContent file = liftIO . go =<< fromRepo getSharedRepository
-} -}
freezeContentDir :: FilePath -> Annex () freezeContentDir :: FilePath -> Annex ()
freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository
where where
dir = parentDir file dir = parentDir file
go GroupShared = groupWriteRead dir go GroupShared = groupWriteRead dir
go AllShared = groupWriteRead dir go AllShared = groupWriteRead dir
go _ = preventWrite dir go _ = preventWrite dir
{- Makes the directory tree to store an annexed file's content, {- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -} - with appropriate permissions on each level. -}
@ -468,5 +468,5 @@ createContentDir dest = do
createAnnexDirectory dir createAnnexDirectory dir
-- might have already existed with restricted perms -- might have already existed with restricted perms
liftIO $ allowWrite dir liftIO $ allowWrite dir
where where
dir = parentDir dest dir = parentDir dest

View file

@ -63,10 +63,10 @@ journalDirty = not . null <$> getJournalFiles
-} -}
journalFile :: FilePath -> Git.Repo -> FilePath journalFile :: FilePath -> Git.Repo -> FilePath
journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file
where where
mangle '/' = "_" mangle '/' = "_"
mangle '_' = "__" mangle '_' = "__"
mangle c = [c] mangle c = [c]
{- Converts a journal file (relative to the journal dir) back to the {- Converts a journal file (relative to the journal dir) back to the
- filename on the branch. -} - filename on the branch. -}
@ -81,9 +81,9 @@ lockJournal a = do
createAnnexDirectory $ takeDirectory file createAnnexDirectory $ takeDirectory file
mode <- annexFileMode mode <- annexFileMode
bracketIO (lock file mode) unlock a bracketIO (lock file mode) unlock a
where where
lock file mode = do lock file mode = do
l <- noUmask mode $ createFile file mode l <- noUmask mode $ createFile file mode
waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0) waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
return l return l
unlock = closeFd unlock = closeFd

View file

@ -17,21 +17,21 @@ import Annex.Perms
{- Create a specified lock file, and takes a shared lock. -} {- Create a specified lock file, and takes a shared lock. -}
lockFile :: FilePath -> Annex () lockFile :: FilePath -> Annex ()
lockFile file = go =<< fromPool file lockFile file = go =<< fromPool file
where where
go (Just _) = noop -- already locked go (Just _) = noop -- already locked
go Nothing = do go Nothing = do
mode <- annexFileMode mode <- annexFileMode
fd <- liftIO $ noUmask mode $ fd <- liftIO $ noUmask mode $
openFd file ReadOnly (Just mode) defaultFileFlags openFd file ReadOnly (Just mode) defaultFileFlags
liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0) liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)
changePool $ M.insert file fd changePool $ M.insert file fd
unlockFile :: FilePath -> Annex () unlockFile :: FilePath -> Annex ()
unlockFile file = maybe noop go =<< fromPool file unlockFile file = maybe noop go =<< fromPool file
where where
go fd = do go fd = do
liftIO $ closeFd fd liftIO $ closeFd fd
changePool $ M.delete file changePool $ M.delete file
getPool :: Annex (M.Map FilePath Fd) getPool :: Annex (M.Map FilePath Fd)
getPool = getState lockpool getPool = getState lockpool

View file

@ -21,11 +21,11 @@ import System.Posix.Types
withShared :: (SharedRepository -> Annex a) -> Annex a withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = maybe startup a =<< Annex.getState Annex.shared withShared a = maybe startup a =<< Annex.getState Annex.shared
where where
startup = do startup = do
shared <- fromRepo getSharedRepository shared <- fromRepo getSharedRepository
Annex.changeState $ \s -> s { Annex.shared = Just shared } Annex.changeState $ \s -> s { Annex.shared = Just shared }
a shared a shared
{- Sets appropriate file mode for a file or directory in the annex, {- Sets appropriate file mode for a file or directory in the annex,
- other than the content files and content directory. Normally, - 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. -} - allow the group to write, etc. -}
setAnnexPerm :: FilePath -> Annex () setAnnexPerm :: FilePath -> Annex ()
setAnnexPerm file = withShared $ liftIO . go setAnnexPerm file = withShared $ liftIO . go
where where
go GroupShared = groupWriteRead file go GroupShared = groupWriteRead file
go AllShared = modifyFileMode file $ addModes $ go AllShared = modifyFileMode file $ addModes $
[ ownerWriteMode, groupWriteMode ] ++ readModes [ ownerWriteMode, groupWriteMode ] ++ readModes
go _ = noop go _ = noop
{- Gets the appropriate mode to use for creating a file in the annex {- Gets the appropriate mode to use for creating a file in the annex
- (other than content files, which are locked down more). -} - (other than content files, which are locked down more). -}
annexFileMode :: Annex FileMode annexFileMode :: Annex FileMode
annexFileMode = withShared $ return . go annexFileMode = withShared $ return . go
where where
go GroupShared = sharedmode go GroupShared = sharedmode
go AllShared = combineModes (sharedmode:readModes) go AllShared = combineModes (sharedmode:readModes)
go _ = stdFileMode go _ = stdFileMode
sharedmode = combineModes sharedmode = combineModes
[ ownerWriteMode, groupWriteMode [ ownerWriteMode, groupWriteMode
, ownerReadMode, groupReadMode , ownerReadMode, groupReadMode
] ]
{- Creates a directory inside the gitAnnexDir, including any parent {- Creates a directory inside the gitAnnexDir, including any parent
- directories. Makes directories with appropriate permissions. -} - directories. Makes directories with appropriate permissions. -}
createAnnexDirectory :: FilePath -> Annex () createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory dir = traverse dir [] =<< top createAnnexDirectory dir = traverse dir [] =<< top
where where
top = parentDir <$> fromRepo gitAnnexDir top = parentDir <$> fromRepo gitAnnexDir
traverse d below stop traverse d below stop
| d `equalFilePath` stop = done | d `equalFilePath` stop = done
| otherwise = ifM (liftIO $ doesDirectoryExist d) | otherwise = ifM (liftIO $ doesDirectoryExist d)
( done ( done
, traverse (parentDir d) (d:below) stop , traverse (parentDir d) (d:below) stop
) )
where where
done = forM_ below $ \p -> do done = forM_ below $ \p -> do
liftIO $ createDirectory p liftIO $ createDirectory p
setAnnexPerm p setAnnexPerm p

View file

@ -58,8 +58,8 @@ new = do
q <- Git.Queue.new <$> queuesize q <- Git.Queue.new <$> queuesize
store q store q
return q return q
where where
queuesize = readish <$> getConfig (annexConfig "queuesize") "" queuesize = readish <$> getConfig (annexConfig "queuesize") ""
store :: Git.Queue.Queue -> Annex () store :: Git.Queue.Queue -> Annex ()
store q = changeState $ \s -> s { repoqueue = Just q } store q = changeState $ \s -> s { repoqueue = Just q }

View file

@ -27,19 +27,19 @@ import qualified Build.SysConfig as SysConfig
- port, with connection caching. -} - port, with connection caching. -}
sshParams :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam] sshParams :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
sshParams (host, port) opts = go =<< sshInfo (host, port) sshParams (host, port) opts = go =<< sshInfo (host, port)
where where
go (Nothing, params) = ret params go (Nothing, params) = ret params
go (Just socketfile, params) = do go (Just socketfile, params) = do
cleanstale cleanstale
liftIO $ createDirectoryIfMissing True $ parentDir socketfile liftIO $ createDirectoryIfMissing True $ parentDir socketfile
lockFile $ socket2lock socketfile lockFile $ socket2lock socketfile
ret params ret params
ret ps = return $ ps ++ opts ++ portParams port ++ [Param host] ret ps = return $ ps ++ opts ++ portParams port ++ [Param host]
-- If the lock pool is empty, this is the first ssh of this -- If the lock pool is empty, this is the first ssh of this
-- run. There could be stale ssh connections hanging around -- run. There could be stale ssh connections hanging around
-- from a previous git-annex run that was interrupted. -- from a previous git-annex run that was interrupted.
cleanstale = whenM (not . any isLock . M.keys <$> getPool) $ cleanstale = whenM (not . any isLock . M.keys <$> getPool) $
sshCleanup sshCleanup
sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
sshInfo (host, port) = ifM caching sshInfo (host, port) = ifM caching
@ -55,13 +55,13 @@ sshInfo (host, port) = ifM caching
else return (Nothing, []) else return (Nothing, [])
, return (Nothing, []) , return (Nothing, [])
) )
where where
#ifdef WITH_OLD_SSH #ifdef WITH_OLD_SSH
caching = return False caching = return False
#else #else
caching = fromMaybe SysConfig.sshconnectioncaching caching = fromMaybe SysConfig.sshconnectioncaching
. Git.Config.isTrue . Git.Config.isTrue
<$> getConfig (annexConfig "sshcaching") "" <$> getConfig (annexConfig "sshcaching") ""
#endif #endif
cacheParams :: FilePath -> [CommandParam] cacheParams :: FilePath -> [CommandParam]
@ -81,34 +81,34 @@ sshCleanup = do
sockets <- filter (not . isLock) <$> sockets <- filter (not . isLock) <$>
liftIO (catchDefaultIO [] $ dirContents dir) liftIO (catchDefaultIO [] $ dirContents dir)
forM_ sockets cleanup forM_ sockets cleanup
where where
cleanup socketfile = do cleanup socketfile = do
-- Drop any shared lock we have, and take an -- Drop any shared lock we have, and take an
-- exclusive lock, without blocking. If the lock -- exclusive lock, without blocking. If the lock
-- succeeds, nothing is using this ssh, and it can -- succeeds, nothing is using this ssh, and it can
-- be stopped. -- be stopped.
let lockfile = socket2lock socketfile let lockfile = socket2lock socketfile
unlockFile lockfile unlockFile lockfile
mode <- annexFileMode mode <- annexFileMode
fd <- liftIO $ noUmask mode $ fd <- liftIO $ noUmask mode $
openFd lockfile ReadWrite (Just mode) defaultFileFlags openFd lockfile ReadWrite (Just mode) defaultFileFlags
v <- liftIO $ tryIO $ v <- liftIO $ tryIO $
setLock fd (WriteLock, AbsoluteSeek, 0, 0) setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of case v of
Left _ -> noop Left _ -> noop
Right _ -> stopssh socketfile Right _ -> stopssh socketfile
liftIO $ closeFd fd liftIO $ closeFd fd
stopssh socketfile = do stopssh socketfile = do
let (host, port) = socket2hostport socketfile let (host, port) = socket2hostport socketfile
(_, params) <- sshInfo (host, port) (_, params) <- sshInfo (host, port)
-- "ssh -O stop" is noisy on stderr even with -q -- "ssh -O stop" is noisy on stderr even with -q
void $ liftIO $ catchMaybeIO $ void $ liftIO $ catchMaybeIO $
withQuietOutput createProcessSuccess $ withQuietOutput createProcessSuccess $
proc "ssh" $ toCommand $ proc "ssh" $ toCommand $
[ Params "-O stop" [ Params "-O stop"
] ++ params ++ [Param host] ] ++ params ++ [Param host]
-- Cannot remove the lock file; other processes may -- Cannot remove the lock file; other processes may
-- be waiting on our exclusive lock to use it. -- be waiting on our exclusive lock to use it.
hostport2socket :: String -> Maybe Integer -> FilePath hostport2socket :: String -> Maybe Integer -> FilePath
hostport2socket host Nothing = host hostport2socket host Nothing = host
@ -118,8 +118,8 @@ socket2hostport :: FilePath -> (String, Maybe Integer)
socket2hostport socket socket2hostport socket
| null p = (h, Nothing) | null p = (h, Nothing)
| otherwise = (h, readish p) | otherwise = (h, readish p)
where where
(h, p) = separate (== '!') $ takeFileName socket (h, p) = separate (== '!') $ takeFileName socket
socket2lock :: FilePath -> FilePath socket2lock :: FilePath -> FilePath
socket2lock socket = socket ++ lockExt socket2lock socket = socket ++ lockExt

View file

@ -34,10 +34,10 @@ configkey = annexConfig "uuid"
- so use the command line tool. -} - so use the command line tool. -}
genUUID :: IO UUID genUUID :: IO UUID
genUUID = gen . lines <$> readProcess command params genUUID = gen . lines <$> readProcess command params
where where
gen [] = error $ "no output from " ++ command gen [] = error $ "no output from " ++ command
gen (l:_) = toUUID l gen (l:_) = toUUID l
(command:params) = words SysConfig.uuid (command:params) = words SysConfig.uuid
{- Get current repository's UUID. -} {- Get current repository's UUID. -}
getUUID :: Annex UUID getUUID :: Annex UUID
@ -54,19 +54,19 @@ getRepoUUID r = do
updatecache u updatecache u
return u return u
else return c else return c
where where
updatecache u = do updatecache u = do
g <- gitRepo g <- gitRepo
when (g /= r) $ storeUUID cachekey u when (g /= r) $ storeUUID cachekey u
cachekey = remoteConfig r "uuid" cachekey = remoteConfig r "uuid"
removeRepoUUID :: Annex () removeRepoUUID :: Annex ()
removeRepoUUID = unsetConfig configkey removeRepoUUID = unsetConfig configkey
getUncachedUUID :: Git.Repo -> UUID getUncachedUUID :: Git.Repo -> UUID
getUncachedUUID = toUUID . Git.Config.get key "" getUncachedUUID = toUUID . Git.Config.get key ""
where where
(ConfigKey key) = configkey (ConfigKey key) = configkey
{- Make sure that the repo has an annex.uuid setting. -} {- Make sure that the repo has an annex.uuid setting. -}
prepUUID :: Annex () prepUUID :: Annex ()

View file

@ -26,9 +26,9 @@ versionField = annexConfig "version"
getVersion :: Annex (Maybe Version) getVersion :: Annex (Maybe Version)
getVersion = handle <$> getConfig versionField "" getVersion = handle <$> getConfig versionField ""
where where
handle [] = Nothing handle [] = Nothing
handle v = Just v handle v = Just v
setVersion :: Annex () setVersion :: Annex ()
setVersion = setConfig versionField defaultVersion setVersion = setConfig versionField defaultVersion
@ -41,6 +41,6 @@ checkVersion v
| v `elem` supportedVersions = noop | v `elem` supportedVersions = noop
| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade" | v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
| otherwise = err "Upgrade git-annex." | otherwise = err "Upgrade git-annex."
where where
err msg = error $ "Repository version " ++ v ++ err msg = error $ "Repository version " ++ v ++
" is not supported. " ++ msg " is not supported. " ++ msg

View file

@ -62,11 +62,12 @@ otool appbase libmap = do
files <- filterM doesFileExist =<< dirContentsRecursive appbase files <- filterM doesFileExist =<< dirContentsRecursive appbase
process [] files libmap process [] files libmap
where 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 [] m = return (nub $ concat c, m)
process c (file:rest) m = do process c (file:rest) m = do
_ <- boolSystem "chmod" [Param "755", File file] _ <- boolSystem "chmod" [Param "755", File file]
libs <- filter unprocessed . parseOtool libs <- filter want . parseOtool
<$> readProcess "otool" ["-L", file] <$> readProcess "otool" ["-L", file]
m' <- install_name_tool file libs m m' <- install_name_tool file libs m
process (libs:c) rest m' process (libs:c) rest m'

View file

@ -33,11 +33,11 @@ similarityFloor = 7
fuzzymatches :: String -> (c -> String) -> [c] -> [c] fuzzymatches :: String -> (c -> String) -> [c] -> [c]
fuzzymatches input showchoice choices = fst $ unzip $ fuzzymatches input showchoice choices = fst $ unzip $
sortBy comparecost $ filter similarEnough $ zip choices costs sortBy comparecost $ filter similarEnough $ zip choices costs
where where
distance = restrictedDamerauLevenshteinDistance gitEditCosts input distance = restrictedDamerauLevenshteinDistance gitEditCosts input
costs = map (distance . showchoice) choices costs = map (distance . showchoice) choices
comparecost a b = compare (snd a) (snd b) comparecost a b = compare (snd a) (snd b)
similarEnough (_, cst) = cst < similarityFloor similarEnough (_, cst) = cst < similarityFloor
{- Takes action based on git's autocorrect configuration, in preparation for {- Takes action based on git's autocorrect configuration, in preparation for
- an autocorrected command being run. -} - an autocorrected command being run. -}
@ -49,23 +49,23 @@ prepare input showmatch matches r =
| n < 0 -> warn | n < 0 -> warn
| otherwise -> sleep n | otherwise -> sleep n
Nothing -> list Nothing -> list
where where
list = error $ unlines $ list = error $ unlines $
[ "Unknown command '" ++ input ++ "'" [ "Unknown command '" ++ input ++ "'"
, "" , ""
, "Did you mean one of these?" , "Did you mean one of these?"
] ++ map (\m -> "\t" ++ showmatch m) matches ] ++ map (\m -> "\t" ++ showmatch m) matches
warn = warn =
hPutStr stderr $ unlines hPutStr stderr $ unlines
[ "WARNING: You called a command named '" ++ [ "WARNING: You called a command named '" ++
input ++ "', which does not exist." input ++ "', which does not exist."
, "Continuing under the assumption that you meant '" ++ , "Continuing under the assumption that you meant '" ++
showmatch (Prelude.head matches) ++ "'" showmatch (Prelude.head matches) ++ "'"
] ]
sleep n = do sleep n = do
warn warn
hPutStrLn stderr $ unwords hPutStrLn stderr $ unwords
[ "in" [ "in"
, show (fromIntegral n / 10 :: Float) , show (fromIntegral n / 10 :: Float)
, "seconds automatically..."] , "seconds automatically..."]
threadDelay (n * 100000) -- deciseconds to microseconds threadDelay (n * 100000) -- deciseconds to microseconds

View file

@ -36,10 +36,10 @@ current r = do
currentUnsafe :: Repo -> IO (Maybe Git.Ref) currentUnsafe :: Repo -> IO (Maybe Git.Ref)
currentUnsafe r = parse . firstLine currentUnsafe r = parse . firstLine
<$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r <$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r
where where
parse l parse l
| null l = Nothing | null l = Nothing
| otherwise = Just $ Git.Ref l | otherwise = Just $ Git.Ref l
{- Checks if the second branch has any commits not present on the first {- Checks if the second branch has any commits not present on the first
- branch. -} - branch. -}
@ -47,12 +47,12 @@ changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo changed origbranch newbranch repo
| origbranch == newbranch = return False | origbranch == newbranch = return False
| otherwise = not . null <$> diffs | otherwise = not . null <$> diffs
where where
diffs = pipeReadStrict diffs = pipeReadStrict
[ Param "log" [ Param "log"
, Param (show origbranch ++ ".." ++ show newbranch) , Param (show origbranch ++ ".." ++ show newbranch)
, Params "--oneline -n1" , Params "--oneline -n1"
] repo ] repo
{- Given a set of refs that are all known to have commits not {- 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. - on the branch, tries to update the branch by a fast-forward.
@ -70,23 +70,23 @@ fastForward branch (first:rest) repo =
( no_ff ( no_ff
, maybe no_ff do_ff =<< findbest first rest , maybe no_ff do_ff =<< findbest first rest
) )
where where
no_ff = return False no_ff = return False
do_ff to = do do_ff to = do
run "update-ref" run "update-ref"
[Param $ show branch, Param $ show to] repo [Param $ show branch, Param $ show to] repo
return True return True
findbest c [] = return $ Just c findbest c [] = return $ Just c
findbest c (r:rs) findbest c (r:rs)
| c == r = findbest c rs | c == r = findbest c rs
| otherwise = do | otherwise = do
better <- changed c r repo better <- changed c r repo
worse <- changed r c repo worse <- changed r c repo
case (better, worse) of case (better, worse) of
(True, True) -> return Nothing -- divergent fail (True, True) -> return Nothing -- divergent fail
(True, False) -> findbest r rs -- better (True, False) -> findbest r rs -- better
(False, True) -> findbest c rs -- worse (False, True) -> findbest c rs -- worse
(False, False) -> findbest c rs -- same (False, False) -> findbest c rs -- same
{- Commits the index into the specified branch (or other ref), {- Commits the index into the specified branch (or other ref),
- with the specified parent refs, and returns the committed sha -} - with the specified parent refs, and returns the committed sha -}
@ -99,5 +99,5 @@ commit message branch parentrefs repo = do
message repo message repo
run "update-ref" [Param $ show branch, Param $ show sha] repo run "update-ref" [Param $ show branch, Param $ show sha] repo
return sha return sha
where where
ps = concatMap (\r -> ["-p", show r]) parentrefs ps = concatMap (\r -> ["-p", show r]) parentrefs

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. -} {- Gets both the content of an object, and its Sha. -}
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha)) catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))
catObjectDetails h object = CoProcess.query h send receive catObjectDetails h object = CoProcess.query h send receive
where where
send to = do send to = do
fileEncoding to fileEncoding to
hPutStrLn to $ show object hPutStrLn to $ show object
receive from = do receive from = do
fileEncoding from fileEncoding from
header <- hGetLine from header <- hGetLine from
case words header of case words header of
[sha, objtype, size] [sha, objtype, size]
| length sha == shaSize && | length sha == shaSize &&
isJust (readObjectType objtype) -> isJust (readObjectType objtype) ->
case reads size of case reads size of
[(bytes, "")] -> readcontent bytes from sha [(bytes, "")] -> readcontent bytes from sha
_ -> dne _ -> dne
| otherwise -> dne | otherwise -> dne
_ _
| header == show object ++ " missing" -> dne | header == show object ++ " missing" -> dne
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object) | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
readcontent bytes from sha = do readcontent bytes from sha = do
content <- S.hGet from bytes content <- S.hGet from bytes
c <- hGetChar from c <- hGetChar from
when (c /= '\n') $ when (c /= '\n') $
error "missing newline from git cat-file" error "missing newline from git cat-file"
return $ Just (L.fromChunks [content], Ref sha) return $ Just (L.fromChunks [content], Ref sha)
dne = return Nothing dne = return Nothing

View file

@ -24,12 +24,12 @@ checkAttrStart attrs repo = do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
h <- gitCoProcessStart params repo h <- gitCoProcessStart params repo
return (h, attrs, cwd) return (h, attrs, cwd)
where where
params = params =
[ Param "check-attr" [ Param "check-attr"
, Params "-z --stdin" , Params "-z --stdin"
] ++ map Param attrs ++ ] ++ map Param attrs ++
[ Param "--" ] [ Param "--" ]
checkAttrStop :: CheckAttrHandle -> IO () checkAttrStop :: CheckAttrHandle -> IO ()
checkAttrStop (h, _, _) = CoProcess.stop h checkAttrStop (h, _, _) = CoProcess.stop h
@ -42,26 +42,26 @@ checkAttr (h, attrs, cwd) want file = do
case vals of case vals of
[v] -> return v [v] -> return v
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file _ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
where where
send to = do send to = do
fileEncoding to fileEncoding to
hPutStr to $ file' ++ "\0" hPutStr to $ file' ++ "\0"
receive from = forM attrs $ \attr -> do receive from = forM attrs $ \attr -> do
fileEncoding from fileEncoding from
l <- hGetLine from l <- hGetLine from
return (attr, attrvalue attr l) return (attr, attrvalue attr l)
{- Before git 1.7.7, git check-attr worked best with {- Before git 1.7.7, git check-attr worked best with
- absolute filenames; using them worked around some bugs - absolute filenames; using them worked around some bugs
- with relative filenames. - with relative filenames.
- -
- With newer git, git check-attr chokes on some absolute - With newer git, git check-attr chokes on some absolute
- filenames, and the bugs that necessitated them were fixed, - filenames, and the bugs that necessitated them were fixed,
- so use relative filenames. -} - so use relative filenames. -}
oldgit = Git.Version.older "1.7.7" oldgit = Git.Version.older "1.7.7"
file' file'
| oldgit = absPathFrom cwd file | oldgit = absPathFrom cwd file
| otherwise = relPathDirToFile cwd $ absPathFrom cwd file | otherwise = relPathDirToFile cwd $ absPathFrom cwd file
attrvalue attr l = end bits !! 0 attrvalue attr l = end bits !! 0
where where
bits = split sep l bits = split sep l
sep = ": " ++ attr ++ ": " sep = ": " ++ attr ++ ": "

View file

@ -17,11 +17,11 @@ import qualified Utility.CoProcess as CoProcess
{- Constructs a git command line operating on the specified repo. -} {- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params
where where
setdir = Param $ "--git-dir=" ++ gitdir l setdir = Param $ "--git-dir=" ++ gitdir l
settree = case worktree l of settree = case worktree l of
Nothing -> [] Nothing -> []
Just t -> [Param $ "--work-tree=" ++ t] Just t -> [Param $ "--work-tree=" ++ t]
gitCommandLine _ repo = assertLocal repo $ error "internal" gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -} {- Runs git in the specified repo. -}
@ -49,8 +49,8 @@ pipeReadLazy params repo = assertLocal repo $ do
fileEncoding h fileEncoding h
c <- hGetContents h c <- hGetContents h
return (c, checkSuccessProcess pid) return (c, checkSuccessProcess pid)
where where
p = gitCreateProcess params repo p = gitCreateProcess params repo
{- Runs a git subcommand, and returns its output, strictly. {- Runs a git subcommand, and returns its output, strictly.
- -
@ -63,8 +63,8 @@ pipeReadStrict params repo = assertLocal repo $
output <- hGetContentsStrict h output <- hGetContentsStrict h
hClose h hClose h
return output return output
where where
p = gitCreateProcess params repo p = gitCreateProcess params repo
{- Runs a git subcommand, feeding it input, and returning its output, {- 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 - 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 pipeNullSplit params repo = do
(s, cleanup) <- pipeReadLazy params repo (s, cleanup) <- pipeReadLazy params repo
return (filter (not . null) $ split sep s, cleanup) return (filter (not . null) $ split sep s, cleanup)
where where
sep = "\0" sep = "\0"
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]

View file

@ -48,18 +48,18 @@ reRead r = read' $ r
-} -}
read' :: Repo -> IO Repo read' :: Repo -> IO Repo
read' repo = go repo read' repo = go repo
where where
go Repo { location = Local { gitdir = d } } = git_config d go Repo { location = Local { gitdir = d } } = git_config d
go Repo { location = LocalUnknown d } = git_config d go Repo { location = LocalUnknown d } = git_config d
go _ = assertLocal repo $ error "internal" go _ = assertLocal repo $ error "internal"
git_config d = withHandle StdoutHandle createProcessSuccess p $ git_config d = withHandle StdoutHandle createProcessSuccess p $
hRead repo hRead repo
where where
params = ["config", "--null", "--list"] params = ["config", "--null", "--list"]
p = (proc "git" params) p = (proc "git" params)
{ cwd = Just d { cwd = Just d
, env = gitEnv repo , env = gitEnv repo
} }
{- Gets the global git config, returning a dummy Repo containing it. -} {- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo) global :: IO (Maybe Repo)
@ -73,9 +73,9 @@ global = do
return $ Just repo' return $ Just repo'
, return Nothing , return Nothing
) )
where where
params = ["config", "--null", "--list", "--global"] params = ["config", "--null", "--list", "--global"]
p = (proc "git" params) p = (proc "git" params)
{- Reads git config from a handle and populates a repo with it. -} {- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo hRead :: Repo -> Handle -> IO Repo
@ -133,10 +133,10 @@ parse s
| all ('=' `elem`) (take 1 ls) = sep '=' ls | all ('=' `elem`) (take 1 ls) = sep '=' ls
-- --null --list output separates keys from values with newlines -- --null --list output separates keys from values with newlines
| otherwise = sep '\n' $ split "\0" s | otherwise = sep '\n' $ split "\0" s
where where
ls = lines s ls = lines s
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
map (separate (== c)) map (separate (== c))
{- Checks if a string from git config is a true value. -} {- Checks if a string from git config is a true value. -}
isTrue :: String -> Maybe Bool isTrue :: String -> Maybe Bool
@ -144,8 +144,8 @@ isTrue s
| s' == "true" = Just True | s' == "true" = Just True
| s' == "false" = Just False | s' == "false" = Just False
| otherwise = Nothing | otherwise = Nothing
where where
s' = map toLower s s' = map toLower s
isBare :: Repo -> Bool isBare :: Repo -> Bool
isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r

View file

@ -33,15 +33,15 @@ import Utility.UserInfo
- directory. -} - directory. -}
fromCwd :: IO Repo fromCwd :: IO Repo
fromCwd = getCurrentDirectory >>= seekUp checkForRepo fromCwd = getCurrentDirectory >>= seekUp checkForRepo
where where
norepo = error "Not in a git repository." norepo = error "Not in a git repository."
seekUp check dir = do seekUp check dir = do
r <- check dir r <- check dir
case r of case r of
Nothing -> case parentDir dir of Nothing -> case parentDir dir of
"" -> norepo "" -> norepo
d -> seekUp check d d -> seekUp check d
Just loc -> newFrom loc Just loc -> newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -} {- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo fromPath :: FilePath -> IO Repo
@ -55,21 +55,21 @@ fromAbsPath dir
ifM (doesDirectoryExist dir') ( ret dir' , hunt ) ifM (doesDirectoryExist dir') ( ret dir' , hunt )
| otherwise = | otherwise =
error $ "internal error, " ++ dir ++ " is not absolute" error $ "internal error, " ++ dir ++ " is not absolute"
where where
ret = newFrom . LocalUnknown ret = newFrom . LocalUnknown
{- Git always looks for "dir.git" in preference to {- Git always looks for "dir.git" in preference to
- to "dir", even if dir ends in a "/". -} - to "dir", even if dir ends in a "/". -}
canondir = dropTrailingPathSeparator dir canondir = dropTrailingPathSeparator dir
dir' = canondir ++ ".git" dir' = canondir ++ ".git"
{- When dir == "foo/.git", git looks for "foo/.git/.git", {- When dir == "foo/.git", git looks for "foo/.git/.git",
- and failing that, uses "foo" as the repository. -} - and failing that, uses "foo" as the repository. -}
hunt hunt
| "/.git" `isSuffixOf` canondir = | "/.git" `isSuffixOf` canondir =
ifM (doesDirectoryExist $ dir </> ".git") ifM (doesDirectoryExist $ dir </> ".git")
( ret dir ( ret dir
, ret $ takeDirectory canondir , ret $ takeDirectory canondir
) )
| otherwise = ret dir | otherwise = ret dir
{- Remote Repo constructor. Throws exception on invalid url. {- Remote Repo constructor. Throws exception on invalid url.
- -
@ -85,9 +85,9 @@ fromUrlStrict :: String -> IO Repo
fromUrlStrict url fromUrlStrict url
| startswith "file://" url = fromAbsPath $ uriPath u | startswith "file://" url = fromAbsPath $ uriPath u
| otherwise = newFrom $ Url u | otherwise = newFrom $ Url u
where where
u = fromMaybe bad $ parseURI url u = fromMaybe bad $ parseURI url
bad = error $ "bad url " ++ url bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -} {- Creates a repo that has an unknown location. -}
fromUnknown :: IO Repo fromUnknown :: IO Repo
@ -100,21 +100,23 @@ localToUrl reference r
| not $ repoIsUrl reference = error "internal error; reference repo not url" | not $ repoIsUrl reference = error "internal error; reference repo not url"
| repoIsUrl r = r | repoIsUrl r = r
| otherwise = r { location = Url $ fromJust $ parseURI absurl } | otherwise = r { location = Url $ fromJust $ parseURI absurl }
where where
absurl = absurl = concat
Url.scheme reference ++ "//" ++ [ Url.scheme reference
Url.authority reference ++ , "//"
repoPath r , Url.authority reference
, repoPath r
]
{- Calculates a list of a repo's configured remotes, by parsing its config. -} {- Calculates a list of a repo's configured remotes, by parsing its config. -}
fromRemotes :: Repo -> IO [Repo] fromRemotes :: Repo -> IO [Repo]
fromRemotes repo = mapM construct remotepairs fromRemotes repo = mapM construct remotepairs
where where
filterconfig f = filter f $ M.toList $ config repo filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k) filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isremote remotepairs = filterkeys isremote
isremote k = startswith "remote." k && endswith ".url" k isremote k = startswith "remote." k && endswith ".url" k
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
{- Sets the name of a remote when constructing the Repo to represent it. -} {- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo remoteNamed :: String -> IO Repo -> IO Repo
@ -126,50 +128,48 @@ remoteNamed n constructor = do
"remote.foo.url". -} "remote.foo.url". -}
remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey :: String -> IO Repo -> IO Repo
remoteNamedFromKey k = remoteNamed basename remoteNamedFromKey k = remoteNamed basename
where where
basename = join "." $ reverse $ drop 1 $ basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k
reverse $ drop 1 $ split "." k
{- Constructs a new Repo for one of a Repo's remotes using a given {- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -} - location (ie, an url). -}
fromRemoteLocation :: String -> Repo -> IO Repo fromRemoteLocation :: String -> Repo -> IO Repo
fromRemoteLocation s repo = gen $ calcloc s fromRemoteLocation s repo = gen $ calcloc s
where where
gen v gen v
| scpstyle v = fromUrl $ scptourl v | scpstyle v = fromUrl $ scptourl v
| urlstyle v = fromUrl v | urlstyle v = fromUrl v
| otherwise = fromRemotePath v repo | otherwise = fromRemotePath v repo
-- insteadof config can rewrite remote location -- insteadof config can rewrite remote location
calcloc l calcloc l
| null insteadofs = l | null insteadofs = l
| otherwise = replacement ++ drop (length bestvalue) l | otherwise = replacement ++ drop (length bestvalue) l
where where
replacement = drop (length prefix) $ replacement = drop (length prefix) $
take (length bestkey - length suffix) bestkey take (length bestkey - length suffix) bestkey
(bestkey, bestvalue) = maximumBy longestvalue insteadofs (bestkey, bestvalue) = maximumBy longestvalue insteadofs
longestvalue (_, a) (_, b) = compare b a longestvalue (_, a) (_, b) = compare b a
insteadofs = filterconfig $ \(k, v) -> insteadofs = filterconfig $ \(k, v) ->
startswith prefix k && startswith prefix k &&
endswith suffix k && endswith suffix k &&
startswith v l startswith v l
filterconfig f = filter f $ filterconfig f = filter f $
concatMap splitconfigs $ concatMap splitconfigs $ M.toList $ fullconfig repo
M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs
splitconfigs (k, vs) = map (\v -> (k, v)) vs (prefix, suffix) = ("url." , ".insteadof")
(prefix, suffix) = ("url." , ".insteadof") urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v -- git remotes can be written scp style -- [user@]host:dir
-- git remotes can be written scp style -- [user@]host:dir -- but foo::bar is a git-remote-helper location instead
-- but foo::bar is a git-remote-helper location instead scpstyle v = ":" `isInfixOf` v
scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v)
&& not ("//" `isInfixOf` v) && not ("::" `isInfixOf` v)
&& not ("::" `isInfixOf` v) scptourl v = "ssh://" ++ host ++ slash dir
scptourl v = "ssh://" ++ host ++ slash dir where
where (host, dir) = separate (== ':') v
(host, dir) = separate (== ':') v slash d | d == "" = "/~/" ++ d
slash d | d == "" = "/~/" ++ d | "/" `isPrefixOf` d = d
| "/" `isPrefixOf` d = d | "~" `isPrefixOf` d = '/':d
| "~" `isPrefixOf` d = '/':d | otherwise = "/~/" ++ d
| otherwise = "/~/" ++ d
{- Constructs a Repo from the path specified in the git remotes of {- Constructs a Repo from the path specified in the git remotes of
- another Repo. -} - another Repo. -}
@ -191,25 +191,25 @@ repoAbsPath d = do
expandTilde :: FilePath -> IO FilePath expandTilde :: FilePath -> IO FilePath
expandTilde = expandt True expandTilde = expandt True
where where
expandt _ [] = return "" expandt _ [] = return ""
expandt _ ('/':cs) = do expandt _ ('/':cs) = do
v <- expandt True cs v <- expandt True cs
return ('/':v) return ('/':v)
expandt True ('~':'/':cs) = do expandt True ('~':'/':cs) = do
h <- myHomeDir h <- myHomeDir
return $ h </> cs return $ h </> cs
expandt True ('~':cs) = do expandt True ('~':cs) = do
let (name, rest) = findname "" cs let (name, rest) = findname "" cs
u <- getUserEntryForName name u <- getUserEntryForName name
return $ homeDirectory u </> rest return $ homeDirectory u </> rest
expandt _ (c:cs) = do expandt _ (c:cs) = do
v <- expandt False cs v <- expandt False cs
return (c:v) return (c:v)
findname n [] = (n, "") findname n [] = (n, "")
findname n (c:cs) findname n (c:cs)
| c == '/' = (n, cs) | c == '/' = (n, cs)
| otherwise = findname (n++[c]) cs | otherwise = findname (n++[c]) cs
checkForRepo :: FilePath -> IO (Maybe RepoLocation) checkForRepo :: FilePath -> IO (Maybe RepoLocation)
checkForRepo dir = checkForRepo dir =
@ -217,28 +217,28 @@ checkForRepo dir =
check gitDirFile $ check gitDirFile $
check isBareRepo $ check isBareRepo $
return Nothing return Nothing
where where
check test cont = maybe cont (return . Just) =<< test check test cont = maybe cont (return . Just) =<< test
checkdir c = ifM c checkdir c = ifM c
( return $ Just $ LocalUnknown dir ( return $ Just $ LocalUnknown dir
, return Nothing , return Nothing
) )
isRepo = checkdir $ gitSignature $ ".git" </> "config" isRepo = checkdir $ gitSignature $ ".git" </> "config"
isBareRepo = checkdir $ gitSignature "config" isBareRepo = checkdir $ gitSignature "config"
<&&> doesDirectoryExist (dir </> "objects") <&&> doesDirectoryExist (dir </> "objects")
gitDirFile = do gitDirFile = do
c <- firstLine <$> c <- firstLine <$>
catchDefaultIO "" (readFile $ dir </> ".git") catchDefaultIO "" (readFile $ dir </> ".git")
return $ if gitdirprefix `isPrefixOf` c return $ if gitdirprefix `isPrefixOf` c
then Just $ Local then Just $ Local
{ gitdir = absPathFrom dir $ { gitdir = absPathFrom dir $
drop (length gitdirprefix) c drop (length gitdirprefix) c
, worktree = Just dir , worktree = Just dir
} }
else Nothing else Nothing
where where
gitdirprefix = "gitdir: " gitdirprefix = "gitdir: "
gitSignature file = doesFileExist $ dir </> file gitSignature file = doesFileExist $ dir </> file
newFrom :: RepoLocation -> IO Repo newFrom :: RepoLocation -> IO Repo
newFrom l = return Repo newFrom l = return Repo

View file

@ -39,23 +39,23 @@ get = do
unless (d `dirContains` cwd) $ unless (d `dirContains` cwd) $
changeWorkingDirectory d changeWorkingDirectory d
return $ addworktree wt r return $ addworktree wt r
where where
pathenv s = do pathenv s = do
v <- getEnv s v <- getEnv s
case v of case v of
Just d -> do Just d -> do
unsetEnv s unsetEnv s
Just <$> absPath d Just <$> absPath d
Nothing -> return Nothing Nothing -> return Nothing
configure Nothing r = Git.Config.read r configure Nothing r = Git.Config.read r
configure (Just d) r = do configure (Just d) r = do
r' <- Git.Config.read r r' <- Git.Config.read r
-- Let GIT_DIR override the default gitdir. -- Let GIT_DIR override the default gitdir.
absd <- absPath d absd <- absPath d
return $ changelocation r' $ Local return $ changelocation r' $ Local
{ gitdir = absd { gitdir = absd
, worktree = worktree (location r') , worktree = worktree (location r')
} }
addworktree w r = changelocation r $ addworktree w r = changelocation r $
Local { gitdir = gitdir (location r), worktree = w } Local { gitdir = gitdir (location r), worktree = w }
changelocation r l = r { location = l } changelocation r l = r { location = l }

View file

@ -29,17 +29,17 @@ hashObjectStop = CoProcess.stop
{- Injects a file into git, returning the Sha of the object. -} {- Injects a file into git, returning the Sha of the object. -}
hashFile :: HashObjectHandle -> FilePath -> IO Sha hashFile :: HashObjectHandle -> FilePath -> IO Sha
hashFile h file = CoProcess.query h send receive hashFile h file = CoProcess.query h send receive
where where
send to = do send to = do
fileEncoding to fileEncoding to
hPutStrLn to file hPutStrLn to file
receive from = getSha "hash-object" $ hGetLine from receive from = getSha "hash-object" $ hGetLine from
{- Injects some content into git, returning its Sha. -} {- Injects some content into git, returning its Sha. -}
hashObject :: ObjectType -> String -> Repo -> IO Sha hashObject :: ObjectType -> String -> Repo -> IO Sha
hashObject objtype content repo = getSha subcmd $ do hashObject objtype content repo = getSha subcmd $ do
s <- pipeWriteRead (map Param params) content repo s <- pipeWriteRead (map Param params) content repo
return s return s
where where
subcmd = "hash-object" subcmd = "hash-object"
params = [subcmd, "-t", show objtype, "-w", "--stdin"] params = [subcmd, "-t", show objtype, "-w", "--stdin"]

View file

@ -21,7 +21,7 @@ override index = do
res <- getEnv var res <- getEnv var
setEnv var index True setEnv var index True
return $ reset res return $ reset res
where where
var = "GIT_INDEX_FILE" var = "GIT_INDEX_FILE"
reset (Just v) = setEnv var v True reset (Just v) = setEnv var v True
reset _ = unsetEnv var reset _ = unsetEnv var

View file

@ -69,6 +69,12 @@ stagedDetails l repo = do
where where
(metadata, file) = separate (== '\t') s (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 {- Returns a list of the files in the specified locations that are staged
- for commit, and whose type has changed. -} - for commit, and whose type has changed. -}
typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)

View file

@ -48,11 +48,11 @@ parseLsTree l = TreeItem
, sha = s , sha = s
, file = Git.Filename.decode f , file = Git.Filename.decode f
} }
where where
-- l = <mode> SP <type> SP <sha> TAB <file> -- l = <mode> SP <type> SP <sha> TAB <file>
-- All fields are fixed, so we can pull them out of -- All fields are fixed, so we can pull them out of
-- specific positions in the line. -- specific positions in the line.
(m, past_m) = splitAt 7 l (m, past_m) = splitAt 7 l
(t, past_t) = splitAt 4 past_m (t, past_t) = splitAt 4 past_m
(s, past_s) = splitAt shaSize $ Prelude.tail past_t (s, past_s) = splitAt shaSize $ Prelude.tail past_t
f = Prelude.tail past_s f = Prelude.tail past_s

View file

@ -86,30 +86,30 @@ new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
addCommand subcommand params files q repo = addCommand subcommand params files q repo =
updateQueue action different (length newfiles) q repo updateQueue action different (length newfiles) q repo
where where
key = actionKey action key = actionKey action
action = CommandAction action = CommandAction
{ getSubcommand = subcommand { getSubcommand = subcommand
, getParams = params , getParams = params
, getFiles = newfiles , getFiles = newfiles
} }
newfiles = files ++ maybe [] getFiles (M.lookup key $ items q) newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)
different (CommandAction { getSubcommand = s }) = s /= subcommand different (CommandAction { getSubcommand = s }) = s /= subcommand
different _ = True different _ = True
{- Adds an update-index streamer to the queue. -} {- Adds an update-index streamer to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
addUpdateIndex streamer q repo = addUpdateIndex streamer q repo =
updateQueue action different 1 q repo updateQueue action different 1 q repo
where where
key = actionKey action key = actionKey action
-- the list is built in reverse order -- the list is built in reverse order
action = UpdateIndexAction $ streamer : streamers action = UpdateIndexAction $ streamer : streamers
streamers = maybe [] getStreamers $ M.lookup key $ items q streamers = maybe [] getStreamers $ M.lookup key $ items q
different (UpdateIndexAction _) = False different (UpdateIndexAction _) = False
different _ = True different _ = True
{- Updates or adds an action in the queue. If the queue already contains a {- 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 - 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 updateQueue !action different sizeincrease q repo
| null (filter different (M.elems (items q))) = return $ go q | null (filter different (M.elems (items q))) = return $ go q
| otherwise = go <$> flush q repo | otherwise = go <$> flush q repo
where where
go q' = newq go q' = newq
where where
!newq = q' !newq = q'
{ size = newsize { size = newsize
, items = newitems , items = newitems
} }
!newsize = size q' + sizeincrease !newsize = size q' + sizeincrease
!newitems = M.insertWith' const (actionKey action) action (items q') !newitems = M.insertWith' const (actionKey action) action (items q')
{- Is a queue large enough that it should be flushed? -} {- Is a queue large enough that it should be flushed? -}
full :: Queue -> Bool full :: Queue -> Bool
@ -153,8 +153,8 @@ runAction repo action@(CommandAction {}) =
fileEncoding h fileEncoding h
hPutStr h $ join "\0" $ getFiles action hPutStr h $ join "\0" $ getFiles action
hClose h hClose h
where where
p = (proc "xargs" params) { env = gitEnv repo } p = (proc "xargs" params) { env = gitEnv repo }
params = "-0":"git":baseparams params = "-0":"git":baseparams
baseparams = toCommand $ gitCommandLine baseparams = toCommand $ gitCommandLine
(Param (getSubcommand action):getParams action) repo (Param (getSubcommand action):getParams action) repo

View file

@ -21,10 +21,10 @@ describe = show . base
- Converts such a fully qualified ref into a base ref (eg: master). -} - Converts such a fully qualified ref into a base ref (eg: master). -}
base :: Ref -> Ref base :: Ref -> Ref
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
where where
remove prefix s remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s | prefix `isPrefixOf` s = drop (length prefix) s
| otherwise = s | otherwise = s
{- Given a directory such as "refs/remotes/origin", and a ref such as {- 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, - 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. -} {- Get the sha of a fully qualified git ref, if it exists. -}
sha :: Branch -> Repo -> IO (Maybe Sha) sha :: Branch -> Repo -> IO (Maybe Sha)
sha branch repo = process <$> showref repo sha branch repo = process <$> showref repo
where where
showref = pipeReadStrict [Param "show-ref", showref = pipeReadStrict [Param "show-ref",
Param "--hash", -- get the hash Param "--hash", -- get the hash
Param $ show branch] Param $ show branch]
process [] = Nothing process [] = Nothing
process s = Just $ Ref $ firstLine s process s = Just $ Ref $ firstLine s
{- List of (refs, branches) matching a given ref spec. -} {- List of (refs, branches) matching a given ref spec. -}
matching :: Ref -> Repo -> IO [(Ref, Branch)] matching :: Ref -> Repo -> IO [(Ref, Branch)]
matching ref repo = map gen . lines <$> matching ref repo = map gen . lines <$>
pipeReadStrict [Param "show-ref", Param $ show ref] repo pipeReadStrict [Param "show-ref", Param $ show ref] repo
where where
gen l = let (r, b) = separate (== ' ') l in gen l = let (r, b) = separate (== ' ') l
(Ref r, Ref b) in (Ref r, Ref b)
{- List of (refs, branches) matching a given ref spec. {- List of (refs, branches) matching a given ref spec.
- Duplicate refs are filtered out. -} - Duplicate refs are filtered out. -}
matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)] matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]
matchingUniq ref repo = nubBy uniqref <$> matching ref repo matchingUniq ref repo = nubBy uniqref <$> matching ref repo
where where
uniqref (a, _) (b, _) = a == b uniqref (a, _) (b, _) = a == b
{- Checks if a String is a legal git ref name. {- Checks if a String is a legal git ref name.
- -
- The rules for this are complex; see git-check-ref-format(1) -} - The rules for this are complex; see git-check-ref-format(1) -}
legal :: Bool -> String -> Bool legal :: Bool -> String -> Bool
legal allowonelevel s = all (== False) illegal legal allowonelevel s = all (== False) illegal
where where
illegal = illegal =
[ any ("." `isPrefixOf`) pathbits [ any ("." `isPrefixOf`) pathbits
, any (".lock" `isSuffixOf`) pathbits , any (".lock" `isSuffixOf`) pathbits
, not allowonelevel && length pathbits < 2 , not allowonelevel && length pathbits < 2
, contains ".." , contains ".."
, any (\c -> contains [c]) illegalchars , any (\c -> contains [c]) illegalchars
, begins "/" , begins "/"
, ends "/" , ends "/"
, contains "//" , contains "//"
, ends "." , ends "."
, contains "@{" , contains "@{"
, null s , null s
] ]
contains v = v `isInfixOf` s contains v = v `isInfixOf` s
ends v = v `isSuffixOf` s ends v = v `isSuffixOf` s
begins v = v `isPrefixOf` s begins v = v `isPrefixOf` s
pathbits = split "/" s pathbits = split "/" s
illegalchars = " ~^:?*[\\" ++ controlchars illegalchars = " ~^:?*[\\" ++ controlchars
controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)] controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]

View file

@ -14,8 +14,8 @@ import Git.Types
any trailing newline, returning the sha. -} any trailing newline, returning the sha. -}
getSha :: String -> IO String -> IO Sha getSha :: String -> IO String -> IO Sha
getSha subcommand a = maybe bad return =<< extractSha <$> a getSha subcommand a = maybe bad return =<< extractSha <$> a
where where
bad = error $ "failed to read sha from git " ++ subcommand bad = error $ "failed to read sha from git " ++ subcommand
{- Extracts the Sha from a string. There can be a trailing newline after {- Extracts the Sha from a string. There can be a trailing newline after
- it, but nothing else. -} - it, but nothing else. -}
@ -24,12 +24,12 @@ extractSha s
| len == shaSize = val s | len == shaSize = val s
| len == shaSize + 1 && length s' == shaSize = val s' | len == shaSize + 1 && length s' == shaSize = val s'
| otherwise = Nothing | otherwise = Nothing
where where
len = length s len = length s
s' = firstLine s s' = firstLine s
val v val v
| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
| otherwise = Nothing | otherwise = Nothing
{- Size of a git sha. -} {- Size of a git sha. -}
shaSize :: Int shaSize :: Int

View file

@ -62,11 +62,11 @@ doMerge ch differ repo streamer = do
(diff, cleanup) <- pipeNullSplit (map Param differ) repo (diff, cleanup) <- pipeNullSplit (map Param differ) repo
go diff go diff
void $ cleanup void $ cleanup
where where
go [] = noop go [] = noop
go (info:file:rest) = mergeFile info file ch repo >>= go (info:file:rest) = mergeFile info file ch repo >>=
maybe (go rest) (\l -> streamer l >> go rest) maybe (go rest) (\l -> streamer l >> go rest)
go (_:[]) = error $ "parse error " ++ show differ go (_:[]) = error $ "parse error " ++ show differ
{- Given an info line from a git raw diff, and the filename, generates {- 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 - 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 shas -> use
=<< either return (\s -> hashObject BlobObject (unlines s) repo) =<< either return (\s -> hashObject BlobObject (unlines s) repo)
=<< calcMerge . zip shas <$> mapM getcontents shas =<< calcMerge . zip shas <$> mapM getcontents shas
where where
[_colonmode, _bmode, asha, bsha, _status] = words info [_colonmode, _bmode, asha, bsha, _status] = words info
use sha = return $ Just $ use sha = return $ Just $
updateIndexLine sha FileBlob $ asTopFilePath file updateIndexLine sha FileBlob $ asTopFilePath file
-- We don't know how the file is encoded, but need to -- We don't know how the file is encoded, but need to
-- split it into lines to union merge. Using the -- split it into lines to union merge. Using the
-- FileSystemEncoding for this is a hack, but ensures there -- FileSystemEncoding for this is a hack, but ensures there
-- are no decoding errors. Note that this works because -- are no decoding errors. Note that this works because
-- hashObject sets fileEncoding on its write handle. -- hashObject sets fileEncoding on its write handle.
getcontents s = lines . encodeW8 . L.unpack <$> catObject h s getcontents s = lines . encodeW8 . L.unpack <$> catObject h s
{- Calculates a union merge between a list of refs, with contents. {- Calculates a union merge between a list of refs, with contents.
- -
@ -98,7 +98,7 @@ calcMerge :: [(Ref, [String])] -> Either Ref [String]
calcMerge shacontents calcMerge shacontents
| null reuseable = Right $ new | null reuseable = Right $ new
| otherwise = Left $ fst $ Prelude.head reuseable | otherwise = Left $ fst $ Prelude.head reuseable
where where
reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
new = sorteduniq $ concat $ map snd shacontents new = sorteduniq $ concat $ map snd shacontents
sorteduniq = S.toList . S.fromList sorteduniq = S.toList . S.fromList

View file

@ -38,12 +38,12 @@ streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
fileEncoding h fileEncoding h
forM_ as (stream h) forM_ as (stream h)
hClose h hClose h
where where
params = map Param ["update-index", "-z", "--index-info"] params = map Param ["update-index", "-z", "--index-info"]
stream h a = a (streamer h) stream h a = a (streamer h)
streamer h s = do streamer h s = do
hPutStr h s hPutStr h s
hPutStr h "\0" hPutStr h "\0"
{- A streamer that adds the current tree for a ref. Useful for eg, copying {- A streamer that adds the current tree for a ref. Useful for eg, copying
- and modifying branches. -} - and modifying branches. -}
@ -52,8 +52,8 @@ lsTree (Ref x) repo streamer = do
(s, cleanup) <- pipeNullSplit params repo (s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s mapM_ streamer s
void $ cleanup void $ cleanup
where where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
{- Generates a line suitable to be fed into update-index, to add {- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -} - a given file with a given sha. -}

View file

@ -28,13 +28,13 @@ scheme repo = notUrl repo
- <http://trac.haskell.org/network/ticket/40> -} - <http://trac.haskell.org/network/ticket/40> -}
uriRegName' :: URIAuth -> String uriRegName' :: URIAuth -> String
uriRegName' a = fixup $ uriRegName a uriRegName' a = fixup $ uriRegName a
where where
fixup x@('[':rest) fixup x@('[':rest)
| rest !! len == ']' = take len rest | rest !! len == ']' = take len rest
| otherwise = x | otherwise = x
where where
len = length rest - 1 len = length rest - 1
fixup x = x fixup x = x
{- Hostname of an URL repo. -} {- Hostname of an URL repo. -}
host :: Repo -> String 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") -} {- The full authority portion an URL repo. (ie, "user@host:port") -}
authority :: Repo -> String authority :: Repo -> String
authority = authpart assemble authority = authpart assemble
where where
assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
{- Applies a function to extract part of the uriAuthority of an URL repo. -} {- Applies a function to extract part of the uriAuthority of an URL repo. -}
authpart :: (URIAuth -> a) -> Repo -> a authpart :: (URIAuth -> a) -> Repo -> a
authpart a Repo { location = Url u } = a auth authpart a Repo { location = Url u } = a auth
where where
auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u) auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
authpart _ repo = notUrl repo authpart _ repo = notUrl repo
notUrl :: Repo -> a notUrl :: Repo -> a

View file

@ -26,13 +26,13 @@ normalize :: String -> Integer
normalize = sum . mult 1 . reverse . normalize = sum . mult 1 . reverse .
extend precision . take precision . extend precision . take precision .
map readi . split "." map readi . split "."
where where
extend n l = l ++ replicate (n - length l) 0 extend n l = l ++ replicate (n - length l) 0
mult _ [] = [] mult _ [] = []
mult n (x:xs) = (n*x) : mult (n*10^width) xs mult n (x:xs) = (n*x) : mult (n*10^width) xs
readi :: String -> Integer readi :: String -> Integer
readi s = case reads s of readi s = case reads s of
((x,_):_) -> x ((x,_):_) -> x
_ -> 0 _ -> 0
precision = 10 -- number of segments of the version to compare precision = 10 -- number of segments of the version to compare
width = length "yyyymmddhhmmss" -- maximum width of a segment width = length "yyyymmddhhmmss" -- maximum width of a segment

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 # 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 # 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 bins=git-annex
mans=git-annex.1 git-annex-shell.1 mans=git-annex.1 git-annex-shell.1
@ -160,8 +160,15 @@ linuxstandalone:
ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-annex-shell" ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-annex-shell"
zcat standalone/licences.gz > $(LINUXSTANDALONE_DEST)/LICENSE zcat standalone/licences.gz > $(LINUXSTANDALONE_DEST)/LICENSE
set -e; \
for bin in $(THIRDPARTY_BINS); do \ 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 done
install -d "$(LINUXSTANDALONE_DEST)/git-core" install -d "$(LINUXSTANDALONE_DEST)/git-core"
@ -200,7 +207,13 @@ osxapp:
cp $(OSXAPP_BASE)/LICENSE $(GIT_ANNEX_TMP_BUILD_DIR)/build-dmg/LICENSE.txt cp $(OSXAPP_BASE)/LICENSE $(GIT_ANNEX_TMP_BUILD_DIR)/build-dmg/LICENSE.txt
for bin in $(THIRDPARTY_BINS); do \ 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 done
(cd "$(shell git --exec-path)" && tar c .) | (cd "$(OSXAPP_BASE)" && tar x) (cd "$(shell git --exec-path)" && tar c .) | (cd "$(OSXAPP_BASE)" && tar x)

View file

@ -36,6 +36,6 @@ descStandardGroup FullArchiveGroup = "full archive: archives all files not archi
preferredContent :: StandardGroup -> String preferredContent :: StandardGroup -> String
preferredContent ClientGroup = "exclude=*/archive/* and exclude=archive/*" preferredContent ClientGroup = "exclude=*/archive/* and exclude=archive/*"
preferredContent TransferGroup = "not (inallgroup=client and copies=client:2) and " ++ preferredContent ClientGroup 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 SmallArchiveGroup = "(include=*/archive/* or include=archive/*) and " ++ preferredContent FullArchiveGroup
preferredContent FullArchiveGroup = "not (copies=archive:1 or copies=smallarchive:1)" preferredContent FullArchiveGroup = "not (copies=archive:1 or copies=smallarchive:1)"

View file

@ -15,4 +15,4 @@ toB64 = encode . s2w8
fromB64 :: String -> String fromB64 :: String -> String
fromB64 s = maybe bad w82s $ decode s fromB64 s = maybe bad w82s $ decode s
where bad = error "bad base64 encoded data" where bad = error "bad base64 encoded data"

View file

@ -17,9 +17,9 @@ copyFileExternal src dest = do
whenM (doesFileExist dest) $ whenM (doesFileExist dest) $
removeFile dest removeFile dest
boolSystem "cp" $ params ++ [File src, File dest] boolSystem "cp" $ params ++ [File src, File dest]
where where
params = map snd $ filter fst params = map snd $ filter fst
[ (SysConfig.cp_reflink_auto, Param "--reflink=auto") [ (SysConfig.cp_reflink_auto, Param "--reflink=auto")
, (SysConfig.cp_a, Param "-a") , (SysConfig.cp_a, Param "-a")
, (SysConfig.cp_p && not SysConfig.cp_a, Param "-p") , (SysConfig.cp_p && not SysConfig.cp_a, Param "-p")
] ]

View file

@ -57,10 +57,10 @@ runClient getaddr clientaction = do
e <- takeMVar mv e <- takeMVar mv
disconnect client disconnect client
throw e throw e
where where
threadrunner storeerr io = loop threadrunner storeerr io = loop
where where
loop = catchClientError (io >> loop) storeerr loop = catchClientError (io >> loop) storeerr
{- Connects to the bus, and runs the client action. {- 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 {- runClient can fail with not just ClientError, but also other
- things, if dbus is not running. Let async exceptions through. -} - things, if dbus is not running. Let async exceptions through. -}
runClient getaddr clientaction `catchNonAsync` retry runClient getaddr clientaction `catchNonAsync` retry
where where
retry e = do retry e = do
v' <- onretry e v v' <- onretry e v
persistentClient getaddr v' onretry clientaction persistentClient getaddr v' onretry clientaction
{- Catches only ClientError -} {- Catches only ClientError -}
catchClientError :: IO () -> (ClientError -> IO ()) -> IO () catchClientError :: IO () -> (ClientError -> IO ()) -> IO ()

View file

@ -22,27 +22,27 @@ daemonize logfd pidfile changedirectory a = do
maybe noop checkalreadyrunning pidfile maybe noop checkalreadyrunning pidfile
_ <- forkProcess child1 _ <- forkProcess child1
out out
where where
checkalreadyrunning f = maybe noop (const $ alreadyRunning) checkalreadyrunning f = maybe noop (const $ alreadyRunning)
=<< checkDaemon f =<< checkDaemon f
child1 = do child1 = do
_ <- createSession _ <- createSession
_ <- forkProcess child2 _ <- forkProcess child2
out out
child2 = do child2 = do
maybe noop lockPidFile pidfile maybe noop lockPidFile pidfile
when changedirectory $ when changedirectory $
setCurrentDirectory "/" setCurrentDirectory "/"
nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
_ <- redir nullfd stdInput _ <- redir nullfd stdInput
mapM_ (redir logfd) [stdOutput, stdError] mapM_ (redir logfd) [stdOutput, stdError]
closeFd logfd closeFd logfd
a a
out out
redir newh h = do redir newh h = do
closeFd h closeFd h
dupTo newh h dupTo newh h
out = exitImmediately ExitSuccess out = exitImmediately ExitSuccess
{- Locks the pid file, with an exclusive, non-blocking lock. {- Locks the pid file, with an exclusive, non-blocking lock.
- Writes the pid to the file, fully atomically. - Writes the pid to the file, fully atomically.
@ -62,8 +62,8 @@ lockPidFile file = do
_ <- fdWrite fd' =<< show <$> getProcessID _ <- fdWrite fd' =<< show <$> getProcessID
renameFile newfile file renameFile newfile file
closeFd fd closeFd fd
where where
newfile = file ++ ".new" newfile = file ++ ".new"
alreadyRunning :: IO () alreadyRunning :: IO ()
alreadyRunning = error "Daemon is already running." alreadyRunning = error "Daemon is already running."
@ -82,19 +82,19 @@ checkDaemon pidfile = do
p <- readish <$> readFile pidfile p <- readish <$> readFile pidfile
return $ check locked p return $ check locked p
Nothing -> return Nothing Nothing -> return Nothing
where where
check Nothing _ = Nothing check Nothing _ = Nothing
check _ Nothing = Nothing check _ Nothing = Nothing
check (Just (pid, _)) (Just pid') check (Just (pid, _)) (Just pid')
| pid == pid' = Just pid | pid == pid' = Just pid
| otherwise = error $ | otherwise = error $
"stale pid in " ++ pidfile ++ "stale pid in " ++ pidfile ++
" (got " ++ show pid' ++ " (got " ++ show pid' ++
"; expected " ++ show pid ++ " )" "; expected " ++ show pid ++ " )"
{- Stops the daemon, safely. -} {- Stops the daemon, safely. -}
stopDaemon :: FilePath -> IO () stopDaemon :: FilePath -> IO ()
stopDaemon pidfile = go =<< checkDaemon pidfile stopDaemon pidfile = go =<< checkDaemon pidfile
where where
go Nothing = noop go Nothing = noop
go (Just pid) = signalProcess sigTERM pid go (Just pid) = signalProcess sigTERM pid

View file

@ -72,9 +72,9 @@ storageUnits =
, Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe
, Unit (p 0) "B" "byte" , Unit (p 0) "B" "byte"
] ]
where where
p :: Integer -> Integer p :: Integer -> Integer
p n = 1000^n p n = 1000^n
{- Memory units are (stupidly named) powers of 2. -} {- Memory units are (stupidly named) powers of 2. -}
memoryUnits :: [Unit] memoryUnits :: [Unit]
@ -89,9 +89,9 @@ memoryUnits =
, Unit (p 1) "KiB" "kibibyte" , Unit (p 1) "KiB" "kibibyte"
, Unit (p 0) "B" "byte" , Unit (p 0) "B" "byte"
] ]
where where
p :: Integer -> Integer p :: Integer -> Integer
p n = 2^(n*10) p n = 2^(n*10)
{- Bandwidth units are only measured in bits if you're some crazy telco. -} {- Bandwidth units are only measured in bits if you're some crazy telco. -}
bandwidthUnits :: [Unit] 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? -} {- Do you yearn for the days when men were men and megabytes were megabytes? -}
oldSchoolUnits :: [Unit] oldSchoolUnits :: [Unit]
oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
where where
mingle (Unit _ a n, Unit s' _ _) = Unit s' a n mingle (Unit _ a n, Unit s' _ _) = Unit s' a n
{- approximate display of a particular number of bytes -} {- approximate display of a particular number of bytes -}
roughSize :: [Unit] -> Bool -> ByteSize -> String roughSize :: [Unit] -> Bool -> ByteSize -> String
roughSize units abbrev i roughSize units abbrev i
| i < 0 = '-' : findUnit units' (negate i) | i < 0 = '-' : findUnit units' (negate i)
| otherwise = findUnit units' i | otherwise = findUnit units' i
where where
units' = reverse $ sort units -- largest first units' = reverse $ sort units -- largest first
findUnit (u@(Unit s _ _):us) i' findUnit (u@(Unit s _ _):us) i'
| i' >= s = showUnit i' u | i' >= s = showUnit i' u
| otherwise = findUnit us i' | otherwise = findUnit us i'
findUnit [] i' = showUnit i' (last units') -- bytes findUnit [] i' = showUnit i' (last units') -- bytes
showUnit i' (Unit s a n) = let num = chop i' s in showUnit i' (Unit s a n) = let num = chop i' s in
show num ++ " " ++ show num ++ " " ++
(if abbrev then a else plural num n) (if abbrev then a else plural num n)
chop :: Integer -> Integer -> Integer chop :: Integer -> Integer -> Integer
chop i' d = round $ (fromInteger i' :: Double) / fromInteger d chop i' d = round $ (fromInteger i' :: Double) / fromInteger d
plural n u plural n u
| n == 1 = u | n == 1 = u
| otherwise = u ++ "s" | otherwise = u ++ "s"
{- displays comparison of two sizes -} {- displays comparison of two sizes -}
compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String
@ -139,22 +139,22 @@ readSize :: [Unit] -> String -> Maybe ByteSize
readSize units input readSize units input
| null parsednum || null parsedunit = Nothing | null parsednum || null parsedunit = Nothing
| otherwise = Just $ round $ number * fromIntegral multiplier | otherwise = Just $ round $ number * fromIntegral multiplier
where where
(number, rest) = head parsednum (number, rest) = head parsednum
multiplier = head parsedunit multiplier = head parsedunit
unitname = takeWhile isAlpha $ dropWhile isSpace rest unitname = takeWhile isAlpha $ dropWhile isSpace rest
parsednum = reads input :: [(Double, String)] parsednum = reads input :: [(Double, String)]
parsedunit = lookupUnit units unitname parsedunit = lookupUnit units unitname
lookupUnit _ [] = [1] -- no unit given, assume bytes lookupUnit _ [] = [1] -- no unit given, assume bytes
lookupUnit [] _ = [] lookupUnit [] _ = []
lookupUnit (Unit s a n:us) v lookupUnit (Unit s a n:us) v
| a ~~ v || n ~~ v = [s] | a ~~ v || n ~~ v = [s]
| plural n ~~ v || a ~~ byteabbrev v = [s] | plural n ~~ v || a ~~ byteabbrev v = [s]
| otherwise = lookupUnit us v | otherwise = lookupUnit us v
a ~~ b = map toLower a == map toLower b a ~~ b = map toLower a == map toLower b
plural n = n ++ "s" plural n = n ++ "s"
byteabbrev a = a ++ "b" byteabbrev a = a ++ "b"

View file

@ -44,46 +44,46 @@ dirContentsRecursive' (dir:dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir) (files, dirs') <- collect [] [] =<< catchDefaultIO [] (dirContents dir)
files' <- dirContentsRecursive' (dirs' ++ dirs) files' <- dirContentsRecursive' (dirs' ++ dirs)
return (files ++ files') return (files ++ files')
where where
collect files dirs' [] = return (reverse files, reverse dirs') collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries) collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries | dirCruft entry = collect files dirs' entries
| otherwise = do | otherwise = do
ifM (doesDirectoryExist entry) ifM (doesDirectoryExist entry)
( collect files (entry:dirs') entries ( collect files (entry:dirs') entries
, collect (entry:files) dirs' entries , collect (entry:files) dirs' entries
) )
{- Moves one filename to another. {- Moves one filename to another.
- First tries a rename, but falls back to moving across devices if needed. -} - First tries a rename, but falls back to moving across devices if needed. -}
moveFile :: FilePath -> FilePath -> IO () moveFile :: FilePath -> FilePath -> IO ()
moveFile src dest = tryIO (rename src dest) >>= onrename moveFile src dest = tryIO (rename src dest) >>= onrename
where where
onrename (Right _) = noop onrename (Right _) = noop
onrename (Left e) onrename (Left e)
| isPermissionError e = rethrow | isPermissionError e = rethrow
| isDoesNotExistError e = rethrow | isDoesNotExistError e = rethrow
| otherwise = do | otherwise = do
-- copyFile is likely not as optimised as -- copyFile is likely not as optimised as
-- the mv command, so we'll use the latter. -- the mv command, so we'll use the latter.
-- But, mv will move into a directory if -- But, mv will move into a directory if
-- dest is one, which is not desired. -- dest is one, which is not desired.
whenM (isdir dest) rethrow whenM (isdir dest) rethrow
viaTmp mv dest undefined viaTmp mv dest undefined
where where
rethrow = throw e rethrow = throw e
mv tmp _ = do mv tmp _ = do
ok <- boolSystem "mv" [Param "-f", ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
Param src, Param tmp] unless ok $ do
unless ok $ do -- delete any partial
-- delete any partial _ <- tryIO $ removeFile tmp
_ <- tryIO $ removeFile tmp rethrow
rethrow
isdir f = do isdir f = do
r <- tryIO $ getFileStatus f r <- tryIO $ getFileStatus f
case r of case r of
(Left _) -> return False (Left _) -> return False
(Right s) -> return $ isDirectory s (Right s) -> return $ isDirectory s
{- Removes a file, which may or may not exist. {- Removes a file, which may or may not exist.
- -

View file

@ -25,5 +25,5 @@ getDiskFree path = withFilePath path $ \c_path -> do
( return $ Just $ toInteger free ( return $ Just $ toInteger free
, return Nothing , return Nothing
) )
where where
safeErrno (Errno v) = v == 0 safeErrno (Errno v) = v == 0

View file

@ -10,9 +10,9 @@ module Utility.Dot where -- import qualified
{- generates a graph description from a list of lines -} {- generates a graph description from a list of lines -}
graph :: [String] -> String graph :: [String] -> String
graph s = unlines $ [header] ++ map indent s ++ [footer] graph s = unlines $ [header] ++ map indent s ++ [footer]
where where
header = "digraph map {" header = "digraph map {"
footer= "}" footer= "}"
{- a node in the graph -} {- a node in the graph -}
graphNode :: String -> String -> String graphNode :: String -> String -> String
@ -21,8 +21,8 @@ graphNode nodeid desc = label desc $ quote nodeid
{- an edge between two nodes -} {- an edge between two nodes -}
graphEdge :: String -> String -> Maybe String -> String graphEdge :: String -> String -> Maybe String -> String
graphEdge fromid toid desc = indent $ maybe edge (`label` edge) desc graphEdge fromid toid desc = indent $ maybe edge (`label` edge) desc
where where
edge = quote fromid ++ " -> " ++ quote toid edge = quote fromid ++ " -> " ++ quote toid
{- adds a label to a node or edge -} {- adds a label to a node or edge -}
label :: String -> String -> String label :: String -> String -> String
@ -46,18 +46,18 @@ subGraph subid l color s =
ii setcolor ++ ii setcolor ++
ii s ++ ii s ++
indent "}" indent "}"
where where
-- the "cluster_" makes dot draw a box -- the "cluster_" makes dot draw a box
name = quote ("cluster_" ++ subid) name = quote ("cluster_" ++ subid)
setlabel = "label=" ++ quote l setlabel = "label=" ++ quote l
setfilled = "style=" ++ quote "filled" setfilled = "style=" ++ quote "filled"
setcolor = "fillcolor=" ++ quote color setcolor = "fillcolor=" ++ quote color
ii x = indent (indent x) ++ "\n" ii x = indent (indent x) ++ "\n"
indent ::String -> String indent ::String -> String
indent s = '\t' : s indent s = '\t' : s
quote :: String -> String quote :: String -> String
quote s = "\"" ++ s' ++ "\"" quote s = "\"" ++ s' ++ "\""
where where
s' = filter (/= '"') s s' = filter (/= '"') s

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. -} {- Runs an action after changing a file's mode, then restores the old mode. -}
withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode file convert a = bracket setup cleanup go withModifiedFileMode file convert a = bracket setup cleanup go
where where
setup = modifyFileMode' file convert setup = modifyFileMode' file convert
cleanup oldmode = modifyFileMode file (const oldmode) cleanup oldmode = modifyFileMode file (const oldmode)
go _ = a go _ = a
writeModes :: [FileMode] writeModes :: [FileMode]
writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode] writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
@ -83,10 +83,10 @@ noUmask :: FileMode -> IO a -> IO a
noUmask mode a noUmask mode a
| mode == stdFileMode = a | mode == stdFileMode = a
| otherwise = bracket setup cleanup go | otherwise = bracket setup cleanup go
where where
setup = setFileCreationMask nullFileMode setup = setFileCreationMask nullFileMode
cleanup = setFileCreationMask cleanup = setFileCreationMask
go _ = a go _ = a
combineModes :: [FileMode] -> FileMode combineModes :: [FileMode] -> FileMode
combineModes [] = undefined combineModes [] = undefined

View file

@ -43,19 +43,19 @@ type Variables = M.Map String String
- This can be repeatedly called, efficiently. -} - This can be repeatedly called, efficiently. -}
format :: Format -> Variables -> String format :: Format -> Variables -> String
format f vars = concatMap expand f format f vars = concatMap expand f
where where
expand (Const s) = s expand (Const s) = s
expand (Var name j) expand (Var name j)
| "escaped_" `isPrefixOf` name = | "escaped_" `isPrefixOf` name =
justify j $ encode_c_strict $ justify j $ encode_c_strict $
getvar $ drop (length "escaped_") name getvar $ drop (length "escaped_") name
| otherwise = justify j $ getvar name | otherwise = justify j $ getvar name
getvar name = fromMaybe "" $ M.lookup name vars getvar name = fromMaybe "" $ M.lookup name vars
justify UnJustified s = s justify UnJustified s = s
justify (LeftJustified i) s = s ++ pad i s justify (LeftJustified i) s = s ++ pad i s
justify (RightJustified i) s = pad i s ++ s justify (RightJustified i) s = pad i s ++ s
pad i s = take (i - length s) spaces pad i s = take (i - length s) spaces
spaces = repeat ' ' spaces = repeat ' '
{- Generates a Format that can be used to expand variables in a {- Generates a Format that can be used to expand variables in a
- format string, such as "${foo} ${bar;10} ${baz;-10}\n" - format string, such as "${foo} ${bar;10} ${baz;-10}\n"
@ -64,37 +64,37 @@ format f vars = concatMap expand f
-} -}
gen :: FormatString -> Format gen :: FormatString -> Format
gen = filter (not . empty) . fuse [] . scan [] . decode_c gen = filter (not . empty) . fuse [] . scan [] . decode_c
where where
-- The Format is built up in reverse, for efficiency, -- The Format is built up in reverse, for efficiency,
-- and can have many adjacent Consts. Fusing it fixes both -- and can have many adjacent Consts. Fusing it fixes both
-- problems. -- problems.
fuse f [] = f fuse f [] = f
fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs
fuse f (v:vs) = fuse (v:f) vs fuse f (v:vs) = fuse (v:f) vs
scan f (a:b:cs) scan f (a:b:cs)
| a == '$' && b == '{' = invar f [] cs | a == '$' && b == '{' = invar f [] cs
| otherwise = scan (Const [a] : f ) (b:cs) | otherwise = scan (Const [a] : f ) (b:cs)
scan f v = Const v : f scan f v = Const v : f
invar f var [] = Const (novar var) : f invar f var [] = Const (novar var) : f
invar f var (c:cs) invar f var (c:cs)
| c == '}' = foundvar f var UnJustified cs | c == '}' = foundvar f var UnJustified cs
| isAlphaNum c || c == '_' = invar f (c:var) cs | isAlphaNum c || c == '_' = invar f (c:var) cs
| c == ';' = inpad "" f var cs | c == ';' = inpad "" f var cs
| otherwise = scan ((Const $ novar $ c:var):f) cs | otherwise = scan ((Const $ novar $ c:var):f) cs
inpad p f var (c:cs) inpad p f var (c:cs)
| c == '}' = foundvar f var (readjustify $ reverse p) cs | c == '}' = foundvar f var (readjustify $ reverse p) cs
| otherwise = inpad (c:p) f var cs | otherwise = inpad (c:p) f var cs
inpad p f var [] = Const (novar $ p++";"++var) : f inpad p f var [] = Const (novar $ p++";"++var) : f
readjustify = getjustify . fromMaybe 0 . readish readjustify = getjustify . fromMaybe 0 . readish
getjustify i getjustify i
| i == 0 = UnJustified | i == 0 = UnJustified
| i < 0 = LeftJustified (-1 * i) | i < 0 = LeftJustified (-1 * i)
| otherwise = RightJustified i | otherwise = RightJustified i
novar v = "${" ++ reverse v novar v = "${" ++ reverse v
foundvar f v p = scan (Var (reverse v) p : f) foundvar f v p = scan (Var (reverse v) p : f)
empty :: Frag -> Bool empty :: Frag -> Bool
empty (Const "") = True empty (Const "") = True
@ -106,36 +106,34 @@ empty _ = False
decode_c :: FormatString -> FormatString decode_c :: FormatString -> FormatString
decode_c [] = [] decode_c [] = []
decode_c s = unescape ("", s) decode_c s = unescape ("", s)
where where
e = '\\' e = '\\'
unescape (b, []) = b unescape (b, []) = b
-- look for escapes starting with '\' -- look for escapes starting with '\'
unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair) unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)
where where
pair = span (/= e) v pair = span (/= e) v
isescape x = x == e isescape x = x == e
-- \NNN is an octal encoded character -- \NNN is an octal encoded character
handle (x:n1:n2:n3:rest) handle (x:n1:n2:n3:rest)
| isescape x && alloctal = (fromoctal, rest) | isescape x && alloctal = (fromoctal, rest)
where where
alloctal = isOctDigit n1 && alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3
isOctDigit n2 && fromoctal = [chr $ readoctal [n1, n2, n3]]
isOctDigit n3 readoctal o = Prelude.read $ "0o" ++ o :: Int
fromoctal = [chr $ readoctal [n1, n2, n3]] -- \C is used for a few special characters
readoctal o = Prelude.read $ "0o" ++ o :: Int handle (x:nc:rest)
-- \C is used for a few special characters | isescape x = ([echar nc], rest)
handle (x:nc:rest) where
| isescape x = ([echar nc], rest) echar 'a' = '\a'
where echar 'b' = '\b'
echar 'a' = '\a' echar 'f' = '\f'
echar 'b' = '\b' echar 'n' = '\n'
echar 'f' = '\f' echar 'r' = '\r'
echar 'n' = '\n' echar 't' = '\t'
echar 'r' = '\r' echar 'v' = '\v'
echar 't' = '\t' echar a = a
echar 'v' = '\v' handle n = ("", n)
echar a = a
handle n = ("", n)
{- Inverse of decode_c. -} {- Inverse of decode_c. -}
encode_c :: FormatString -> FormatString encode_c :: FormatString -> FormatString
@ -147,28 +145,28 @@ encode_c_strict = encode_c' isSpace
encode_c' :: (Char -> Bool) -> FormatString -> FormatString encode_c' :: (Char -> Bool) -> FormatString -> FormatString
encode_c' p = concatMap echar encode_c' p = concatMap echar
where where
e c = '\\' : [c] e c = '\\' : [c]
echar '\a' = e 'a' echar '\a' = e 'a'
echar '\b' = e 'b' echar '\b' = e 'b'
echar '\f' = e 'f' echar '\f' = e 'f'
echar '\n' = e 'n' echar '\n' = e 'n'
echar '\r' = e 'r' echar '\r' = e 'r'
echar '\t' = e 't' echar '\t' = e 't'
echar '\v' = e 'v' echar '\v' = e 'v'
echar '\\' = e '\\' echar '\\' = e '\\'
echar '"' = e '"' echar '"' = e '"'
echar c echar c
| ord c < 0x20 = e_asc c -- low ascii | ord c < 0x20 = e_asc c -- low ascii
| ord c >= 256 = e_utf c -- unicode | ord c >= 256 = e_utf c -- unicode
| ord c > 0x7E = e_asc c -- high ascii | ord c > 0x7E = e_asc c -- high ascii
| p c = e_asc c -- unprintable ascii | p c = e_asc c -- unprintable ascii
| otherwise = [c] -- printable ascii | otherwise = [c] -- printable ascii
-- unicode character is decomposed to individual Word8s, -- unicode character is decomposed to individual Word8s,
-- and each is shown in octal -- and each is shown in octal
e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])
e_asc c = showoctal $ ord c e_asc c = showoctal $ ord c
showoctal i = '\\' : printf "%03o" i showoctal i = '\\' : printf "%03o" i
{- for quickcheck -} {- for quickcheck -}
prop_idempotent_deencode :: String -> Bool prop_idempotent_deencode :: String -> Bool

View file

@ -51,8 +51,8 @@ toString(NumericV f) = show f
toString (ListV l) toString (ListV l)
| null l = "" | null l = ""
| otherwise = (intercalate ";" $ map (escapesemi . toString) l) ++ ";" | otherwise = (intercalate ";" $ map (escapesemi . toString) l) ++ ";"
where where
escapesemi = join "\\;" . split ";" escapesemi = join "\\;" . split ";"
genDesktopEntry :: String -> String -> Bool -> FilePath -> [String] -> DesktopEntry genDesktopEntry :: String -> String -> Bool -> FilePath -> [String] -> DesktopEntry
genDesktopEntry name comment terminal program categories = genDesktopEntry name comment terminal program categories =
@ -64,13 +64,13 @@ genDesktopEntry name comment terminal program categories =
, item "Exec" StringV program , item "Exec" StringV program
, item "Categories" ListV (map StringV categories) , item "Categories" ListV (map StringV categories)
] ]
where where
item x c y = (x, c y) item x c y = (x, c y)
buildDesktopMenuFile :: DesktopEntry -> String buildDesktopMenuFile :: DesktopEntry -> String
buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n" buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n"
where where
keyvalue (k, v) = k ++ "=" ++ toString v keyvalue (k, v) = k ++ "=" ++ toString v
writeDesktopMenuFile :: DesktopEntry -> String -> IO () writeDesktopMenuFile :: DesktopEntry -> String -> IO ()
writeDesktopMenuFile d file = do writeDesktopMenuFile d file = do
@ -115,11 +115,10 @@ userConfigDir = xdgEnvHome "CONFIG_HOME" ".config"
- to ~/Desktop. -} - to ~/Desktop. -}
userDesktopDir :: IO FilePath userDesktopDir :: IO FilePath
userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir) userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir)
where where
parse = maybe Nothing (headMaybe . lines) parse = maybe Nothing (headMaybe . lines)
xdg_user_dir = catchMaybeIO $ xdg_user_dir = catchMaybeIO $ readProcess "xdg-user-dir" ["DESKTOP"]
readProcess "xdg-user-dir" ["DESKTOP"] fallback = xdgEnvHome "DESKTOP_DIR" "Desktop"
fallback = xdgEnvHome "DESKTOP_DIR" "Desktop"
xdgEnvHome :: String -> String -> IO String xdgEnvHome :: String -> String -> IO String
xdgEnvHome envbase homedef = do xdgEnvHome envbase homedef = do

View file

@ -29,9 +29,9 @@ stdParams params = do
then [] then []
else ["--batch", "--no-tty", "--use-agent"] else ["--batch", "--no-tty", "--use-agent"]
return $ batch ++ defaults ++ toCommand params return $ batch ++ defaults ++ toCommand params
where where
-- be quiet, even about checking the trustdb -- be quiet, even about checking the trustdb
defaults = ["--quiet", "--trust-model", "always"] defaults = ["--quiet", "--trust-model", "always"]
{- Runs gpg with some params and returns its stdout, strictly. -} {- Runs gpg with some params and returns its stdout, strictly. -}
readStrict :: [CommandParam] -> IO String readStrict :: [CommandParam] -> IO String
@ -74,22 +74,22 @@ feedRead params passphrase feeder reader = do
params' <- stdParams $ passphrasefd ++ params params' <- stdParams $ passphrasefd ++ params
closeFd frompipe `after` closeFd frompipe `after`
withBothHandles createProcessSuccess (proc "gpg" params') go withBothHandles createProcessSuccess (proc "gpg" params') go
where where
go (to, from) = do go (to, from) = do
void $ forkIO $ do void $ forkIO $ do
feeder to feeder to
hClose to hClose to
reader from reader from
{- Finds gpg public keys matching some string. (Could be an email address, {- Finds gpg public keys matching some string. (Could be an email address,
- a key id, or a name. -} - a key id, or a name. -}
findPubKeys :: String -> IO KeyIds findPubKeys :: String -> IO KeyIds
findPubKeys for = KeyIds . parse <$> readStrict params findPubKeys for = KeyIds . parse <$> readStrict params
where where
params = [Params "--with-colons --list-public-keys", Param for] params = [Params "--with-colons --list-public-keys", Param for]
parse = catMaybes . map (keyIdField . split ":") . lines parse = catMaybes . map (keyIdField . split ":") . lines
keyIdField ("pub":_:_:_:f:_) = Just f keyIdField ("pub":_:_:_:f:_) = Just f
keyIdField _ = Nothing keyIdField _ = Nothing
{- Creates a block of high-quality random data suitable to use as a cipher. {- 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 - 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 randomquality
, Param $ show size , Param $ show size
] ]
where where
-- 1 is /dev/urandom; 2 is /dev/random -- 1 is /dev/urandom; 2 is /dev/random
randomquality = 1 :: Int randomquality = 1 :: Int
{- A test key. This is provided pre-generated since generating a new gpg {- 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 - key is too much work (requires too much entropy) for a test suite to
@ -173,10 +173,10 @@ keyBlock public ls = unlines
, unlines ls , unlines ls
, "-----END PGP "++t++" KEY BLOCK-----" , "-----END PGP "++t++" KEY BLOCK-----"
] ]
where where
t t
| public = "PUBLIC" | public = "PUBLIC"
| otherwise = "PRIVATE" | otherwise = "PRIVATE"
{- Runs an action using gpg in a test harness, in which gpg does {- 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. -} - 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 testHarness a = do
orig <- getEnv var orig <- getEnv var
bracket setup (cleanup orig) (const a) bracket setup (cleanup orig) (const a)
where where
var = "GNUPGHOME" var = "GNUPGHOME"
setup = do setup = do
base <- getTemporaryDirectory base <- getTemporaryDirectory
dir <- mktmpdir $ base </> "gpgtmpXXXXXX" dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
setEnv var dir True setEnv var dir True
_ <- pipeStrict [Params "--import -q"] $ unlines _ <- pipeStrict [Params "--import -q"] $ unlines
[testSecretKey, testKey] [testSecretKey, testKey]
return dir return dir
cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig
reset (Just v) = setEnv var v True reset (Just v) = setEnv var v True
reset _ = unsetEnv var reset _ = unsetEnv var
{- Tests the test harness. -} {- Tests the test harness. -}
testTestHarness :: IO Bool testTestHarness :: IO Bool

View file

@ -17,10 +17,10 @@ parseDuration s = do
num <- readish s :: Maybe Integer num <- readish s :: Maybe Integer
units <- findUnits =<< lastMaybe s units <- findUnits =<< lastMaybe s
return $ fromIntegral num * units return $ fromIntegral num * units
where where
findUnits 's' = Just 1 findUnits 's' = Just 1
findUnits 'm' = Just 60 findUnits 'm' = Just 60
findUnits 'h' = Just $ 60 * 60 findUnits 'h' = Just $ 60 * 60
findUnits 'd' = Just $ 60 * 60 * 24 findUnits 'd' = Just $ 60 * 60 * 24
findUnits 'y' = Just $ 60 * 60 * 24 * 365 findUnits 'y' = Just $ 60 * 60 * 24 * 365
findUnits _ = Nothing findUnits _ = Nothing

View file

@ -59,116 +59,116 @@ watchDir i dir ignored hooks
withLock lock $ withLock lock $
mapM_ scan =<< filter (not . dirCruft) <$> mapM_ scan =<< filter (not . dirCruft) <$>
getDirectoryContents dir getDirectoryContents dir
where where
recurse d = watchDir i d ignored hooks recurse d = watchDir i d ignored hooks
-- Select only inotify events required by the enabled -- Select only inotify events required by the enabled
-- hooks, but always include Create so new directories can -- hooks, but always include Create so new directories can
-- be scanned. -- be scanned.
watchevents = Create : addevents ++ delevents ++ modifyevents watchevents = Create : addevents ++ delevents ++ modifyevents
addevents addevents
| hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite] | hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]
| otherwise = [] | otherwise = []
delevents delevents
| hashook delHook || hashook delDirHook = [MoveOut, Delete] | hashook delHook || hashook delDirHook = [MoveOut, Delete]
| otherwise = [] | otherwise = []
modifyevents modifyevents
| hashook modifyHook = [Modify] | hashook modifyHook = [Modify]
| otherwise = [] | otherwise = []
scan f = unless (ignored f) $ do scan f = unless (ignored f) $ do
ms <- getstatus f ms <- getstatus f
case ms of case ms of
Nothing -> return () Nothing -> return ()
Just s Just s
| Files.isDirectory s -> | Files.isDirectory s ->
recurse $ indir f recurse $ indir f
| Files.isSymbolicLink s -> | Files.isSymbolicLink s ->
runhook addSymlinkHook f ms runhook addSymlinkHook f ms
| Files.isRegularFile s -> | Files.isRegularFile s ->
runhook addHook f ms runhook addHook f ms
| otherwise -> | otherwise ->
noop noop
-- Ignore creation events for regular files, which won't be -- Ignore creation events for regular files, which won't be
-- done being written when initially created, but handle for -- done being written when initially created, but handle for
-- directories and symlinks. -- directories and symlinks.
go (Created { isDirectory = isd, filePath = f }) go (Created { isDirectory = isd, filePath = f })
| isd = recurse $ indir f | isd = recurse $ indir f
| hashook addSymlinkHook = | hashook addSymlinkHook =
checkfiletype Files.isSymbolicLink addSymlinkHook f checkfiletype Files.isSymbolicLink addSymlinkHook f
| otherwise = noop | otherwise = noop
-- Closing a file is assumed to mean it's done being written. -- Closing a file is assumed to mean it's done being written.
go (Closed { isDirectory = False, maybeFilePath = Just f }) = go (Closed { isDirectory = False, maybeFilePath = Just f }) =
checkfiletype Files.isRegularFile addHook f checkfiletype Files.isRegularFile addHook f
-- When a file or directory is moved in, scan it to add new -- When a file or directory is moved in, scan it to add new
-- stuff. -- stuff.
go (MovedIn { filePath = f }) = scan f go (MovedIn { filePath = f }) = scan f
go (MovedOut { isDirectory = isd, filePath = f }) go (MovedOut { isDirectory = isd, filePath = f })
| isd = runhook delDirHook f Nothing | isd = runhook delDirHook f Nothing
| otherwise = runhook delHook f Nothing | otherwise = runhook delHook f Nothing
-- Verify that the deleted item really doesn't exist, -- Verify that the deleted item really doesn't exist,
-- since there can be spurious deletion events for items -- since there can be spurious deletion events for items
-- in a directory that has been moved out, but is still -- in a directory that has been moved out, but is still
-- being watched. -- being watched.
go (Deleted { isDirectory = isd, filePath = f }) go (Deleted { isDirectory = isd, filePath = f })
| isd = guarded $ runhook delDirHook f Nothing | isd = guarded $ runhook delDirHook f Nothing
| otherwise = guarded $ runhook delHook f Nothing | otherwise = guarded $ runhook delHook f Nothing
where where
guarded = unlessM (filetype (const True) f) guarded = unlessM (filetype (const True) f)
go (Modified { isDirectory = isd, maybeFilePath = Just f }) go (Modified { isDirectory = isd, maybeFilePath = Just f })
| isd = noop | isd = noop
| otherwise = runhook modifyHook f Nothing | otherwise = runhook modifyHook f Nothing
go _ = noop go _ = noop
hashook h = isJust $ h hooks hashook h = isJust $ h hooks
runhook h f s runhook h f s
| ignored f = noop | ignored f = noop
| otherwise = maybe noop (\a -> a (indir f) s) (h hooks) | otherwise = maybe noop (\a -> a (indir f) s) (h hooks)
indir f = dir </> f indir f = dir </> f
getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f
checkfiletype check h f = do checkfiletype check h f = do
ms <- getstatus f ms <- getstatus f
case ms of case ms of
Just s Just s
| check s -> runhook h f ms | check s -> runhook h f ms
_ -> noop _ -> noop
filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)
-- Inotify fails when there are too many watches with a -- Inotify fails when there are too many watches with a
-- disk full error. -- disk full error.
failedaddwatch e failedaddwatch e
| isFullError e = | isFullError e =
case errHook hooks of case errHook hooks of
Nothing -> throw e Nothing -> throw e
Just hook -> tooManyWatches hook dir Just hook -> tooManyWatches hook dir
| otherwise = throw e | otherwise = throw e
tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO () tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO ()
tooManyWatches hook dir = do tooManyWatches hook dir = do
sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer) sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)
hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing
where where
maxwatches = "fs.inotify.max_user_watches" maxwatches = "fs.inotify.max_user_watches"
basewarning = "Too many directories to watch! (Not watching " ++ dir ++")" basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"
withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"] withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]
withsysctl n = let new = n * 10 in withsysctl n = let new = n * 10 in
[ "Increase the limit permanently by running:" [ "Increase the limit permanently by running:"
, " echo " ++ maxwatches ++ "=" ++ show new ++ , " echo " ++ maxwatches ++ "=" ++ show new ++
" | sudo tee -a /etc/sysctl.conf; sudo sysctl -p" " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"
, "Or temporarily by running:" , "Or temporarily by running:"
, " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new , " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new
] ]
querySysctl :: Read a => [CommandParam] -> IO (Maybe a) querySysctl :: Read a => [CommandParam] -> IO (Maybe a)
querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"] querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"]
where where
go p = do go p = do
v <- catchMaybeIO $ readProcess p (toCommand ps) v <- catchMaybeIO $ readProcess p (toCommand ps)
case v of case v of
Nothing -> return Nothing Nothing -> return Nothing
Just s -> return $ parsesysctl s Just s -> return $ parsesysctl s
parsesysctl s = readish =<< lastMaybe (words s) parsesysctl s = readish =<< lastMaybe (words s)

View file

@ -21,15 +21,15 @@ start :: JSON a => [(String, a)] -> String
start l start l
| last s == endchar = init s | last s == endchar = init s
| otherwise = bad s | otherwise = bad s
where where
s = encodeStrict $ toJSObject l s = encodeStrict $ toJSObject l
add :: JSON a => [(String, a)] -> String add :: JSON a => [(String, a)] -> String
add l add l
| head s == startchar = ',' : drop 1 s | head s == startchar = ',' : drop 1 s
| otherwise = bad s | otherwise = bad s
where where
s = start l s = start l
end :: String end :: String
end = [endchar, '\n'] end = [endchar, '\n']

View file

@ -78,44 +78,44 @@ getDirInfo dir = do
l <- filter (not . dirCruft) <$> getDirectoryContents dir l <- filter (not . dirCruft) <$> getDirectoryContents dir
contents <- S.fromList . catMaybes <$> mapM getDirEnt l contents <- S.fromList . catMaybes <$> mapM getDirEnt l
return $ DirInfo dir contents return $ DirInfo dir contents
where where
getDirEnt f = catchMaybeIO $ do getDirEnt f = catchMaybeIO $ do
s <- getFileStatus (dir </> f) s <- getFileStatus (dir </> f)
return $ DirEnt f (fileID s) (isDirectory s) return $ DirEnt f (fileID s) (isDirectory s)
{- Difference between the dirCaches of two DirInfos. -} {- Difference between the dirCaches of two DirInfos. -}
(//) :: DirInfo -> DirInfo -> [Change] (//) :: DirInfo -> DirInfo -> [Change]
oldc // newc = deleted ++ added oldc // newc = deleted ++ added
where where
deleted = calc gendel oldc newc deleted = calc gendel oldc newc
added = calc genadd newc oldc added = calc genadd newc oldc
gendel x = (if isSubDir x then DeletedDir else Deleted) $ gendel x = (if isSubDir x then DeletedDir else Deleted) $
dirName oldc </> dirEnt x dirName oldc </> dirEnt x
genadd x = Added $ dirName newc </> dirEnt x genadd x = Added $ dirName newc </> dirEnt x
calc a x y = map a $ S.toList $ calc a x y = map a $ S.toList $
S.difference (dirCache x) (dirCache y) S.difference (dirCache x) (dirCache y)
{- Builds a map of directories in a tree, possibly pruning some. {- Builds a map of directories in a tree, possibly pruning some.
- Opens each directory in the tree, and records its current contents. -} - Opens each directory in the tree, and records its current contents. -}
scanRecursive :: FilePath -> Pruner -> IO DirMap scanRecursive :: FilePath -> Pruner -> IO DirMap
scanRecursive topdir prune = M.fromList <$> walk [] [topdir] scanRecursive topdir prune = M.fromList <$> walk [] [topdir]
where where
walk c [] = return c walk c [] = return c
walk c (dir:rest) walk c (dir:rest)
| prune dir = walk c rest | prune dir = walk c rest
| otherwise = do | otherwise = do
minfo <- catchMaybeIO $ getDirInfo dir minfo <- catchMaybeIO $ getDirInfo dir
case minfo of case minfo of
Nothing -> walk c rest Nothing -> walk c rest
Just info -> do Just info -> do
mfd <- catchMaybeIO $ mfd <- catchMaybeIO $
openFd dir ReadOnly Nothing defaultFileFlags openFd dir ReadOnly Nothing defaultFileFlags
case mfd of case mfd of
Nothing -> walk c rest Nothing -> walk c rest
Just fd -> do Just fd -> do
let subdirs = map (dir </>) . map dirEnt $ let subdirs = map (dir </>) . map dirEnt $
S.toList $ dirCache info S.toList $ dirCache info
walk ((fd, info):c) (subdirs ++ rest) walk ((fd, info):c) (subdirs ++ rest)
{- Adds a list of subdirectories (and all their children), unless pruned to a {- 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 - 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 removeSubDir dirmap dir = do
mapM_ closeFd $ M.keys toremove mapM_ closeFd $ M.keys toremove
return rest return rest
where where
(toremove, rest) = M.partition (dirContains dir . dirName) dirmap (toremove, rest) = M.partition (dirContains dir . dirName) dirmap
findDirContents :: DirMap -> FilePath -> [FilePath] findDirContents :: DirMap -> FilePath -> [FilePath]
findDirContents dirmap dir = concatMap absolutecontents $ search findDirContents dirmap dir = concatMap absolutecontents $ search
where where
absolutecontents i = map (dirName i </>) absolutecontents i = map (dirName i </>)
(map dirEnt $ S.toList $ dirCache i) (map dirEnt $ S.toList $ dirCache i)
search = map snd $ M.toList $ search = map snd $ M.toList $
M.filter (\i -> dirName i == dir) dirmap M.filter (\i -> dirName i == dir) dirmap
foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue
:: IO Fd :: IO Fd
@ -181,8 +181,8 @@ waitChange kq@(Kqueue h _ dirmap _) = do
else case M.lookup changedfd dirmap of else case M.lookup changedfd dirmap of
Nothing -> nochange Nothing -> nochange
Just info -> handleChange kq changedfd info Just info -> handleChange kq changedfd info
where where
nochange = return (kq, []) nochange = return (kq, [])
{- The kqueue interface does not tell what type of change took place in {- 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 - 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 :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change])
handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo = handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo =
go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo) go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo)
where where
go (Just newdirinfo) = do go (Just newdirinfo) = do
let changes = filter (not . pruner . changedFile) $ let changes = filter (not . pruner . changedFile) $
olddirinfo // newdirinfo olddirinfo // newdirinfo
let (added, deleted) = partition isAdd changes let (added, deleted) = partition isAdd changes
-- Scan newly added directories to add to the map. -- Scan newly added directories to add to the map.
-- (Newly added files will fail getDirInfo.) -- (Newly added files will fail getDirInfo.)
newdirinfos <- catMaybes <$> newdirinfos <- catMaybes <$>
mapM (catchMaybeIO . getDirInfo . changedFile) added mapM (catchMaybeIO . getDirInfo . changedFile) added
newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos
-- Remove deleted directories from the map. -- Remove deleted directories from the map.
newmap' <- foldM removeSubDir newmap (map changedFile deleted) newmap' <- foldM removeSubDir newmap (map changedFile deleted)
-- Update the cached dirinfo just looked up. -- Update the cached dirinfo just looked up.
let newmap'' = M.insertWith' const fd newdirinfo newmap' let newmap'' = M.insertWith' const fd newdirinfo newmap'
-- When new directories were added, need to update -- When new directories were added, need to update
-- the kqueue to watch them. -- the kqueue to watch them.
let kq' = kq { kqueueMap = newmap'' } let kq' = kq { kqueueMap = newmap'' }
unless (null newdirinfos) $ unless (null newdirinfos) $
updateKqueue kq' updateKqueue kq'
return (kq', changes) return (kq', changes)
go Nothing = do go Nothing = do
-- The directory has been moved or deleted, so -- The directory has been moved or deleted, so
-- remove it from our map. -- remove it from our map.
newmap <- removeSubDir dirmap (dirName olddirinfo) newmap <- removeSubDir dirmap (dirName olddirinfo)
return (kq { kqueueMap = newmap }, []) return (kq { kqueueMap = newmap }, [])
{- Processes changes on the Kqueue, calling the hooks as appropriate. {- Processes changes on the Kqueue, calling the hooks as appropriate.
- Never returns. -} - Never returns. -}
@ -235,35 +235,33 @@ runHooks kq hooks = do
-- to catch any files created beforehand. -- to catch any files created beforehand.
recursiveadd (kqueueMap kq) (Added $ kqueueTop kq) recursiveadd (kqueueMap kq) (Added $ kqueueTop kq)
loop kq loop kq
where where
loop q = do loop q = do
(q', changes) <- waitChange q (q', changes) <- waitChange q
forM_ changes $ dispatch (kqueueMap q') forM_ changes $ dispatch (kqueueMap q')
loop q' loop q'
dispatch _ change@(Deleted _) = dispatch _ change@(Deleted _) =
callhook delHook Nothing change callhook delHook Nothing change
dispatch _ change@(DeletedDir _) = dispatch _ change@(DeletedDir _) =
callhook delDirHook Nothing change callhook delDirHook Nothing change
dispatch dirmap change@(Added _) = dispatch dirmap change@(Added _) =
withstatus change $ dispatchadd dirmap withstatus change $ dispatchadd dirmap
dispatchadd dirmap change s dispatchadd dirmap change s
| Files.isSymbolicLink s = | Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change
callhook addSymlinkHook (Just s) change | Files.isDirectory s = recursiveadd dirmap change
| Files.isDirectory s = recursiveadd dirmap change | Files.isRegularFile s = callhook addHook (Just s) change
| Files.isRegularFile s = | otherwise = noop
callhook addHook (Just s) change
| otherwise = noop
recursiveadd dirmap change = do recursiveadd dirmap change = do
let contents = findDirContents dirmap $ changedFile change let contents = findDirContents dirmap $ changedFile change
forM_ contents $ \f -> forM_ contents $ \f ->
withstatus (Added f) $ dispatchadd dirmap withstatus (Added f) $ dispatchadd dirmap
callhook h s change = case h hooks of callhook h s change = case h hooks of
Nothing -> noop Nothing -> noop
Just a -> a (changedFile change) s Just a -> a (changedFile change) s
withstatus change a = maybe noop (a change) =<< withstatus change a = maybe noop (a change) =<<
(catchMaybeIO (getSymbolicLinkStatus (changedFile change))) (catchMaybeIO (getSymbolicLinkStatus (changedFile change)))

View file

@ -23,9 +23,9 @@ rotateLog logfile num
| otherwise = whenM (doesFileExist currfile) $ do | otherwise = whenM (doesFileExist currfile) $ do
rotateLog logfile (num + 1) rotateLog logfile (num + 1)
renameFile currfile nextfile renameFile currfile nextfile
where where
currfile = filename num currfile = filename num
nextfile = filename (num + 1) nextfile = filename (num + 1)
filename n filename n
| n == 0 = logfile | n == 0 = logfile
| otherwise = logfile ++ "." ++ show n | otherwise = logfile ++ "." ++ show n

View file

@ -36,8 +36,8 @@ query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
query opts = query opts =
withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do
parse <$> hGetContentsStrict h parse <$> hGetContentsStrict h
where where
p = proc "lsof" ("-F0can" : opts) p = proc "lsof" ("-F0can" : opts)
{- Parsing null-delimited output like: {- Parsing null-delimited output like:
- -
@ -51,38 +51,36 @@ query opts =
-} -}
parse :: String -> [(FilePath, LsofOpenMode, ProcessInfo)] parse :: String -> [(FilePath, LsofOpenMode, ProcessInfo)]
parse s = bundle $ go [] $ lines s parse s = bundle $ go [] $ lines s
where where
bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs) bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs)
go c [] = c go c [] = c
go c ((t:r):ls) go c ((t:r):ls)
| t == 'p' = | t == 'p' =
let (fs, ls') = parsefiles [] ls let (fs, ls') = parsefiles [] ls
in go ((fs, parseprocess r):c) ls' in go ((fs, parseprocess r):c) ls'
| otherwise = parsefail | otherwise = parsefail
go _ _ = parsefail go _ _ = parsefail
parseprocess l = parseprocess l = case splitnull l of
case splitnull l of [pid, 'c':cmdline, ""] ->
[pid, 'c':cmdline, ""] -> case readish pid of
case readish pid of (Just n) -> ProcessInfo n cmdline
(Just n) -> ProcessInfo n cmdline Nothing -> parsefail
Nothing -> parsefail _ -> parsefail
_ -> parsefail
parsefiles c [] = (c, []) parsefiles c [] = (c, [])
parsefiles c (l:ls) = parsefiles c (l:ls) = case splitnull l of
case splitnull l of ['a':mode, 'n':file, ""] ->
['a':mode, 'n':file, ""] -> parsefiles ((file, parsemode mode):c) ls
parsefiles ((file, parsemode mode):c) ls (('p':_):_) -> (c, l:ls)
(('p':_):_) -> (c, l:ls) _ -> parsefail
_ -> parsefail
parsemode ('r':_) = OpenReadOnly parsemode ('r':_) = OpenReadOnly
parsemode ('w':_) = OpenWriteOnly parsemode ('w':_) = OpenWriteOnly
parsemode ('u':_) = OpenReadWrite parsemode ('u':_) = OpenReadWrite
parsemode _ = OpenUnknown 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

View file

@ -58,36 +58,36 @@ tokens = words "and or not ( )"
{- Converts a list of Tokens into a Matcher. -} {- Converts a list of Tokens into a Matcher. -}
generate :: [Token op] -> Matcher op generate :: [Token op] -> Matcher op
generate = go MAny generate = go MAny
where where
go m [] = m go m [] = m
go m ts = uncurry go $ consume m ts go m ts = uncurry go $ consume m ts
{- Consumes one or more Tokens, constructs a new Matcher, {- Consumes one or more Tokens, constructs a new Matcher,
- and returns unconsumed Tokens. -} - and returns unconsumed Tokens. -}
consume :: Matcher op -> [Token op] -> (Matcher op, [Token op]) consume :: Matcher op -> [Token op] -> (Matcher op, [Token op])
consume m [] = (m, []) consume m [] = (m, [])
consume m (t:ts) = go t consume m (t:ts) = go t
where where
go And = cont $ m `MAnd` next go And = cont $ m `MAnd` next
go Or = cont $ m `MOr` next go Or = cont $ m `MOr` next
go Not = cont $ m `MAnd` MNot next go Not = cont $ m `MAnd` MNot next
go Open = let (n, r) = consume next rest in (m `MAnd` n, r) go Open = let (n, r) = consume next rest in (m `MAnd` n, r)
go Close = (m, ts) go Close = (m, ts)
go (Operation o) = (m `MAnd` MOp o, ts) go (Operation o) = (m `MAnd` MOp o, ts)
(next, rest) = consume MAny ts (next, rest) = consume MAny ts
cont v = (v, rest) cont v = (v, rest)
{- Checks if a Matcher matches, using a supplied function to check {- Checks if a Matcher matches, using a supplied function to check
- the value of Operations. -} - the value of Operations. -}
match :: (op -> v -> Bool) -> Matcher op -> v -> Bool match :: (op -> v -> Bool) -> Matcher op -> v -> Bool
match a m v = go m match a m v = go m
where where
go MAny = True go MAny = True
go (MAnd m1 m2) = go m1 && go m2 go (MAnd m1 m2) = go m1 && go m2
go (MOr m1 m2) = go m1 || go m2 go (MOr m1 m2) = go m1 || go m2
go (MNot m1) = not $ go m1 go (MNot m1) = not $ go m1
go (MOp o) = a o v go (MOp o) = a o v
{- Runs a monadic Matcher, where Operations are actions in the monad. -} {- Runs a monadic Matcher, where Operations are actions in the monad. -}
matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool
@ -98,12 +98,12 @@ matchM m v = matchMrun m $ \o -> o v
- parameter. -} - parameter. -}
matchMrun :: forall o (m :: * -> *). Monad m => Matcher o -> (o -> m Bool) -> m Bool matchMrun :: forall o (m :: * -> *). Monad m => Matcher o -> (o -> m Bool) -> m Bool
matchMrun m run = go m matchMrun m run = go m
where where
go MAny = return True go MAny = return True
go (MAnd m1 m2) = go m1 <&&> go m2 go (MAnd m1 m2) = go m1 <&&> go m2
go (MOr m1 m2) = go m1 <||> go m2 go (MOr m1 m2) = go m1 <||> go m2
go (MNot m1) = liftM not (go m1) go (MNot m1) = liftM not (go m1)
go (MOp o) = run o go (MOp o) = run o
{- Checks if a matcher contains no limits. -} {- Checks if a matcher contains no limits. -}
isEmpty :: Matcher a -> Bool isEmpty :: Matcher a -> Bool

View file

@ -33,10 +33,10 @@ readFileStrict = readFile >=> \s -> length s `seq` return s
-} -}
separate :: (a -> Bool) -> [a] -> ([a], [a]) separate :: (a -> Bool) -> [a] -> ([a], [a])
separate c l = unbreak $ break c l separate c l = unbreak $ break c l
where where
unbreak r@(a, b) unbreak r@(a, b)
| null b = r | null b = r
| otherwise = (a, tail b) | otherwise = (a, tail b)
{- Breaks out the first line. -} {- Breaks out the first line. -}
firstLine :: String -> String firstLine :: String -> String
@ -47,11 +47,11 @@ firstLine = takeWhile (/= '\n')
- Segments may be empty. -} - Segments may be empty. -}
segment :: (a -> Bool) -> [a] -> [[a]] segment :: (a -> Bool) -> [a] -> [[a]]
segment p l = map reverse $ go [] [] l segment p l = map reverse $ go [] [] l
where where
go c r [] = reverse $ c:r go c r [] = reverse $ c:r
go c r (i:is) go c r (i:is)
| p i = go [] (c:r) is | p i = go [] (c:r) is
| otherwise = go (i:c) r is | otherwise = go (i:c) r is
prop_segment_regressionTest :: Bool prop_segment_regressionTest :: Bool
prop_segment_regressionTest = all id prop_segment_regressionTest = all id
@ -64,11 +64,11 @@ prop_segment_regressionTest = all id
{- Includes the delimiters as segments of their own. -} {- Includes the delimiters as segments of their own. -}
segmentDelim :: (a -> Bool) -> [a] -> [[a]] segmentDelim :: (a -> Bool) -> [a] -> [[a]]
segmentDelim p l = map reverse $ go [] [] l segmentDelim p l = map reverse $ go [] [] l
where where
go c r [] = reverse $ c:r go c r [] = reverse $ c:r
go c r (i:is) go c r (i:is)
| p i = go [] ([i]:c:r) is | p i = go [] ([i]:c:r) is
| otherwise = go (i:c) r is | otherwise = go (i:c) r is
{- Given two orderings, returns the second if the first is EQ and returns {- Given two orderings, returns the second if the first is EQ and returns
- the first otherwise. - the first otherwise.
@ -96,9 +96,9 @@ hGetSomeString h sz = do
fp <- mallocForeignPtrBytes sz fp <- mallocForeignPtrBytes sz
len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz
map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len) map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)
where where
peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes :: Int -> Ptr Word8 -> IO [Word8]
peekbytes len buf = mapM (peekElemOff buf) [0..pred len] peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
{- Reaps any zombie git processes. {- Reaps any zombie git processes.
- -

View file

@ -41,21 +41,21 @@ getMounts = do
_ <- c_mounts_end h _ <- c_mounts_end h
return mntent return mntent
where where
getmntent h c = do getmntent h c = do
ptr <- c_mounts_next h ptr <- c_mounts_next h
if (ptr == nullPtr) if (ptr == nullPtr)
then return $ reverse c then return $ reverse c
else do else do
mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString
mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString
mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString
let ent = Mntent let ent = Mntent
{ mnt_fsname = mnt_fsname_str { mnt_fsname = mnt_fsname_str
, mnt_dir = mnt_dir_str , mnt_dir = mnt_dir_str
, mnt_type = mnt_type_str , mnt_type = mnt_type_str
} }
getmntent h (ent:c) getmntent h (ent:c)
{- Using unsafe imports because the C functions are belived to never block. {- Using unsafe imports because the C functions are belived to never block.
- Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking; - Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking;

View file

@ -17,6 +17,5 @@ import Control.Applicative
- use uname -n when available. -} - use uname -n when available. -}
getHostname :: IO (Maybe String) getHostname :: IO (Maybe String)
getHostname = catchMaybeIO uname_node getHostname = catchMaybeIO uname_node
where where
uname_node = takeWhile (/= '\n') <$> uname_node = takeWhile (/= '\n') <$> readProcess "uname" ["-n"]
readProcess "uname" ["-n"]

View file

@ -45,13 +45,13 @@ newNotificationHandle :: NotificationBroadcaster -> IO NotificationHandle
newNotificationHandle b = NotificationHandle newNotificationHandle b = NotificationHandle
<$> pure b <$> pure b
<*> addclient <*> addclient
where where
addclient = do addclient = do
s <- newEmptySV s <- newEmptySV
atomically $ do atomically $ do
l <- takeTMVar b l <- takeTMVar b
putTMVar b $ l ++ [s] putTMVar b $ l ++ [s]
return $ NotificationId $ length l return $ NotificationId $ length l
{- Extracts the identifier from a notification handle. {- Extracts the identifier from a notification handle.
- This can be used to eg, pass the identifier through to a WebApp. -} - This can be used to eg, pass the identifier through to a WebApp. -}
@ -66,8 +66,8 @@ sendNotification :: NotificationBroadcaster -> IO ()
sendNotification b = do sendNotification b = do
l <- atomically $ readTMVar b l <- atomically $ readTMVar b
mapM_ notify l mapM_ notify l
where where
notify s = writeSV s () notify s = writeSV s ()
{- Used by a client to block until a new notification is available since {- Used by a client to block until a new notification is available since
- the last time it tried. -} - the last time it tried. -}

View file

@ -23,13 +23,13 @@ inParallel a l = do
mvars <- mapM thread l mvars <- mapM thread l
statuses <- mapM takeMVar mvars statuses <- mapM takeMVar mvars
return $ reduce $ partition snd $ zip l statuses return $ reduce $ partition snd $ zip l statuses
where where
reduce (x,y) = (map fst x, map fst y) reduce (x,y) = (map fst x, map fst y)
thread v = do thread v = do
mvar <- newEmptyMVar mvar <- newEmptyMVar
_ <- forkIO $ do _ <- forkIO $ do
r <- try (a v) :: IO (Either SomeException Bool) r <- try (a v) :: IO (Either SomeException Bool)
case r of case r of
Left _ -> putMVar mvar False Left _ -> putMVar mvar False
Right b -> putMVar mvar b Right b -> putMVar mvar b
return mvar return mvar

View file

@ -23,18 +23,18 @@ parentDir :: FilePath -> FilePath
parentDir dir parentDir dir
| not $ null dirs = slash ++ join s (init dirs) | not $ null dirs = slash ++ join s (init dirs)
| otherwise = "" | otherwise = ""
where where
dirs = filter (not . null) $ split s dir dirs = filter (not . null) $ split s dir
slash = if isAbsolute dir then s else "" slash = if isAbsolute dir then s else ""
s = [pathSeparator] s = [pathSeparator]
prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir prop_parentDir_basics dir
| null dir = True | null dir = True
| dir == "/" = parentDir dir == "" | dir == "/" = parentDir dir == ""
| otherwise = p /= dir | otherwise = p /= dir
where where
p = parentDir dir p = parentDir dir
{- Checks if the first FilePath is, or could be said to contain the second. {- 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 - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
@ -42,10 +42,10 @@ prop_parentDir_basics dir
-} -}
dirContains :: FilePath -> FilePath -> Bool dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b' dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
where where
norm p = fromMaybe "" $ absNormPath p "." norm p = fromMaybe "" $ absNormPath p "."
a' = norm a a' = norm a
b' = norm b b' = norm b
{- Converts a filename into a normalized, absolute path. {- Converts a filename into a normalized, absolute path.
- -
@ -60,8 +60,8 @@ absPath file = do
- from the specified cwd. -} - from the specified cwd. -}
absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file
where where
bad = error $ "unable to normalize " ++ file bad = error $ "unable to normalize " ++ file
{- Constructs a relative path from the CWD to a 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 :: FilePath -> FilePath -> FilePath
relPathDirToFile from to = join s $ dotdots ++ uncommon relPathDirToFile from to = join s $ dotdots ++ uncommon
where where
s = [pathSeparator] s = [pathSeparator]
pfrom = split s from pfrom = split s from
pto = split s to pto = split s to
common = map fst $ takeWhile same $ zip pfrom pto common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c == d same (c,d) = c == d
uncommon = drop numcommon pto uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".." dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common numcommon = length common
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to prop_relPathDirToFile_basics from to
| from == to = null r | from == to = null r
| otherwise = not (null r) | otherwise = not (null r)
where where
r = relPathDirToFile from to r = relPathDirToFile from to
prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
where where
{- Two paths have the same directory component at the same {- Two paths have the same directory component at the same
- location, but it's not really the same directory. - location, but it's not really the same directory.
- Code used to get this wrong. -} - Code used to get this wrong. -}
same_dir_shortcurcuits_at_difference = 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" 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, {- 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 - 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]
segmentPaths [_] new = [new] -- optimisation segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest
where where
(found, rest)=partition (l `dirContains`) new (found, rest)=partition (l `dirContains`) new
{- This assumes that it's cheaper to call segmentPaths on the result, {- 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 - 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. -} {- Checks if a command is available in PATH. -}
inPath :: String -> IO Bool inPath :: String -> IO Bool
inPath command = getSearchPath >>= anyM indir inPath command = getSearchPath >>= anyM indir
where where
indir d = doesFileExist $ d </> command indir d = doesFileExist $ d </> command
{- Checks if a filename is a unix dotfile. All files inside dotdirs {- Checks if a filename is a unix dotfile. All files inside dotdirs
- count as dotfiles. -} - count as dotfiles. -}
@ -146,5 +146,5 @@ dotfile file
| f == ".." = False | f == ".." = False
| f == "" = False | f == "" = False
| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file) | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
where where
f = takeFileName file f = takeFileName file

View file

@ -28,11 +28,11 @@ showPercentage :: Int -> Percentage -> String
showPercentage precision (Percentage p) showPercentage precision (Percentage p)
| precision == 0 || remainder == 0 = go $ show int | precision == 0 || remainder == 0 = go $ show int
| otherwise = go $ show int ++ "." ++ strip0s (show remainder) | otherwise = go $ show int ++ "." ++ strip0s (show remainder)
where where
go v = v ++ "%" go v = v ++ "%"
int :: Integer int :: Integer
(int, frac) = properFraction (fromRational p) (int, frac) = properFraction (fromRational p)
remainder = floor (frac * multiplier) :: Integer remainder = floor (frac * multiplier) :: Integer
strip0s = reverse . dropWhile (== '0') . reverse strip0s = reverse . dropWhile (== '0') . reverse
multiplier :: Float multiplier :: Float
multiplier = 10 ** (fromIntegral precision) multiplier = 10 ** (fromIntegral precision)

View file

@ -59,11 +59,11 @@ readProcessEnv cmd args environ =
output <- hGetContentsStrict h output <- hGetContentsStrict h
hClose h hClose h
return output return output
where where
p = (proc cmd args) p = (proc cmd args)
{ std_out = CreatePipe { std_out = CreatePipe
, env = environ , env = environ
} }
{- Writes a string to a process on its stdin, {- Writes a string to a process on its stdin,
- returns its output, and also allows specifying the environment. - returns its output, and also allows specifying the environment.
@ -99,13 +99,13 @@ writeReadProcessEnv cmd args environ input adjusthandle = do
return output return output
where where
p = (proc cmd args) p = (proc cmd args)
{ std_in = CreatePipe { std_in = CreatePipe
, std_out = CreatePipe , std_out = CreatePipe
, std_err = Inherit , std_err = Inherit
, env = environ , env = environ
} }
{- Waits for a ProcessHandle, and throws an IOError if the process {- Waits for a ProcessHandle, and throws an IOError if the process
- did not exit successfully. -} - did not exit successfully. -}
@ -156,19 +156,19 @@ withHandle
-> (Handle -> IO a) -> (Handle -> IO a)
-> IO a -> IO a
withHandle h creator p a = creator p' $ a . select withHandle h creator p a = creator p' $ a . select
where where
base = p base = p
{ std_in = Inherit { std_in = Inherit
, std_out = Inherit , std_out = Inherit
, std_err = Inherit , std_err = Inherit
} }
(select, p') (select, p')
| h == StdinHandle = | h == StdinHandle =
(stdinHandle, base { std_in = CreatePipe }) (stdinHandle, base { std_in = CreatePipe })
| h == StdoutHandle = | h == StdoutHandle =
(stdoutHandle, base { std_out = CreatePipe }) (stdoutHandle, base { std_out = CreatePipe })
| h == StderrHandle = | h == StderrHandle =
(stderrHandle, base { std_err = CreatePipe }) (stderrHandle, base { std_err = CreatePipe })
{- Like withHandle, but passes (stdin, stdout) handles to the action. -} {- Like withHandle, but passes (stdin, stdout) handles to the action. -}
withBothHandles withBothHandles
@ -177,12 +177,12 @@ withBothHandles
-> ((Handle, Handle) -> IO a) -> ((Handle, Handle) -> IO a)
-> IO a -> IO a
withBothHandles creator p a = creator p' $ a . bothHandles withBothHandles creator p a = creator p' $ a . bothHandles
where where
p' = p p' = p
{ std_in = CreatePipe { std_in = CreatePipe
, std_out = CreatePipe , std_out = CreatePipe
, std_err = Inherit , std_err = Inherit
} }
{- Forces the CreateProcessRunner to run quietly; {- Forces the CreateProcessRunner to run quietly;
- both stdout and stderr are discarded. -} - both stdout and stderr are discarded. -}
@ -223,21 +223,21 @@ debugProcess p = do
[ action ++ ":" [ action ++ ":"
, showCmd p , showCmd p
] ]
where where
action action
| piped (std_in p) && piped (std_out p) = "chat" | piped (std_in p) && piped (std_out p) = "chat"
| piped (std_in p) = "feed" | piped (std_in p) = "feed"
| piped (std_out p) = "read" | piped (std_out p) = "read"
| otherwise = "call" | otherwise = "call"
piped Inherit = False piped Inherit = False
piped _ = True piped _ = True
{- Shows the command that a CreateProcess will run. -} {- Shows the command that a CreateProcess will run. -}
showCmd :: CreateProcess -> String showCmd :: CreateProcess -> String
showCmd = go . cmdspec showCmd = go . cmdspec
where where
go (ShellCommand s) = s go (ShellCommand s) = s
go (RawCommand c ps) = c ++ " " ++ show ps go (RawCommand c ps) = c ++ " " ++ show ps
{- Wrappers for System.Process functions that do debug logging. {- Wrappers for System.Process functions that do debug logging.
- -

View file

@ -15,11 +15,11 @@ import Data.Char
- shell. -} - shell. -}
rsyncShell :: [CommandParam] -> [CommandParam] rsyncShell :: [CommandParam] -> [CommandParam]
rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)] rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)]
where where
{- rsync requires some weird, non-shell like quoting in {- rsync requires some weird, non-shell like quoting in
- here. A doubled single quote inside the single quoted - here. A doubled single quote inside the single quoted
- string is a single quote. -} - string is a single quote. -}
escape s = "'" ++ join "''" (split "'" s) ++ "'" escape s = "'" ++ join "''" (split "'" s) ++ "'"
{- Runs rsync in server mode to send a file. -} {- Runs rsync in server mode to send a file. -}
rsyncServerSend :: FilePath -> IO Bool rsyncServerSend :: FilePath -> IO Bool
@ -60,22 +60,22 @@ rsyncProgress callback params = do
- on. Reap the resulting zombie. -} - on. Reap the resulting zombie. -}
reapZombies reapZombies
return r return r
where where
p = proc "rsync" (toCommand params) p = proc "rsync" (toCommand params)
feedprogress prev buf h = do feedprogress prev buf h = do
s <- hGetSomeString h 80 s <- hGetSomeString h 80
if null s if null s
then return True then return True
else do else do
putStr s putStr s
hFlush stdout hFlush stdout
let (mbytes, buf') = parseRsyncProgress (buf++s) let (mbytes, buf') = parseRsyncProgress (buf++s)
case mbytes of case mbytes of
Nothing -> feedprogress prev buf' h Nothing -> feedprogress prev buf' h
(Just bytes) -> do (Just bytes) -> do
when (bytes /= prev) $ when (bytes /= prev) $
callback bytes callback bytes
feedprogress bytes buf' h feedprogress bytes buf' h
{- Checks if an rsync url involves the remote shell (ssh or rsh). {- Checks if an rsync url involves the remote shell (ssh or rsh).
- Use of such urls with rsync requires additional shell - Use of such urls with rsync requires additional shell
@ -84,13 +84,13 @@ rsyncUrlIsShell :: String -> Bool
rsyncUrlIsShell s rsyncUrlIsShell s
| "rsync://" `isPrefixOf` s = False | "rsync://" `isPrefixOf` s = False
| otherwise = go s | otherwise = go s
where where
-- host::dir is rsync protocol, while host:dir is ssh/rsh -- host::dir is rsync protocol, while host:dir is ssh/rsh
go [] = False go [] = False
go (c:cs) go (c:cs)
| c == '/' = False -- got to directory with no colon | c == '/' = False -- got to directory with no colon
| c == ':' = not $ ":" `isPrefixOf` cs | c == ':' = not $ ":" `isPrefixOf` cs
| otherwise = go cs | otherwise = go cs
{- Checks if a rsync url is really just a local path. -} {- Checks if a rsync url is really just a local path. -}
rsyncUrlIsPath :: String -> Bool rsyncUrlIsPath :: String -> Bool
@ -113,19 +113,19 @@ rsyncUrlIsPath s
-} -}
parseRsyncProgress :: String -> (Maybe Integer, String) parseRsyncProgress :: String -> (Maybe Integer, String)
parseRsyncProgress = go [] . reverse . progresschunks parseRsyncProgress = go [] . reverse . progresschunks
where where
go remainder [] = (Nothing, remainder) go remainder [] = (Nothing, remainder)
go remainder (x:xs) = case parsebytes (findbytesstart x) of go remainder (x:xs) = case parsebytes (findbytesstart x) of
Nothing -> go (delim:x++remainder) xs Nothing -> go (delim:x++remainder) xs
Just b -> (Just b, remainder) Just b -> (Just b, remainder)
delim = '\r' delim = '\r'
{- Find chunks that each start with delim. {- Find chunks that each start with delim.
- The first chunk doesn't start with it - The first chunk doesn't start with it
- (it's empty when delim is at the start of the string). -} - (it's empty when delim is at the start of the string). -}
progresschunks = drop 1 . split [delim] progresschunks = drop 1 . split [delim]
findbytesstart s = dropWhile isSpace s findbytesstart s = dropWhile isSpace s
parsebytes s = case break isSpace s of parsebytes s = case break isSpace s of
([], _) -> Nothing ([], _) -> Nothing
(_, []) -> Nothing (_, []) -> Nothing
(b, _) -> readish b (b, _) -> readish b

View file

@ -74,11 +74,11 @@ lookupSRV (SRV srv) = do
r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv
print r print r
return $ maybe [] (orderHosts . map tohosts) r return $ maybe [] (orderHosts . map tohosts) r
where where
tohosts (priority, weight, port, hostname) = tohosts (priority, weight, port, hostname) =
( (priority, weight) ( (priority, weight)
, (B8.toString hostname, PortNumber $ fromIntegral port) , (B8.toString hostname, PortNumber $ fromIntegral port)
) )
#else #else
lookupSRV = lookupSRVHost lookupSRV = lookupSRVHost
#endif #endif
@ -93,21 +93,21 @@ lookupSRVHost (SRV srv) = catchDefaultIO [] $
parseSrvHost :: String -> [HostPort] parseSrvHost :: String -> [HostPort]
parseSrvHost = orderHosts . catMaybes . map parse . lines parseSrvHost = orderHosts . catMaybes . map parse . lines
where where
parse l = case words l of parse l = case words l of
[_, _, _, _, spriority, sweight, sport, hostname] -> do [_, _, _, _, spriority, sweight, sport, hostname] -> do
let v = let v =
( readish sport :: Maybe Int ( readish sport :: Maybe Int
, readish spriority :: Maybe Int , readish spriority :: Maybe Int
, readish sweight :: 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 _ -> Nothing
(Just port, Just priority, Just weight) -> Just _ -> Nothing
( (priority, weight)
, (hostname, PortNumber $ fromIntegral port)
)
_ -> Nothing
_ -> Nothing
orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort] orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort]
orderHosts = map snd . sortBy (compare `on` fst) orderHosts = map snd . sortBy (compare `on` fst)

View file

@ -25,13 +25,13 @@ data CommandParam = Params String | Param String | File FilePath
- a command and expects Strings. -} - a command and expects Strings. -}
toCommand :: [CommandParam] -> [String] toCommand :: [CommandParam] -> [String]
toCommand = (>>= unwrap) toCommand = (>>= unwrap)
where where
unwrap (Param s) = [s] unwrap (Param s) = [s]
unwrap (Params s) = filter (not . null) (split " " s) unwrap (Params s) = filter (not . null) (split " " s)
-- Files that start with a dash are modified to avoid -- Files that start with a dash are modified to avoid
-- the command interpreting them as options. -- the command interpreting them as options.
unwrap (File s@('-':_)) = ["./" ++ s] unwrap (File s@('-':_)) = ["./" ++ s]
unwrap (File s) = [s] unwrap (File s) = [s]
{- Run a system command, and returns True or False {- Run a system command, and returns True or False
- if it succeeded or failed. - 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 :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
where where
dispatch ExitSuccess = True dispatch ExitSuccess = True
dispatch _ = False dispatch _ = False
{- Runs a system command, returning the exit status. -} {- Runs a system command, returning the exit status. -}
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
@ -59,26 +59,26 @@ safeSystemEnv command params environ = do
- the shell. -} - the shell. -}
shellEscape :: String -> String shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'" shellEscape f = "'" ++ escaped ++ "'"
where where
-- replace ' with '"'"' -- replace ' with '"'"'
escaped = join "'\"'\"'" $ split "'" f escaped = join "'\"'\"'" $ split "'" f
{- Unescapes a set of shellEscaped words or filenames. -} {- Unescapes a set of shellEscaped words or filenames. -}
shellUnEscape :: String -> [String] shellUnEscape :: String -> [String]
shellUnEscape [] = [] shellUnEscape [] = []
shellUnEscape s = word : shellUnEscape rest shellUnEscape s = word : shellUnEscape rest
where where
(word, rest) = findword "" s (word, rest) = findword "" s
findword w [] = (w, "") findword w [] = (w, "")
findword w (c:cs) findword w (c:cs)
| c == ' ' = (w, cs) | c == ' ' = (w, cs)
| c == '\'' = inquote c w cs | c == '\'' = inquote c w cs
| c == '"' = inquote c w cs | c == '"' = inquote c w cs
| otherwise = findword (w++[c]) cs | otherwise = findword (w++[c]) cs
inquote _ w [] = (w, "") inquote _ w [] = (w, "")
inquote q w (c:cs) inquote q w (c:cs)
| c == q = findword w cs | c == q = findword w cs
| otherwise = inquote q (w++[c]) cs | otherwise = inquote q (w++[c]) cs
{- For quickcheck. -} {- For quickcheck. -}
prop_idempotent_shellEscape :: String -> Bool prop_idempotent_shellEscape :: String -> Bool

View file

@ -23,12 +23,12 @@ getTSet :: TSet a -> IO [a]
getTSet tset = runTSet $ do getTSet tset = runTSet $ do
c <- readTChan tset c <- readTChan tset
go [c] go [c]
where where
go l = do go l = do
v <- tryReadTChan tset v <- tryReadTChan tset
case v of case v of
Nothing -> return l Nothing -> return l
Just c -> go (c:l) Just c -> go (c:l)
{- Puts items into a TSet. -} {- Puts items into a TSet. -}
putTSet :: TSet a -> [a] -> IO () putTSet :: TSet a -> [a] -> IO ()

View file

@ -32,11 +32,11 @@ instance IsString TenseText where
renderTense :: Tense -> TenseText -> Text renderTense :: Tense -> TenseText -> Text
renderTense tense (TenseText chunks) = T.concat $ map render chunks renderTense tense (TenseText chunks) = T.concat $ map render chunks
where where
render (Tensed present past) render (Tensed present past)
| tense == Present = present | tense == Present = present
| otherwise = past | otherwise = past
render (UnTensed s) = s render (UnTensed s) = s
{- Builds up a TenseText, separating chunks with spaces. {- 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 :: [TenseChunk] -> TenseText
tenseWords = TenseText . go [] tenseWords = TenseText . go []
where where
go c [] = reverse c go c [] = reverse c
go c (w:[]) = reverse (w:c) go c (w:[]) = reverse (w:c)
go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws
go c ((Tensed w1 w2):ws) = go c ((Tensed w1 w2):ws) =
go (Tensed (addspace w1) (addspace w2) : c) ws go (Tensed (addspace w1) (addspace w2) : c) ws
addspace w = T.append w " " addspace w = T.append w " "
unTensed :: Text -> TenseText unTensed :: Text -> TenseText
unTensed t = TenseText [UnTensed t] unTensed t = TenseText [UnTensed t]

View file

@ -26,8 +26,8 @@ runEvery n a = forever $ do
threadDelaySeconds :: Seconds -> IO () threadDelaySeconds :: Seconds -> IO ()
threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond) threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
where where
oneSecond = 1000000 -- microseconds oneSecond = 1000000 -- microseconds
{- Like threadDelay, but not bounded by an Int. {- Like threadDelay, but not bounded by an Int.
- -
@ -52,6 +52,6 @@ waitForTermination = do
whenM (queryTerminal stdInput) $ whenM (queryTerminal stdInput) $
check keyboardSignal lock check keyboardSignal lock
takeMVar lock takeMVar lock
where where
check sig lock = void $ check sig lock = void $
installHandler sig (CatchOnce $ putMVar lock ()) Nothing installHandler sig (CatchOnce $ putMVar lock ()) Nothing

View file

@ -48,9 +48,9 @@ at_symlink_nofollow = #const AT_SYMLINK_NOFOLLOW
instance Storable TimeSpec where instance Storable TimeSpec where
-- use the larger alignment of the two types in the struct -- use the larger alignment of the two types in the struct
alignment _ = max sec_alignment nsec_alignment alignment _ = max sec_alignment nsec_alignment
where where
sec_alignment = alignment (undefined::CTime) sec_alignment = alignment (undefined::CTime)
nsec_alignment = alignment (undefined::CLong) nsec_alignment = alignment (undefined::CLong)
sizeOf _ = #{size struct timespec} sizeOf _ = #{size struct timespec}
peek ptr = do peek ptr = do
sec <- #{peek struct timespec, tv_sec} ptr sec <- #{peek struct timespec, tv_sec} ptr
@ -70,10 +70,10 @@ touchBoth file atime mtime follow =
pokeArray ptr [atime, mtime] pokeArray ptr [atime, mtime]
r <- c_utimensat at_fdcwd f ptr flags r <- c_utimensat at_fdcwd f ptr flags
when (r /= 0) $ throwErrno "touchBoth" when (r /= 0) $ throwErrno "touchBoth"
where where
flags = if follow flags
then 0 | follow = 0
else at_symlink_nofollow | otherwise = at_symlink_nofollow
#else #else
#if 0 #if 0
@ -108,10 +108,10 @@ touchBoth file atime mtime follow =
r <- syscall f ptr r <- syscall f ptr
when (r /= 0) $ when (r /= 0) $
throwErrno "touchBoth" throwErrno "touchBoth"
where where
syscall = if follow syscall
then c_lutimes | follow = c_lutimes
else c_utimes | otherwise = c_utimes
#else #else
#warning "utimensat and lutimes not available; building without symlink timestamp preservation support" #warning "utimensat and lutimes not available; building without symlink timestamp preservation support"

View file

@ -29,10 +29,10 @@ type Headers = [String]
- also checking that its size, if available, matches a specified size. -} - also checking that its size, if available, matches a specified size. -}
check :: URLString -> Headers -> Maybe Integer -> IO Bool check :: URLString -> Headers -> Maybe Integer -> IO Bool
check url headers expected_size = handle <$> exists url headers check url headers expected_size = handle <$> exists url headers
where where
handle (False, _) = False handle (False, _) = False
handle (True, Nothing) = True handle (True, Nothing) = True
handle (True, s) = expected_size == s handle (True, s) = expected_size == s
{- Checks that an url exists and could be successfully downloaded, {- Checks that an url exists and could be successfully downloaded,
- also returning its size if available. -} - also returning its size if available. -}
@ -50,8 +50,8 @@ exists url headers = case parseURI url of
case rspCode r of case rspCode r of
(2,_,_) -> return (True, size r) (2,_,_) -> return (True, size r)
_ -> return (False, Nothing) _ -> return (False, Nothing)
where where
size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders
{- Used to download large files, such as the contents of keys. {- 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 download url headers options file
| "file://" `isPrefixOf` url = curl | "file://" `isPrefixOf` url = curl
| otherwise = ifM (inPath "wget") (wget , curl) | otherwise = ifM (inPath "wget") (wget , curl)
where where
headerparams = map (\h -> Param $ "--header=" ++ h) headers headerparams = map (\h -> Param $ "--header=" ++ h) headers
wget = go "wget" $ headerparams ++ [Params "-c -O"] wget = go "wget" $ headerparams ++ [Params "-c -O"]
{- Uses the -# progress display, because the normal {- Uses the -# progress display, because the normal
- one is very confusing when resuming, showing - one is very confusing when resuming, showing
- the remainder to download as the whole file, - the remainder to download as the whole file,
- and not indicating how much percent was - and not indicating how much percent was
- downloaded before the resume. -} - downloaded before the resume. -}
curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"] curl = go "curl" $ headerparams ++ [Params "-L -C - -# -o"]
go cmd opts = boolSystem cmd $ go cmd opts = boolSystem cmd $
options++opts++[File file, File url] options++opts++[File file, File url]
{- Downloads a small file. -} {- Downloads a small file. -}
get :: URLString -> Headers -> IO String get :: URLString -> Headers -> IO String
@ -98,36 +98,36 @@ get url headers =
-} -}
request :: URI -> Headers -> RequestMethod -> IO (Response String) request :: URI -> Headers -> RequestMethod -> IO (Response String)
request url headers requesttype = go 5 url request url headers requesttype = go 5 url
where where
go :: Int -> URI -> IO (Response String) go :: Int -> URI -> IO (Response String)
go 0 _ = error "Too many redirects " go 0 _ = error "Too many redirects "
go n u = do go n u = do
rsp <- Browser.browse $ do rsp <- Browser.browse $ do
Browser.setErrHandler ignore Browser.setErrHandler ignore
Browser.setOutHandler ignore Browser.setOutHandler ignore
Browser.setAllowRedirects False Browser.setAllowRedirects False
let req = mkRequest requesttype u :: Request_String let req = mkRequest requesttype u :: Request_String
snd <$> Browser.request (addheaders req) snd <$> Browser.request (addheaders req)
case rspCode rsp of case rspCode rsp of
(3,0,x) | x /= 5 -> redir (n - 1) u rsp (3,0,x) | x /= 5 -> redir (n - 1) u rsp
_ -> return rsp _ -> return rsp
ignore = const noop ignore = const noop
redir n u rsp = case retrieveHeaders HdrLocation rsp of redir n u rsp = case retrieveHeaders HdrLocation rsp of
[] -> return rsp [] -> return rsp
(Header _ newu:_) -> (Header _ newu:_) ->
case parseURIReference newu of case parseURIReference newu of
Nothing -> return rsp Nothing -> return rsp
Just newURI -> go n newURI_abs Just newURI -> go n newURI_abs
where where
#if defined VERSION_network #if defined VERSION_network
#if ! MIN_VERSION_network(2,4,0) #if ! MIN_VERSION_network(2,4,0)
#define WITH_OLD_URI #define WITH_OLD_URI
#endif #endif
#endif #endif
#ifdef WITH_OLD_URI #ifdef WITH_OLD_URI
newURI_abs = fromMaybe newURI (newURI `relativeTo` u) newURI_abs = fromMaybe newURI (newURI `relativeTo` u)
#else #else
newURI_abs = newURI `relativeTo` u newURI_abs = newURI `relativeTo` u
#endif #endif
addheaders req = setHeaders req (rqHeaders req ++ userheaders) addheaders req = setHeaders req (rqHeaders req ++ userheaders)
userheaders = rights $ map parseHeader headers userheaders = rights $ map parseHeader headers

View file

@ -26,7 +26,7 @@ myUserName = myVal ["USER", "LOGNAME"] userName
myVal :: [String] -> (UserEntry -> String) -> IO String myVal :: [String] -> (UserEntry -> String) -> IO String
myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars
where where
check [] = return Nothing check [] = return Nothing
check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
getpwent = getUserEntryForID =<< getEffectiveUserID getpwent = getUserEntryForID =<< getEffectiveUserID

View file

@ -33,5 +33,5 @@ calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v
{- for quickcheck -} {- for quickcheck -}
prop_verifiable_sane :: String -> String -> Bool prop_verifiable_sane :: String -> String -> Bool
prop_verifiable_sane a s = verify (mkVerifiable a secret) secret prop_verifiable_sane a s = verify (mkVerifiable a secret) secret
where where
secret = fromString s secret = fromString s

View file

@ -43,11 +43,11 @@ localhost = "localhost"
- Note: The url *will* be visible to an attacker. -} - Note: The url *will* be visible to an attacker. -}
runBrowser :: String -> (Maybe [(String, String)]) -> IO Bool runBrowser :: String -> (Maybe [(String, String)]) -> IO Bool
runBrowser url env = boolSystemEnv cmd [Param url] env runBrowser url env = boolSystemEnv cmd [Param url] env
where where
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
cmd = "open" cmd = "open"
#else #else
cmd = "xdg-open" cmd = "xdg-open"
#endif #endif
{- Binds to a socket on localhost, and runs a webapp on it. {- Binds to a socket on localhost, and runs a webapp on it.
@ -75,25 +75,25 @@ localSocket = do
(v4addr:_, _) -> go v4addr (v4addr:_, _) -> go v4addr
(_, v6addr:_) -> go v6addr (_, v6addr:_) -> go v6addr
_ -> error "unable to bind to a local socket" _ -> error "unable to bind to a local socket"
where where
hints = defaultHints hints = defaultHints
{ addrFlags = [AI_ADDRCONFIG] { addrFlags = [AI_ADDRCONFIG]
, addrSocketType = Stream , addrSocketType = Stream
} }
{- Repeated attempts because bind sometimes fails for an {- Repeated attempts because bind sometimes fails for an
- unknown reason on OSX. -} - unknown reason on OSX. -}
go addr = go' 100 addr go addr = go' 100 addr
go' :: Int -> AddrInfo -> IO Socket go' :: Int -> AddrInfo -> IO Socket
go' 0 _ = error "unable to bind to local socket" go' 0 _ = error "unable to bind to local socket"
go' n addr = do go' n addr = do
r <- tryIO $ bracketOnError (open addr) sClose (use addr) r <- tryIO $ bracketOnError (open addr) sClose (use addr)
either (const $ go' (pred n) addr) return r either (const $ go' (pred n) addr) return r
open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
use addr sock = do use addr sock = do
setSocketOption sock ReuseAddr 1 setSocketOption sock ReuseAddr 1
bindSocket sock (addrAddress addr) bindSocket sock (addrAddress addr)
listen sock maxListenQueue listen sock maxListenQueue
return sock return sock
{- Checks if debugging is actually enabled. -} {- Checks if debugging is actually enabled. -}
debugEnabled :: IO Bool debugEnabled :: IO Bool
@ -121,8 +121,8 @@ logRequest req = do
--, frombs $ lookupRequestField "referer" req --, frombs $ lookupRequestField "referer" req
, frombs $ lookupRequestField "user-agent" req , frombs $ lookupRequestField "user-agent" req
] ]
where where
frombs v = toString $ L.fromChunks [v] frombs v = toString $ L.fromChunks [v]
lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString
lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
@ -179,12 +179,12 @@ insertAuthToken :: forall y. (y -> T.Text)
-> Builder -> Builder
insertAuthToken extractToken predicate webapp root pathbits params = insertAuthToken extractToken predicate webapp root pathbits params =
fromText root `mappend` encodePath pathbits' encodedparams fromText root `mappend` encodePath pathbits' encodedparams
where where
pathbits' = if null pathbits then [T.empty] else pathbits pathbits' = if null pathbits then [T.empty] else pathbits
encodedparams = map (TE.encodeUtf8 *** go) params' encodedparams = map (TE.encodeUtf8 *** go) params'
go "" = Nothing go "" = Nothing
go x = Just $ TE.encodeUtf8 x go x = Just $ TE.encodeUtf8 x
authparam = (T.pack "auth", extractToken webapp) authparam = (T.pack "auth", extractToken webapp)
params' params'
| predicate pathbits = authparam:params | predicate pathbits = authparam:params
| otherwise = 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 * webapp: Defaults to sharing box.com account info with friends, allowing
one-click enabling of the repository. 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. * assistant: Fix syncing to just created ssh remotes.
* Enable WebDAV support in Debian package. Closes: #695532 * 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 git-annex (3.20121127) unstable; urgency=low

2
debian/rules vendored
View file

@ -2,7 +2,7 @@
ARCH = $(shell dpkg-architecture -qDEB_BUILD_ARCH) ARCH = $(shell dpkg-architecture -qDEB_BUILD_ARCH)
ifeq (install ok installed,$(shell dpkg-query -W -f '$${Status}' libghc-yesod-dev 2>/dev/null)) 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 else
export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBDAV -DWITH_HOST -DWITH_OLD_URI -DWITH_PAIRING -DWITH_XMPP export FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBDAV -DWITH_HOST -DWITH_OLD_URI -DWITH_PAIRING -DWITH_XMPP
endif endif

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 ## version 3.20121126
This adds several features to the git-annex assistant, which is still in beta. This adds several features to the git-annex assistant, which is still in beta.

View file

@ -1,4 +1,6 @@
This is a collection of problem reports for the standalone OSX app. This is a collection of problem reports for the standalone OSX app.
If you have a problem using it, post it here. --[[Joey]] 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]] [[!tag /design/assistant/OSX]]

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

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

View file

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

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

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.

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.

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

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

View file

@ -13,9 +13,10 @@ and use cases to add. Feel free to chip in with comments! --[[Joey]]
We are, approximately, here: We are, approximately, here:
* Month 6 "9k bonus round": [[!traillink Android]] or [[!traillink desymlink]] * Month 6 "9k bonus round": [[!traillink desymlink]]
* Month 7: user-driven features and polishing * Month 7: user-driven features and polishing;
* Month 8: whatever I don't get to in month 6 [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) * Months 9-11: more user-driven features and polishing (see remaining TODO items in all pages above)
* Month 12: "Windows purgatory" [[Windows]] * Month 12: "Windows purgatory" [[Windows]]

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

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

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.

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.

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, * `git annex sync` updates the key to files mappings for files changed,
but needs much other work to handle direct mode: but needs much other work to handle direct mode:
* Generate git commit, without running `git commit`, because it will * Generate git commit, without running `git commit`, because it will
want to stage the full files. want to stage the full files. **done**
* Update location logs for any files deleted by a commit. * Update location logs for any files deleted by a commit. **done**
* Generate a git merge, without running `git merge` (or possibly running * Generate a git merge, without running `git merge` (or possibly running
it in a scratch repo?), because it will stumble over the direct files. it in a scratch repo?), because it will stumble over the direct files.
* Drop contents of files deleted by a merge (including updating the * Drop contents of files deleted by a merge (including updating the

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

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

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

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

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