all commands building except for assistant

also, changed ConfigValue to a newtype, and moved it into Git.Config.
This commit is contained in:
Joey Hess 2019-12-05 14:36:43 -04:00
parent 718fa83da6
commit c20f4704a7
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
40 changed files with 187 additions and 174 deletions

View file

@ -156,7 +156,7 @@ startRemote r o file uri sz = do
performRemote r o uri file' sz
performRemote :: Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform
performRemote r o uri file sz = ifAnnexed file adduri geturi
performRemote r o uri file sz = ifAnnexed (toRawFilePath file) adduri geturi
where
loguri = setDownloader uri OtherDownloader
adduri = addUrlChecked o loguri file (Remote.uuid r) checkexistssize
@ -180,7 +180,7 @@ downloadRemoteFile r o uri file sz = checkCanAdd file $ do
setTempUrl urlkey loguri
let downloader = \dest p -> fst
<$> Remote.retrieveKeyFile r urlkey
(AssociatedFile (Just file)) dest p
(AssociatedFile (Just (toRawFilePath file))) dest p
ret <- downloadWith downloader urlkey (Remote.uuid r) loguri file
removeTempUrl urlkey
return ret
@ -212,7 +212,7 @@ startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring
performWeb o urlstring file urlinfo
performWeb :: AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform
performWeb o url file urlinfo = ifAnnexed file addurl geturl
performWeb o url file urlinfo = ifAnnexed (toRawFilePath file) addurl geturl
where
geturl = next $ isJust <$> addUrlFile (downloadOptions o) url urlinfo file
addurl = addUrlChecked o url file webUUID $ \k ->
@ -258,7 +258,7 @@ addUrlFile o url urlinfo file =
downloadWeb :: DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
downloadWeb o url urlinfo file =
go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file))
go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just (toRawFilePath file)))
where
urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing
downloader f p = downloadUrl urlkey p [url] f
@ -278,7 +278,7 @@ downloadWeb o url urlinfo file =
-- first, and check if that is already an annexed file,
-- to avoid unnecessary work in that case.
| otherwise = youtubeDlFileNameHtmlOnly url >>= \case
Right dest -> ifAnnexed dest
Right dest -> ifAnnexed (toRawFilePath dest)
(alreadyannexed dest)
(dl dest)
Left _ -> normalfinish tmp
@ -345,7 +345,7 @@ downloadWith :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLStr
downloadWith downloader dummykey u url file =
go =<< downloadWith' downloader dummykey u url afile
where
afile = AssociatedFile (Just file)
afile = AssociatedFile (Just (toRawFilePath file))
go Nothing = return Nothing
go (Just tmp) = finishDownloadWith tmp u url file
@ -401,7 +401,7 @@ addWorkTree u url file key mtmp = case mtmp of
-- than the work tree file.
liftIO $ renameFile file tmp
go
else void $ Command.Add.addSmall file
else void $ Command.Add.addSmall (toRawFilePath file)
where
go = do
maybeShowJSON $ JSONChunk [("key", serializeKey key)]

View file

@ -10,6 +10,9 @@ module Command.Config where
import Command
import Logs.Config
import Config
import Git.Types (ConfigKey(..), fromConfigValue)
import qualified Data.ByteString as S
cmd :: Command
cmd = noMessages $ command "config" SectionSetup
@ -17,9 +20,9 @@ cmd = noMessages $ command "config" SectionSetup
paramNothing (seek <$$> optParser)
data Action
= SetConfig ConfigName ConfigValue
| GetConfig ConfigName
| UnsetConfig ConfigName
= SetConfig ConfigKey ConfigValue
| GetConfig ConfigKey
| UnsetConfig ConfigKey
type Name = String
type Value = String
@ -48,19 +51,19 @@ optParser _ = setconfig <|> getconfig <|> unsetconfig
)
seek :: Action -> CommandSeek
seek (SetConfig name val) = commandAction $
startingUsualMessages name (ActionItemOther (Just val)) $ do
setGlobalConfig name val
setConfig (ConfigKey name) val
seek (SetConfig ck@(ConfigKey name) val) = commandAction $
startingUsualMessages (decodeBS' name) (ActionItemOther (Just (fromConfigValue val))) $ do
setGlobalConfig ck val
setConfig ck (fromConfigValue val)
next $ return True
seek (UnsetConfig name) = commandAction $
startingUsualMessages name (ActionItemOther (Just "unset")) $do
unsetGlobalConfig name
unsetConfig (ConfigKey name)
seek (UnsetConfig ck@(ConfigKey name)) = commandAction $
startingUsualMessages (decodeBS' name) (ActionItemOther (Just "unset")) $do
unsetGlobalConfig ck
unsetConfig ck
next $ return True
seek (GetConfig name) = commandAction $
seek (GetConfig ck) = commandAction $
startingCustomOutput (ActionItemOther Nothing) $ do
getGlobalConfig name >>= \case
getGlobalConfig ck >>= \case
Nothing -> return ()
Just v -> liftIO $ putStrLn v
Just (ConfigValue v) -> liftIO $ S.putStrLn v
next $ return True

View file

@ -30,7 +30,7 @@ start :: CommandStart
start = do
u <- findOrGenUUID
showConfig configkeyUUID $ fromUUID u
showConfig coreGCryptId . decodeBS'
showConfig coreGCryptId . fromConfigValue
=<< fromRepo (Git.Config.get coreGCryptId mempty)
stop
where

View file

@ -85,9 +85,9 @@ fixupReq req@(Req {}) =
check rOldFile rOldMode (\r f -> r { rOldFile = f }) req
>>= check rNewFile rNewMode (\r f -> r { rNewFile = f })
where
check getfile getmode setfile r = case readTreeItemType (getmode r) of
check getfile getmode setfile r = case readTreeItemType (encodeBS' (getmode r)) of
Just TreeSymlink -> do
v <- getAnnexLinkTarget' (getfile r) False
v <- getAnnexLinkTarget' (toRawFilePath (getfile r)) False
case parseLinkTargetOrPointer =<< v of
Nothing -> return r
Just k -> withObjectLoc k (pure . setfile r)

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Command.FuzzTest where
import Command
@ -13,6 +15,7 @@ import qualified Git.Config
import Config
import Utility.ThreadScheduler
import Utility.DiskFree
import Git.Types (fromConfigKey)
import Data.Time.Clock
import System.Random (getStdRandom, random, randomR)
@ -32,25 +35,23 @@ start :: CommandStart
start = do
guardTest
logf <- fromRepo gitAnnexFuzzTestLogFile
showStart "fuzztest" logf
showStart "fuzztest" (toRawFilePath logf)
logh <- liftIO $ openFile logf WriteMode
void $ forever $ fuzz logh
stop
guardTest :: Annex ()
guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
guardTest = unlessM (fromMaybe False . Git.Config.isTrue' <$> getConfig key mempty) $
giveup $ unlines
[ "Running fuzz tests *writes* to and *deletes* files in"
, "this repository, and pushes those changes to other"
, "repositories! This is a developer tool, not something"
, "to play with."
, ""
, "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!"
, "Refusing to run fuzz tests, since " ++ fromConfigKey key ++ " is not set!"
]
where
key = annexConfig "eat-my-repository"
(ConfigKey keyname) = key
fuzz :: Handle -> Annex ()
fuzz logh = do

View file

@ -67,7 +67,7 @@ seek o = do
getFeed :: ImportFeedOptions -> Cache -> URLString -> CommandSeek
getFeed opts cache url = do
showStart "importfeed" url
showStart' "importfeed" (Just url)
downloadFeed url >>= \case
Nothing -> showEndResult =<< feedProblem url
"downloading the feed failed"
@ -222,7 +222,7 @@ performDownload opts cache todownload = case location todownload of
case dest of
Nothing -> return True
Just f -> do
showStart "addurl" url
showStart' "addurl" (Just url)
ks <- getter f
if null ks
then do
@ -244,7 +244,7 @@ performDownload opts cache todownload = case location todownload of
- to be re-downloaded. -}
makeunique url n file = ifM alreadyexists
( ifM forced
( ifAnnexed f checksameurl tryanother
( ifAnnexed (toRawFilePath f) checksameurl tryanother
, tryanother
)
, return $ Just f

View file

@ -152,7 +152,7 @@ itemInfo o p = ifM (isdir p)
v' <- Remote.nameToUUID' p
case v' of
Right u -> uuidInfo o u
Left _ -> ifAnnexed p
Left _ -> ifAnnexed (toRawFilePath p)
(fileInfo o p)
(treeishInfo o p)
)
@ -161,7 +161,7 @@ itemInfo o p = ifM (isdir p)
noInfo :: String -> Annex ()
noInfo s = do
showStart "info" s
showStart "info" (encodeBS' s)
showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid"
showEndFail
@ -311,8 +311,8 @@ showStat :: Stat -> StatState ()
showStat s = maybe noop calc =<< s
where
calc (desc, a) = do
(lift . showHeader) desc
lift . showRaw =<< a
(lift . showHeader . encodeBS') desc
lift . showRaw . encodeBS' =<< a
repo_list :: TrustLevel -> Stat
repo_list level = stat n $ nojson $ lift $ do
@ -435,7 +435,7 @@ transfer_list = stat desc $ nojson $ lift $ do
desc = "transfers in progress"
line uuidmap t i = unwords
[ formatDirection (transferDirection t) ++ "ing"
, actionItemDesc $ mkActionItem
, fromRawFilePath $ actionItemDesc $ mkActionItem
(transferKey t, associatedFile i)
, if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $
@ -444,7 +444,7 @@ transfer_list = stat desc $ nojson $ lift $ do
jsonify t i = object $ map (\(k, v) -> (packString k, v)) $
[ ("transfer", toJSON' (formatDirection (transferDirection t)))
, ("key", toJSON' (transferKey t))
, ("file", toJSON' afile)
, ("file", toJSON' (fromRawFilePath <$> afile))
, ("remote", toJSON' (fromUUID (transferUUID t) :: String))
]
where
@ -566,7 +566,7 @@ getDirStatInfo o dir = do
where
initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty)
update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) =
ifM (matcher $ MatchingFile $ FileInfo file file)
ifM (matcher $ MatchingFile $ FileInfo file' file')
( do
!presentdata' <- ifM (inAnnex key)
( return $ addKey key presentdata
@ -577,11 +577,13 @@ getDirStatInfo o dir = do
then return (numcopiesstats, repodata)
else do
locs <- Remote.keyLocations key
nc <- updateNumCopiesStats file numcopiesstats locs
nc <- updateNumCopiesStats file' numcopiesstats locs
return (nc, updateRepoData key locs repodata)
return $! (presentdata', referenceddata', numcopiesstats', repodata')
, return vs
)
where
file' = fromRawFilePath file
getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo)
getTreeStatInfo o r = do

View file

@ -42,7 +42,7 @@ seek o = do
(commandAction . (whenAnnexed (start s)))
=<< workTreeItems (inprogressFiles o)
start :: S.Set Key -> FilePath -> Key -> CommandStart
start :: S.Set Key -> RawFilePath -> Key -> CommandStart
start s _file k
| S.member k s = start' k
| otherwise = stop

View file

@ -72,7 +72,7 @@ getList o
printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l
start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> Key -> CommandStart
start :: [(UUID, RemoteName, TrustLevel)] -> RawFilePath -> Key -> CommandStart
start l file key = do
ls <- S.fromList <$> keyLocations key
liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file
@ -88,8 +88,8 @@ lheader remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length
trust UnTrusted = " (untrusted)"
trust _ = ""
format :: [(TrustLevel, Present)] -> FilePath -> String
format remotes file = thereMap ++ " " ++ file
format :: [(TrustLevel, Present)] -> RawFilePath -> String
format remotes file = thereMap ++ " " ++ fromRawFilePath file
where
thereMap = concatMap there remotes
there (UnTrusted, True) = "x"

View file

@ -92,10 +92,10 @@ seek o = do
([], True) -> commandAction (startAll o outputter)
(_, True) -> giveup "Cannot specify both files and --all"
start :: LogOptions -> (FilePath -> Outputter) -> FilePath -> Key -> CommandStart
start :: LogOptions -> (FilePath -> Outputter) -> RawFilePath -> Key -> CommandStart
start o outputter file key = do
(changes, cleanup) <- getKeyLog key (passthruOptions o)
showLogIncremental (outputter file) changes
showLogIncremental (outputter (fromRawFilePath file)) changes
void $ liftIO cleanup
stop
@ -201,7 +201,7 @@ getKeyLog key os = do
top <- fromRepo Git.repoPath
p <- liftIO $ relPathCwdToFile top
config <- Annex.getGitConfig
let logfile = p </> locationLogFile config key
let logfile = p </> fromRawFilePath (locationLogFile config key)
getGitLog [logfile] (Param "--remove-empty" : os)
{- Streams the git log for all git-annex branch changes. -}
@ -220,7 +220,7 @@ getGitLog fs os = do
[ Param $ Git.fromRef Annex.Branch.fullname
, Param "--"
] ++ map Param fs
return (parseGitRawLog ls, cleanup)
return (parseGitRawLog (map decodeBL' ls), cleanup)
-- Parses chunked git log --raw output, which looks something like:
--
@ -250,7 +250,7 @@ parseGitRawLog = parse epoch
(tss, cl') -> (parseTimeStamp tss, cl')
mrc = do
(old, new) <- parseRawChangeLine cl
key <- locationLogFileKey c2
key <- locationLogFileKey (toRawFilePath c2)
return $ RefChange
{ changetime = ts
, oldref = old

View file

@ -28,16 +28,16 @@ cmd = withGlobalOptions [annexedMatchingOptions] $
seek :: CmdParams -> CommandSeek
seek = withFilesInGit (commandAction . (whenAnnexed start)) <=< workTreeItems
start :: FilePath -> Key -> CommandStart
start :: RawFilePath -> Key -> CommandStart
start file key = do
forced <- Annex.getState Annex.force
v <- Backend.getBackend file key
v <- Backend.getBackend (fromRawFilePath file) key
case v of
Nothing -> stop
Just oldbackend -> do
exists <- inAnnex key
newbackend <- maybe defaultBackend return
=<< chooseBackend file
=<< chooseBackend (fromRawFilePath file)
if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists
then starting "migrate" (mkActionItem (key, file)) $
perform file key oldbackend newbackend
@ -63,7 +63,7 @@ upgradableKey backend key = isNothing (fromKey keySize key) || backendupgradable
- data cannot get corrupted after the fsck but before the new key is
- generated.
-}
perform :: FilePath -> Key -> Backend -> Backend -> CommandPerform
perform :: RawFilePath -> Key -> Backend -> Backend -> CommandPerform
perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbackend)
where
go Nothing = stop
@ -85,7 +85,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbacken
genkey Nothing = do
content <- calcRepo $ gitAnnexLocation oldkey
let source = KeySource
{ keyFilename = file
{ keyFilename = fromRawFilePath file
, contentLocation = content
, inodeCache = Nothing
}

View file

@ -47,7 +47,7 @@ seek o = startConcurrency transferStages $
(withFilesInGit (commandAction . (whenAnnexed $ start o)))
=<< workTreeItems (mirrorFiles o)
start :: MirrorOptions -> FilePath -> Key -> CommandStart
start :: MirrorOptions -> RawFilePath -> Key -> CommandStart
start o file k = startKey o afile (k, ai)
where
afile = AssociatedFile (Just file)
@ -75,4 +75,4 @@ startKey o afile (key, ai) = case fromToOptions o of
where
getnumcopies = case afile of
AssociatedFile Nothing -> getNumCopies
AssociatedFile (Just af) -> getFileNumCopies af
AssociatedFile (Just af) -> getFileNumCopies (fromRawFilePath af)

View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Command.P2P where
import Command

View file

@ -42,9 +42,11 @@ batchParser s = case separate (== ' ') (reverse s) of
| otherwise -> Right (reverse rf, reverse ru)
start :: (FilePath, URLString) -> CommandStart
start (file, url) = flip whenAnnexed file $ \_ key ->
starting "rmurl" (mkActionItem (key, AssociatedFile (Just file))) $
start (file, url) = flip whenAnnexed file' $ \_ key ->
starting "rmurl" (mkActionItem (key, AssociatedFile (Just file'))) $
next $ cleanup url key
where
file' = toRawFilePath file
cleanup :: String -> Key -> CommandCleanup
cleanup url key = do

View file

@ -236,7 +236,7 @@ testExportTree st (Just _) ea k1 k2 =
]
where
testexportdirectory = "testremote-export"
testexportlocation = mkExportLocation (testexportdirectory </> "location")
testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory </> "location"))
check desc a = testCase desc $
Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed"
storeexport k = do
@ -252,7 +252,7 @@ testExportTree st (Just _) ea k1 k2 =
removeexport k = Remote.removeExport ea k testexportlocation
removeexportdirectory = case Remote.removeExportDirectory ea of
Nothing -> return True
Just a -> a (mkExportDirectory testexportdirectory)
Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory))
testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree]
testUnavailable st r k =
@ -326,7 +326,7 @@ randKey sz = withTmpFile "randkey" $ \f h -> do
return k
getReadonlyKey :: Remote -> FilePath -> Annex Key
getReadonlyKey r f = lookupFile f >>= \case
getReadonlyKey r f = lookupFile (toRawFilePath f) >>= \case
Nothing -> giveup $ f ++ " is not an annexed file"
Just k -> do
unlessM (inAnnex k) $

View file

@ -27,9 +27,9 @@ seek :: CmdParams -> CommandSeek
seek ps = do
-- Safety first; avoid any undo that would touch files that are not
-- in the index.
(fs, cleanup) <- inRepo $ LsFiles.notInRepo False ps
(fs, cleanup) <- inRepo $ LsFiles.notInRepo False (map toRawFilePath ps)
unless (null fs) $
giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords fs
giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords (map fromRawFilePath fs)
void $ liftIO $ cleanup
-- Committing staged changes before undo allows later

View file

@ -31,6 +31,7 @@ import Types.StandardGroups
import Types.ScheduledActivity
import Types.NumCopies
import Remote
import Git.Types (ConfigKey(..), fromConfigKey, fromConfigValue)
cmd :: Command
cmd = command "vicfg" SectionSetup "edit configuration in git-annex branch"
@ -70,7 +71,7 @@ data Cfg = Cfg
, cfgRequiredContentMap :: M.Map UUID PreferredContentExpression
, cfgGroupPreferredContentMap :: M.Map Group PreferredContentExpression
, cfgScheduleMap :: M.Map UUID [ScheduledActivity]
, cfgGlobalConfigs :: M.Map ConfigName ConfigValue
, cfgGlobalConfigs :: M.Map ConfigKey ConfigValue
, cfgNumCopies :: Maybe NumCopies
}
@ -218,9 +219,9 @@ genCfg cfg descs = unlines $ intercalate [""]
[ com "Other global configuration"
]
(\(s, g) -> gline g s)
(\g -> gline g "")
(\g -> gline g mempty)
where
gline g val = [ unwords ["config", g, "=", val] ]
gline k v = [ unwords ["config", fromConfigKey k, "=", fromConfigValue v] ]
line setting u val =
[ com $ "(for " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) ++ ")"
@ -308,7 +309,7 @@ parseCfg defcfg = go [] defcfg . lines
let m = M.insert u l (cfgScheduleMap cfg)
in Right $ cfg { cfgScheduleMap = m }
| setting == "config" =
let m = M.insert f val (cfgGlobalConfigs cfg)
let m = M.insert (ConfigKey (encodeBS' f)) (ConfigValue (encodeBS' val)) (cfgGlobalConfigs cfg)
in Right $ cfg { cfgGlobalConfigs = m }
| setting == "numcopies" = case readish val of
Nothing -> Left "parse error (expected an integer)"