where indentation

This commit is contained in:
Joey Hess 2012-11-12 01:05:04 -04:00
parent f0dd6d00d1
commit ebd576ebcb
30 changed files with 804 additions and 812 deletions

View file

@ -32,20 +32,20 @@ seek = [withFilesNotInGit start, withFilesUnlocked start]
- to its content. -}
start :: FilePath -> CommandStart
start file = notBareRepo $ ifAnnexed file fixup add
where
add = do
s <- liftIO $ getSymbolicLinkStatus file
if isSymbolicLink s || not (isRegularFile s)
then stop
else do
showStart "add" file
next $ perform file
fixup (key, _) = do
-- fixup from an interrupted add; the symlink
-- is present but not yet added to git
showStart "add" file
liftIO $ removeFile file
next $ next $ cleanup file key =<< inAnnex key
where
add = do
s <- liftIO $ getSymbolicLinkStatus file
if isSymbolicLink s || not (isRegularFile s)
then stop
else do
showStart "add" file
next $ perform file
fixup (key, _) = do
-- fixup from an interrupted add; the symlink
-- is present but not yet added to git
showStart "add" file
liftIO $ removeFile file
next $ next $ cleanup file key =<< inAnnex key
{- The file that's being added is locked down before a key is generated,
- to prevent it from being modified in between. It's hard linked into a
@ -67,15 +67,15 @@ ingest :: KeySource -> Annex (Maybe Key)
ingest source = do
backend <- chooseBackend $ keyFilename source
genKey source backend >>= go
where
go Nothing = do
liftIO $ nukeFile $ contentLocation source
return Nothing
go (Just (key, _)) = do
handle (undo (keyFilename source) key) $
moveAnnex key $ contentLocation source
liftIO $ nukeFile $ keyFilename source
return $ Just key
where
go Nothing = do
liftIO $ nukeFile $ contentLocation source
return Nothing
go (Just (key, _)) = do
handle (undo (keyFilename source) key) $
moveAnnex key $ contentLocation source
liftIO $ nukeFile $ keyFilename source
return $ Just key
perform :: FilePath -> CommandPerform
perform file =
@ -91,12 +91,12 @@ undo file key e = do
handle tryharder $ fromAnnex key file
logStatus key InfoMissing
throw e
where
-- fromAnnex could fail if the file ownership is weird
tryharder :: IOException -> Annex ()
tryharder _ = do
src <- inRepo $ gitAnnexLocation key
liftIO $ moveFile src file
where
-- fromAnnex could fail if the file ownership is weird
tryharder :: IOException -> Annex ()
tryharder _ = do
src <- inRepo $ gitAnnexLocation key
liftIO $ moveFile src file
{- Creates the symlink to the annexed content, returns the link target. -}
link :: FilePath -> Key -> Bool -> Annex String

View file

@ -25,8 +25,8 @@ start = startUnused "addunused" perform (performOther "bad") (performOther "tmp"
perform :: Key -> CommandPerform
perform key = next $ Command.Add.cleanup file key True
where
file = "unused." ++ key2file key
where
file = "unused." ++ key2file key
{- The content is not in the annex, but in another directory, and
- it seems better to error out, rather than moving bad/tmp content into

View file

@ -40,31 +40,31 @@ seek = [withField fileOption return $ \f ->
start :: Maybe FilePath -> Maybe Int -> String -> CommandStart
start optfile pathdepth s = notBareRepo $ go $ fromMaybe bad $ parseURI s
where
bad = fromMaybe (error $ "bad url " ++ s) $
parseURI $ escapeURIString isUnescapedInURI s
go url = do
let file = fromMaybe (url2file url pathdepth) optfile
showStart "addurl" file
next $ perform s file
where
bad = fromMaybe (error $ "bad url " ++ s) $
parseURI $ escapeURIString isUnescapedInURI s
go url = do
let file = fromMaybe (url2file url pathdepth) optfile
showStart "addurl" file
next $ perform s file
perform :: String -> FilePath -> CommandPerform
perform url file = ifAnnexed file addurl geturl
where
geturl = do
liftIO $ createDirectoryIfMissing True (parentDir file)
ifM (Annex.getState Annex.fast)
( nodownload url file , download url file )
addurl (key, _backend) = do
headers <- getHttpHeaders
ifM (liftIO $ Url.check url headers $ keySize key)
( do
setUrlPresent key url
next $ return True
, do
warning $ "failed to verify url: " ++ url
stop
)
where
geturl = do
liftIO $ createDirectoryIfMissing True (parentDir file)
ifM (Annex.getState Annex.fast)
( nodownload url file , download url file )
addurl (key, _backend) = do
headers <- getHttpHeaders
ifM (liftIO $ Url.check url headers $ keySize key)
( do
setUrlPresent key url
next $ return True
, do
warning $ "failed to verify url: " ++ url
stop
)
download :: String -> FilePath -> CommandPerform
download url file = do
@ -103,10 +103,10 @@ url2file url pathdepth = case pathdepth of
| depth > 0 -> frombits $ drop depth
| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
| otherwise -> error "bad --pathdepth"
where
fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
frombits a = join "/" $ a urlbits
urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl
auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
filesize = take 255
escape = replace "/" "_" . replace "?" "_"
where
fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
frombits a = join "/" $ a urlbits
urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl
auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
filesize = take 255
escape = replace "/" "_" . replace "?" "_"

View file

@ -65,7 +65,7 @@ autoStart = do
)
, nothing
)
where
go program dir = do
changeWorkingDirectory dir
boolSystem program [Param "assistant"]
where
go program dir = do
changeWorkingDirectory dir
boolSystem program [Param "assistant"]

View file

@ -24,6 +24,6 @@ start = next $ next $ do
Annex.Branch.commit "update"
_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
return True
where
runhook (Just hook) = liftIO $ boolSystem hook []
runhook Nothing = return True
where
runhook (Just hook) = liftIO $ boolSystem hook []
runhook Nothing = return True

View file

@ -29,7 +29,7 @@ start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandSt
start to from file (key, backend) = autoCopies file key (<) $
stopUnless shouldCopy $
Command.Move.start to from False file (key, backend)
where
shouldCopy = case to of
Nothing -> checkAuto $ wantGet (Just file)
Just r -> checkAuto $ wantSend (Just file) (Remote.uuid r)
where
shouldCopy = case to of
Nothing -> checkAuto $ wantGet (Just file)
Just r -> checkAuto $ wantSend (Just file) (Remote.uuid r)

View file

@ -76,8 +76,8 @@ performRemote key numcopies remote = lockContent key $ do
stopUnless (canDropKey key numcopies have tocheck [uuid]) $ do
ok <- Remote.removeKey remote key
next $ cleanupRemote key remote ok
where
uuid = Remote.uuid remote
where
uuid = Remote.uuid remote
cleanupLocal :: Key -> CommandCleanup
cleanupLocal key = do
@ -106,20 +106,20 @@ canDropKey key numcopiesM have check skip = do
findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
findCopies key need skip = helper []
where
helper bad have []
| length have >= need = return True
| otherwise = notEnoughCopies key need have skip bad
helper bad have (r:rs)
| length have >= need = return True
| otherwise = do
let u = Remote.uuid r
let duplicate = u `elem` have
haskey <- Remote.hasKey r key
case (duplicate, haskey) of
(False, Right True) -> helper bad (u:have) rs
(False, Left _) -> helper (r:bad) have rs
_ -> helper bad have rs
where
helper bad have []
| length have >= need = return True
| otherwise = notEnoughCopies key need have skip bad
helper bad have (r:rs)
| length have >= need = return True
| otherwise = do
let u = Remote.uuid r
let duplicate = u `elem` have
haskey <- Remote.hasKey r key
case (duplicate, haskey) of
(False, Right True) -> helper bad (u:have) rs
(False, Left _) -> helper (r:bad) have rs
_ -> helper bad have rs
notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool
notEnoughCopies key need have skip bad = do
@ -132,6 +132,6 @@ notEnoughCopies key need have skip bad = do
Remote.showLocations key (have++skip)
hint
return False
where
unsafe = showNote "unsafe"
hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"
where
unsafe = showNote "unsafe"
hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"

View file

@ -29,13 +29,13 @@ start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (per
perform :: Key -> CommandPerform
perform key = maybe droplocal dropremote =<< Remote.byName =<< from
where
dropremote r = do
showAction $ "from " ++ Remote.name r
ok <- Remote.removeKey r key
next $ Command.Drop.cleanupRemote key r ok
droplocal = Command.Drop.performLocal key (Just 0) -- force drop
from = Annex.getField $ Option.name Command.Drop.fromOption
where
dropremote r = do
showAction $ "from " ++ Remote.name r
ok <- Remote.removeKey r key
next $ Command.Drop.cleanupRemote key r ok
droplocal = Command.Drop.performLocal key (Just 0) -- force drop
from = Annex.getField $ Option.name Command.Drop.fromOption
performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform
performOther filespec key = do

View file

@ -29,14 +29,14 @@ formatOption = Option.field [] "format" paramFormat "control format of output"
print0Option :: Option
print0Option = Option.Option [] ["print0"] (Option.NoArg set)
"terminate output with null"
where
set = Annex.setField (Option.name formatOption) "${file}\0"
where
set = Annex.setField (Option.name formatOption) "${file}\0"
seek :: [CommandSeek]
seek = [withField formatOption formatconverter $ \f ->
withFilesInGit $ whenAnnexed $ start f]
where
formatconverter = return . fmap Utility.Format.gen
where
formatconverter = return . fmap Utility.Format.gen
start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart
start format file (key, _) = do
@ -50,12 +50,12 @@ start format file (key, _) = do
Utility.Format.format formatter $
M.fromList vars
stop
where
vars =
[ ("file", file)
, ("key", key2file key)
, ("backend", keyBackendName key)
, ("bytesize", size show)
, ("humansize", size $ roughSize storageUnits True)
]
size c = maybe "unknown" c $ keySize key
where
vars =
[ ("file", file)
, ("key", key2file key)
, ("backend", keyBackendName key)
, ("bytesize", size show)
, ("humansize", size $ roughSize storageUnits True)
]
size c = maybe "unknown" c $ keySize key

View file

@ -78,22 +78,22 @@ withIncremental = withValue $ do
(True, _, _) ->
maybe startIncremental (return . ContIncremental . Just)
=<< getStartTime
where
startIncremental = do
recordStartTime
return StartIncremental
where
startIncremental = do
recordStartTime
return StartIncremental
checkschedule Nothing = error "bad --incremental-schedule value"
checkschedule (Just delta) = do
Annex.addCleanup "" $ do
v <- getStartTime
case v of
Nothing -> noop
Just started -> do
now <- liftIO getPOSIXTime
when (now - realToFrac started >= delta) $
resetStartTime
return True
checkschedule Nothing = error "bad --incremental-schedule value"
checkschedule (Just delta) = do
Annex.addCleanup "" $ do
v <- getStartTime
case v of
Nothing -> noop
Just started -> do
now <- liftIO getPOSIXTime
when (now - realToFrac started >= delta) $
resetStartTime
return True
start :: Maybe Remote -> Incremental -> FilePath -> (Key, Backend) -> CommandStart
start from inc file (key, backend) = do
@ -101,8 +101,8 @@ start from inc file (key, backend) = do
case from of
Nothing -> go $ perform key file backend numcopies
Just r -> go $ performRemote key file backend numcopies r
where
go = runFsck inc file key
where
go = runFsck inc file key
perform :: Key -> FilePath -> Backend -> Maybe Int -> Annex Bool
perform key file backend numcopies = check
@ -119,48 +119,48 @@ perform key file backend numcopies = check
performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> Annex Bool
performRemote key file backend numcopies remote =
dispatch =<< Remote.hasKey remote key
where
dispatch (Left err) = do
showNote err
return False
dispatch (Right True) = withtmp $ \tmpfile ->
ifM (getfile tmpfile)
( go True (Just tmpfile)
, go True Nothing
)
dispatch (Right False) = go False Nothing
go present localcopy = check
[ verifyLocationLogRemote key file remote present
, checkKeySizeRemote key remote localcopy
, checkBackendRemote backend key remote localcopy
, checkKeyNumCopies key file numcopies
]
withtmp a = do
pid <- liftIO getProcessID
t <- fromRepo gitAnnexTmpDir
createAnnexDirectory t
let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
cleanup
cleanup `after` a tmp
getfile tmp =
ifM (Remote.retrieveKeyFileCheap remote key tmp)
( return True
, ifM (Annex.getState Annex.fast)
( return False
, Remote.retrieveKeyFile remote key Nothing tmp
)
where
dispatch (Left err) = do
showNote err
return False
dispatch (Right True) = withtmp $ \tmpfile ->
ifM (getfile tmpfile)
( go True (Just tmpfile)
, go True Nothing
)
dispatch (Right False) = go False Nothing
go present localcopy = check
[ verifyLocationLogRemote key file remote present
, checkKeySizeRemote key remote localcopy
, checkBackendRemote backend key remote localcopy
, checkKeyNumCopies key file numcopies
]
withtmp a = do
pid <- liftIO getProcessID
t <- fromRepo gitAnnexTmpDir
createAnnexDirectory t
let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key
let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
cleanup
cleanup `after` a tmp
getfile tmp =
ifM (Remote.retrieveKeyFileCheap remote key tmp)
( return True
, ifM (Annex.getState Annex.fast)
( return False
, Remote.retrieveKeyFile remote key Nothing tmp
)
)
{- To fsck a bare repository, fsck each key in the location log. -}
withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek
withBarePresentKeys a params = isBareRepo >>= go
where
go False = return []
go True = do
unless (null params) $
error "fsck should be run without parameters in a bare repository"
map a <$> loggedKeys
where
go False = return []
go True = do
unless (null params) $
error "fsck should be run without parameters in a bare repository"
map a <$> loggedKeys
startBare :: Incremental -> Key -> CommandStart
startBare inc key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
@ -242,10 +242,10 @@ verifyLocationLog' key desc present u bad = do
"but its content is missing."
return False
_ -> return True
where
fix s = do
showNote "fixing location log"
bad s
where
fix s = do
showNote "fixing location log"
bad s
{- The size of the data for a key is checked against the size encoded in
- the key's metadata, if available. -}
@ -269,19 +269,19 @@ checkKeySizeOr bad key file = case Types.Key.keySize key of
size' <- fromIntegral . fileSize
<$> liftIO (getFileStatus file)
comparesizes size size'
where
comparesizes a b = do
let same = a == b
unless same $ badsize a b
return same
badsize a b = do
msg <- bad key
warning $ concat
[ "Bad file size ("
, compareSizes storageUnits True a b
, "); "
, msg
]
where
comparesizes a b = do
let same = a == b
unless same $ badsize a b
return same
badsize a b = do
msg <- bad key
warning $ concat
[ "Bad file size ("
, compareSizes storageUnits True a b
, "); "
, msg
]
checkBackend :: Backend -> Key -> Annex Bool
checkBackend backend key = do
@ -290,8 +290,8 @@ checkBackend backend key = do
checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool
checkBackendRemote backend key remote = maybe (return True) go
where
go = checkBackendOr (badContentRemote remote) backend key
where
go = checkBackendOr (badContentRemote remote) backend key
checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool
checkBackendOr bad backend key file =
@ -414,9 +414,9 @@ recordStartTime = do
t <- modificationTime <$> getFileStatus f
hPutStr h $ showTime $ realToFrac t
hClose h
where
showTime :: POSIXTime -> String
showTime = show
where
showTime :: POSIXTime -> String
showTime = show
resetStartTime :: Annex ()
resetStartTime = liftIO . nukeFile =<< fromRepo gitAnnexFsckState
@ -431,7 +431,7 @@ getStartTime = do
return $ if Just (realToFrac timestamp) == t
then Just timestamp
else Nothing
where
readishTime :: String -> Maybe POSIXTime
readishTime s = utcTimeToPOSIXSeconds <$>
parseTime defaultTimeLocale "%s%Qs" s
where
readishTime :: String -> Maybe POSIXTime
readishTime s = utcTimeToPOSIXSeconds <$>
parseTime defaultTimeLocale "%s%Qs" s

View file

@ -32,10 +32,10 @@ start from file (key, _) = stopUnless ((not <$> inAnnex key) <&&> checkAuto (wan
-- get --from = copy --from
stopUnless (Command.Move.fromOk src key) $
go $ Command.Move.fromPerform src False key file
where
go a = do
showStart "get" file
next a
where
go a = do
showStart "get" file
next a
perform :: Key -> FilePath -> CommandPerform
perform key file = stopUnless (getViaTmp key $ getKeyFile key file) $
@ -45,29 +45,29 @@ perform key file = stopUnless (getViaTmp key $ getKeyFile key file) $
- and copy it to here. -}
getKeyFile :: Key -> FilePath -> FilePath -> Annex Bool
getKeyFile key file dest = dispatch =<< Remote.keyPossibilities key
where
dispatch [] = do
showNote "not available"
Remote.showLocations key []
return False
dispatch remotes = trycopy remotes remotes
trycopy full [] = do
Remote.showTriedRemotes full
Remote.showLocations key []
return False
trycopy full (r:rs) =
ifM (probablyPresent r)
( docopy r (trycopy full rs)
, trycopy full rs
)
-- This check is to avoid an ugly message if a remote is a
-- drive that is not mounted.
probablyPresent r
| Remote.hasKeyCheap r =
either (const False) id <$> Remote.hasKey r key
| otherwise = return True
docopy r continue = do
ok <- download (Remote.uuid r) key (Just file) noRetry $ do
showAction $ "from " ++ Remote.name r
Remote.retrieveKeyFile r key (Just file) dest
if ok then return ok else continue
where
dispatch [] = do
showNote "not available"
Remote.showLocations key []
return False
dispatch remotes = trycopy remotes remotes
trycopy full [] = do
Remote.showTriedRemotes full
Remote.showLocations key []
return False
trycopy full (r:rs) =
ifM (probablyPresent r)
( docopy r (trycopy full rs)
, trycopy full rs
)
-- This check is to avoid an ugly message if a remote is a
-- drive that is not mounted.
probablyPresent r
| Remote.hasKeyCheap r =
either (const False) id <$> Remote.hasKey r key
| otherwise = return True
docopy r continue = do
ok <- download (Remote.uuid r) key (Just file) noRetry $ do
showAction $ "from " ++ Remote.name r
Remote.retrieveKeyFile r key (Just file) dest
if ok then return ok else continue

View file

@ -47,5 +47,5 @@ showHelp = liftIO $ putStrLn $ unlines
]
, "Run git-annex without any options for a complete command and option list."
]
where
cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c
where
cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c

View file

@ -20,8 +20,8 @@ seek = [withKeys start]
start :: Key -> CommandStart
start key = inAnnexSafe key >>= dispatch
where
dispatch (Just True) = stop
dispatch (Just False) = exit 1
dispatch Nothing = exit 100
exit n = liftIO $ exitWith $ ExitFailure n
where
dispatch (Just True) = stop
dispatch (Just False) = exit 1
dispatch Nothing = exit 100
exit n = liftIO $ exitWith $ ExitFailure n

View file

@ -22,8 +22,8 @@ start :: [String] -> CommandStart
start ws = do
showStart "init" description
next $ perform description
where
description = unwords ws
where
description = unwords ws
perform :: String -> CommandPerform
perform description = do

View file

@ -40,8 +40,8 @@ start (name:ws) = do
showStart "initremote" name
next $ perform t u name $ M.union config c
where
config = Logs.Remote.keyValToConfig ws
where
config = Logs.Remote.keyValToConfig ws
perform :: RemoteType -> UUID -> String -> R.RemoteConfig -> CommandPerform
perform t u name c = do
@ -59,19 +59,19 @@ findByName :: String -> Annex (UUID, R.RemoteConfig)
findByName name = do
m <- Logs.Remote.readRemoteLog
maybe generate return $ findByName' name m
where
generate = do
uuid <- liftIO genUUID
return (uuid, M.insert nameKey name M.empty)
where
generate = do
uuid <- liftIO genUUID
return (uuid, M.insert nameKey name M.empty)
findByName' :: String -> M.Map UUID R.RemoteConfig -> Maybe (UUID, R.RemoteConfig)
findByName' n = headMaybe . filter (matching . snd) . M.toList
where
matching c = case M.lookup nameKey c of
Nothing -> False
Just n'
| n' == n -> True
| otherwise -> False
where
matching c = case M.lookup nameKey c of
Nothing -> False
Just n'
| n' == n -> True
| otherwise -> False
remoteNames :: Annex [String]
remoteNames = do
@ -81,12 +81,12 @@ remoteNames = do
{- find the specified remote type -}
findType :: R.RemoteConfig -> Annex RemoteType
findType config = maybe unspecified specified $ M.lookup typeKey config
where
unspecified = error "Specify the type of remote with type="
specified s = case filter (findtype s) Remote.remoteTypes of
[] -> error $ "Unknown remote type " ++ s
(t:_) -> return t
findtype s i = R.typename i == s
where
unspecified = error "Specify the type of remote with type="
specified s = case filter (findtype s) Remote.remoteTypes of
[] -> error $ "Unknown remote type " ++ s
(t:_) -> return t
findtype s i = R.typename i == s
{- The name of a configured remote is stored in its config using this key. -}
nameKey :: String

View file

@ -47,9 +47,8 @@ passthruOptions = map odate ["since", "after", "until", "before"] ++
[ Option.field ['n'] "max-count" paramNumber
"limit number of logs displayed"
]
where
odate n = Option.field [] n paramDate $
"show log " ++ n ++ " date"
where
odate n = Option.field [] n paramDate $ "show log " ++ n ++ " date"
gourceOption :: Option
gourceOption = Option.flag [] "gource" "format output for gource"
@ -60,10 +59,10 @@ seek = [withValue Remote.uuidDescriptions $ \m ->
withValue (concat <$> mapM getoption passthruOptions) $ \os ->
withFlag gourceOption $ \gource ->
withFilesInGit $ whenAnnexed $ start m zone os gource]
where
getoption o = maybe [] (use o) <$>
Annex.getField (Option.name o)
use o v = [Param ("--" ++ Option.name o), Param v]
where
getoption o = maybe [] (use o) <$>
Annex.getField (Option.name o)
use o v = [Param ("--" ++ Option.name o), Param v]
start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool ->
FilePath -> (Key, Backend) -> CommandStart
@ -72,41 +71,41 @@ start m zone os gource file (key, _) = do
-- getLog produces a zombie; reap it
liftIO reapZombies
stop
where
output
| gource = gourceOutput lookupdescription file
| otherwise = normalOutput lookupdescription file zone
lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m
where
output
| gource = gourceOutput lookupdescription file
| otherwise = normalOutput lookupdescription file zone
lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m
showLog :: Outputter -> [RefChange] -> Annex ()
showLog outputter ps = do
sets <- mapM (getset newref) ps
previous <- maybe (return genesis) (getset oldref) (lastMaybe ps)
sequence_ $ compareChanges outputter $ sets ++ [previous]
where
genesis = (0, S.empty)
getset select change = do
s <- S.fromList <$> get (select change)
return (changetime change, s)
get ref = map toUUID . Logs.Presence.getLog . L.unpack <$>
catObject ref
where
genesis = (0, S.empty)
getset select change = do
s <- S.fromList <$> get (select change)
return (changetime change, s)
get ref = map toUUID . Logs.Presence.getLog . L.unpack <$>
catObject ref
normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter
normalOutput lookupdescription file zone present ts us =
liftIO $ mapM_ (putStrLn . format) us
where
time = showTimeStamp zone ts
addel = if present then "+" else "-"
format u = unwords [ addel, time, file, "|",
fromUUID u ++ " -- " ++ lookupdescription u ]
where
time = showTimeStamp zone ts
addel = if present then "+" else "-"
format u = unwords [ addel, time, file, "|",
fromUUID u ++ " -- " ++ lookupdescription u ]
gourceOutput :: (UUID -> String) -> FilePath -> Outputter
gourceOutput lookupdescription file present ts us =
liftIO $ mapM_ (putStrLn . intercalate "|" . format) us
where
time = takeWhile isDigit $ show ts
addel = if present then "A" else "M"
format u = [ time, lookupdescription u, addel, file ]
where
time = takeWhile isDigit $ show ts
addel = if present then "A" else "M"
format u = [ time, lookupdescription u, addel, file ]
{- Generates a display of the changes (which are ordered with newest first),
- by comparing each change with the previous change.
@ -114,12 +113,12 @@ gourceOutput lookupdescription file present ts us =
- removed. -}
compareChanges :: Ord a => (Bool -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a)] -> [b]
compareChanges format changes = concatMap diff $ zip changes (drop 1 changes)
where
diff ((ts, new), (_, old)) =
[format True ts added, format False ts removed]
where
added = S.toList $ S.difference new old
removed = S.toList $ S.difference old new
where
diff ((ts, new), (_, old)) =
[format True ts added, format False ts removed]
where
added = S.toList $ S.difference new old
removed = S.toList $ S.difference old new
{- Gets the git log for a given location log file.
-
@ -148,21 +147,21 @@ getLog key os = do
readLog :: [String] -> [RefChange]
readLog = mapMaybe (parse . lines)
where
parse (ts:raw:[]) = let (old, new) = parseRaw raw in
Just RefChange
{ changetime = parseTimeStamp ts
, oldref = old
, newref = new
}
parse _ = Nothing
where
parse (ts:raw:[]) = let (old, new) = parseRaw raw in
Just RefChange
{ changetime = parseTimeStamp ts
, oldref = old
, newref = new
}
parse _ = Nothing
-- Parses something like ":100644 100644 oldsha newsha M"
parseRaw :: String -> (Git.Ref, Git.Ref)
parseRaw l = go $ words l
where
go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha)
go _ = error $ "unable to parse git log output: " ++ l
where
go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha)
go _ = error $ "unable to parse git log output: " ++ l
parseTimeStamp :: String -> POSIXTime
parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .

View file

@ -63,14 +63,13 @@ start = do
-}
drawMap :: [Git.Repo] -> M.Map UUID String -> [UUID] -> String
drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others
where
repos = map (node umap rs) rs
ruuids = ts ++ map getUncachedUUID rs
others = map (unreachable . uuidnode) $
filter (`notElem` ruuids) (M.keys umap)
trusted = map (trustworthy . uuidnode) ts
uuidnode u = Dot.graphNode (fromUUID u) $
M.findWithDefault "" u umap
where
repos = map (node umap rs) rs
ruuids = ts ++ map getUncachedUUID rs
others = map (unreachable . uuidnode) $
filter (`notElem` ruuids) (M.keys umap)
trusted = map (trustworthy . uuidnode) ts
uuidnode u = Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap
hostname :: Git.Repo -> String
hostname r
@ -86,9 +85,9 @@ repoName :: M.Map UUID String -> Git.Repo -> String
repoName umap r
| repouuid == NoUUID = fallback
| otherwise = M.findWithDefault fallback repouuid umap
where
repouuid = getUncachedUUID r
fallback = fromMaybe "unknown" $ Git.remoteName r
where
repouuid = getUncachedUUID r
fallback = fromMaybe "unknown" $ Git.remoteName r
{- A unique id for the node for a repo. Uses the annex.uuid if available. -}
nodeId :: Git.Repo -> String
@ -100,32 +99,32 @@ nodeId r =
{- A node representing a repo. -}
node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String
node umap fullinfo r = unlines $ n:edges
where
n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
decorate $ Dot.graphNode (nodeId r) (repoName umap r)
edges = map (edge umap fullinfo r) (Git.remotes r)
decorate
| Git.config r == M.empty = unreachable
| otherwise = reachable
where
n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $
decorate $ Dot.graphNode (nodeId r) (repoName umap r)
edges = map (edge umap fullinfo r) (Git.remotes r)
decorate
| Git.config r == M.empty = unreachable
| otherwise = reachable
{- An edge between two repos. The second repo is a remote of the first. -}
edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String
edge umap fullinfo from to =
Dot.graphEdge (nodeId from) (nodeId fullto) edgename
where
-- get the full info for the remote, to get its UUID
fullto = findfullinfo to
findfullinfo n =
case filter (same n) fullinfo of
[] -> n
(n':_) -> n'
{- Only name an edge if the name is different than the name
- that will be used for the destination node, and is
- different from its hostname. (This reduces visual clutter.) -}
edgename = maybe Nothing calcname $ Git.remoteName to
calcname n
| n `elem` [repoName umap fullto, hostname fullto] = Nothing
| otherwise = Just n
where
-- get the full info for the remote, to get its UUID
fullto = findfullinfo to
findfullinfo n =
case filter (same n) fullinfo of
[] -> n
(n':_) -> n'
{- Only name an edge if the name is different than the name
- that will be used for the destination node, and is
- different from its hostname. (This reduces visual clutter.) -}
edgename = maybe Nothing calcname $ Git.remoteName to
calcname n
| n `elem` [repoName umap fullto, hostname fullto] = Nothing
| otherwise = Just n
unreachable :: String -> String
unreachable = Dot.fillColor "red"
@ -165,11 +164,10 @@ same a b
| both Git.repoIsUrl && neither Git.repoIsSsh = matching show
| neither Git.repoIsSsh = matching Git.repoPath
| otherwise = False
where
matching t = t a == t b
both t = t a && t b
neither t = not (t a) && not (t b)
where
matching t = t a == t b
both t = t a && t b
neither t = not (t a) && not (t b)
{- reads the config of a remote, with progress display -}
scan :: Git.Repo -> Annex Git.Repo
@ -192,50 +190,49 @@ tryScan r
| Git.repoIsSsh r = sshscan
| Git.repoIsUrl r = return Nothing
| otherwise = safely $ Git.Config.read r
where
safely a = do
result <- liftIO (try a :: IO (Either SomeException Git.Repo))
case result of
Left _ -> return Nothing
Right r' -> return $ Just r'
pipedconfig cmd params = safely $
withHandle StdoutHandle createProcessSuccess p $
Git.Config.hRead r
where
p = proc cmd $ toCommand params
where
safely a = do
result <- liftIO (try a :: IO (Either SomeException Git.Repo))
case result of
Left _ -> return Nothing
Right r' -> return $ Just r'
pipedconfig cmd params = safely $
withHandle StdoutHandle createProcessSuccess p $
Git.Config.hRead r
where
p = proc cmd $ toCommand params
configlist =
onRemote r (pipedconfig, Nothing) "configlist" [] []
manualconfiglist = do
sshparams <- sshToRepo r [Param sshcmd]
liftIO $ pipedconfig "ssh" sshparams
where
sshcmd = cddir ++ " && " ++
"git config --null --list"
dir = Git.repoPath r
cddir
| "/~" `isPrefixOf` dir =
let (userhome, reldir) = span (/= '/') (drop 1 dir)
in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir)
| otherwise = "cd " ++ shellEscape dir
configlist = onRemote r (pipedconfig, Nothing) "configlist" [] []
manualconfiglist = do
sshparams <- sshToRepo r [Param sshcmd]
liftIO $ pipedconfig "ssh" sshparams
where
sshcmd = cddir ++ " && " ++
"git config --null --list"
dir = Git.repoPath r
cddir
| "/~" `isPrefixOf` dir =
let (userhome, reldir) = span (/= '/') (drop 1 dir)
in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir)
| otherwise = "cd " ++ shellEscape dir
-- First, try sshing and running git config manually,
-- only fall back to git-annex-shell configlist if that
-- fails.
--
-- This is done for two reasons, first I'd like this
-- subcommand to be usable on non-git-annex repos.
-- Secondly, configlist doesn't include information about
-- the remote's remotes.
sshscan = do
sshnote
v <- manualconfiglist
case v of
Nothing -> do
sshnote
configlist
ok -> return ok
-- First, try sshing and running git config manually,
-- only fall back to git-annex-shell configlist if that
-- fails.
--
-- This is done for two reasons, first I'd like this
-- subcommand to be usable on non-git-annex repos.
-- Secondly, configlist doesn't include information about
-- the remote's remotes.
sshscan = do
sshnote
v <- manualconfiglist
case v of
Nothing -> do
sshnote
configlist
ok -> return ok
sshnote = do
showAction "sshing"
showOutput
sshnote = do
showAction "sshing"
showOutput

View file

@ -31,9 +31,9 @@ start file (key, oldbackend) = do
showStart "migrate" file
next $ perform file key oldbackend newbackend
else stop
where
choosebackend Nothing = Prelude.head <$> orderedList
choosebackend (Just backend) = return backend
where
choosebackend Nothing = Prelude.head <$> orderedList
choosebackend (Just backend) = return backend
{- Checks if a key is upgradable to a newer representation. -}
{- Ideally, all keys have file size metadata. Old keys may not. -}
@ -49,10 +49,10 @@ perform file oldkey oldbackend newbackend = do
( maybe stop go =<< genkey
, stop
)
where
go newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $
next $ Command.ReKey.cleanup file oldkey newkey
genkey = do
content <- inRepo $ gitAnnexLocation oldkey
let source = KeySource { keyFilename = file, contentLocation = content }
liftM fst <$> genKey source (Just newbackend)
where
go newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $
next $ Command.ReKey.cleanup file oldkey newkey
genkey = do
content <- inRepo $ gitAnnexLocation oldkey
let source = KeySource { keyFilename = file, contentLocation = content }
liftM fst <$> genKey source (Just newbackend)

View file

@ -44,9 +44,9 @@ start to from move file (key, _) = do
(Nothing, Just dest) -> toStart dest move file key
(Just src, Nothing) -> fromStart src move file key
(_ , _) -> error "only one of --from or --to can be specified"
where
noAuto = when move $ whenM (Annex.getState Annex.auto) $ error
"--auto is not supported for move"
where
noAuto = when move $ whenM (Annex.getState Annex.auto) $ error
"--auto is not supported for move"
showMoveAction :: Bool -> FilePath -> Annex ()
showMoveAction True file = showStart "move" file
@ -98,15 +98,15 @@ toPerform dest move key file = moveLock move key $ do
warning "This could have failed because --fast is enabled."
stop
Right True -> finish False
where
finish remotechanged = do
when remotechanged $
Remote.logStatus dest key InfoPresent
if move
then do
whenM (inAnnex key) $ removeAnnex key
next $ Command.Drop.cleanupLocal key
else next $ return True
where
finish remotechanged = do
when remotechanged $
Remote.logStatus dest key InfoPresent
if move
then do
whenM (inAnnex key) $ removeAnnex key
next $ Command.Drop.cleanupLocal key
else next $ return True
{- Moves (or copies) the content of an annexed file from a remote
- to the current repository.
@ -118,35 +118,37 @@ fromStart :: Remote -> Bool -> FilePath -> Key -> CommandStart
fromStart src move file key
| move = go
| otherwise = stopUnless (not <$> inAnnex key) go
where
go = stopUnless (fromOk src key) $ do
showMoveAction move file
next $ fromPerform src move key file
where
go = stopUnless (fromOk src key) $ do
showMoveAction move file
next $ fromPerform src move key file
fromOk :: Remote -> Key -> Annex Bool
fromOk src key
| Remote.hasKeyCheap src =
either (const expensive) return =<< Remote.hasKey src key
| otherwise = expensive
where
expensive = do
u <- getUUID
remotes <- Remote.keyPossibilities key
return $ u /= Remote.uuid src && elem src remotes
where
expensive = do
u <- getUUID
remotes <- Remote.keyPossibilities key
return $ u /= Remote.uuid src && elem src remotes
fromPerform :: Remote -> Bool -> Key -> FilePath -> CommandPerform
fromPerform src move key file = moveLock move key $
ifM (inAnnex key)
( handle move True
, handle move =<< go
)
where
go = download (Remote.uuid src) key (Just file) noRetry $ do
showAction $ "from " ++ Remote.name src
getViaTmp key $ Remote.retrieveKeyFile src key (Just file)
handle _ False = stop -- failed
handle False True = next $ return True -- copy complete
handle True True = do -- finish moving
ok <- Remote.removeKey src key
next $ Command.Drop.cleanupRemote key src ok
where
go = download (Remote.uuid src) key (Just file) noRetry $ do
showAction $ "from " ++ Remote.name src
getViaTmp key $ Remote.retrieveKeyFile src key (Just file)
handle _ False = stop -- failed
handle False True = next $ return True -- copy complete
handle True True = do -- finish moving
ok <- Remote.removeKey src key
next $ Command.Drop.cleanupRemote key src ok
{- Locks a key in order for it to be moved.
- No lock is needed when a key is being copied. -}

View file

@ -25,13 +25,13 @@ seek = [withPairs start]
start :: (FilePath, String) -> CommandStart
start (file, keyname) = ifAnnexed file go stop
where
newkey = fromMaybe (error "bad key") $ file2key keyname
go (oldkey, _)
| oldkey == newkey = stop
| otherwise = do
showStart "rekey" file
next $ perform file oldkey newkey
where
newkey = fromMaybe (error "bad key") $ file2key keyname
go (oldkey, _)
| oldkey == newkey = stop
| otherwise = do
showStart "rekey" file
next $ perform file oldkey newkey
perform :: FilePath -> Key -> Key -> CommandPerform
perform file oldkey newkey = do

View file

@ -27,10 +27,10 @@ start (src:dest:[])
ifAnnexed src
(error $ "cannot used annexed file as src: " ++ src)
go
where
go = do
showStart "reinject" dest
next $ whenAnnexed (perform src) dest
where
go = do
showStart "reinject" dest
next $ whenAnnexed (perform src) dest
start _ = error "specify a src file and a dest file"
perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform
@ -43,14 +43,14 @@ perform src _dest (key, backend) = do
next $ cleanup key
, error "not reinjecting"
)
where
-- the file might be on a different filesystem,
-- so mv is used rather than simply calling
-- moveToObjectDir; disk space is also
-- checked this way.
move = getViaTmp key $ \tmp ->
liftIO $ boolSystem "mv" [File src, File tmp]
reject = const $ return "wrong file?"
where
-- the file might be on a different filesystem,
-- so mv is used rather than simply calling
-- moveToObjectDir; disk space is also
-- checked this way.
move = getViaTmp key $ \tmp ->
liftIO $ boolSystem "mv" [File src, File tmp]
reject = const $ return "wrong file?"
cleanup :: Key -> CommandCleanup
cleanup key = do

View file

@ -114,10 +114,10 @@ nojson a _ = a
showStat :: Stat -> StatState ()
showStat s = maybe noop calc =<< s
where
calc (desc, a) = do
(lift . showHeader) desc
lift . showRaw =<< a
where
calc (desc, a) = do
(lift . showHeader) desc
lift . showRaw =<< a
supported_backends :: Stat
supported_backends = stat "supported backends" $ json unwords $
@ -133,8 +133,8 @@ remote_list level = stat n $ nojson $ lift $ do
rs <- fst <$> trustPartition level us
s <- prettyPrintUUIDs n rs
return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
where
n = showTrustLevel level ++ " repositories"
where
n = showTrustLevel level ++ " repositories"
local_annex_size :: Stat
local_annex_size = stat "local annex size" $ json id $
@ -182,42 +182,42 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do
then return "none"
else return $ multiLine $
map (\(t, i) -> line uuidmap t i) $ sort ts
where
line uuidmap t i = unwords
[ showLcDirection (transferDirection t) ++ "ing"
, fromMaybe (key2file $ transferKey t) (associatedFile i)
, if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $
M.lookup (transferUUID t) uuidmap
]
where
line uuidmap t i = unwords
[ showLcDirection (transferDirection t) ++ "ing"
, fromMaybe (key2file $ transferKey t) (associatedFile i)
, if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $
M.lookup (transferUUID t) uuidmap
]
disk_size :: Stat
disk_size = stat "available local disk space" $ json id $ lift $
calcfree
<$> getDiskReserve
<*> inRepo (getDiskFree . gitAnnexDir)
where
calcfree reserve (Just have) = unwords
[ roughSize storageUnits False $ nonneg $ have - reserve
, "(+" ++ roughSize storageUnits False reserve
, "reserved)"
]
calcfree _ _ = "unknown"
nonneg x
| x >= 0 = x
| otherwise = 0
where
calcfree reserve (Just have) = unwords
[ roughSize storageUnits False $ nonneg $ have - reserve
, "(+" ++ roughSize storageUnits False reserve
, "reserved)"
]
calcfree _ _ = "unknown"
nonneg x
| x >= 0 = x
| otherwise = 0
backend_usage :: Stat
backend_usage = stat "backend usage" $ nojson $
calc
<$> (backendsKeys <$> cachedReferencedData)
<*> (backendsKeys <$> cachedPresentData)
where
calc x y = multiLine $
map (\(n, b) -> b ++ ": " ++ show n) $
reverse $ sort $ map swap $ M.toList $
M.unionWith (+) x y
where
calc x y = multiLine $
map (\(n, b) -> b ++ ": " ++ show n) $
reverse $ sort $ map swap $ M.toList $
M.unionWith (+) x y
cachedPresentData :: StatState KeyData
cachedPresentData = do
@ -249,39 +249,38 @@ foldKeys = foldl' (flip addKey) emptyKeyData
addKey :: Key -> KeyData -> KeyData
addKey key (KeyData count size unknownsize backends) =
KeyData count' size' unknownsize' backends'
where
{- All calculations strict to avoid thunks when repeatedly
- applied to many keys. -}
!count' = count + 1
!backends' = M.insertWith' (+) (keyBackendName key) 1 backends
!size' = maybe size (+ size) ks
!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
ks = keySize key
where
{- All calculations strict to avoid thunks when repeatedly
- applied to many keys. -}
!count' = count + 1
!backends' = M.insertWith' (+) (keyBackendName key) 1 backends
!size' = maybe size (+ size) ks
!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
ks = keySize key
showSizeKeys :: KeyData -> String
showSizeKeys d = total ++ missingnote
where
total = roughSize storageUnits False $ sizeKeys d
missingnote
| unknownSizeKeys d == 0 = ""
| otherwise = aside $
"+ " ++ show (unknownSizeKeys d) ++
" keys of unknown size"
where
total = roughSize storageUnits False $ sizeKeys d
missingnote
| unknownSizeKeys d == 0 = ""
| otherwise = aside $
"+ " ++ show (unknownSizeKeys d) ++
" keys of unknown size"
staleSize :: String -> (Git.Repo -> FilePath) -> Stat
staleSize label dirspec = go =<< lift (Command.Unused.staleKeys dirspec)
where
go [] = nostat
go keys = onsize =<< sum <$> keysizes keys
onsize 0 = nostat
onsize size = stat label $
json (++ aside "clean up with git-annex unused") $
return $ roughSize storageUnits False size
keysizes keys = map (fromIntegral . fileSize) <$> stats keys
stats keys = do
dir <- lift $ fromRepo dirspec
liftIO $ forM keys $ \k ->
getFileStatus (dir </> keyFile k)
where
go [] = nostat
go keys = onsize =<< sum <$> keysizes keys
onsize 0 = nostat
onsize size = stat label $
json (++ aside "clean up with git-annex unused") $
return $ roughSize storageUnits False size
keysizes keys = map (fromIntegral . fileSize) <$> stats keys
stats keys = do
dir <- lift $ fromRepo dirspec
liftIO $ forM keys $ \k -> getFileStatus (dir </> keyFile k)
aside :: String -> String
aside s = " (" ++ s ++ ")"

View file

@ -48,8 +48,8 @@ seek rs = do
, [ pushLocal branch ]
, [ pushRemote remote branch | remote <- remotes ]
]
where
nobranch = error "no branch is checked out"
where
nobranch = error "no branch is checked out"
syncBranch :: Git.Ref -> Git.Ref
syncBranch = Git.Ref.under "refs/heads/synced/"
@ -59,23 +59,23 @@ remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote
syncRemotes :: [String] -> Annex [Remote]
syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
where
pickfast = (++) <$> listed <*> (good =<< fastest <$> available)
wanted
| null rs = good =<< concat . Remote.byCost <$> available
| otherwise = listed
listed = do
l <- catMaybes <$> mapM (Remote.byName . Just) rs
let s = filter Remote.specialRemote l
unless (null s) $
error $ "cannot sync special remotes: " ++
unwords (map Types.Remote.name s)
return l
available = filter (not . Remote.specialRemote)
<$> (filterM (repoSyncable . Types.Remote.repo)
=<< Remote.enabledRemoteList)
good = filterM $ Remote.Git.repoAvail . Types.Remote.repo
fastest = fromMaybe [] . headMaybe . Remote.byCost
where
pickfast = (++) <$> listed <*> (good =<< fastest <$> available)
wanted
| null rs = good =<< concat . Remote.byCost <$> available
| otherwise = listed
listed = do
l <- catMaybes <$> mapM (Remote.byName . Just) rs
let s = filter Remote.specialRemote l
unless (null s) $
error $ "cannot sync special remotes: " ++
unwords (map Types.Remote.name s)
return l
available = filter (not . Remote.specialRemote)
<$> (filterM (repoSyncable . Types.Remote.repo)
=<< Remote.enabledRemoteList)
good = filterM $ Remote.Git.repoAvail . Types.Remote.repo
fastest = fromMaybe [] . headMaybe . Remote.byCost
commit :: CommandStart
commit = do
@ -90,16 +90,16 @@ commit = do
mergeLocal :: Git.Ref -> CommandStart
mergeLocal branch = go =<< needmerge
where
syncbranch = syncBranch branch
needmerge = do
unlessM (inRepo $ Git.Ref.exists syncbranch) $
inRepo $ updateBranch syncbranch
inRepo $ Git.Branch.changed branch syncbranch
go False = stop
go True = do
showStart "merge" $ Git.Ref.describe syncbranch
next $ next $ mergeFrom syncbranch
where
syncbranch = syncBranch branch
needmerge = do
unlessM (inRepo $ Git.Ref.exists syncbranch) $
inRepo $ updateBranch syncbranch
inRepo $ Git.Branch.changed branch syncbranch
go False = stop
go True = do
showStart "merge" $ Git.Ref.describe syncbranch
next $ next $ mergeFrom syncbranch
pushLocal :: Git.Ref -> CommandStart
pushLocal branch = do
@ -109,11 +109,11 @@ pushLocal branch = do
updateBranch :: Git.Ref -> Git.Repo -> IO ()
updateBranch syncbranch g =
unlessM go $ error $ "failed to update " ++ show syncbranch
where
go = Git.Command.runBool "branch"
[ Param "-f"
, Param $ show $ Git.Ref.base syncbranch
] g
where
go = Git.Command.runBool "branch"
[ Param "-f"
, Param $ show $ Git.Ref.base syncbranch
] g
pullRemote :: Remote -> Git.Ref -> CommandStart
pullRemote remote branch = do
@ -122,9 +122,9 @@ pullRemote remote branch = do
showOutput
stopUnless fetch $
next $ mergeRemote remote (Just branch)
where
fetch = inRepo $ Git.Command.runBool "fetch"
[Param $ Remote.name remote]
where
fetch = inRepo $ Git.Command.runBool "fetch"
[Param $ Remote.name remote]
{- The remote probably has both a master and a synced/master branch.
- Which to merge from? Well, the master has whatever latest changes
@ -136,22 +136,22 @@ mergeRemote remote b = case b of
branch <- inRepo Git.Branch.currentUnsafe
all id <$> (mapM merge $ branchlist branch)
Just _ -> all id <$> (mapM merge =<< tomerge (branchlist b))
where
merge = mergeFrom . remoteBranch remote
tomerge branches = filterM (changed remote) branches
branchlist Nothing = []
branchlist (Just branch) = [branch, syncBranch branch]
where
merge = mergeFrom . remoteBranch remote
tomerge branches = filterM (changed remote) branches
branchlist Nothing = []
branchlist (Just branch) = [branch, syncBranch branch]
pushRemote :: Remote -> Git.Ref -> CommandStart
pushRemote remote branch = go =<< needpush
where
needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
go False = stop
go True = do
showStart "push" (Remote.name remote)
next $ next $ do
showOutput
inRepo $ pushBranch remote branch
where
needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name]
go False = stop
go True = do
showStart "push" (Remote.name remote)
next $ next $ do
showOutput
inRepo $ pushBranch remote branch
pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool
pushBranch remote branch g =
@ -160,12 +160,12 @@ pushBranch remote branch g =
, Param $ refspec Annex.Branch.name
, Param $ refspec branch
] g
where
refspec b = concat
[ show $ Git.Ref.base b
, ":"
, show $ Git.Ref.base $ syncBranch b
]
where
refspec b = concat
[ show $ Git.Ref.base b
, ":"
, show $ Git.Ref.base $ syncBranch b
]
mergeAnnex :: CommandStart
mergeAnnex = do
@ -213,37 +213,37 @@ resolveMerge' u
withKey LsFiles.valUs $ \keyUs ->
withKey LsFiles.valThem $ \keyThem -> go keyUs keyThem
| otherwise = return False
where
go keyUs keyThem
| keyUs == keyThem = do
makelink keyUs
return True
| otherwise = do
liftIO $ nukeFile file
Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file]
makelink keyUs
makelink keyThem
return True
file = LsFiles.unmergedFile u
issymlink select = any (select (LsFiles.unmergedBlobType u) ==)
[Just SymlinkBlob, Nothing]
makelink (Just key) = do
let dest = mergeFile file key
l <- calcGitLink dest key
liftIO $ do
nukeFile dest
createSymbolicLink l dest
Annex.Queue.addCommand "add" [Param "--force", Param "--"] [dest]
makelink _ = noop
withKey select a = do
let msha = select $ LsFiles.unmergedSha u
case msha of
Nothing -> a Nothing
Just sha -> do
key <- fileKey . takeFileName
. encodeW8 . L.unpack
<$> catObject sha
maybe (return False) (a . Just) key
where
go keyUs keyThem
| keyUs == keyThem = do
makelink keyUs
return True
| otherwise = do
liftIO $ nukeFile file
Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file]
makelink keyUs
makelink keyThem
return True
file = LsFiles.unmergedFile u
issymlink select = any (select (LsFiles.unmergedBlobType u) ==)
[Just SymlinkBlob, Nothing]
makelink (Just key) = do
let dest = mergeFile file key
l <- calcGitLink dest key
liftIO $ do
nukeFile dest
createSymbolicLink l dest
Annex.Queue.addCommand "add" [Param "--force", Param "--"] [dest]
makelink _ = noop
withKey select a = do
let msha = select $ LsFiles.unmergedSha u
case msha of
Nothing -> a Nothing
Just sha -> do
key <- fileKey . takeFileName
. encodeW8 . L.unpack
<$> catObject sha
maybe (return False) (a . Just) key
{- The filename to use when resolving a conflicted merge of a file,
- that points to a key.
@ -262,13 +262,13 @@ mergeFile :: FilePath -> Key -> FilePath
mergeFile file key
| doubleconflict = go $ key2file key
| otherwise = go $ shortHash $ key2file key
where
varmarker = ".variant-"
doubleconflict = varmarker `isSuffixOf` (dropExtension file)
go v = takeDirectory file
</> dropExtension (takeFileName file)
++ varmarker ++ v
++ takeExtension file
where
varmarker = ".variant-"
doubleconflict = varmarker `isSuffixOf` (dropExtension file)
go v = takeDirectory file
</> dropExtension (takeFileName file)
++ varmarker ++ v
++ takeExtension file
shortHash :: String -> String
shortHash = take 4 . md5s . md5FilePath

View file

@ -30,10 +30,10 @@ check = do
cwd <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $
error "can only run uninit from the top of the git repository"
where
current_branch = Git.Ref . Prelude.head . lines <$> revhead
revhead = inRepo $ Git.Command.pipeReadStrict
[Params "rev-parse --abbrev-ref HEAD"]
where
current_branch = Git.Ref . Prelude.head . lines <$> revhead
revhead = inRepo $ Git.Command.pipeReadStrict
[Params "rev-parse --abbrev-ref HEAD"]
seek :: [CommandSeek]
seek = [

View file

@ -17,8 +17,8 @@ def =
[ c "unlock" "unlock files for modification"
, c "edit" "same as unlock"
]
where
c n = command n paramPaths seek
where
c n = command n paramPaths seek
seek :: [CommandSeek]
seek = [withFilesInGit $ whenAnnexed start]

View file

@ -64,27 +64,26 @@ checkUnused = chain 0
, check "bad" staleBadMsg $ staleKeysPrune gitAnnexBadDir
, check "tmp" staleTmpMsg $ staleKeysPrune gitAnnexTmpDir
]
where
findunused True = do
showNote "fast mode enabled; only finding stale files"
return []
findunused False = do
showAction "checking for unused data"
excludeReferenced =<< getKeysPresent
chain _ [] = next $ return True
chain v (a:as) = do
v' <- a v
chain v' as
where
findunused True = do
showNote "fast mode enabled; only finding stale files"
return []
findunused False = do
showAction "checking for unused data"
excludeReferenced =<< getKeysPresent
chain _ [] = next $ return True
chain v (a:as) = do
v' <- a v
chain v' as
checkRemoteUnused :: String -> CommandPerform
checkRemoteUnused name = go =<< fromJust <$> Remote.byName (Just name)
where
go r = do
showAction "checking for unused data"
_ <- check "" (remoteUnusedMsg r) (remoteunused r) 0
next $ return True
remoteunused r =
excludeReferenced <=< loggedKeysFor $ Remote.uuid r
where
go r = do
showAction "checking for unused data"
_ <- check "" (remoteUnusedMsg r) (remoteunused r) 0
next $ return True
remoteunused r = excludeReferenced <=< loggedKeysFor $ Remote.uuid r
check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int
check file msg a c = do
@ -100,9 +99,9 @@ number n (x:xs) = (n+1, x) : number (n+1) xs
table :: [(Int, Key)] -> [String]
table l = " NUMBER KEY" : map cols l
where
cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k
pad n s = s ++ replicate (n - length s) ' '
where
cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k
pad n s = s ++ replicate (n - length s) ' '
staleTmpMsg :: [(Int, Key)] -> String
staleTmpMsg t = unlines $
@ -129,8 +128,8 @@ remoteUnusedMsg :: Remote -> [(Int, Key)] -> String
remoteUnusedMsg r u = unusedMsg' u
["Some annexed data on " ++ name ++ " is not used by any files:"]
[dropMsg $ Just r]
where
name = Remote.name r
where
name = Remote.name r
dropMsg :: Maybe Remote -> String
dropMsg Nothing = dropMsg' ""
@ -159,11 +158,11 @@ dropMsg' s = "\nTo remove unwanted data: git-annex dropunused" ++ s ++ " NUMBER\
-}
excludeReferenced :: [Key] -> Annex [Key]
excludeReferenced ks = runfilter firstlevel ks >>= runfilter secondlevel
where
runfilter _ [] = return [] -- optimisation
runfilter a l = bloomFilter show l <$> genBloomFilter show a
firstlevel = withKeysReferencedM
secondlevel = withKeysReferencedInGit
where
runfilter _ [] = return [] -- optimisation
runfilter a l = bloomFilter show l <$> genBloomFilter show a
firstlevel = withKeysReferencedM
secondlevel = withKeysReferencedInGit
{- Finds items in the first, smaller list, that are not
- present in the second, larger list.
@ -174,8 +173,8 @@ excludeReferenced ks = runfilter firstlevel ks >>= runfilter secondlevel
exclude :: Ord a => [a] -> [a] -> [a]
exclude [] _ = [] -- optimisation
exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
where
remove a b = foldl (flip S.delete) b a
where
remove a b = foldl (flip S.delete) b a
{- A bloom filter capable of holding half a million keys with a
- false positive rate of 1 in 1000 uses around 8 mb of memory,
@ -208,8 +207,8 @@ genBloomFilter convert populate = do
bloom <- lift $ newMB (cheapHashes numhashes) numbits
_ <- populate $ \v -> lift $ insertMB bloom (convert v)
lift $ unsafeFreezeMB bloom
where
lift = liftIO . stToIO
where
lift = liftIO . stToIO
bloomFilter :: Hashable t => (v -> t) -> [v] -> Bloom t -> [v]
bloomFilter convert l bloom = filter (\k -> convert k `notElemB` bloom) l
@ -218,14 +217,14 @@ bloomFilter convert l bloom = filter (\k -> convert k `notElemB` bloom) l
- symlinks in the git repo. -}
withKeysReferenced :: v -> (Key -> v -> v) -> Annex v
withKeysReferenced initial a = withKeysReferenced' initial folda
where
folda k v = return $ a k v
where
folda k v = return $ a k v
{- Runs an action on each referenced key in the git repo. -}
withKeysReferencedM :: (Key -> Annex ()) -> Annex ()
withKeysReferencedM a = withKeysReferenced' () calla
where
calla k _ = a k
where
calla k _ = a k
withKeysReferenced' :: v -> (Key -> v -> Annex v) -> Annex v
withKeysReferenced' initial a = do
@ -233,54 +232,53 @@ withKeysReferenced' initial a = do
r <- go initial files
liftIO $ void clean
return r
where
getfiles = ifM isBareRepo
( return ([], return True)
, do
top <- fromRepo Git.repoPath
inRepo $ LsFiles.inRepo [top]
)
go v [] = return v
go v (f:fs) = do
x <- Backend.lookupFile f
case x of
Nothing -> go v fs
Just (k, _) -> do
!v' <- a k v
go v' fs
where
getfiles = ifM isBareRepo
( return ([], return True)
, do
top <- fromRepo Git.repoPath
inRepo $ LsFiles.inRepo [top]
)
go v [] = return v
go v (f:fs) = do
x <- Backend.lookupFile f
case x of
Nothing -> go v fs
Just (k, _) -> do
!v' <- a k v
go v' fs
withKeysReferencedInGit :: (Key -> Annex ()) -> Annex ()
withKeysReferencedInGit a = do
rs <- relevantrefs <$> showref
forM_ rs (withKeysReferencedInGitRef a)
where
showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"]
relevantrefs = map (Git.Ref . snd) .
nubBy uniqref .
filter ourbranches .
map (separate (== ' ')) . lines
uniqref (x, _) (y, _) = x == y
ourbranchend = '/' : show Annex.Branch.name
ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
&& not ("refs/synced/" `isPrefixOf` b)
where
showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"]
relevantrefs = map (Git.Ref . snd) .
nubBy uniqref .
filter ourbranches .
map (separate (== ' ')) . lines
uniqref (x, _) (y, _) = x == y
ourbranchend = '/' : show Annex.Branch.name
ourbranches (_, b) = not (ourbranchend `isSuffixOf` b)
&& not ("refs/synced/" `isPrefixOf` b)
withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex ()
withKeysReferencedInGitRef a ref = do
showAction $ "checking " ++ Git.Ref.describe ref
go <=< inRepo $ LsTree.lsTree ref
where
go [] = noop
go (l:ls)
| isSymLink (LsTree.mode l) = do
content <- encodeW8 . L.unpack
<$> catFile ref (LsTree.file l)
case fileKey (takeFileName content) of
Nothing -> go ls
Just k -> do
a k
go ls
| otherwise = go ls
where
go [] = noop
go (l:ls)
| isSymLink (LsTree.mode l) = do
content <- encodeW8 . L.unpack
<$> catFile ref (LsTree.file l)
case fileKey (takeFileName content) of
Nothing -> go ls
Just k -> do
a k
go ls
| otherwise = go ls
{- Looks in the specified directory for bad/tmp keys, and returns a list
- of those that might still have value, or might be stale and removable.

View file

@ -29,8 +29,8 @@ start = do
putStrLn $ "supported repository versions: " ++ vs supportedVersions
putStrLn $ "upgrade supported from repository versions: " ++ vs upgradableVersions
stop
where
vs = join " "
where
vs = join " "
showPackageVersion :: IO ()
showPackageVersion = putStrLn $ "git-annex version: " ++ SysConfig.packageversion

View file

@ -75,119 +75,116 @@ setCfg curcfg newcfg = do
diffCfg :: Cfg -> Cfg -> (TrustMap, M.Map UUID (S.Set Group), M.Map UUID String)
diffCfg curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap, diff cfgPreferredContentMap)
where
diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)
(f newcfg) (f curcfg)
where
diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x)
(f newcfg) (f curcfg)
genCfg :: Cfg -> M.Map UUID String -> String
genCfg cfg descs = unlines $ concat [intro, trust, groups, preferredcontent]
where
intro =
[ com "git-annex configuration"
, com ""
, com "Changes saved to this file will be recorded in the git-annex branch."
, com ""
, com "Lines in this file have the format:"
, com " setting uuid = value"
]
where
intro =
[ com "git-annex configuration"
, com ""
, com "Changes saved to this file will be recorded in the git-annex branch."
, com ""
, com "Lines in this file have the format:"
, com " setting uuid = value"
]
trust = settings cfgTrustMap
[ ""
, com "Repository trust configuration"
, com "(Valid trust levels: " ++
unwords (map showTrustLevel [Trusted .. DeadTrusted]) ++
")"
]
(\(t, u) -> line "trust" u $ showTrustLevel t)
(\u -> lcom $ line "trust" u $ showTrustLevel SemiTrusted)
trust = settings cfgTrustMap
[ ""
, com "Repository trust configuration"
, com "(Valid trust levels: " ++
unwords (map showTrustLevel [Trusted .. DeadTrusted]) ++
")"
]
(\(t, u) -> line "trust" u $ showTrustLevel t)
(\u -> lcom $ line "trust" u $ showTrustLevel SemiTrusted)
groups = settings cfgGroupMap
[ ""
, com "Repository groups"
, com "(Separate group names with spaces)"
]
(\(s, u) -> line "group" u $ unwords $ S.toList s)
(\u -> lcom $ line "group" u "")
groups = settings cfgGroupMap
[ ""
, com "Repository groups"
, com "(Separate group names with spaces)"
]
(\(s, u) -> line "group" u $ unwords $ S.toList s)
(\u -> lcom $ line "group" u "")
preferredcontent = settings cfgPreferredContentMap
[ ""
, com "Repository preferred contents"
]
(\(s, u) -> line "preferred-content" u s)
(\u -> line "preferred-content" u "")
preferredcontent = settings cfgPreferredContentMap
[ ""
, com "Repository preferred contents"
]
(\(s, u) -> line "preferred-content" u s)
(\u -> line "preferred-content" u "")
settings field desc showvals showdefaults = concat
[ desc
, concatMap showvals $
sort $ map swap $ M.toList $ field cfg
, concatMap (\u -> lcom $ showdefaults u) $
missing field
]
settings field desc showvals showdefaults = concat
[ desc
, concatMap showvals $ sort $ map swap $ M.toList $ field cfg
, concatMap (\u -> lcom $ showdefaults u) $ missing field
]
line setting u value =
[ com $ "(for " ++ (fromMaybe "" $ M.lookup u descs) ++ ")"
, unwords [setting, fromUUID u, "=", value]
]
lcom = map (\l -> if "#" `isPrefixOf` l then l else "#" ++ l)
missing field = S.toList $ M.keysSet descs `S.difference` M.keysSet (field cfg)
line setting u value =
[ com $ "(for " ++ (fromMaybe "" $ M.lookup u descs) ++ ")"
, unwords [setting, fromUUID u, "=", value]
]
lcom = map (\l -> if "#" `isPrefixOf` l then l else "#" ++ l)
missing field = S.toList $ M.keysSet descs `S.difference` M.keysSet (field cfg)
{- If there's a parse error, returns a new version of the file,
- with the problem lines noted. -}
parseCfg :: Cfg -> String -> Either String Cfg
parseCfg curcfg = go [] curcfg . lines
where
go c cfg []
| null (catMaybes $ map fst c) = Right cfg
| otherwise = Left $ unlines $
badheader ++ concatMap showerr (reverse c)
go c cfg (l:ls) = case parse (dropWhile isSpace l) cfg of
Left msg -> go ((Just msg, l):c) cfg ls
Right cfg' -> go ((Nothing, l):c) cfg' ls
where
go c cfg []
| null (catMaybes $ map fst c) = Right cfg
| otherwise = Left $ unlines $
badheader ++ concatMap showerr (reverse c)
go c cfg (l:ls) = case parse (dropWhile isSpace l) cfg of
Left msg -> go ((Just msg, l):c) cfg ls
Right cfg' -> go ((Nothing, l):c) cfg' ls
parse l cfg
| null l = Right cfg
| "#" `isPrefixOf` l = Right cfg
| null setting || null u = Left "missing repository uuid"
| otherwise = handle cfg (toUUID u) setting value'
where
(setting, rest) = separate isSpace l
(r, value) = separate (== '=') rest
value' = trimspace value
u = reverse $ trimspace $
reverse $ trimspace r
trimspace = dropWhile isSpace
parse l cfg
| null l = Right cfg
| "#" `isPrefixOf` l = Right cfg
| null setting || null u = Left "missing repository uuid"
| otherwise = handle cfg (toUUID u) setting value'
where
(setting, rest) = separate isSpace l
(r, value) = separate (== '=') rest
value' = trimspace value
u = reverse $ trimspace $ reverse $ trimspace r
trimspace = dropWhile isSpace
handle cfg u setting value
| setting == "trust" = case readTrustLevel value of
Nothing -> badval "trust value" value
Just t ->
let m = M.insert u t (cfgTrustMap cfg)
in Right $ cfg { cfgTrustMap = m }
| setting == "group" =
let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg)
in Right $ cfg { cfgGroupMap = m }
| setting == "preferred-content" =
case checkPreferredContentExpression value of
Just e -> Left e
Nothing ->
let m = M.insert u value (cfgPreferredContentMap cfg)
in Right $ cfg { cfgPreferredContentMap = m }
| otherwise = badval "setting" setting
handle cfg u setting value
| setting == "trust" = case readTrustLevel value of
Nothing -> badval "trust value" value
Just t ->
let m = M.insert u t (cfgTrustMap cfg)
in Right $ cfg { cfgTrustMap = m }
| setting == "group" =
let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg)
in Right $ cfg { cfgGroupMap = m }
| setting == "preferred-content" =
case checkPreferredContentExpression value of
Just e -> Left e
Nothing ->
let m = M.insert u value (cfgPreferredContentMap cfg)
in Right $ cfg { cfgPreferredContentMap = m }
| otherwise = badval "setting" setting
showerr (Just msg, l) = [parseerr ++ msg, l]
showerr (Nothing, l)
-- filter out the header and parse error lines
-- from any previous parse failure
| any (`isPrefixOf` l) (parseerr:badheader) = []
| otherwise = [l]
showerr (Just msg, l) = [parseerr ++ msg, l]
showerr (Nothing, l)
-- filter out the header and parse error lines
-- from any previous parse failure
| any (`isPrefixOf` l) (parseerr:badheader) = []
| otherwise = [l]
badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\""
badheader =
[ com "There was a problem parsing your input."
, com "Search for \"Parse error\" to find the bad lines."
, com "Either fix the bad lines, or delete them (to discard your changes)."
]
parseerr = com "Parse error in next line: "
badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\""
badheader =
[ com "There was a problem parsing your input."
, com "Search for \"Parse error\" to find the bad lines."
, com "Either fix the bad lines, or delete them (to discard your changes)."
]
parseerr = com "Parse error in next line: "
com :: String -> String
com s = "# " ++ s

View file

@ -43,24 +43,24 @@ start' allowauto = notBareRepo $ do
liftIO $ ensureInstalled
ifM isInitialized ( go , auto )
stop
where
go = do
browser <- fromRepo webBrowser
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
ifM (checkpid <&&> checkshim f)
( liftIO $ openBrowser browser f
, startDaemon True True $ Just $
const $ openBrowser browser
)
auto
| allowauto = liftIO startNoRepo
| otherwise = do
d <- liftIO getCurrentDirectory
error $ "no git repository in " ++ d
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
liftIO $ isJust <$> checkDaemon pidfile
checkshim f = liftIO $ doesFileExist f
where
go = do
browser <- fromRepo webBrowser
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
ifM (checkpid <&&> checkshim f)
( liftIO $ openBrowser browser f
, startDaemon True True $ Just $
const $ openBrowser browser
)
auto
| allowauto = liftIO startNoRepo
| otherwise = do
d <- liftIO getCurrentDirectory
error $ "no git repository in " ++ d
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
liftIO $ isJust <$> checkDaemon pidfile
checkshim f = liftIO $ doesFileExist f
{- When run without a repo, see if there is an autoStartFile,
- and if so, start the first available listed repository.
@ -111,35 +111,35 @@ firstRun = do
webAppThread d urlrenderer True
(callback signaler)
(callback mainthread)
where
signaler v = do
putMVar v ""
takeMVar v
mainthread v _url htmlshim = do
browser <- maybe Nothing webBrowser <$> Git.Config.global
openBrowser browser htmlshim
where
signaler v = do
putMVar v ""
takeMVar v
mainthread v _url htmlshim = do
browser <- maybe Nothing webBrowser <$> Git.Config.global
openBrowser browser htmlshim
_wait <- takeMVar v
_wait <- takeMVar v
state <- Annex.new =<< Git.CurrentRepo.get
Annex.eval state $ do
dummydaemonize
startAssistant True id $ Just $ sendurlback v
sendurlback v url _htmlshim = putMVar v url
{- Set up the pid file in the new repo. -}
dummydaemonize =
liftIO . lockPidFile =<< fromRepo gitAnnexPidFile
state <- Annex.new =<< Git.CurrentRepo.get
Annex.eval state $ do
dummydaemonize
startAssistant True id $ Just $ sendurlback v
sendurlback v url _htmlshim = putMVar v url
{- Set up the pid file in the new repo. -}
dummydaemonize = liftIO . lockPidFile =<< fromRepo gitAnnexPidFile
openBrowser :: Maybe FilePath -> FilePath -> IO ()
openBrowser cmd htmlshim = go $ maybe runBrowser runCustomBrowser cmd
where
url = fileUrl htmlshim
go a = do
putStrLn ""
putStrLn $ "Launching web browser on " ++ url
unlessM (a url) $
error $ "failed to start web browser"
runCustomBrowser c u = boolSystem c [Param u]
where
url = fileUrl htmlshim
go a = do
putStrLn ""
putStrLn $ "Launching web browser on " ++ url
unlessM (a url) $
error $ "failed to start web browser"
runCustomBrowser c u = boolSystem c [Param u]
{- web.browser is a generic git config setting for a web browser program -}
webBrowser :: Git.Repo -> Maybe FilePath

View file

@ -40,15 +40,15 @@ perform remotemap key = do
forM_ (mapMaybe (`M.lookup` remotemap) locations) $
performRemote key
if null safelocations then stop else next $ return True
where
copiesplural 1 = "copy"
copiesplural _ = "copies"
untrustedheader = "The following untrusted locations may also have copies:\n"
where
copiesplural 1 = "copy"
copiesplural _ = "copies"
untrustedheader = "The following untrusted locations may also have copies:\n"
performRemote :: Key -> Remote -> Annex ()
performRemote key remote = maybe noop go $ whereisKey remote
where
go a = do
ls <- a key
unless (null ls) $ showLongNote $ unlines $
map (\l -> name remote ++ ": " ++ l) ls
where
go a = do
ls <- a key
unless (null ls) $ showLongNote $ unlines $
map (\l -> name remote ++ ": " ++ l) ls