where indentation
This commit is contained in:
parent
f0dd6d00d1
commit
ebd576ebcb
30 changed files with 804 additions and 812 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 "?" "_"
|
||||
|
|
|
@ -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"]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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.)"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
160
Command/Fsck.hs
160
Command/Fsck.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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") .
|
||||
|
|
159
Command/Map.hs
159
Command/Map.hs
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ++ ")"
|
||||
|
|
188
Command/Sync.hs
188
Command/Sync.hs
|
@ -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
|
||||
|
|
|
@ -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 = [
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
189
Command/Vicfg.hs
189
Command/Vicfg.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue