simplify and speed up Utility.FileSystemEncoding

This eliminates the distinction between decodeBS and decodeBS', encodeBS
and encodeBS', etc. The old implementation truncated at NUL, and the
primed versions had to do extra work to avoid that problem. The new
implementation does not truncate at NUL, and is also a lot faster.
(Benchmarked at 2x faster for decodeBS and 3x for encodeBS; more for the
primed versions.)

Note that filepath-bytestring 1.4.2.1.8 contains the same optimisation,
and upgrading to it will speed up to/fromRawFilePath.

AFAIK, nothing relied on the old behavior of truncating at NUL. Some
code used the faster versions in places where I was sure there would not
be a NUL. So this change is unlikely to break anything.

Also, moved s2w8 and w82s out of the module, as they do not involve
filesystem encoding really.

Sponsored-by: Shae Erisson on Patreon
This commit is contained in:
Joey Hess 2021-08-10 20:45:02 -04:00
parent a38b724bfa
commit fa62c98910
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
55 changed files with 138 additions and 217 deletions

View file

@ -401,7 +401,7 @@ adjustGitRepo a = do
addGitConfigOverride :: String -> Annex ()
addGitConfigOverride v = do
adjustGitRepo $ \r ->
Git.Config.store (encodeBS' v) Git.Config.ConfigList $
Git.Config.store (encodeBS v) Git.Config.ConfigList $
r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }
changeState $ \st -> st { gitconfigoverride = v : gitconfigoverride st }
where

View file

@ -72,11 +72,11 @@ genMetaData key file status = do
- only changes to add the date fields. -}
dateMetaData :: UTCTime -> MetaData -> MetaData
dateMetaData mtime old = modMeta old $
(SetMeta yearMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show y)
(SetMeta yearMetaField $ S.singleton $ toMetaValue $ encodeBS $ show y)
`ComposeModMeta`
(SetMeta monthMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show m)
(SetMeta monthMetaField $ S.singleton $ toMetaValue $ encodeBS $ show m)
`ComposeModMeta`
(SetMeta dayMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show d)
(SetMeta dayMetaField $ S.singleton $ toMetaValue $ encodeBS $ show d)
where
(y, m, d) = toGregorian $ utctDay mtime

View file

@ -110,7 +110,7 @@ storeUUIDIn configfield = setConfig configfield . fromUUID
{- Only sets the configkey in the Repo; does not change .git/config -}
setUUID :: Git.Repo -> UUID -> IO Git.Repo
setUUID r u = do
let s = encodeBS' $ show configkeyUUID ++ "=" ++ fromUUID u
let s = encodeBS $ show configkeyUUID ++ "=" ++ fromUUID u
Git.Config.store s Git.Config.ConfigList r
-- Dummy uuid for the whole web. Do not alter.

View file

@ -118,6 +118,6 @@ isAnnexBranch f = n `isSuffixOf` f
n = '/' : Git.fromRef Annex.Branch.name
fileToBranch :: FilePath -> Git.Ref
fileToBranch f = Git.Ref $ encodeBS' $ "refs" </> base
fileToBranch f = Git.Ref $ encodeBS $ "refs" </> base
where
base = Prelude.last $ split "/refs/" f

View file

@ -321,7 +321,7 @@ addLink :: FilePath -> LinkTarget -> Maybe Key -> Assistant (Maybe Change)
addLink file link mk = do
debug ["add symlink", file]
liftAnnex $ do
v <- catObjectDetails $ Ref $ encodeBS' $ ':':file
v <- catObjectDetails $ Ref $ encodeBS $ ':':file
case v of
Just (currlink, sha, _type)
| L.fromStrict link == currlink ->

View file

@ -102,7 +102,7 @@ setRepoConfig uuid mremote oldc newc = do
- there's not. Special remotes don't normally
- have that, and don't use it. Temporarily add
- it if it's missing. -}
let remotefetch = Git.ConfigKey $ encodeBS' $
let remotefetch = Git.ConfigKey $ encodeBS $
"remote." ++ T.unpack (repoName oldc) ++ ".fetch"
needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch)
when needfetch $

View file

@ -239,7 +239,7 @@ newExternalState ebname hasext pid = do
warning msg
externalBackendProgram :: ExternalBackendName -> String
externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS' bname
externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS bname
-- Runs an action with an ExternalState, starting a new external backend
-- process if necessary. It is returned to the pool once the action

View file

@ -28,10 +28,10 @@ import Data.Word
genKeyName :: String -> S.ByteString
genKeyName s
-- Avoid making keys longer than the length of a SHA256 checksum.
| bytelen > sha256len = encodeBS' $
| bytelen > sha256len = encodeBS $
truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++
show (md5 bl)
| otherwise = encodeBS' s'
| otherwise = encodeBS s'
where
s' = preSanitizeKeyName s
bl = encodeBL s

View file

@ -79,7 +79,7 @@ commonGlobalOptions =
-- Also set in git config so it will be passed on to any
-- git-annex child processes.
, setAnnexState $ Annex.addGitConfigOverride $
decodeBS' $ debugconfig <> "=" <> boolConfig' v
decodeBS $ debugconfig <> "=" <> boolConfig' v
]
setdebugfilter v = mconcat
@ -88,7 +88,7 @@ commonGlobalOptions =
-- Also set in git config so it will be passed on to any
-- git-annex child processes.
, setAnnexState $ Annex.addGitConfigOverride $
decodeBS' (debugfilterconfig <> "=") ++ v
decodeBS (debugfilterconfig <> "=") ++ v
]
(ConfigKey debugconfig) = annexConfig "debug"

View file

@ -55,23 +55,23 @@ optParser _ = setconfig <|> getconfig <|> unsetconfig
seek :: Action -> CommandSeek
seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ commandAction $
startingUsualMessages (decodeBS' name) ai si $ do
startingUsualMessages (decodeBS name) ai si $ do
setGlobalConfig ck val
when (needLocalUpdate ck) $
setConfig ck (fromConfigValue val)
next $ return True
where
ai = ActionItemOther (Just (fromConfigValue val))
si = SeekInput [decodeBS' name]
si = SeekInput [decodeBS name]
seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $
startingUsualMessages (decodeBS' name) ai si $ do
startingUsualMessages (decodeBS name) ai si $ do
unsetGlobalConfig ck
when (needLocalUpdate ck) $
unsetConfig ck
next $ return True
where
ai = ActionItemOther (Just "unset")
si = SeekInput [decodeBS' name]
si = SeekInput [decodeBS name]
seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $
startingCustomOutput ai $ do
getGlobalConfig ck >>= \case

View file

@ -89,7 +89,7 @@ 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 (encodeBS' (getmode r)) of
check getfile getmode setfile r = case readTreeItemType (encodeBS (getmode r)) of
Just TreeSymlink -> do
v <- getAnnexLinkTarget' f False
maybe (return r) repoint (parseLinkTargetOrPointer =<< v)

View file

@ -22,6 +22,6 @@ seek o = Find.seek o'
where
o' = o
{ Find.keyOptions = Just $ WantBranchKeys $
map (Git.Ref . encodeBS') (Find.findThese o)
map (Git.Ref . encodeBS) (Find.findThese o)
, Find.findThese = []
}

View file

@ -292,7 +292,7 @@ verifyLocationLog' key ai present u updatestatus = do
fix InfoMissing
warning $
"** Based on the location log, " ++
decodeBS' (actionItemDesc ai) ++
decodeBS (actionItemDesc ai) ++
"\n** was expected to be present, " ++
"but its content is missing."
return False
@ -332,7 +332,7 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = case afile of
missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs
warning $
"** Required content " ++
decodeBS' (actionItemDesc ai) ++
decodeBS (actionItemDesc ai) ++
" is missing from these repositories:\n" ++
missingrequired
return False
@ -406,7 +406,7 @@ checkKeySizeOr bad key file ai = case fromKey keySize key of
badsize a b = do
msg <- bad key
warning $ concat
[ decodeBS' (actionItemDesc ai)
[ decodeBS (actionItemDesc ai)
, ": Bad file size ("
, compareSizes storageUnits True a b
, "); "
@ -424,11 +424,11 @@ checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =
case Types.Backend.canUpgradeKey backend of
Just a | a key -> do
warning $ concat
[ decodeBS' (actionItemDesc ai)
[ decodeBS (actionItemDesc ai)
, ": Can be upgraded to an improved key format. "
, "You can do so by running: git annex migrate --backend="
, decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " "
, decodeBS' file
, decodeBS file
]
return True
_ -> return True
@ -475,7 +475,7 @@ checkBackendOr bad backend key file ai =
unless ok $ do
msg <- bad key
warning $ concat
[ decodeBS' (actionItemDesc ai)
[ decodeBS (actionItemDesc ai)
, ": Bad file content; "
, msg
]
@ -503,7 +503,7 @@ checkInodeCache key content mic ai = case mic of
Nothing -> noop
Just ic' -> whenM (compareInodeCaches ic ic') $ do
warning $ concat
[ decodeBS' (actionItemDesc ai)
[ decodeBS (actionItemDesc ai)
, ": Stale or missing inode cache; updating."
]
Database.Keys.addInodeCaches key [ic]

View file

@ -85,7 +85,7 @@ optParser desc = do
[bs] ->
let (branch, subdir) = separate (== ':') bs
in RemoteImportOptions r
(Ref (encodeBS' branch))
(Ref (encodeBS branch))
(if null subdir then Nothing else Just subdir)
content
ic

View file

@ -163,7 +163,7 @@ itemInfo o (si, p) = ifM (isdir p)
noInfo :: String -> SeekInput -> Annex ()
noInfo s si = do
showStart "info" (encodeBS' s) si
showStart "info" (encodeBS s) si
showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid"
showEndFail
@ -183,7 +183,7 @@ dirInfo o dir si = showCustom (unwords ["info", dir]) si $ do
treeishInfo :: InfoOptions -> String -> SeekInput -> Annex ()
treeishInfo o t si = do
mi <- getTreeStatInfo o (Git.Ref (encodeBS' t))
mi <- getTreeStatInfo o (Git.Ref (encodeBS t))
case mi of
Nothing -> noInfo t si
Just i -> showCustom (unwords ["info", t]) si $ do
@ -313,8 +313,8 @@ showStat :: Stat -> StatState ()
showStat s = maybe noop calc =<< s
where
calc (desc, a) = do
(lift . showHeader . encodeBS') desc
lift . showRaw . encodeBS' =<< a
(lift . showHeader . encodeBS) desc
lift . showRaw . encodeBS =<< a
repo_list :: TrustLevel -> Stat
repo_list level = stat n $ nojson $ lift $ do

View file

@ -230,7 +230,7 @@ getGitLog fs os = do
[ Param $ Git.fromRef Annex.Branch.fullname
, Param "--"
] ++ map Param fs
return (parseGitRawLog config (map decodeBL' ls), cleanup)
return (parseGitRawLog config (map decodeBL ls), cleanup)
-- Parses chunked git log --raw output, which looks something like:
--

View file

@ -39,7 +39,7 @@ seek o
| otherwise = do
prepMerge
forM_ (mergeBranches o) $
commandAction . mergeBranch o . Git.Ref . encodeBS'
commandAction . mergeBranch o . Git.Ref . encodeBS
mergeAnnexBranch :: CommandStart
mergeAnnexBranch = starting "merge" ai si $ do

View file

@ -37,7 +37,7 @@ check = do
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
giveup "can only run uninit from the top of the git repository"
where
current_branch = Git.Ref . encodeBS' . Prelude.head . lines . decodeBS' <$> revhead
current_branch = Git.Ref . encodeBS . Prelude.head . lines . decodeBS <$> revhead
revhead = inRepo $ Git.Command.pipeReadStrict
[Param "rev-parse", Param "--abbrev-ref", Param "HEAD"]

View file

@ -311,7 +311,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 (ConfigKey (encodeBS' f)) (ConfigValue (encodeBS' 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)"

View file

@ -39,7 +39,7 @@ setConfig :: ConfigKey -> String -> Annex ()
setConfig (ConfigKey key) value = do
inRepo $ Git.Command.run
[ Param "config"
, Param (decodeBS' key)
, Param (decodeBS key)
, Param value
]
reloadConfig

View file

@ -95,10 +95,10 @@ newtype SSha = SSha String
deriving (Eq, Show)
toSSha :: Sha -> SSha
toSSha (Ref s) = SSha (decodeBS' s)
toSSha (Ref s) = SSha (decodeBS s)
fromSSha :: SSha -> Ref
fromSSha (SSha s) = Ref (encodeBS' s)
fromSSha (SSha s) = Ref (encodeBS s)
instance PersistField SSha where
toPersistValue (SSha b) = toPersistValue b

View file

@ -170,7 +170,7 @@ parse s st
{- Checks if a string from git config is a true/false value. -}
isTrueFalse :: String -> Maybe Bool
isTrueFalse = isTrueFalse' . ConfigValue . encodeBS'
isTrueFalse = isTrueFalse' . ConfigValue . encodeBS
isTrueFalse' :: ConfigValue -> Maybe Bool
isTrueFalse' (ConfigValue s)
@ -248,8 +248,8 @@ changeFile f (ConfigKey k) v = boolSystem "git"
[ Param "config"
, Param "--file"
, File f
, Param (decodeBS' k)
, Param (decodeBS' v)
, Param (decodeBS k)
, Param (decodeBS v)
]
{- Unsets a git config setting, in both the git repo,
@ -264,4 +264,4 @@ unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)
, return Nothing
)
where
ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]
ps = [Param "config", Param "--unset-all", Param (decodeBS k)]

View file

@ -31,7 +31,7 @@ getSharedRepository r =
"all" -> AllShared
"world" -> AllShared
"everybody" -> AllShared
_ -> maybe UnShared UmaskShared (readish (decodeBS' v))
_ -> maybe UnShared UmaskShared (readish (decodeBS v))
Just NoConfigValue -> UnShared
Nothing -> UnShared

View file

@ -114,7 +114,7 @@ parseDiffRaw l = go l
go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of
A.Done _ r -> r : go rest
A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err
go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL' s ++ "\""
go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL s ++ "\""
-- :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
--

View file

@ -159,7 +159,7 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
] r
findShas :: [String] -> [Sha]
findShas = catMaybes . map (extractSha . encodeBS')
findShas = catMaybes . map (extractSha . encodeBS)
. concat . map words . filter wanted
where
wanted l = not ("dangling " `isPrefixOf` l)

View file

@ -107,7 +107,7 @@ getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust
where
defaultkey = "gcrypt.participants"
parse (Just (ConfigValue "simple")) = []
parse (Just (ConfigValue b)) = words (decodeBS' b)
parse (Just (ConfigValue b)) = words (decodeBS b)
parse (Just NoConfigValue) = []
parse Nothing = []
@ -122,4 +122,4 @@ remoteSigningKey = remoteConfigKey "gcrypt-signingkey"
remoteConfigKey :: S.ByteString -> RemoteName -> ConfigKey
remoteConfigKey key remotename = ConfigKey $
"remote." <> encodeBS' remotename <> "." <> key
"remote." <> encodeBS remotename <> "." <> key

View file

@ -251,7 +251,7 @@ data Unmerged = Unmerged
unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)
unmerged l repo = guardSafeForLsFiles repo $ do
(fs, cleanup) <- pipeNullSplit params repo
return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)
return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup)
where
params =
Param "ls-files" :
@ -277,7 +277,7 @@ parseUnmerged s
then Nothing
else do
treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
sha <- extractSha (encodeBS' rawsha)
sha <- extractSha (encodeBS rawsha)
return $ InternalUnmerged (stage == 2) (toRawFilePath file)
(Just treeitemtype) (Just sha)
_ -> Nothing

View file

@ -149,7 +149,7 @@ parserLsTree long = case long of
- generated, so any size information is not included. -}
formatLsTree :: TreeItem -> S.ByteString
formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' ')))
[ encodeBS' (showOct (mode ti) "")
[ encodeBS (showOct (mode ti) "")
, typeobj ti
, fromRef' (sha ti)
] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti)))

View file

@ -82,7 +82,7 @@ branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d
dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS d
{- A Ref that can be used to refer to a file in the repository as it
- appears in a given Ref. -}
@ -177,7 +177,7 @@ tree (Ref ref) = extractSha <$$> pipeReadStrict
[ Param "rev-parse"
, Param "--verify"
, Param "--quiet"
, Param (decodeBS' ref')
, Param (decodeBS ref')
]
where
ref' = if ":" `S.isInfixOf` ref

View file

@ -37,7 +37,7 @@ remoteKeyToRemoteName :: ConfigKey -> Maybe RemoteName
remoteKeyToRemoteName (ConfigKey k)
| "remote." `S.isPrefixOf` k =
let n = S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k
in if S.null n then Nothing else Just (decodeBS' n)
in if S.null n then Nothing else Just (decodeBS n)
| otherwise = Nothing
{- Construct a legal git remote name out of an arbitrary input string.
@ -90,7 +90,7 @@ parseRemoteLocation s repo = ret $ calcloc s
| null insteadofs = l
| otherwise = replacement ++ drop (S.length bestvalue) l
where
replacement = decodeBS' $ S.drop (S.length prefix) $
replacement = decodeBS $ S.drop (S.length prefix) $
S.take (S.length bestkey - S.length suffix) bestkey
(bestkey, bestvalue) =
case maximumBy longestvalue insteadofs of

View file

@ -252,7 +252,7 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")
getAllRefs' :: FilePath -> IO [Ref]
getAllRefs' refdir = do
let topsegs = length (splitPath refdir) - 1
let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath
let toref = Ref . encodeBS . joinPath . drop topsegs . splitPath
map toref <$> dirContentsRecursive refdir
explodePackedRefsFile :: Repo -> IO ()
@ -279,8 +279,8 @@ packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"
parsePacked :: String -> Maybe (Sha, Ref)
parsePacked l = case words l of
(sha:ref:[])
| isJust (extractSha (encodeBS' sha)) && Ref.legal True ref ->
Just (Ref (encodeBS' sha), Ref (encodeBS' ref))
| isJust (extractSha (encodeBS sha)) && Ref.legal True ref ->
Just (Ref (encodeBS sha), Ref (encodeBS ref))
_ -> Nothing
{- git-branch -d cannot be used to remove a branch that is directly
@ -350,8 +350,8 @@ verifyCommit missing goodcommits commit r
where
parse l = case words l of
(commitsha:treesha:[]) -> (,)
<$> extractSha (encodeBS' commitsha)
<*> extractSha (encodeBS' treesha)
<$> extractSha (encodeBS commitsha)
<*> extractSha (encodeBS treesha)
_ -> Nothing
check [] = return True
check ((c, t):rest)
@ -469,7 +469,7 @@ preRepair g = do
where
headfile = localGitDir g P.</> "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s
|| isJust (extractSha (encodeBS' s))
|| isJust (extractSha (encodeBS s))
{- Put it all together. -}
runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch])

View file

@ -75,7 +75,7 @@ instance Default ConfigValue where
def = ConfigValue mempty
fromConfigKey :: ConfigKey -> String
fromConfigKey (ConfigKey s) = decodeBS' s
fromConfigKey (ConfigKey s) = decodeBS s
instance Show ConfigKey where
show = fromConfigKey
@ -88,16 +88,16 @@ instance FromConfigValue S.ByteString where
fromConfigValue NoConfigValue = mempty
instance FromConfigValue String where
fromConfigValue = decodeBS' . fromConfigValue
fromConfigValue = decodeBS . fromConfigValue
instance Show ConfigValue where
show = fromConfigValue
instance IsString ConfigKey where
fromString = ConfigKey . encodeBS'
fromString = ConfigKey . encodeBS
instance IsString ConfigValue where
fromString = ConfigValue . encodeBS'
fromString = ConfigValue . encodeBS
type RemoteName = String
@ -106,7 +106,7 @@ newtype Ref = Ref S.ByteString
deriving (Eq, Ord, Read, Show)
fromRef :: Ref -> String
fromRef = decodeBS' . fromRef'
fromRef = decodeBS . fromRef'
fromRef' :: Ref -> S.ByteString
fromRef' (Ref s) = s

View file

@ -80,14 +80,14 @@ lsTree (Ref x) repo streamer = do
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x]
params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x]
lsSubTree :: Ref -> FilePath -> Repo -> Streamer
lsSubTree (Ref x) p repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x, p]
params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p]
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}

4
Key.hs
View file

@ -59,13 +59,13 @@ isChunkKey :: Key -> Bool
isChunkKey k = isJust (fromKey keyChunkSize k) && isJust (fromKey keyChunkNum k)
serializeKey :: Key -> String
serializeKey = decodeBS' . serializeKey'
serializeKey = decodeBS . serializeKey'
serializeKey' :: Key -> S.ByteString
serializeKey' = keySerialization
deserializeKey :: String -> Maybe Key
deserializeKey = deserializeKey' . encodeBS'
deserializeKey = deserializeKey' . encodeBS
deserializeKey' :: S.ByteString -> Maybe Key
deserializeKey' = eitherToMaybe . A.parseOnly keyParser

View file

@ -54,7 +54,7 @@ deserializeFsckResults = deserialize . lines
deserialize ("truncated":ls) = deserialize' ls True
deserialize ls = deserialize' ls False
deserialize' ls t =
let s = S.fromList $ map (Ref . encodeBS') ls
let s = S.fromList $ map (Ref . encodeBS) ls
in if S.null s then FsckFailed else FsckFoundMissing s t
clearFsckResults :: UUID -> Annex ()

View file

@ -35,7 +35,7 @@ describeTransfer :: Transfer -> TransferInfo -> String
describeTransfer t info = unwords
[ show $ transferDirection t
, show $ transferUUID t
, decodeBS' $ actionItemDesc $ ActionItemAssociatedFile
, decodeBS $ actionItemDesc $ ActionItemAssociatedFile
(associatedFile info)
(transferKey t)
, show $ bytesComplete info

View file

@ -74,7 +74,7 @@ branchView view
| B.null name = Git.Ref branchViewPrefix
| otherwise = Git.Ref $ branchViewPrefix <> "/" <> name
where
name = encodeBS' $
name = encodeBS $
intercalate ";" $ map branchcomp (viewComponents view)
branchcomp c
| viewVisible c = branchcomp' c

View file

@ -72,18 +72,18 @@ import qualified Annex
showStart :: String -> RawFilePath -> SeekInput -> Annex ()
showStart command file si = outputMessage json $
encodeBS' command <> " " <> file <> " "
encodeBS command <> " " <> file <> " "
where
json = JSON.start command (Just file) Nothing si
showStartKey :: String -> Key -> ActionItem -> SeekInput -> Annex ()
showStartKey command key ai si = outputMessage json $
encodeBS' command <> " " <> actionItemDesc ai <> " "
encodeBS command <> " " <> actionItemDesc ai <> " "
where
json = JSON.start command (actionItemFile ai) (Just key) si
showStartOther :: String -> Maybe String -> SeekInput -> Annex ()
showStartOther command mdesc si = outputMessage json $ encodeBS' $
showStartOther command mdesc si = outputMessage json $ encodeBS $
command ++ (maybe "" (" " ++) mdesc) ++ " "
where
json = JSON.start command Nothing Nothing si
@ -116,7 +116,7 @@ showEndMessage (StartNoMessage _) = const noop
showEndMessage (CustomOutput _) = const noop
showNote :: String -> Annex ()
showNote s = outputMessage (JSON.note s) $ encodeBS' $ "(" ++ s ++ ") "
showNote s = outputMessage (JSON.note s) $ encodeBS $ "(" ++ s ++ ") "
showAction :: String -> Annex ()
showAction s = showNote $ s ++ "..."
@ -131,7 +131,7 @@ showSideAction m = Annex.getState Annex.output >>= go
Annex.changeState $ \s -> s { Annex.output = st' }
| sideActionBlock st == InBlock = return ()
| otherwise = go'
go' = outputMessage JSON.none $ encodeBS' $ "(" ++ m ++ "...)\n"
go' = outputMessage JSON.none $ encodeBS $ "(" ++ m ++ "...)\n"
showStoringStateAction :: Annex ()
showStoringStateAction = showSideAction "recording state in git"
@ -175,7 +175,7 @@ showOutput = unlessM commandProgressDisabled $
outputMessage JSON.none "\n"
showLongNote :: String -> Annex ()
showLongNote s = outputMessage (JSON.note s) (encodeBS' (formatLongNote s))
showLongNote s = outputMessage (JSON.note s) (encodeBS (formatLongNote s))
formatLongNote :: String -> String
formatLongNote s = '\n' : indent s ++ "\n"
@ -184,7 +184,7 @@ formatLongNote s = '\n' : indent s ++ "\n"
-- to console, but json object containing the info is emitted immediately.
showInfo :: String -> Annex ()
showInfo s = outputMessage' outputJSON (JSON.info s) $
encodeBS' (formatLongNote s)
encodeBS (formatLongNote s)
showEndOk :: Annex ()
showEndOk = showEndResult True

View file

@ -172,7 +172,7 @@ instance Proto.Serializable Service where
instance Proto.Serializable ProtoAssociatedFile where
serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = ""
serialize (ProtoAssociatedFile (AssociatedFile (Just af))) =
decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af
decodeBS $ toInternalGitPath $ encodeBS $ concatMap esc $ fromRawFilePath af
where
esc '%' = "%%"
esc c

View file

@ -153,7 +153,7 @@ byName' n = go . filter matching <$> remoteList
{- Finds the remote or remote group matching the name. -}
byNameOrGroup :: RemoteName -> Annex [Remote]
byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS' n))
byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS n))
where
go (Just l) = catMaybes
<$> mapM (byName . Just) (splitc ' ' (fromConfigValue l))

View file

@ -307,7 +307,7 @@ listImportableContentsM serial adir = adbfind >>= \case
mk ('S':'T':'\t':l) =
let (stat, fn) = separate (== '\t') l
sz = fromMaybe 0 (readish (takeWhile (/= ' ') stat))
cid = ContentIdentifier (encodeBS' stat)
cid = ContentIdentifier (encodeBS stat)
loc = mkImportLocation $ toRawFilePath $
Posix.makeRelative (fromAndroidPath adir) fn
in Just (loc, (cid, sz))
@ -440,7 +440,7 @@ getExportContentIdentifier serial adir loc = do
return $ case ls of
Just ["n"] -> Right Nothing
Just (('S':'T':'\t':stat):[]) -> Right $ Just $
ContentIdentifier (encodeBS' stat)
ContentIdentifier (encodeBS stat)
_ -> Left (ExitFailure 1)
where
aloc = fromAndroidPath $ androidExportLocation adir loc

View file

@ -149,7 +149,7 @@ borgLocal :: BorgRepo -> Bool
borgLocal (BorgRepo r) = notElem ':' r
borgArchive :: BorgRepo -> BorgArchiveName -> String
borgArchive (BorgRepo r) n = r ++ "::" ++ decodeBS' n
borgArchive (BorgRepo r) n = r ++ "::" ++ decodeBS n
absBorgRepo :: BorgRepo -> IO BorgRepo
absBorgRepo r@(BorgRepo p)

View file

@ -311,7 +311,7 @@ setupRepo gcryptid r
, Param tmpconfig
]
liftIO $ do
void $ Git.Config.changeFile tmpconfig coreGCryptId (encodeBS' gcryptid)
void $ Git.Config.changeFile tmpconfig coreGCryptId (encodeBS gcryptid)
void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False)
ok <- liftIO $ rsync $ opts ++
[ Param "--recursive"

View file

@ -213,7 +213,7 @@ configKnownUrl r
set k v r' = do
let k' = remoteAnnexConfig r' k
setConfig k' v
return $ Git.Config.store' k' (Git.ConfigValue (encodeBS' v)) r'
return $ Git.Config.store' k' (Git.ConfigValue (encodeBS v)) r'
data LFSHandle = LFSHandle
{ downloadEndpoint :: Maybe LFS.Endpoint

View file

@ -68,13 +68,13 @@ findSpecialRemotes s = do
(pure Git.Construct.fromUnknown)
match (ConfigKey k) _ =
"remote." `S.isPrefixOf` k
&& (".annex-" <> encodeBS' s) `S.isSuffixOf` k
&& (".annex-" <> encodeBS s) `S.isSuffixOf` k
{- Sets up configuration for a special remote in .git/config. -}
gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex ()
gitConfigSpecialRemote u c cfgs = do
forM_ cfgs $ \(k, v) ->
setConfig (remoteAnnexConfig c (encodeBS' k)) v
setConfig (remoteAnnexConfig c (encodeBS k)) v
storeUUIDIn (remoteAnnexConfig c "uuid") u
-- RetrievalVerifiableKeysSecure unless overridden by git config.

View file

@ -131,8 +131,8 @@ lookupHook hookname action = do
else return $ Just fallback
else return $ Just command
where
hook = annexConfig $ encodeBS' $ hookname ++ "-" ++ action ++ "-hook"
hookfallback = annexConfig $ encodeBS' $ hookname ++ "-hook"
hook = annexConfig $ encodeBS $ hookname ++ "-" ++ action ++ "-hook"
hookfallback = annexConfig $ encodeBS $ hookname ++ "-hook"
runHook :: HookName -> Action -> Key -> Maybe FilePath -> Annex ()
runHook hook action k f = lookupHook hook action >>= \case

View file

@ -108,7 +108,7 @@ inmainrepo a = do
with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)
with_ssh_origin cloner a = cloner $ do
let k = Git.Types.ConfigKey (encodeBS' config)
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)

View file

@ -65,7 +65,7 @@ actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp
actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $
ActionItemAssociatedFile (associatedFile i) (transferKey t)
actionItemDesc (ActionItemTreeFile f) = f
actionItemDesc (ActionItemOther s) = encodeBS' (fromMaybe "" s)
actionItemDesc (ActionItemOther s) = encodeBS (fromMaybe "" s)
actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai
actionItemKey :: ActionItem -> Maybe Key

View file

@ -476,4 +476,4 @@ remoteAnnexConfigEnd key = "annex-" <> key
{- A per-remote setting in git config. -}
remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
remoteConfig r key = ConfigKey $
"remote." <> encodeBS' (getRemoteName r) <> "." <> key
"remote." <> encodeBS (getRemoteName r) <> "." <> key

View file

@ -48,10 +48,10 @@ instance ToUUID B.ByteString where
| otherwise = UUID b
instance FromUUID String where
fromUUID s = decodeBS' (fromUUID s)
fromUUID s = decodeBS (fromUUID s)
instance ToUUID String where
toUUID s = toUUID (encodeBS' s)
toUUID s = toUUID (encodeBS s)
instance FromUUID ConfigValue where
fromUUID s = (ConfigValue (fromUUID s))

View file

@ -93,7 +93,7 @@ logFiles dir = return . filter (".log" `isSuffixOf`)
push :: Annex ()
push = do
origin_master <- inRepo $ Git.Ref.exists $
Git.Ref $ encodeBS' "origin/master"
Git.Ref $ encodeBS "origin/master"
origin_gitannex <- Annex.Branch.hasOrigin
case (origin_master, origin_gitannex) of
(_, True) -> do

View file

@ -60,7 +60,7 @@ setIndirect = do
fromDirectBranch :: Ref -> Ref
fromDirectBranch directhead = case splitc '/' $ fromRef directhead of
("refs":"heads":"annex":"direct":rest) ->
Ref $ encodeBS' $ "refs/heads/" ++ intercalate "/" rest
Ref $ encodeBS $ "refs/heads/" ++ intercalate "/" rest
_ -> directhead
switchHEADBack :: Annex ()

View file

@ -1,6 +1,6 @@
{- utilities for simple data types
-
- Copyright 2013 Joey Hess <id@joeyh.name>
- Copyright 2013-2021 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@ -10,8 +10,12 @@
module Utility.Data (
firstJust,
eitherToMaybe,
s2w8,
w82s,
) where
import Data.Word
{- First item in the list that is not Nothing. -}
firstJust :: Eq a => [Maybe a] -> Maybe a
firstJust ms = case dropWhile (== Nothing) ms of
@ -20,3 +24,15 @@ firstJust ms = case dropWhile (== Nothing) ms of
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe = either (const Nothing) Just
c2w8 :: Char -> Word8
c2w8 = fromIntegral . fromEnum
w82c :: Word8 -> Char
w82c = toEnum . fromIntegral
s2w8 :: String -> [Word8]
s2w8 = map c2w8
w82s :: [Word8] -> String
w82s = map w82c

View file

@ -34,7 +34,7 @@ newtype DebugSource = DebugSource S.ByteString
deriving (Eq, Show)
instance IsString DebugSource where
fromString = DebugSource . encodeBS'
fromString = DebugSource . encodeBS
-- | Selects whether to display a message from a source.
data DebugSelector
@ -97,6 +97,6 @@ fastDebug (DebugSelector p) src msg
formatDebugMessage :: DebugSource -> String -> IO S.ByteString
formatDebugMessage (DebugSource src) msg = do
t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]"
t <- encodeBS . formatTime defaultTimeLocale "[%F %X%Q]"
<$> getZonedTime
return (t <> " (" <> src <> ") " <> encodeBS msg)

View file

@ -1,6 +1,6 @@
{- GHC File system encoding handling.
-
- Copyright 2012-2016 Joey Hess <id@joeyh.name>
- Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@ -18,36 +18,22 @@ module Utility.FileSystemEncoding (
encodeBL,
decodeBS,
encodeBS,
decodeBL',
encodeBL',
decodeBS',
encodeBS',
truncateFilePath,
s2w8,
w82s,
c2w8,
w82c,
) where
import qualified GHC.Foreign as GHC
import qualified GHC.IO.Encoding as Encoding
import Foreign.C
import System.IO
import System.IO.Unsafe
import Data.Word
import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Unsafe (unsafePackMallocCStringLen)
#ifdef mingw32_HOST_OS
import qualified Data.ByteString.UTF8 as S8
import qualified Data.ByteString.Lazy.UTF8 as L8
#else
import Data.List
import Utility.Split
#endif
import Utility.Exception
{- Makes all subsequent Handles that are opened, as well as stdio Handles,
- use the filesystem encoding, instead of the encoding of the current
- locale.
@ -80,32 +66,10 @@ fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
fileEncoding h = hSetEncoding h Encoding.utf8
#endif
{- Encodes a FilePath into a String, applying the filesystem encoding.
-
- There are very few things it makes sense to do with such an encoded
- string. It's not a legal filename; it should not be displayed.
- So this function is not exported, but instead used by the few functions
- that can usefully consume it.
-
- This use of unsafePerformIO is belived to be safe; GHC's interface
- only allows doing this conversion with CStrings, and the CString buffer
- is allocated, used, and deallocated within the call, with no side
- effects.
-
- If the FilePath contains a value that is not legal in the filesystem
- encoding, rather than thowing an exception, it will be returned as-is.
-}
{-# NOINLINE _encodeFilePath #-}
_encodeFilePath :: FilePath -> String
_encodeFilePath fp = unsafePerformIO $ do
enc <- Encoding.getFileSystemEncoding
GHC.withCString enc fp (GHC.peekCString Encoding.char8)
`catchNonAsync` (\_ -> return fp)
{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
decodeBL :: L.ByteString -> FilePath
#ifndef mingw32_HOST_OS
decodeBL = encodeW8NUL . L.unpack
decodeBL = decodeBS . L.toStrict
#else
{- On Windows, we assume that the ByteString is utf-8, since Windows
- only uses unicode for filenames. -}
@ -115,104 +79,45 @@ decodeBL = L8.toString
{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -}
encodeBL :: FilePath -> L.ByteString
#ifndef mingw32_HOST_OS
encodeBL = L.pack . decodeW8NUL
encodeBL = L.fromStrict . encodeBS
#else
encodeBL = L8.fromString
#endif
decodeBS :: S.ByteString -> FilePath
#ifndef mingw32_HOST_OS
decodeBS = encodeW8NUL . S.unpack
-- This is a copy of code from System.FilePath.Internal.decodeFilePath.
-- However, older versions of that library truncated at NUL, which this
-- must not do, because it may end up used on something other than a unix
-- filepath.
{-# NOINLINE decodeBS #-}
decodeBS b = unsafePerformIO $ do
enc <- Encoding.getFileSystemEncoding
S.useAsCStringLen b (GHC.peekCStringLen enc)
#else
decodeBS = S8.toString
#endif
encodeBS :: FilePath -> S.ByteString
#ifndef mingw32_HOST_OS
encodeBS = S.pack . decodeW8NUL
-- This is a copy of code from System.FilePath.Internal.encodeFilePath.
-- However, older versions of that library truncated at NUL, which this
-- must not do, because it may end up used on something other than a unix
-- filepath.
{-# NOINLINE encodeBS #-}
encodeBS f = unsafePerformIO $ do
enc <- Encoding.getFileSystemEncoding
GHC.newCStringLen enc f >>= unsafePackMallocCStringLen
#else
encodeBS = S8.fromString
#endif
{- Faster version that assumes the string does not contain NUL;
- if it does it will be truncated before the NUL. -}
decodeBS' :: S.ByteString -> FilePath
#ifndef mingw32_HOST_OS
decodeBS' = encodeW8 . S.unpack
#else
decodeBS' = S8.toString
#endif
encodeBS' :: FilePath -> S.ByteString
#ifndef mingw32_HOST_OS
encodeBS' = S.pack . decodeW8
#else
encodeBS' = S8.fromString
#endif
decodeBL' :: L.ByteString -> FilePath
#ifndef mingw32_HOST_OS
decodeBL' = encodeW8 . L.unpack
#else
decodeBL' = L8.toString
#endif
encodeBL' :: FilePath -> L.ByteString
#ifndef mingw32_HOST_OS
encodeBL' = L.pack . decodeW8
#else
encodeBL' = L8.fromString
#endif
fromRawFilePath :: RawFilePath -> FilePath
fromRawFilePath = decodeFilePath
toRawFilePath :: FilePath -> RawFilePath
toRawFilePath = encodeFilePath
#ifndef mingw32_HOST_OS
{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
-
- w82s produces a String, which may contain Chars that are invalid
- unicode. From there, this is really a simple matter of applying the
- file system encoding, only complicated by GHC's interface to doing so.
-
- Note that the encoding stops at any NUL in the input. FilePaths
- cannot contain embedded NUL, but Haskell Strings may.
-}
{-# NOINLINE encodeW8 #-}
encodeW8 :: [Word8] -> FilePath
encodeW8 w8 = unsafePerformIO $ do
enc <- Encoding.getFileSystemEncoding
GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc
decodeW8 :: FilePath -> [Word8]
decodeW8 = s2w8 . _encodeFilePath
{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}
encodeW8NUL :: [Word8] -> FilePath
encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul)
where
nul = '\NUL'
decodeW8NUL :: FilePath -> [Word8]
decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul
where
nul = '\NUL'
#endif
c2w8 :: Char -> Word8
c2w8 = fromIntegral . fromEnum
w82c :: Word8 -> Char
w82c = toEnum . fromIntegral
s2w8 :: String -> [Word8]
s2w8 = map c2w8
w82s :: [Word8] -> String
w82s = map w82c
{- Truncates a FilePath to the given number of bytes (or less),
- as represented on disk.
-
@ -224,8 +129,8 @@ truncateFilePath :: Int -> FilePath -> FilePath
truncateFilePath n = go . reverse
where
go f =
let bytes = decodeW8 f
in if length bytes <= n
let b = encodeBS f
in if S.length b <= n
then reverse f
else go (drop 1 f)
#else