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:
parent
a38b724bfa
commit
fa62c98910
55 changed files with 138 additions and 217 deletions
2
Annex.hs
2
Annex.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 = []
|
||||
}
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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:
|
||||
--
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"]
|
||||
|
||||
|
|
|
@ -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)"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)]
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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>
|
||||
--
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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])
|
||||
|
|
10
Git/Types.hs
10
Git/Types.hs
|
@ -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
|
||||
|
|
|
@ -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
4
Key.hs
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
14
Messages.hs
14
Messages.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue