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
parent
718fa83da6
commit
c20f4704a7
40 changed files with 187 additions and 174 deletions
|
|
@ -23,6 +23,7 @@ import qualified Annex
|
|||
import qualified Git
|
||||
import qualified Git.Config
|
||||
import qualified Git.Objects
|
||||
import Git.Types (fromConfigValue)
|
||||
import qualified Annex.Branch
|
||||
import Logs.UUID
|
||||
import Logs.Trust.Basic
|
||||
|
|
@ -275,5 +276,5 @@ initSharedClone True = do
|
|||
- affect it. -}
|
||||
propigateSecureHashesOnly :: Annex ()
|
||||
propigateSecureHashesOnly =
|
||||
maybe noop (setConfig "annex.securehashesonly" . decodeBS')
|
||||
maybe noop (setConfig "annex.securehashesonly" . fromConfigValue)
|
||||
=<< getGlobalConfig "annex.securehashesonly"
|
||||
|
|
|
|||
|
|
@ -65,15 +65,10 @@ import qualified Command.AddUnused
|
|||
import qualified Command.Unlock
|
||||
import qualified Command.Lock
|
||||
import qualified Command.PreCommit
|
||||
{-
|
||||
import qualified Command.PostReceive
|
||||
-}
|
||||
import qualified Command.Find
|
||||
{-
|
||||
import qualified Command.FindRef
|
||||
-}
|
||||
import qualified Command.Whereis
|
||||
{-
|
||||
import qualified Command.List
|
||||
import qualified Command.Log
|
||||
import qualified Command.Merge
|
||||
|
|
@ -97,17 +92,13 @@ import qualified Command.Schedule
|
|||
import qualified Command.Ungroup
|
||||
import qualified Command.Config
|
||||
import qualified Command.Vicfg
|
||||
-}
|
||||
import qualified Command.Sync
|
||||
{-
|
||||
import qualified Command.Mirror
|
||||
import qualified Command.AddUrl
|
||||
import qualified Command.ImportFeed
|
||||
import qualified Command.RmUrl
|
||||
-}
|
||||
import qualified Command.Import
|
||||
import qualified Command.Export
|
||||
{-
|
||||
import qualified Command.Map
|
||||
import qualified Command.Direct
|
||||
import qualified Command.Indirect
|
||||
|
|
@ -116,9 +107,7 @@ import qualified Command.Forget
|
|||
import qualified Command.P2P
|
||||
import qualified Command.Proxy
|
||||
import qualified Command.DiffDriver
|
||||
-}
|
||||
import qualified Command.Smudge
|
||||
{-
|
||||
import qualified Command.Undo
|
||||
import qualified Command.Version
|
||||
import qualified Command.RemoteDaemon
|
||||
|
|
@ -132,7 +121,6 @@ import qualified Command.WebApp
|
|||
import qualified Command.Test
|
||||
import qualified Command.FuzzTest
|
||||
import qualified Command.TestRemote
|
||||
-}
|
||||
import qualified Command.Benchmark
|
||||
|
||||
cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command]
|
||||
|
|
@ -148,12 +136,10 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
|
|||
, Command.Unlock.editcmd
|
||||
, Command.Lock.cmd
|
||||
, Command.Sync.cmd
|
||||
{-
|
||||
, Command.Mirror.cmd
|
||||
, Command.AddUrl.cmd
|
||||
, Command.ImportFeed.cmd
|
||||
, Command.RmUrl.cmd
|
||||
-}
|
||||
, Command.Import.cmd
|
||||
, Command.Export.cmd
|
||||
, Command.Init.cmd
|
||||
|
|
@ -165,12 +151,9 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
|
|||
, Command.Multicast.cmd
|
||||
, Command.Reinject.cmd
|
||||
, Command.Unannex.cmd
|
||||
{-
|
||||
, Command.Uninit.cmd
|
||||
, Command.Reinit.cmd
|
||||
-}
|
||||
, Command.PreCommit.cmd
|
||||
{-
|
||||
, Command.PostReceive.cmd
|
||||
, Command.NumCopies.cmd
|
||||
, Command.Trust.cmd
|
||||
|
|
@ -185,7 +168,6 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
|
|||
, Command.Ungroup.cmd
|
||||
, Command.Config.cmd
|
||||
, Command.Vicfg.cmd
|
||||
-}
|
||||
, Command.LookupKey.cmd
|
||||
, Command.CalcKey.cmd
|
||||
, Command.ContentLocation.cmd
|
||||
|
|
@ -215,11 +197,8 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
|
|||
, Command.DropUnused.cmd
|
||||
, Command.AddUnused.cmd
|
||||
, Command.Find.cmd
|
||||
{-
|
||||
, Command.FindRef.cmd
|
||||
-}
|
||||
, Command.Whereis.cmd
|
||||
{-
|
||||
, Command.List.cmd
|
||||
, Command.Log.cmd
|
||||
, Command.Merge.cmd
|
||||
|
|
@ -236,9 +215,7 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
|
|||
, Command.P2P.cmd
|
||||
, Command.Proxy.cmd
|
||||
, Command.DiffDriver.cmd
|
||||
-}
|
||||
, Command.Smudge.cmd
|
||||
{-
|
||||
, Command.Undo.cmd
|
||||
, Command.Version.cmd
|
||||
, Command.RemoteDaemon.cmd
|
||||
|
|
@ -252,7 +229,6 @@ cmds testoptparser testrunner mkbenchmarkgenerator =
|
|||
, Command.Test.cmd testoptparser testrunner
|
||||
, Command.FuzzTest.cmd
|
||||
, Command.TestRemote.cmd
|
||||
-}
|
||||
, Command.Benchmark.cmd $
|
||||
mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop)
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Command.P2P where
|
||||
|
||||
import Command
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)"
|
||||
|
|
|
|||
|
|
@ -29,10 +29,10 @@ type UnqualifiedConfigKey = S.ByteString
|
|||
|
||||
{- Looks up a setting in git config. This is not as efficient as using the
|
||||
- GitConfig type. -}
|
||||
getConfig :: ConfigKey -> S.ByteString -> Annex S.ByteString
|
||||
getConfig :: ConfigKey -> ConfigValue -> Annex ConfigValue
|
||||
getConfig key d = fromRepo $ Git.Config.get key d
|
||||
|
||||
getConfigMaybe :: ConfigKey -> Annex (Maybe S.ByteString)
|
||||
getConfigMaybe :: ConfigKey -> Annex (Maybe ConfigValue)
|
||||
getConfigMaybe key = fromRepo $ Git.Config.getMaybe key
|
||||
|
||||
{- Changes a git config setting in both internal state and .git/config -}
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ fuzzymatches input showchoice choices = fst $ unzip $
|
|||
-}
|
||||
prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO ()
|
||||
prepare input showmatch matches r =
|
||||
case readish . decodeBS' . Git.Config.get "help.autocorrect" "0" =<< r of
|
||||
case readish . fromConfigValue . Git.Config.get "help.autocorrect" "0" =<< r of
|
||||
Just n
|
||||
| n == 0 -> list
|
||||
| n < 0 -> warn Nothing
|
||||
|
|
|
|||
|
|
@ -21,16 +21,16 @@ import qualified Git.Command
|
|||
import qualified Git.Construct
|
||||
import Utility.UserInfo
|
||||
|
||||
{- Returns a single git config setting, or a default value if not set. -}
|
||||
get :: ConfigKey -> S.ByteString -> Repo -> S.ByteString
|
||||
get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
|
||||
{- Returns a single git config setting, or a fallback value if not set. -}
|
||||
get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
|
||||
get key fallback repo = M.findWithDefault fallback key (config repo)
|
||||
|
||||
{- Returns a list with each line of a multiline config setting. -}
|
||||
getList :: ConfigKey -> Repo -> [S.ByteString]
|
||||
{- Returns a list of values. -}
|
||||
getList :: ConfigKey -> Repo -> [ConfigValue]
|
||||
getList key repo = M.findWithDefault [] key (fullconfig repo)
|
||||
|
||||
{- Returns a single git config setting, if set. -}
|
||||
getMaybe :: ConfigKey -> Repo -> Maybe S.ByteString
|
||||
getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue
|
||||
getMaybe key repo = M.lookup key (config repo)
|
||||
|
||||
{- Runs git config and populates a repo with its config.
|
||||
|
|
@ -100,7 +100,7 @@ store s repo = do
|
|||
|
||||
{- Stores a single config setting in a Repo, returning the new version of
|
||||
- the Repo. Config settings can be updated incrementally. -}
|
||||
store' :: ConfigKey -> S.ByteString -> Repo -> Repo
|
||||
store' :: ConfigKey -> ConfigValue -> Repo -> Repo
|
||||
store' k v repo = repo
|
||||
{ config = M.singleton k v `M.union` config repo
|
||||
, fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)
|
||||
|
|
@ -128,7 +128,7 @@ updateLocation' :: Repo -> RepoLocation -> IO Repo
|
|||
updateLocation' r l = do
|
||||
l' <- case getMaybe "core.worktree" r of
|
||||
Nothing -> return l
|
||||
Just d -> do
|
||||
Just (ConfigValue d) -> do
|
||||
{- core.worktree is relative to the gitdir -}
|
||||
top <- absPath $ gitdir l
|
||||
let p = absPathFrom top (fromRawFilePath d)
|
||||
|
|
@ -137,7 +137,7 @@ updateLocation' r l = do
|
|||
|
||||
{- Parses git config --list or git config --null --list output into a
|
||||
- config map. -}
|
||||
parse :: S.ByteString -> M.Map ConfigKey [S.ByteString]
|
||||
parse :: S.ByteString -> M.Map ConfigKey [ConfigValue]
|
||||
parse s
|
||||
| S.null s = M.empty
|
||||
-- --list output will have a '=' in the first line
|
||||
|
|
@ -152,15 +152,15 @@ parse s
|
|||
firstline = S.takeWhile (/= nl) s
|
||||
|
||||
sep c = M.fromListWith (++)
|
||||
. map (\(k,v) -> (ConfigKey k, [S.drop 1 v]))
|
||||
. map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)]))
|
||||
. map (S.break (== c))
|
||||
|
||||
{- Checks if a string from git config is a true value. -}
|
||||
isTrue :: String -> Maybe Bool
|
||||
isTrue = isTrue' . encodeBS'
|
||||
isTrue = isTrue' . ConfigValue . encodeBS'
|
||||
|
||||
isTrue' :: S.ByteString -> Maybe Bool
|
||||
isTrue' s
|
||||
isTrue' :: ConfigValue -> Maybe Bool
|
||||
isTrue' (ConfigValue s)
|
||||
| s' == "true" = Just True
|
||||
| s' == "false" = Just False
|
||||
| otherwise = Nothing
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ import qualified Data.ByteString.Char8 as S8
|
|||
|
||||
import Common
|
||||
import Git
|
||||
import Git.Types
|
||||
import qualified Git.Config
|
||||
|
||||
data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int
|
||||
|
|
@ -21,23 +22,27 @@ data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int
|
|||
|
||||
getSharedRepository :: Repo -> SharedRepository
|
||||
getSharedRepository r =
|
||||
case S8.map toLower $ Git.Config.get "core.sharedrepository" "" r of
|
||||
"1" -> GroupShared
|
||||
"2" -> AllShared
|
||||
"group" -> GroupShared
|
||||
"true" -> GroupShared
|
||||
"all" -> AllShared
|
||||
"world" -> AllShared
|
||||
"everybody" -> AllShared
|
||||
v -> maybe UnShared UmaskShared (readish (decodeBS' v))
|
||||
case Git.Config.getMaybe "core.sharedrepository" r of
|
||||
Nothing -> UnShared
|
||||
Just (ConfigValue v) -> case S8.map toLower v of
|
||||
"1" -> GroupShared
|
||||
"2" -> AllShared
|
||||
"group" -> GroupShared
|
||||
"true" -> GroupShared
|
||||
"all" -> AllShared
|
||||
"world" -> AllShared
|
||||
"everybody" -> AllShared
|
||||
_ -> maybe UnShared UmaskShared (readish (decodeBS' v))
|
||||
|
||||
data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush
|
||||
deriving (Eq)
|
||||
|
||||
getDenyCurrentBranch :: Repo -> DenyCurrentBranch
|
||||
getDenyCurrentBranch r =
|
||||
case S8.map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of
|
||||
"updateinstead" -> UpdateInstead
|
||||
"warn" -> WarnPush
|
||||
"ignore" -> IgnorePush
|
||||
_ -> RefusePush
|
||||
case Git.Config.getMaybe "receive.denycurrentbranch" r of
|
||||
Just (ConfigValue v) -> case S8.map toLower v of
|
||||
"updateinstead" -> UpdateInstead
|
||||
"warn" -> WarnPush
|
||||
"ignore" -> IgnorePush
|
||||
_ -> RefusePush
|
||||
Nothing -> RefusePush
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ fromRemotes repo = mapM construct remotepairs
|
|||
filterconfig f = filter f $ M.toList $ config repo
|
||||
filterkeys f = filterconfig (\(k,_) -> f k)
|
||||
remotepairs = filterkeys isRemoteKey
|
||||
construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (decodeBS' v) repo)
|
||||
construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo)
|
||||
|
||||
{- Sets the name of a remote when constructing the Repo to represent it. -}
|
||||
remoteNamed :: String -> IO Repo -> IO Repo
|
||||
|
|
|
|||
|
|
@ -79,9 +79,9 @@ type GCryptId = String
|
|||
- which is stored in the repository (in encrypted form)
|
||||
- and cached in a per-remote gcrypt-id configuration setting. -}
|
||||
remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId
|
||||
remoteRepoId r n = decodeBS' <$> getRemoteConfig "gcrypt-id" r n
|
||||
remoteRepoId r n = fromConfigValue <$> getRemoteConfig "gcrypt-id" r n
|
||||
|
||||
getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe S.ByteString
|
||||
getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe ConfigValue
|
||||
getRemoteConfig field repo remotename = do
|
||||
n <- remotename
|
||||
Config.getMaybe (remoteConfigKey field n) repo
|
||||
|
|
@ -96,8 +96,8 @@ getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust
|
|||
]
|
||||
where
|
||||
defaultkey = "gcrypt.participants"
|
||||
parse (Just "simple") = []
|
||||
parse (Just b) = words (decodeBS' b)
|
||||
parse (Just (ConfigValue "simple")) = []
|
||||
parse (Just (ConfigValue b)) = words (decodeBS' b)
|
||||
parse Nothing = []
|
||||
|
||||
remoteParticipantConfigKey :: RemoteName -> ConfigKey
|
||||
|
|
|
|||
|
|
@ -84,9 +84,9 @@ parseRemoteLocation s repo = ret $ calcloc s
|
|||
where
|
||||
replacement = decodeBS' $ S.drop (S.length prefix) $
|
||||
S.take (S.length bestkey - S.length suffix) bestkey
|
||||
(ConfigKey bestkey, bestvalue) = maximumBy longestvalue insteadofs
|
||||
(ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs
|
||||
longestvalue (_, a) (_, b) = compare b a
|
||||
insteadofs = filterconfig $ \(ConfigKey k, v) ->
|
||||
insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) ->
|
||||
prefix `S.isPrefixOf` k &&
|
||||
suffix `S.isSuffixOf` k &&
|
||||
v `S.isPrefixOf` encodeBS l
|
||||
|
|
|
|||
21
Git/Types.hs
21
Git/Types.hs
|
|
@ -6,11 +6,13 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Git.Types where
|
||||
|
||||
import Network.URI
|
||||
import Data.String
|
||||
import Data.Default
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.ByteString as S
|
||||
import System.Posix.Types
|
||||
|
|
@ -36,9 +38,9 @@ data RepoLocation
|
|||
|
||||
data Repo = Repo
|
||||
{ location :: RepoLocation
|
||||
, config :: M.Map ConfigKey S.ByteString
|
||||
, config :: M.Map ConfigKey ConfigValue
|
||||
-- a given git config key can actually have multiple values
|
||||
, fullconfig :: M.Map ConfigKey [S.ByteString]
|
||||
, fullconfig :: M.Map ConfigKey [ConfigValue]
|
||||
-- remoteName holds the name used for this repo in some other
|
||||
-- repo's list of remotes, when this repo is such a remote
|
||||
, remoteName :: Maybe RemoteName
|
||||
|
|
@ -52,15 +54,30 @@ data Repo = Repo
|
|||
newtype ConfigKey = ConfigKey S.ByteString
|
||||
deriving (Ord, Eq)
|
||||
|
||||
newtype ConfigValue = ConfigValue S.ByteString
|
||||
deriving (Ord, Eq, Semigroup, Monoid)
|
||||
|
||||
instance Default ConfigValue where
|
||||
def = ConfigValue mempty
|
||||
|
||||
fromConfigKey :: ConfigKey -> String
|
||||
fromConfigKey (ConfigKey s) = decodeBS' s
|
||||
|
||||
instance Show ConfigKey where
|
||||
show = fromConfigKey
|
||||
|
||||
fromConfigValue :: ConfigValue -> String
|
||||
fromConfigValue (ConfigValue s) = decodeBS' s
|
||||
|
||||
instance Show ConfigValue where
|
||||
show = fromConfigValue
|
||||
|
||||
instance IsString ConfigKey where
|
||||
fromString = ConfigKey . encodeBS'
|
||||
|
||||
instance IsString ConfigValue where
|
||||
fromString = ConfigValue . encodeBS'
|
||||
|
||||
type RemoteName = String
|
||||
|
||||
{- A git ref. Can be a sha1, or a branch or tag name. -}
|
||||
|
|
|
|||
|
|
@ -6,8 +6,8 @@
|
|||
-}
|
||||
|
||||
module Logs.Config (
|
||||
ConfigKey,
|
||||
ConfigValue,
|
||||
ConfigKey(..),
|
||||
ConfigValue(..),
|
||||
setGlobalConfig,
|
||||
unsetGlobalConfig,
|
||||
getGlobalConfig,
|
||||
|
|
@ -18,7 +18,7 @@ import Annex.Common
|
|||
import Logs
|
||||
import Logs.MapLog
|
||||
import qualified Annex.Branch
|
||||
import Git.Types (ConfigKey(..))
|
||||
import Git.Types (ConfigKey(..), ConfigValue(..))
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.ByteString as S
|
||||
|
|
@ -26,8 +26,6 @@ import qualified Data.ByteString.Lazy as L
|
|||
import qualified Data.Attoparsec.ByteString.Lazy as A
|
||||
import Data.ByteString.Builder
|
||||
|
||||
type ConfigValue = S.ByteString
|
||||
|
||||
setGlobalConfig :: ConfigKey -> ConfigValue -> Annex ()
|
||||
setGlobalConfig name new = do
|
||||
curr <- getGlobalConfig name
|
||||
|
|
@ -44,7 +42,8 @@ unsetGlobalConfig :: ConfigKey -> Annex ()
|
|||
unsetGlobalConfig name = do
|
||||
curr <- getGlobalConfig name
|
||||
when (curr /= Nothing) $
|
||||
setGlobalConfig' name mempty -- set to empty string to unset
|
||||
-- set to empty string to unset
|
||||
setGlobalConfig' name (ConfigValue mempty)
|
||||
|
||||
-- Reads the global config log every time.
|
||||
getGlobalConfig :: ConfigKey -> Annex (Maybe ConfigValue)
|
||||
|
|
@ -53,15 +52,17 @@ getGlobalConfig name = M.lookup name <$> loadGlobalConfig
|
|||
buildGlobalConfig :: MapLog ConfigKey ConfigValue -> Builder
|
||||
buildGlobalConfig = buildMapLog configkeybuilder valuebuilder
|
||||
where
|
||||
configkeybuilder (ConfigKey f) = byteString f
|
||||
valuebuilder = byteString
|
||||
configkeybuilder (ConfigKey k) = byteString k
|
||||
valuebuilder (ConfigValue v) = byteString v
|
||||
|
||||
parseGlobalConfig :: L.ByteString -> MapLog ConfigKey ConfigValue
|
||||
parseGlobalConfig = parseMapLog configkeyparser valueparser
|
||||
where
|
||||
configkeyparser = ConfigKey <$> A.takeByteString
|
||||
valueparser = A.takeByteString
|
||||
valueparser = ConfigValue <$> A.takeByteString
|
||||
|
||||
loadGlobalConfig :: Annex (M.Map ConfigKey ConfigValue)
|
||||
loadGlobalConfig = M.filter (not . S.null) . simpleMap . parseGlobalConfig
|
||||
loadGlobalConfig = M.filter (\(ConfigValue v) -> not (S.null v))
|
||||
. simpleMap
|
||||
. parseGlobalConfig
|
||||
<$> Annex.Branch.get configLog
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ import Logs.Web
|
|||
import Remote.List
|
||||
import Config
|
||||
import Config.DynamicConfig
|
||||
import Git.Types (RemoteName, ConfigKey(..))
|
||||
import Git.Types (RemoteName, ConfigKey(..), fromConfigValue)
|
||||
import Utility.Aeson
|
||||
|
||||
{- Map from UUIDs of Remotes to a calculated value. -}
|
||||
|
|
@ -150,7 +150,7 @@ byNameOrGroup :: RemoteName -> Annex [Remote]
|
|||
byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS' n))
|
||||
where
|
||||
go (Just l) = catMaybes
|
||||
<$> mapM (byName . Just) (splitc ' ' (decodeBS' l))
|
||||
<$> mapM (byName . Just) (splitc ' ' (fromConfigValue l))
|
||||
go Nothing = maybeToList
|
||||
<$> byName (Just n)
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ import Annex.Common
|
|||
import qualified Annex
|
||||
import Types.Remote
|
||||
import Types.Creds
|
||||
import Git.Types (fromConfigKey)
|
||||
import Git.Types (ConfigValue(..), fromConfigKey)
|
||||
import qualified Git
|
||||
import qualified Git.Command
|
||||
import qualified Git.Config
|
||||
|
|
@ -213,7 +213,7 @@ storeBupUUID u buprepo = do
|
|||
giveup "ssh failed"
|
||||
else liftIO $ do
|
||||
r' <- Git.Config.read r
|
||||
let olduuid = Git.Config.get configkeyUUID mempty r'
|
||||
let ConfigValue olduuid = Git.Config.get configkeyUUID mempty r'
|
||||
when (S.null olduuid) $
|
||||
Git.Command.run
|
||||
[ Param "config"
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ import Types.GitConfig
|
|||
import Types.Crypto
|
||||
import Types.Creds
|
||||
import Types.Transfer
|
||||
import Git.Types (ConfigKey(..), fromConfigKey)
|
||||
import Git.Types (ConfigKey(..), fromConfigKey, fromConfigValue)
|
||||
import qualified Git
|
||||
import qualified Git.Command
|
||||
import qualified Git.Config
|
||||
|
|
@ -462,7 +462,7 @@ getGCryptId fast r gc
|
|||
| otherwise = return (Nothing, r)
|
||||
where
|
||||
extract Nothing = (Nothing, r)
|
||||
extract (Just r') = (decodeBS' <$> Git.Config.getMaybe coreGCryptId r', r')
|
||||
extract (Just r') = (fromConfigValue <$> Git.Config.getMaybe coreGCryptId r', r')
|
||||
|
||||
getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString))
|
||||
getConfigViaRsync r gc = do
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ list autoinit = do
|
|||
Nothing -> return r
|
||||
Just url -> inRepo $ \g ->
|
||||
Git.Construct.remoteNamed n $
|
||||
Git.Construct.fromRemoteLocation (decodeBS' url) g
|
||||
Git.Construct.fromRemoteLocation (Git.fromConfigValue url) g
|
||||
|
||||
{- Git remotes are normally set up using standard git command, not
|
||||
- git-annex initremote and enableremote.
|
||||
|
|
|
|||
|
|
@ -189,7 +189,7 @@ configKnownUrl r
|
|||
set k v r' = do
|
||||
let k' = remoteConfig r' k
|
||||
setConfig k' v
|
||||
return $ Git.Config.store' k' (encodeBS' v) r'
|
||||
return $ Git.Config.store' k' (Git.ConfigValue (encodeBS' v)) r'
|
||||
|
||||
data LFSHandle = LFSHandle
|
||||
{ downloadEndpoint :: Maybe LFS.Endpoint
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import Annex.Common
|
|||
import Types.Remote
|
||||
import Types.Creds
|
||||
import qualified Git
|
||||
import Git.Types (fromConfigKey)
|
||||
import Git.Types (fromConfigKey, fromConfigValue)
|
||||
import Config
|
||||
import Config.Cost
|
||||
import Annex.UUID
|
||||
|
|
@ -108,10 +108,10 @@ hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv)
|
|||
|
||||
lookupHook :: HookName -> Action -> Annex (Maybe String)
|
||||
lookupHook hookname action = do
|
||||
command <- decodeBS' <$> getConfig hook mempty
|
||||
command <- fromConfigValue <$> getConfig hook mempty
|
||||
if null command
|
||||
then do
|
||||
fallback <- decodeBS' <$> getConfig hookfallback mempty
|
||||
fallback <- fromConfigValue <$> getConfig hookfallback mempty
|
||||
if null fallback
|
||||
then do
|
||||
warning $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback
|
||||
|
|
|
|||
15
Test.hs
15
Test.hs
|
|
@ -204,17 +204,12 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck"
|
|||
- of git-annex. They are always run before the unitTests. -}
|
||||
initTests :: TestTree
|
||||
initTests = testGroup "Init Tests"
|
||||
[]
|
||||
{-
|
||||
[ testCase "init" test_init
|
||||
, testCase "add" test_add
|
||||
]
|
||||
-}
|
||||
|
||||
unitTests :: String -> TestTree
|
||||
unitTests note = testGroup ("Unit Tests " ++ note)
|
||||
[]
|
||||
{-
|
||||
[ testCase "add dup" test_add_dup
|
||||
, testCase "add extras" test_add_extras
|
||||
, testCase "export_import" test_export_import
|
||||
|
|
@ -629,7 +624,7 @@ test_lock_force = intmpclonerepo $ do
|
|||
git_annex "get" [annexedfile] @? "get of file failed"
|
||||
git_annex "unlock" [annexedfile] @? "unlock failed"
|
||||
annexeval $ do
|
||||
Just k <- Annex.WorkTree.lookupFile annexedfile
|
||||
Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile)
|
||||
Database.Keys.removeInodeCaches k
|
||||
Database.Keys.closeDb
|
||||
liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache
|
||||
|
|
@ -1151,7 +1146,7 @@ test_mixed_conflict_resolution = do
|
|||
@? (what ++ " too many variant files in: " ++ show v)
|
||||
indir d $ do
|
||||
git_annex "get" (conflictor:v) @? ("get failed in " ++ what)
|
||||
git_annex_expectoutput "find" [conflictor] [Git.FilePath.toInternalGitPath subfile]
|
||||
git_annex_expectoutput "find" [conflictor] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath subfile))]
|
||||
git_annex_expectoutput "find" v v
|
||||
|
||||
{- Check merge conflict resolution when both repos start with an annexed
|
||||
|
|
@ -1348,7 +1343,7 @@ test_conflict_resolution_symlink_bit = unlessM (hasUnlockedFiles <$> getTestMode
|
|||
where
|
||||
conflictor = "conflictor"
|
||||
check_is_link f what = do
|
||||
git_annex_expectoutput "find" ["--include=*", f] [Git.FilePath.toInternalGitPath f]
|
||||
git_annex_expectoutput "find" ["--include=*", f] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath f))]
|
||||
l <- annexeval $ Annex.inRepo $ Git.LsTree.lsTreeFiles Git.Ref.headRef [f]
|
||||
all (\i -> Git.Types.toTreeItemType (Git.LsTree.mode i) == Just Git.Types.TreeSymlink) l
|
||||
@? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l)
|
||||
|
|
@ -1603,7 +1598,7 @@ test_crypto = do
|
|||
(c,k) <- annexeval $ do
|
||||
uuid <- Remote.nameToUUID "foo"
|
||||
rs <- Logs.Remote.readRemoteLog
|
||||
Just k <- Annex.WorkTree.lookupFile annexedfile
|
||||
Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile)
|
||||
return (fromJust $ M.lookup uuid rs, k)
|
||||
let key = if scheme `elem` ["hybrid","pubkey"]
|
||||
then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]
|
||||
|
|
@ -1781,5 +1776,3 @@ test_export_import_subdir = intmpclonerepo $ do
|
|||
-- Make sure that import did not import the file to the top
|
||||
-- of the repo.
|
||||
checkdoesnotexist annexedfile
|
||||
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -89,8 +89,9 @@ inmainrepo a = do
|
|||
|
||||
with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
|
||||
with_ssh_origin cloner a = cloner $ do
|
||||
origindir <- absPath . decodeBS'
|
||||
=<< annexeval (Config.getConfig (Git.Types.ConfigKey (encodeBS' config)) (toRawFilePath "/dev/null"))
|
||||
let k = Git.Types.ConfigKey (encodeBS' config)
|
||||
let v = Git.Types.ConfigValue (toRawFilePath "/dev/null")
|
||||
origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v)
|
||||
let originurl = "localhost:" ++ origindir
|
||||
boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"
|
||||
a
|
||||
|
|
|
|||
|
|
@ -203,9 +203,9 @@ extractGitConfig r = GitConfig
|
|||
getbool k d = fromMaybe d $ getmaybebool k
|
||||
getmaybebool k = Git.Config.isTrue' =<< getmaybe' k
|
||||
getmayberead k = readish =<< getmaybe k
|
||||
getmaybe = fmap decodeBS' . getmaybe'
|
||||
getmaybe = fmap fromConfigValue . getmaybe'
|
||||
getmaybe' k = Git.Config.getMaybe k r
|
||||
getlist k = map decodeBS' $ Git.Config.getList k r
|
||||
getlist k = map fromConfigValue $ Git.Config.getList k r
|
||||
getwords k = fromMaybe [] $ words <$> getmaybe k
|
||||
|
||||
configurable d Nothing = DefaultConfig d
|
||||
|
|
@ -345,7 +345,7 @@ extractRemoteGitConfig r remotename = do
|
|||
getbool k d = fromMaybe d $ getmaybebool k
|
||||
getmaybebool k = Git.Config.isTrue' =<< getmaybe' k
|
||||
getmayberead k = readish =<< getmaybe k
|
||||
getmaybe = fmap decodeBS' . getmaybe'
|
||||
getmaybe = fmap fromConfigValue . getmaybe'
|
||||
getmaybe' k = mplus (Git.Config.getMaybe (key k) r)
|
||||
(Git.Config.getMaybe (remotekey k) r)
|
||||
getoptions k = fromMaybe [] $ words <$> getmaybe k
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ import Data.String
|
|||
import Data.ByteString.Builder
|
||||
import qualified Data.Semigroup as Sem
|
||||
|
||||
import Git.Types (ConfigValue(..))
|
||||
import Utility.FileSystemEncoding
|
||||
import Utility.QuickCheck
|
||||
import qualified Utility.SimpleProtocol as Proto
|
||||
|
|
@ -52,6 +53,12 @@ instance FromUUID String where
|
|||
instance ToUUID String where
|
||||
toUUID s = toUUID (encodeBS' s)
|
||||
|
||||
instance FromUUID ConfigValue where
|
||||
fromUUID s = (ConfigValue (fromUUID s))
|
||||
|
||||
instance ToUUID ConfigValue where
|
||||
toUUID (ConfigValue v) = toUUID v
|
||||
|
||||
-- There is no matching FromUUID U.UUID because a git-annex UUID may
|
||||
-- be NoUUID or perhaps contain something not allowed in a canonical UUID.
|
||||
instance ToUUID U.UUID where
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ setIndirect = do
|
|||
Nothing -> noop
|
||||
Just wt -> do
|
||||
unsetConfig src
|
||||
setConfig dest (decodeBS' wt)
|
||||
setConfig dest (fromConfigValue wt)
|
||||
reloadConfig
|
||||
|
||||
{- Converts a directBranch back to the original branch.
|
||||
|
|
|
|||
|
|
@ -407,16 +407,16 @@ Executable git-annex
|
|||
if flag(S3)
|
||||
Build-Depends: aws (>= 0.20)
|
||||
CPP-Options: -DWITH_S3
|
||||
Other-Modules-temp-disabled: Remote.S3
|
||||
Other-Modules: Remote.S3
|
||||
|
||||
if flag(WebDAV)
|
||||
Build-Depends: DAV (>= 1.0)
|
||||
CPP-Options: -DWITH_WEBDAV
|
||||
Other-Modules-temp-disabled:
|
||||
Other-Modules:
|
||||
Remote.WebDAV
|
||||
Remote.WebDAV.DavLocation
|
||||
if flag(S3) || flag(WebDAV)
|
||||
Other-Modules-temp-disabled:
|
||||
Other-Modules:
|
||||
Remote.Helper.Http
|
||||
|
||||
if flag(Assistant) && ! os(solaris) && ! os(gnu)
|
||||
|
|
@ -602,7 +602,7 @@ Executable git-annex
|
|||
if flag(DebugLocks)
|
||||
CPP-Options: -DDEBUGLOCKS
|
||||
|
||||
Other-Modules-Temp-Disabled:
|
||||
Other-Modules:
|
||||
Annex
|
||||
Annex.Action
|
||||
Annex.AdjustedBranch
|
||||
|
|
@ -860,6 +860,7 @@ Executable git-annex
|
|||
Git.RefLog
|
||||
Git.Remote
|
||||
Git.Remote.Remove
|
||||
Git.Repair
|
||||
Git.Sha
|
||||
Git.Ssh
|
||||
Git.Status
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue