From fa62c98910746c2c5dda21b3f80effc147a04f65 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 10 Aug 2021 20:45:02 -0400 Subject: [PATCH] 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 --- Annex.hs | 2 +- Annex/MetaData.hs | 6 +- Annex/UUID.hs | 2 +- Assistant/Threads/Merger.hs | 2 +- Assistant/Threads/Watcher.hs | 2 +- Assistant/WebApp/Configurators/Edit.hs | 2 +- Backend/External.hs | 2 +- Backend/Utilities.hs | 4 +- CmdLine/Option.hs | 4 +- Command/Config.hs | 8 +- Command/DiffDriver.hs | 2 +- Command/FindRef.hs | 2 +- Command/Fsck.hs | 14 +-- Command/Import.hs | 2 +- Command/Info.hs | 8 +- Command/Log.hs | 2 +- Command/Merge.hs | 2 +- Command/Uninit.hs | 2 +- Command/Vicfg.hs | 2 +- Config.hs | 2 +- Database/Types.hs | 4 +- Git/Config.hs | 8 +- Git/ConfigTypes.hs | 2 +- Git/DiffTree.hs | 2 +- Git/Fsck.hs | 2 +- Git/GCrypt.hs | 4 +- Git/LsFiles.hs | 4 +- Git/LsTree.hs | 2 +- Git/Ref.hs | 4 +- Git/Remote.hs | 4 +- Git/Repair.hs | 12 +-- Git/Types.hs | 10 +- Git/UpdateIndex.hs | 4 +- Key.hs | 4 +- Logs/FsckResults.hs | 2 +- Logs/Transfer.hs | 2 +- Logs/View.hs | 2 +- Messages.hs | 14 +-- P2P/Protocol.hs | 2 +- Remote.hs | 2 +- Remote/Adb.hs | 4 +- Remote/Borg.hs | 2 +- Remote/GCrypt.hs | 2 +- Remote/GitLFS.hs | 2 +- Remote/Helper/Special.hs | 4 +- Remote/Hook.hs | 4 +- Test/Framework.hs | 2 +- Types/ActionItem.hs | 2 +- Types/GitConfig.hs | 2 +- Types/UUID.hs | 4 +- Upgrade/V2.hs | 2 +- Upgrade/V5/Direct.hs | 2 +- Utility/Data.hs | 18 +++- Utility/Debug.hs | 4 +- Utility/FileSystemEncoding.hs | 139 ++++--------------------- 55 files changed, 138 insertions(+), 217 deletions(-) diff --git a/Annex.hs b/Annex.hs index 4d3786cc9b..cc2f8b1607 100644 --- a/Annex.hs +++ b/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 diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs index e821101c0a..a21cdd601f 100644 --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -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 diff --git a/Annex/UUID.hs b/Annex/UUID.hs index e85062e438..872fb9091a 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -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. diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 04d1a135b2..a7897086a8 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -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 diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 72ff1233a4..b1346a9723 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -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 -> diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 14856e5aa7..c430697097 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -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 $ diff --git a/Backend/External.hs b/Backend/External.hs index bd4ac5ef05..c353e049c7 100644 --- a/Backend/External.hs +++ b/Backend/External.hs @@ -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 diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs index ad9b142ab9..7121d4f2f5 100644 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -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 diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index 8f31060112..bf54189c5d 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -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" diff --git a/Command/Config.hs b/Command/Config.hs index 4a408ab742..9313ea1b5c 100644 --- a/Command/Config.hs +++ b/Command/Config.hs @@ -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 diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs index 9dc8c5b26b..9b1e3ec512 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -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) diff --git a/Command/FindRef.hs b/Command/FindRef.hs index 27dfcbe07a..f332923309 100644 --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -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 = [] } diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 1e2ea3801c..5ab724362f 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -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] diff --git a/Command/Import.hs b/Command/Import.hs index d133d0f306..b0a1b0898a 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -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 diff --git a/Command/Info.hs b/Command/Info.hs index 36c7a88cb9..2d97603e9b 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -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 diff --git a/Command/Log.hs b/Command/Log.hs index b46749d9ba..b4d99b5f72 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -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: -- diff --git a/Command/Merge.hs b/Command/Merge.hs index e7523f6252..ad5dce3453 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -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 diff --git a/Command/Uninit.hs b/Command/Uninit.hs index ac206594ed..473040c2c4 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -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"] diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 443570eb85..323ed22241 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -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)" diff --git a/Config.hs b/Config.hs index 5dd65cdff3..0af6810e31 100644 --- a/Config.hs +++ b/Config.hs @@ -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 diff --git a/Database/Types.hs b/Database/Types.hs index 561972284a..7b317ce6ac 100644 --- a/Database/Types.hs +++ b/Database/Types.hs @@ -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 diff --git a/Git/Config.hs b/Git/Config.hs index 20ddf790d8..7b3678aaa7 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -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)] diff --git a/Git/ConfigTypes.hs b/Git/ConfigTypes.hs index 1f8f9455b3..3ec43be6a5 100644 --- a/Git/ConfigTypes.hs +++ b/Git/ConfigTypes.hs @@ -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 diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs index 273b9427e0..fde223ddf3 100644 --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -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 ++ "\"" -- : SP SP SP SP -- diff --git a/Git/Fsck.hs b/Git/Fsck.hs index de11e89af4..4544c1312f 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -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) diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs index c6a83313ef..c7e5df47f0 100644 --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -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 diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 297c068284..aff408deb6 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -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 diff --git a/Git/LsTree.hs b/Git/LsTree.hs index a49c4eaa78..fb3b3e171b 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -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))) diff --git a/Git/Ref.hs b/Git/Ref.hs index 6929a8ee91..a26e32fb49 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -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 diff --git a/Git/Remote.hs b/Git/Remote.hs index 8f5d99f0d4..80acccaf4c 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -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 diff --git a/Git/Repair.hs b/Git/Repair.hs index d221fa6335..f41677a0d9 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -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]) diff --git a/Git/Types.hs b/Git/Types.hs index db1c71b8f1..68045fc027 100644 --- a/Git/Types.hs +++ b/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 diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 8e406b1ed7..74816a665a 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -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. -} diff --git a/Key.hs b/Key.hs index 529c7b7b0d..4d31dcda36 100644 --- a/Key.hs +++ b/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 diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs index 1ade47d733..017941d370 100644 --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -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 () diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index be6cc87b86..bfee177543 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -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 diff --git a/Logs/View.hs b/Logs/View.hs index f76a9b9ec2..4a021b64fe 100644 --- a/Logs/View.hs +++ b/Logs/View.hs @@ -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 diff --git a/Messages.hs b/Messages.hs index bc81fd88fb..f261862ace 100644 --- a/Messages.hs +++ b/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 diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index 353167406d..cd7f24d863 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -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 diff --git a/Remote.hs b/Remote.hs index 588457f728..b3207bd6d1 100644 --- a/Remote.hs +++ b/Remote.hs @@ -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)) diff --git a/Remote/Adb.hs b/Remote/Adb.hs index d023d6f25d..5114fa465e 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -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 diff --git a/Remote/Borg.hs b/Remote/Borg.hs index 1a30c5385a..3cf4888448 100644 --- a/Remote/Borg.hs +++ b/Remote/Borg.hs @@ -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) diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 3d710e40f8..c224a14bec 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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" diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index c9d0cc2633..0ceddd3d3a 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -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 diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index e7e0243cd4..dc5689e028 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -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. diff --git a/Remote/Hook.hs b/Remote/Hook.hs index ab3f53524a..23ab1f5729 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -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 diff --git a/Test/Framework.hs b/Test/Framework.hs index 626302b248..f5b380f26f 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -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) diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs index b5d52f5401..e797969b79 100644 --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -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 diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index c058fc1619..70c24cccfc 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -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 diff --git a/Types/UUID.hs b/Types/UUID.hs index b15fc39d7e..3e59fc685c 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -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)) diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index 091655d19d..6ba538634a 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -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 diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index e1c8ac4e41..9903f84d07 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -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 () diff --git a/Utility/Data.hs b/Utility/Data.hs index 55108457d6..faf9b34ecc 100644 --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -1,6 +1,6 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013-2021 Joey Hess - - 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 diff --git a/Utility/Debug.hs b/Utility/Debug.hs index e0be9c9254..6e6e701162 100644 --- a/Utility/Debug.hs +++ b/Utility/Debug.hs @@ -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) diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 4690d5fa63..b58f4438a1 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2016 Joey Hess + - Copyright 2012-2021 Joey Hess - - 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