git-repair 1.20200102 → 1.20200504
raw patch · 34 files changed
+974/−242 lines, 34 files
Files
- Build/Configure.hs +0/−1
- CHANGELOG +8/−0
- COPYRIGHT +36/−3
- Git.hs +1/−0
- Git/Branch.hs +12/−10
- Git/CatFile.hs +48/−41
- Git/Command.hs +7/−2
- Git/Config.hs +45/−28
- Git/DiffTreeItem.hs +4/−3
- Git/FilePath.hs +1/−1
- Git/Fsck.hs +2/−1
- Git/HashObject.hs +2/−1
- Git/LsFiles.hs +116/−30
- Git/LsTree.hs +2/−3
- Git/Objects.hs +1/−1
- Git/Ref.hs +32/−22
- Git/RefLog.hs +4/−1
- Git/Remote.hs +10/−5
- Git/Repair.hs +29/−25
- Git/Sha.hs +47/−16
- Git/Types.hs +24/−6
- Git/UpdateIndex.hs +4/−4
- Utility/CoProcess.hs +1/−0
- Utility/Directory.hs +78/−3
- Utility/FileSystemEncoding.hs +3/−12
- Utility/HumanTime.hs +3/−2
- Utility/InodeCache.hs +307/−0
- Utility/Misc.hs +8/−0
- Utility/Path.hs +13/−4
- Utility/Process.hs +6/−10
- Utility/RawFilePath.hs +50/−0
- Utility/TimeStamp.hs +58/−0
- git-repair.1 +1/−1
- git-repair.cabal +11/−6
Build/Configure.hs view
@@ -4,7 +4,6 @@ module Build.Configure where -import System.Environment import Control.Monad.IfElse import Control.Applicative import Prelude
CHANGELOG view
@@ -1,3 +1,11 @@+git-repair (1.20200504) unstable; urgency=medium++ * Fix a few documentation typos.+ * Improve fetching from a remote with an url in host:path format.+ * Merge from git-annex.++ -- Joey Hess <id@joeyh.name> Mon, 04 May 2020 15:38:53 -0400+ git-repair (1.20200102) unstable; urgency=medium * Relicensed AGPL.
COPYRIGHT view
@@ -1,14 +1,19 @@-Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/-Source: native package+Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/+Source: git://git-repair.branchable.com/ Files: * Copyright: © 2013-2019 Joey Hess <joey@kitenet.net> License: AGPL-3+ Files: Utility/*-Copyright: 2012-2019 Joey Hess <joey@kitenet.net>+Copyright: 2012-2014 Joey Hess <joey@kitenet.net> License: BSD-2-clause +Files: Utility/Attoparsec.hs+Copyright: (C) 2019 Joey Hess <id@joeyh.name>+ (C) 2007-2015 Bryan O'Sullivan+License: BSD-3-clause+ License: BSD-2-clause Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions@@ -30,6 +35,34 @@ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++License: BSD-3-clause+ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:+ .+ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ .+ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ .+ 3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.+ .+ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+ POSSIBILITY OF SUCH DAMAGE. License: AGPL-3+ GNU AFFERO GENERAL PUBLIC LICENSE
Git.hs view
@@ -14,6 +14,7 @@ Repo(..), Ref(..), fromRef,+ fromRef', Branch, Sha, Tag,
Git/Branch.hs view
@@ -18,6 +18,7 @@ import qualified Git.Ref import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8 {- The currently checked out branch. -@@ -39,25 +40,27 @@ {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch)-currentUnsafe r = parse . firstLine'- <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r+currentUnsafe r = parse . firstLine' <$> pipeReadStrict+ [ Param "symbolic-ref"+ , Param "-q"+ , Param $ fromRef Git.Ref.headRef+ ] r where parse b | B.null b = Nothing- | otherwise = Just $ Git.Ref $ decodeBS b+ | otherwise = Just $ Git.Ref b {- Checks if the second branch has any commits not present on the first - branch. -} changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False- | otherwise = not . null+ | otherwise = not . B.null <$> changed' origbranch newbranch [Param "-n1"] repo where -changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String-changed' origbranch newbranch extraps repo =- decodeBS <$> pipeReadStrict ps repo+changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString+changed' origbranch newbranch extraps repo = pipeReadStrict ps repo where ps = [ Param "log"@@ -68,7 +71,7 @@ {- Lists commits that are in the second branch and not in the first branch. -} changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] changedCommits origbranch newbranch extraps repo = - catMaybes . map extractSha . lines+ catMaybes . map extractSha . B8.lines <$> changed' origbranch newbranch extraps repo {- Check if it's possible to fast-forward from the old@@ -163,8 +166,7 @@ -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do- tree <- getSha "write-tree" $- decodeBS' <$> pipeReadStrict [Param "write-tree"] repo+ tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo
Git/CatFile.hs view
@@ -1,10 +1,12 @@ {- git cat-file interface -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-}+ module Git.CatFile ( CatFileHandle, catFileStart,@@ -22,7 +24,9 @@ import System.IO import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Char8 as S8+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A8 import qualified Data.Map as M import Data.String import Data.Char@@ -69,11 +73,11 @@ {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $- fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)+ fromRef' branch <> ":" <> toInternalGitPath file catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $- fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)+ fromRef' branch <> ":" <> toInternalGitPath file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -}@@ -82,9 +86,9 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do- header <- hGetLine from+ header <- S8.hGetLine from case parseResp object header of- Just (ParsedResp sha size objtype) -> do+ Just (ParsedResp sha objtype size) -> do content <- S.hGet from (fromIntegral size) eatchar '\n' from return $ Just (L.fromChunks [content], sha, objtype)@@ -112,9 +116,9 @@ {- Gets the size and type of an object, without reading its content. -} catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do- resp <- hGetLine from+ resp <- S8.hGetLine from case parseResp object resp of- Just (ParsedResp sha size objtype) ->+ Just (ParsedResp sha objtype size) -> return $ Just (sha, size, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)@@ -126,37 +130,40 @@ objtype <- queryObjectType object (gitRepo h) return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE+data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE+ deriving (Show) query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a query hdl object newlinefallback receive -- git cat-file --batch uses a line based protocol, so when the -- filename itself contains a newline, have to fall back to another -- method of getting the information.- | '\n' `elem` s = newlinefallback+ | '\n' `S8.elem` s = newlinefallback -- git strips carriage return from the end of a line, out of some -- misplaced desire to support windows, so also use the newline -- fallback for those.- | "\r" `isSuffixOf` s = newlinefallback+ | "\r" `S8.isSuffixOf` s = newlinefallback | otherwise = CoProcess.query hdl send receive where- send to = hPutStrLn to s- s = fromRef object+ send to = S8.hPutStrLn to s+ s = fromRef' object -parseResp :: Ref -> String -> Maybe ParsedResp-parseResp object l - | " missing" `isSuffixOf` l -- less expensive than full check- && l == fromRef object ++ " missing" = Just DNE- | otherwise = case words l of- [sha, objtype, size]- | length sha == shaSize ->- case (readObjectType (encodeBS objtype), reads size) of- (Just t, [(bytes, "")]) -> - Just $ ParsedResp (Ref sha) bytes t- _ -> Nothing- | otherwise -> Nothing- _ -> Nothing+parseResp :: Ref -> S.ByteString -> Maybe ParsedResp+parseResp object s+ | " missing" `S.isSuffixOf` s -- less expensive than full check+ && s == fromRef' object <> " missing" = Just DNE+ | otherwise = eitherToMaybe $ A.parseOnly respParser s +respParser :: A.Parser ParsedResp+respParser = ParsedResp+ <$> (maybe (fail "bad sha") return . extractSha =<< nextword)+ <* A8.char ' '+ <*> (maybe (fail "bad object type") return . readObjectType =<< nextword)+ <* A8.char ' '+ <*> A8.decimal+ where+ nextword = A8.takeTill (== ' ')+ querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a) querySingle o r repo reader = assertLocal repo $ -- In non-batch mode, git cat-file warns on stderr when@@ -219,39 +226,39 @@ catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) catCommit h commitref = go <$> catObjectDetails h commitref where- go (Just (b, _, CommitObject)) = parseCommit b+ go (Just (b, _, CommitObject)) = parseCommit (L.toStrict b) go _ = Nothing -parseCommit :: L.ByteString -> Maybe Commit+parseCommit :: S.ByteString -> Maybe Commit parseCommit b = Commit- <$> (extractSha . L8.unpack =<< field "tree")- <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent"))+ <$> (extractSha =<< field "tree")+ <*> Just (maybe [] (mapMaybe extractSha) (fields "parent")) <*> (parsemetadata <$> field "author") <*> (parsemetadata <$> field "committer")- <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message)+ <*> Just (decodeBS $ S.intercalate (S.singleton nl) message) where field n = headMaybe =<< fields n fields n = M.lookup (fromString n) fieldmap fieldmap = M.fromListWith (++) ((map breakfield) header) breakfield l =- let (k, sp_v) = L.break (== sp) l- in (k, [L.drop 1 sp_v])- (header, message) = separate L.null ls- ls = L.split nl b+ let (k, sp_v) = S.break (== sp) l+ in (k, [S.drop 1 sp_v])+ (header, message) = separate S.null ls+ ls = S.split nl b -- author and committer lines have the form: "name <email> date" -- The email is always present, even if empty "<>" parsemetadata l = CommitMetaData- { commitName = whenset $ L.init name_sp+ { commitName = whenset $ S.init name_sp , commitEmail = whenset email- , commitDate = whenset $ L.drop 2 gt_sp_date+ , commitDate = whenset $ S.drop 2 gt_sp_date } where- (name_sp, rest) = L.break (== lt) l- (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest)+ (name_sp, rest) = S.break (== lt) l+ (email, gt_sp_date) = S.break (== gt) (S.drop 1 rest) whenset v- | L.null v = Nothing- | otherwise = Just (L8.unpack v)+ | S.null v = Nothing+ | otherwise = Just (decodeBS v) nl = fromIntegral (ord '\n') sp = fromIntegral (ord ' ')
Git/Command.hs view
@@ -81,11 +81,16 @@ {- Runs a git command, feeding it an input, and returning its output, - which is expected to be fairly small, since it's all read into memory - strictly. -}-pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String+pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO S.ByteString pipeWriteRead params writer repo = assertLocal repo $ writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo) - (gitEnv repo) writer (Just adjusthandle)+ (gitEnv repo) writer' where+ writer' = case writer of+ Nothing -> Nothing+ Just a -> Just $ \h -> do+ adjusthandle h+ a h adjusthandle h = hSetNewlineMode h noNewlineTranslation {- Runs a git command, feeding it input on a handle with an action. -}
Git/Config.hs view
@@ -1,6 +1,6 @@ {- git repository configuration handling -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -14,6 +14,7 @@ import qualified Data.ByteString.Char8 as S8 import Data.Char import qualified System.FilePath.ByteString as P+import Control.Concurrent.Async import Common import Git@@ -58,7 +59,7 @@ go Repo { location = LocalUnknown d } = git_config d go _ = assertLocal repo $ error "internal" git_config d = withHandle StdoutHandle createProcessSuccess p $- hRead repo+ hRead repo ConfigNullList where params = ["config", "--null", "--list"] p = (proc "git" params)@@ -73,7 +74,7 @@ ifM (doesFileExist $ home </> ".gitconfig") ( do repo <- withHandle StdoutHandle createProcessSuccess p $- hRead (Git.Construct.fromUnknown)+ hRead (Git.Construct.fromUnknown) ConfigNullList return $ Just repo , return Nothing )@@ -82,18 +83,18 @@ p = (proc "git" params) {- Reads git config from a handle and populates a repo with it. -}-hRead :: Repo -> Handle -> IO Repo-hRead repo h = do+hRead :: Repo -> ConfigStyle -> Handle -> IO Repo+hRead repo st h = do val <- S.hGetContents h- store val repo+ store val st repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -}-store :: S.ByteString -> Repo -> IO Repo-store s repo = do- let c = parse s+store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo+store s st repo = do+ let c = parse s st updateLocation $ repo { config = (M.map Prelude.head c) `M.union` config repo , fullconfig = M.unionWith (++) c (fullconfig repo)@@ -134,27 +135,30 @@ top <- absPath $ fromRawFilePath (gitdir l) let p = absPathFrom top (fromRawFilePath d) return $ l { worktree = Just (toRawFilePath p) }+ Just NoConfigValue -> return l return $ r { location = l' } +data ConfigStyle = ConfigList | ConfigNullList+ {- Parses git config --list or git config --null --list output into a - config map. -}-parse :: S.ByteString -> M.Map ConfigKey [ConfigValue]-parse s+parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue]+parse s st | S.null s = M.empty- -- --list output will have a '=' in the first line- -- (The first line of --null --list output is the name of a key,- -- which is assumed to never contain '='.)- | S.elem eq firstline = sep eq $ S.split nl s- -- --null --list output separates keys from values with newlines- | otherwise = sep nl $ S.split 0 s+ | otherwise = case st of+ ConfigList -> sep eq $ S.split nl s+ ConfigNullList -> sep nl $ S.split 0 s where nl = fromIntegral (ord '\n') eq = fromIntegral (ord '=')- firstline = S.takeWhile (/= nl) s sep c = M.fromListWith (++)- . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) + . map (\(k,v) -> (ConfigKey k, [mkval v])) . map (S.break (== c))+ + mkval v + | S.null v = NoConfigValue+ | otherwise = ConfigValue (S.drop 1 v) {- Checks if a string from git config is a true/false value. -} isTrueFalse :: String -> Maybe Bool@@ -162,11 +166,21 @@ isTrueFalse' :: ConfigValue -> Maybe Bool isTrueFalse' (ConfigValue s)+ | s' == "yes" = Just True+ | s' == "on" = Just True | s' == "true" = Just True+ | s' == "1" = Just True++ | s' == "no" = Just False+ | s' == "off" = Just False | s' == "false" = Just False+ | s' == "0" = Just False+ | s' == "" = Just False+ | otherwise = Nothing where s' = S8.map toLower s+isTrueFalse' NoConfigValue = Just True boolConfig :: Bool -> String boolConfig True = "true"@@ -184,25 +198,28 @@ {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw- - output of the command. -}-fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString))-fromPipe r cmd params = try $- withHandle StdoutHandle createProcessSuccess p $ \h -> do- val <- S.hGetContents h- r' <- store val r- return (r', val)+ - output and any standard output of the command. -}+fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString))+fromPipe r cmd params st = try $+ withOEHandles createProcessSuccess p $ \(hout, herr) -> do+ geterr <- async $ S.hGetContents herr+ getval <- async $ S.hGetContents hout+ val <- wait getval+ err <- wait geterr+ r' <- store val st r+ return (r', val, err) where p = proc cmd $ toCommand params {- Reads git config from a specified file and returns the repo populated - with the configuration. -}-fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString))+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" , File f , Param "--list"- ]+ ] ConfigList {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -}
Git/DiffTreeItem.hs view
@@ -10,6 +10,7 @@ ) where import System.Posix.Types+import qualified Data.ByteString as S import Git.FilePath import Git.Types@@ -17,8 +18,8 @@ data DiffTreeItem = DiffTreeItem { srcmode :: FileMode , dstmode :: FileMode- , srcsha :: Sha -- nullSha if file was added- , dstsha :: Sha -- nullSha if file was deleted- , status :: String+ , srcsha :: Sha -- null sha if file was added+ , dstsha :: Sha -- null sha if file was deleted+ , status :: S.ByteString , file :: TopFilePath } deriving Show
Git/FilePath.hs view
@@ -50,7 +50,7 @@ {- Git uses the branch:file form to refer to a BranchFilePath -} descBranchFilePath :: BranchFilePath -> S.ByteString descBranchFilePath (BranchFilePath b f) =- encodeBS' (fromRef b) <> ":" <> getTopFilePath f+ fromRef' b <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
Git/Fsck.hs view
@@ -139,7 +139,8 @@ ] r findShas :: [String] -> [Sha]-findShas = catMaybes . map extractSha . concat . map words . filter wanted+findShas = catMaybes . map (extractSha . encodeBS') + . concat . map words . filter wanted where wanted l = not ("dangling " `isPrefixOf` l)
Git/HashObject.hs view
@@ -18,6 +18,7 @@ import Utility.Tmp import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder @@ -39,7 +40,7 @@ hashFile h file = CoProcess.query h send receive where send to = hPutStrLn to =<< absPath file- receive from = getSha "hash-object" $ hGetLine from+ receive from = getSha "hash-object" $ S8.hGetLine from class HashableBlob t where hashableBlobToHandle :: Handle -> t -> IO ()
Git/LsFiles.hs view
@@ -1,6 +1,6 @@ {- git ls-files interface -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -24,6 +24,7 @@ Unmerged(..), unmerged, StagedDetails,+ inodeCaches, ) where import Common@@ -31,17 +32,45 @@ import Git.Command import Git.Types import Git.Sha+import Utility.InodeCache+import Utility.TimeStamp import Numeric+import Data.Char import System.Posix.Types-import qualified Data.ByteString.Lazy as L+import qualified Data.Map as M+import qualified Data.ByteString as S -{- Scans for files that are checked into git's index at the specified locations. -}+{- It's only safe to use git ls-files on the current repo, not on a remote.+ -+ - Git has some strange behavior when git ls-files is used with repos+ - that are not the one that the cwd is in:+ - git --git-dir=../foo/.git --worktree=../foo ../foo fails saying + - "../foo is outside repository".+ - That does not happen when an absolute path is provided.+ -+ - Also, the files output by ls-files are relative to the cwd. + - Unless it's run on remote. Then it's relative to the top of the remote+ - repo.+ -+ - So, best to avoid that class of problems.+ -}+safeForLsFiles :: Repo -> Bool+safeForLsFiles r = isNothing (remoteName r)++guardSafeForLsFiles :: Repo -> IO a -> IO a+guardSafeForLsFiles r a+ | safeForLsFiles r = a+ | otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r++{- Lists files that are checked into git's index at the specified paths.+ - With no paths, all files are listed.+ -} inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepo = inRepo' [] inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-inRepo' ps l repo = pipeNullSplit' params repo+inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" :@@ -53,14 +82,15 @@ {- Files that are checked into the index or have been committed to a - branch. -} inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b]+inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b] {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo = notInRepo' [] notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-notInRepo' ps include_ignored l repo = pipeNullSplit' params repo+notInRepo' ps include_ignored l repo = guardSafeForLsFiles repo $+ pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"]@@ -81,18 +111,20 @@ {- Finds all files in the specified locations, whether checked into git or - not. -} allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-allFiles l = pipeNullSplit' $- Param "ls-files" :- Param "--cached" :- Param "--others" :- Param "-z" :- Param "--" :- map (File . fromRawFilePath) l+allFiles l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo+ where+ params =+ Param "ls-files" :+ Param "--cached" :+ Param "--others" :+ Param "-z" :+ Param "--" :+ map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-deleted l repo = pipeNullSplit' params repo+deleted l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" :@@ -104,7 +136,7 @@ {- Returns a list of files in the specified locations that have been - modified. -} modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-modified l repo = pipeNullSplit' params repo+modified l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" :@@ -116,7 +148,7 @@ {- Files that have been modified or are not checked into git (and are not - ignored). -} modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-modifiedOthers l repo = pipeNullSplit' params repo+modifiedOthers l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo where params = Param "ls-files" :@@ -137,7 +169,8 @@ stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo+staged' ps l repo = guardSafeForLsFiles repo $+ pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map (File . fromRawFilePath) l@@ -156,20 +189,23 @@ {- Gets details about staged files, including the Sha of their staged - contents. -} stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)-stagedDetails' ps l repo = do- (ls, cleanup) <- pipeNullSplit params repo- return (map parse ls, cleanup)+stagedDetails' ps l repo = guardSafeForLsFiles repo $ do+ (ls, cleanup) <- pipeNullSplit' params repo+ return (map parseStagedDetails ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l- parse s- | null file = (L.toStrict s, Nothing, Nothing)- | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode)- where- (metadata, file) = separate (== '\t') (decodeBL' s)- (mode, rest) = separate (== ' ') metadata- readmode = fst <$$> headMaybe . readOct +parseStagedDetails :: S.ByteString -> StagedDetails+parseStagedDetails s+ | S.null file = (s, Nothing, Nothing)+ | otherwise = (file, extractSha sha, readmode mode)+ where+ (metadata, file) = separate' (== fromIntegral (ord '\t')) s+ (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata+ (sha, _) = separate' (== fromIntegral (ord ' ')) metadata'+ readmode = fst <$$> headMaybe . readOct . decodeBS'+ {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)@@ -181,7 +217,7 @@ typeChanged = typeChanged' [] typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-typeChanged' ps l repo = do+typeChanged' ps l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files.@@ -221,7 +257,7 @@ - If a line is omitted, that side removed the file. -} unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)-unmerged l repo = do+unmerged l repo = guardSafeForLsFiles repo $ do (fs, cleanup) <- pipeNullSplit params repo return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where@@ -249,7 +285,7 @@ then Nothing else do treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)- sha <- extractSha rawsha+ sha <- extractSha (encodeBS' rawsha) return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing@@ -278,3 +314,53 @@ , itreeitemtype = Nothing , isha = Nothing }++{- Gets the InodeCache equivilant information stored in the git index.+ -+ - Note that this uses a --debug option whose output could change at some+ - point in the future. If the output is not as expected, will use Nothing.+ -}+inodeCaches :: [RawFilePath] -> Repo -> IO ([(FilePath, Maybe InodeCache)], IO Bool)+inodeCaches locs repo = guardSafeForLsFiles repo $ do+ (ls, cleanup) <- pipeNullSplit params repo+ return (parse Nothing (map decodeBL ls), cleanup)+ where+ params = + Param "ls-files" :+ Param "--cached" :+ Param "-z" :+ Param "--debug" :+ Param "--" :+ map (File . fromRawFilePath) locs+ + parse Nothing (f:ls) = parse (Just f) ls+ parse (Just f) (s:[]) = + let i = parsedebug s+ in (f, i) : []+ parse (Just f) (s:ls) =+ let (d, f') = splitdebug s+ i = parsedebug d+ in (f, i) : parse (Just f') ls+ parse _ _ = []++ -- First 5 lines are --debug output, remainder is the next filename.+ -- This assumes that --debug does not start outputting more lines.+ splitdebug s = case splitc '\n' s of+ (d1:d2:d3:d4:d5:rest) ->+ ( intercalate "\n" [d1, d2, d3, d4, d5]+ , intercalate "\n" rest+ )+ _ -> ("", s)+ + -- This parser allows for some changes to the --debug output,+ -- including reordering, or adding more items.+ parsedebug s = do+ let l = words s+ let iskey v = ":" `isSuffixOf` v+ let m = M.fromList $ zip+ (filter iskey l)+ (filter (not . iskey) l)+ mkInodeCache+ <$> (readish =<< M.lookup "ino:" m)+ <*> (readish =<< M.lookup "size:" m)+ <*> (parsePOSIXTime =<< (replace ":" "." <$> M.lookup "mtime:" m))
Git/LsTree.hs view
@@ -21,7 +21,6 @@ import Common import Git import Git.Command-import Git.Sha import Git.FilePath import qualified Git.Filename import Utility.Attoparsec@@ -94,10 +93,10 @@ <$> octal <* A8.char ' ' -- type- <*> A.takeTill (== 32)+ <*> A8.takeTill (== ' ') <* A8.char ' ' -- sha- <*> (Ref . decodeBS' <$> A.take shaSize)+ <*> (Ref <$> A8.takeTill (== '\t')) <* A8.char '\t' -- file <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
Git/Objects.hs view
@@ -26,7 +26,7 @@ listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas r = catchDefaultIO [] $- mapMaybe (extractSha . concat . reverse . take 2 . reverse . splitDirectories)+ mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) <$> dirContentsRecursiveSkipping (== "pack") True (objectsDir r) looseObjectFile :: Repo -> Sha -> FilePath
Git/Ref.hs view
@@ -17,6 +17,7 @@ import Data.Char (chr, ord) import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 headRef :: Ref headRef = Ref "HEAD"@@ -25,7 +26,7 @@ headFile r = fromRawFilePath (localGitDir r) </> "HEAD" setHeadRef :: Ref -> Repo -> IO ()-setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)+setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref) {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String@@ -41,10 +42,11 @@ {- Removes a directory such as "refs/heads/master" from a - fully qualified ref. Any ref not starting with it is left as-is. -} removeBase :: String -> Ref -> Ref-removeBase dir (Ref r)- | prefix `isPrefixOf` r = Ref (drop (length prefix) r)- | otherwise = Ref r+removeBase dir r+ | prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs+ | otherwise = r where+ rs = fromRef r prefix = case end dir of ['/'] -> dir _ -> dir ++ "/"@@ -53,7 +55,7 @@ - refs/heads/master, yields a version of that ref under the directory, - such as refs/remotes/origin/master. -} underBase :: String -> Ref -> Ref-underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)+underBase dir r = Ref $ encodeBS dir <> "/" <> fromRef' (base r) {- Convert a branch such as "master" into a fully qualified ref. -} branchRef :: Branch -> Ref@@ -66,21 +68,25 @@ - of a repo. -} fileRef :: RawFilePath -> Ref-fileRef f = Ref $ ":./" ++ fromRawFilePath f+fileRef f = Ref $ ":./" <> f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref-dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ 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. -} fileFromRef :: Ref -> RawFilePath -> Ref-fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)+fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' r <> fr) {- Checks if a ref exists. -} exists :: Ref -> Repo -> IO Bool exists ref = runBool- [Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]+ [ Param "show-ref"+ , Param "--verify"+ , Param "-q"+ , Param $ fromRef ref+ ] {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -}@@ -107,26 +113,26 @@ ] process s | S.null s = Nothing- | otherwise = Just $ Ref $ decodeBS' $ firstLine' s+ | otherwise = Just $ Ref $ firstLine' s headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef {- List of (shas, branches) matching a given ref or refs. -} matching :: [Ref] -> Repo -> IO [(Sha, Branch)]-matching refs repo = matching' (map fromRef refs) repo+matching = matching' [] {- Includes HEAD in the output, if asked for it. -} matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]-matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo+matchingWithHEAD = matching' [Param "--head"] -{- List of (shas, branches) matching a given ref spec. -}-matching' :: [String] -> Repo -> IO [(Sha, Branch)]-matching' ps repo = map gen . lines . decodeBS' <$> - pipeReadStrict (Param "show-ref" : map Param ps) repo+matching' :: [CommandParam] -> [Ref] -> Repo -> IO [(Sha, Branch)]+matching' ps rs repo = map gen . S8.lines <$> + pipeReadStrict (Param "show-ref" : ps ++ rps) repo where- gen l = let (r, b) = separate (== ' ') l+ gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l in (Ref r, Ref b)+ rps = map (Param . fromRef) rs {- List of (shas, branches) matching a given ref. - Duplicate shas are filtered out. -}@@ -137,7 +143,7 @@ {- List of all refs. -} list :: Repo -> IO [(Sha, Ref)]-list = matching' []+list = matching' [] [] {- Deletes a ref. This can delete refs that are not branches, - which git branch --delete refuses to delete. -}@@ -154,13 +160,17 @@ - The ref may be something like a branch name, and it could contain - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha)-tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict- [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ]+tree (Ref ref) = extractSha <$$> pipeReadStrict+ [ Param "rev-parse"+ , Param "--verify"+ , Param "--quiet"+ , Param (decodeBS' ref')+ ] where- ref' = if ":" `isInfixOf` ref+ ref' = if ":" `S.isInfixOf` ref then ref -- de-reference commit objects to the tree- else ref ++ ":"+ else ref <> ":" {- Checks if a String is a legal git ref name. -
Git/RefLog.hs view
@@ -12,6 +12,9 @@ import Git.Command import Git.Sha +import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+ {- Gets the reflog for a given branch. -} get :: Branch -> Repo -> IO [Sha] get b = getMulti [b]@@ -21,7 +24,7 @@ getMulti bs = get' (map (Param . fromRef) bs) get' :: [CommandParam] -> Repo -> IO [Sha]-get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps'+get' ps = mapMaybe (extractSha . S.copy) . S8.lines <$$> pipeReadStrict ps' where ps' = catMaybes [ Just $ Param "log"
Git/Remote.hs view
@@ -84,12 +84,17 @@ where replacement = decodeBS' $ S.drop (S.length prefix) $ S.take (S.length bestkey - S.length suffix) bestkey- (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs+ (bestkey, bestvalue) = + case maximumBy longestvalue insteadofs of+ (ConfigKey k, ConfigValue v) -> (k, v)+ (ConfigKey k, NoConfigValue) -> (k, mempty) longestvalue (_, a) (_, b) = compare b a- insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> - prefix `S.isPrefixOf` k &&- suffix `S.isSuffixOf` k &&- v `S.isPrefixOf` encodeBS l+ insteadofs = filterconfig $ \case+ (ConfigKey k, ConfigValue v) -> + prefix `S.isPrefixOf` k &&+ suffix `S.isSuffixOf` k &&+ v `S.isPrefixOf` encodeBS l+ (_, NoConfigValue) -> False filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs
Git/Repair.hs view
@@ -122,24 +122,26 @@ ) pullremotes tmpr (rmt:rmts) fetchrefs ms | not (foundBroken ms) = return ms- | otherwise = do- putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "."- ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)- ( do- void $ explodePacks tmpr- void $ copyObjects tmpr r- case ms of- FsckFailed -> pullremotes tmpr rmts fetchrefs ms- FsckFoundMissing s t -> do- stillmissing <- findMissing (S.toList s) r- pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t)- , pullremotes tmpr rmts fetchrefs ms- )- fetchfrom fetchurl ps fetchr = runBool ps' fetchr'+ | otherwise = case remoteName rmt of+ Just n -> do+ putStrLn $ "Trying to recover missing objects from remote " ++ n ++ "."+ ifM (fetchfrom n fetchrefs tmpr)+ ( do+ void $ explodePacks tmpr+ void $ copyObjects tmpr r+ case ms of+ FsckFailed -> pullremotes tmpr rmts fetchrefs ms+ FsckFoundMissing s t -> do+ stillmissing <- findMissing (S.toList s) r+ pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t)+ , pullremotes tmpr rmts fetchrefs ms+ )+ Nothing -> pullremotes tmpr rmts fetchrefs ms+ fetchfrom loc ps fetchr = runBool ps' fetchr' where ps' = [ Param "fetch"- , Param fetchurl+ , Param loc , Param "--force" , Param "--update-head-ok" , Param "--quiet"@@ -232,7 +234,7 @@ getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1- let toref = Ref . joinPath . drop topsegs . splitPath+ let toref = Ref . encodeBS' . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO ()@@ -245,8 +247,9 @@ nukeFile f where makeref (sha, ref) = do- let dest = fromRawFilePath (localGitDir r) </> fromRef ref- createDirectoryIfMissing True (parentDir dest)+ let gitd = fromRawFilePath (localGitDir r)+ let dest = gitd </> fromRef ref+ createDirectoryUnder gitd (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) @@ -256,8 +259,8 @@ parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of (sha:ref:[])- | isJust (extractSha sha) && Ref.legal True ref ->- Just (Ref sha, Ref 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@@ -278,13 +281,13 @@ if ok then return (Just branch, goodcommits') else do- (ls, cleanup) <- pipeNullSplit+ (ls, cleanup) <- pipeNullSplit' [ Param "log" , Param "-z" , Param "--format=%H" , Param (fromRef branch) ] r- let branchshas = catMaybes $ map (extractSha . decodeBL) ls+ let branchshas = catMaybes $ map extractSha ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the@@ -327,8 +330,8 @@ where parse l = case words l of (commitsha:treesha:[]) -> (,)- <$> extractSha commitsha- <*> extractSha treesha+ <$> extractSha (encodeBS' commitsha)+ <*> extractSha (encodeBS' treesha) _ -> Nothing check [] = return True check ((c, t):rest)@@ -447,7 +450,8 @@ void $ tryIO $ allowWrite f where headfile = fromRawFilePath (localGitDir g) </> "HEAD"- validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)+ validhead s = "ref: refs/" `isPrefixOf` s+ || isJust (extractSha (encodeBS' s)) {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch])
Git/Sha.hs view
@@ -1,43 +1,74 @@ {- git SHA stuff -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011,2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-}+ module Git.Sha where import Common import Git.Types +import qualified Data.ByteString as S+import Data.Char+ {- Runs an action that causes a git subcommand to emit a Sha, and strips - any trailing newline, returning the sha. -}-getSha :: String -> IO String -> IO Sha+getSha :: String -> IO S.ByteString -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a where bad = error $ "failed to read sha from git " ++ subcommand -{- Extracts the Sha from a string. There can be a trailing newline after- - it, but nothing else. -}-extractSha :: String -> Maybe Sha+{- Extracts the Sha from a ByteString. + -+ - There can be a trailing newline after it, but nothing else.+ -}+extractSha :: S.ByteString -> Maybe Sha extractSha s- | len == shaSize = val s- | len == shaSize + 1 && length s' == shaSize = val s'+ | len `elem` shaSizes = val s+ | len - 1 `elem` shaSizes && S.length s' == len - 1 = val s' | otherwise = Nothing where- len = length s- s' = firstLine s+ len = S.length s+ s' = firstLine' s val v- | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v+ | S.all validinsha v = Just $ Ref v | otherwise = Nothing+ validinsha w = or+ [ w >= 48 && w <= 57 -- 0-9+ , w >= 97 && w <= 102 -- a-f+ , w >= 65 && w <= 70 -- A-F+ ] -{- Size of a git sha. -}-shaSize :: Int-shaSize = 40+{- Sizes of git shas. -}+shaSizes :: [Int]+shaSizes = + [ 40 -- sha1 (must come first)+ , 64 -- sha256+ ] -nullSha :: Ref -nullSha = Ref $ replicate shaSize '0'+{- Git plumbing often uses a all 0 sha to represent things like a+ - deleted file. -}+nullShas :: [Sha]+nullShas = map (\n -> Ref (S.replicate n zero)) shaSizes+ where+ zero = fromIntegral (ord '0') -{- Git's magic empty tree. -}+{- Sha to provide to git plumbing when deleting a file.+ -+ - It's ok to provide a sha1; git versions that use sha256 will map the+ - sha1 to the sha256, or probably just treat all null sha1 specially+ - the same as all null sha256. -}+deleteSha :: Sha+deleteSha = Prelude.head nullShas++{- Git's magic empty tree.+ -+ - It's ok to provide the sha1 of this to git to refer to an empty tree;+ - git versions that use sha256 will map the sha1 to the sha256.+ -} emptyTree :: Ref emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"
Git/Types.hs view
@@ -1,12 +1,11 @@ {- git data types -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Git.Types where @@ -18,6 +17,8 @@ import System.Posix.Types import Utility.SafeCommand import Utility.FileSystemEncoding+import qualified Data.Semigroup as Sem+import Prelude {- Support repositories on local disk, and repositories accessed via an URL. -@@ -54,9 +55,21 @@ newtype ConfigKey = ConfigKey S.ByteString deriving (Ord, Eq) -newtype ConfigValue = ConfigValue S.ByteString- deriving (Ord, Eq, Semigroup, Monoid)+data ConfigValue+ = ConfigValue S.ByteString+ | NoConfigValue+ -- ^ git treats a setting with no value as different than a setting+ -- with an empty value+ deriving (Ord, Eq) +instance Sem.Semigroup ConfigValue where+ ConfigValue a <> ConfigValue b = ConfigValue (a <> b)+ a <> NoConfigValue = a+ NoConfigValue <> b = b++instance Monoid ConfigValue where+ mempty = ConfigValue mempty+ instance Default ConfigValue where def = ConfigValue mempty @@ -68,6 +81,7 @@ fromConfigValue :: ConfigValue -> String fromConfigValue (ConfigValue s) = decodeBS' s+fromConfigValue NoConfigValue = mempty instance Show ConfigValue where show = fromConfigValue@@ -81,12 +95,15 @@ type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -}-newtype Ref = Ref String+newtype Ref = Ref S.ByteString deriving (Eq, Ord, Read, Show) fromRef :: Ref -> String-fromRef (Ref s) = s+fromRef = decodeBS' . fromRef' +fromRef' :: Ref -> S.ByteString+fromRef' (Ref s) = s+ {- Aliases for Ref. -} type Branch = Ref type Sha = Ref@@ -98,6 +115,7 @@ {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject+ deriving (Show) readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject
Git/UpdateIndex.hs view
@@ -75,14 +75,14 @@ mapM_ streamer s void $ cleanup where- params = map Param ["ls-tree", "-z", "-r", "--full-tree", 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", 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. -}@@ -90,7 +90,7 @@ updateIndexLine sha treeitemtype file = L.fromStrict $ fmtTreeItemType treeitemtype <> " blob "- <> encodeBS (fromRef sha)+ <> fromRef' sha <> "\t" <> indexPath file @@ -108,7 +108,7 @@ unstageFile' :: TopFilePath -> Streamer unstageFile' p = pureStreamer $ L.fromStrict $ "0 "- <> encodeBS' (fromRef nullSha)+ <> fromRef' deleteSha <> "\t" <> indexPath p
Utility/CoProcess.hs view
@@ -10,6 +10,7 @@ module Utility.CoProcess ( CoProcessHandle,+ CoProcessState(..), start, stop, query,
Utility/Directory.hs view
@@ -1,11 +1,12 @@ {- directory traversal and manipulation -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory (@@ -13,25 +14,28 @@ module Utility.SystemDirectory ) where -import System.IO.Error import Control.Monad import System.FilePath import System.PosixCompat.Files import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad.IfElse import System.IO.Unsafe (unsafeInterleaveIO)+import System.IO.Error import Data.Maybe import Prelude #ifndef mingw32_HOST_OS import Utility.SafeCommand-import Control.Monad.IfElse #endif import Utility.SystemDirectory+import Utility.Path import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.Applicative+import Utility.PartialPrelude dirCruft :: FilePath -> Bool dirCruft "." = True@@ -154,3 +158,74 @@ #else go = removeFile file #endif++{- Like createDirectoryIfMissing True, but it will only create+ - missing parent directories up to but not including the directory+ - in the first parameter.+ -+ - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz"+ - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist,+ - it will throw an exception.+ -+ - The exception thrown is the same that createDirectory throws if the+ - parent directory does not exist.+ -+ - If the second FilePath is not under the first+ - FilePath (or the same as it), it will fail with an exception+ - even if the second FilePath's parent directory already exists.+ -+ - Either or both of the FilePaths can be relative, or absolute.+ - They will be normalized as necessary.+ -+ - Note that, the second FilePath, if relative, is relative to the current+ - working directory, not to the first FilePath.+ -}+createDirectoryUnder :: FilePath -> FilePath -> IO ()+createDirectoryUnder topdir dir =+ createDirectoryUnder' topdir dir createDirectory++createDirectoryUnder'+ :: (MonadIO m, MonadCatch m)+ => FilePath+ -> FilePath+ -> (FilePath -> m ())+ -> m ()+createDirectoryUnder' topdir dir0 mkdir = do+ p <- liftIO $ relPathDirToFile topdir dir0+ let dirs = splitDirectories p+ -- Catch cases where the dir is not beneath the topdir.+ -- If the relative path between them starts with "..",+ -- it's not. And on Windows, if they are on different drives,+ -- the path will not be relative.+ if headMaybe dirs == Just ".." || isAbsolute p+ then liftIO $ ioError $ customerror userErrorType+ ("createDirectoryFrom: not located in " ++ topdir)+ -- If dir0 is the same as the topdir, don't try to create+ -- it, but make sure it does exist.+ else if null dirs+ then liftIO $ unlessM (doesDirectoryExist topdir) $+ ioError $ customerror doesNotExistErrorType+ "createDirectoryFrom: does not exist"+ else createdirs $+ map (topdir </>) (reverse (scanl1 (</>) dirs))+ where+ customerror t s = mkIOError t s Nothing (Just dir0)++ createdirs [] = pure ()+ createdirs (dir:[]) = createdir dir (liftIO . ioError)+ createdirs (dir:dirs) = createdir dir $ \_ -> do+ createdirs dirs+ createdir dir (liftIO . ioError)++ -- This is the same method used by createDirectoryIfMissing,+ -- in particular the handling of errors that occur when the+ -- directory already exists. See its source for explanation+ -- of several subtleties.+ createdir dir notexisthandler = tryIO (mkdir dir) >>= \case+ Right () -> pure ()+ Left e+ | isDoesNotExistError e -> notexisthandler e+ | isAlreadyExistsError e || isPermissionError e ->+ liftIO $ unlessM (doesDirectoryExist dir) $+ ioError e+ | otherwise -> liftIO $ ioError e
Utility/FileSystemEncoding.hs view
@@ -43,6 +43,7 @@ import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif+import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import Utility.Exception import Utility.Split@@ -171,21 +172,11 @@ encodeBL' = L8.fromString #endif -{- Recent versions of the unix package have this alias; defined here- - for backwards compatibility. -}-type RawFilePath = S.ByteString--{- Note that the RawFilePath is assumed to never contain NUL,- - since filename's don't. This should only be used with actual- - RawFilePaths not arbitrary ByteString that may contain NUL. -} fromRawFilePath :: RawFilePath -> FilePath-fromRawFilePath = decodeBS'+fromRawFilePath = decodeFilePath -{- Note that the FilePath is assumed to never contain NUL,- - since filename's don't. This should only be used with actual FilePaths- - not arbitrary String that may contain NUL. -} toRawFilePath :: FilePath -> RawFilePath-toRawFilePath = encodeBS'+toRawFilePath = encodeFilePath {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. -
Utility/HumanTime.hs view
@@ -19,6 +19,7 @@ import Utility.PartialPrelude import Utility.QuickCheck +import Control.Monad.Fail as Fail (MonadFail(..)) import qualified Data.Map as M import Data.Time.Clock import Data.Time.Clock.POSIX (POSIXTime)@@ -44,7 +45,7 @@ daysToDuration i = Duration $ i * dsecs {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -}-parseDuration :: Monad m => String -> m Duration+parseDuration :: MonadFail m => String -> m Duration parseDuration = maybe parsefail (return . Duration) . go 0 where go n [] = return n@@ -55,7 +56,7 @@ u <- M.lookup c unitmap go (n + num * u) rest _ -> return $ n + num- parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\""+ parsefail = Fail.fail "duration parse error; expected eg \"5m\" or \"1h5m\"" fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d }
+ Utility/InodeCache.hs view
@@ -0,0 +1,307 @@+{- Caching a file's inode, size, and modification time+ - to see when it's changed.+ -+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Utility.InodeCache (+ InodeCache,+ mkInodeCache,+ InodeComparisonType(..),+ inodeCacheFileSize,++ compareStrong,+ compareWeak,+ compareBy,++ readInodeCache,+ showInodeCache,+ genInodeCache,+ toInodeCache,++ InodeCacheKey,+ inodeCacheToKey,+ inodeCacheToFileSize,+ inodeCacheToMtime,+ inodeCacheToEpochTime,+ inodeCacheEpochTimeRange,++ SentinalFile(..),+ SentinalStatus(..),+ TSDelta,+ noTSDelta,+ writeSentinalFile,+ checkSentinalFile,+ sentinalFileExists,++ prop_read_show_inodecache+) where++import Common+import Utility.TimeStamp+import Utility.QuickCheck+import qualified Utility.RawFilePath as R++import System.PosixCompat.Types+import Data.Time.Clock.POSIX++#ifdef mingw32_HOST_OS+import Data.Word (Word64)+#else+import System.Posix.Files+#endif++data InodeCachePrim = InodeCachePrim FileID FileSize MTime+ deriving (Show, Eq, Ord)++newtype InodeCache = InodeCache InodeCachePrim+ deriving (Show)++mkInodeCache :: FileID -> FileSize -> POSIXTime -> InodeCache+mkInodeCache inode sz mtime = InodeCache $+ InodeCachePrim inode sz (MTimeHighRes mtime)++inodeCacheFileSize :: InodeCache -> FileSize+inodeCacheFileSize (InodeCache (InodeCachePrim _ sz _)) = sz++{- Inode caches can be compared in two different ways, either weakly+ - or strongly. -}+data InodeComparisonType = Weakly | Strongly+ deriving (Eq, Ord, Show)++{- Strong comparison, including inodes. -}+compareStrong :: InodeCache -> InodeCache -> Bool+compareStrong (InodeCache x) (InodeCache y) = x == y++{- Weak comparison of the inode caches, comparing the size and mtime,+ - but not the actual inode. Useful when inodes have changed, perhaps+ - due to some filesystems being remounted.+ -+ - The weak mtime comparison treats any mtimes that are within 2 seconds+ - of one-another as the same. This is because FAT has only a 2 second+ - resolution. When a FAT filesystem is used on Linux, higher resolution+ - timestamps maybe are cached and used by Linux, but they are lost+ - on unmount, so after a remount, the timestamp can appear to have changed.+ -}+compareWeak :: InodeCache -> InodeCache -> Bool+compareWeak (InodeCache (InodeCachePrim _ size1 mtime1)) (InodeCache (InodeCachePrim _ size2 mtime2)) =+ size1 == size2 && (abs (lowResTime mtime1 - lowResTime mtime2) < 2)++compareBy :: InodeComparisonType -> InodeCache -> InodeCache -> Bool+compareBy Strongly = compareStrong+compareBy Weakly = compareWeak++{- For use in a Map; it's determined at creation time whether this+ - uses strong or weak comparison for Eq. -}+data InodeCacheKey = InodeCacheKey InodeComparisonType InodeCachePrim+ deriving (Ord, Show)++instance Eq InodeCacheKey where+ (InodeCacheKey ctx x) == (InodeCacheKey cty y) =+ compareBy (maximum [ctx,cty]) (InodeCache x ) (InodeCache y)++inodeCacheToKey :: InodeComparisonType -> InodeCache -> InodeCacheKey +inodeCacheToKey ct (InodeCache prim) = InodeCacheKey ct prim++inodeCacheToFileSize :: InodeCache -> FileSize+inodeCacheToFileSize (InodeCache (InodeCachePrim _ sz _)) = sz++inodeCacheToMtime :: InodeCache -> POSIXTime+inodeCacheToMtime (InodeCache (InodeCachePrim _ _ mtime)) = highResTime mtime++inodeCacheToEpochTime :: InodeCache -> EpochTime+inodeCacheToEpochTime (InodeCache (InodeCachePrim _ _ mtime)) = lowResTime mtime++-- Returns min, max EpochTime that weakly match the time of the InodeCache.+inodeCacheEpochTimeRange :: InodeCache -> (EpochTime, EpochTime)+inodeCacheEpochTimeRange i =+ let t = inodeCacheToEpochTime i+ in (t-1, t+1)++{- For backwards compatability, support low-res mtime with no+ - fractional seconds. -}+data MTime = MTimeLowRes EpochTime | MTimeHighRes POSIXTime+ deriving (Show, Ord)++{- A low-res time compares equal to any high-res time in the same second. -}+instance Eq MTime where+ MTimeLowRes a == MTimeLowRes b = a == b+ MTimeHighRes a == MTimeHighRes b = a == b+ MTimeHighRes a == MTimeLowRes b = lowResTime a == b+ MTimeLowRes a == MTimeHighRes b = a == lowResTime b++class MultiResTime t where+ lowResTime :: t -> EpochTime+ highResTime :: t -> POSIXTime++instance MultiResTime EpochTime where+ lowResTime = id+ highResTime = realToFrac++instance MultiResTime POSIXTime where+ lowResTime = fromInteger . floor+ highResTime = id++instance MultiResTime MTime where+ lowResTime (MTimeLowRes t) = t+ lowResTime (MTimeHighRes t) = lowResTime t+ highResTime (MTimeLowRes t) = highResTime t+ highResTime (MTimeHighRes t) = t++showInodeCache :: InodeCache -> String+showInodeCache (InodeCache (InodeCachePrim inode size (MTimeHighRes mtime))) = + let (t, d) = separate (== '.') (takeWhile (/= 's') (show mtime))+ in unwords+ [ show inode+ , show size+ , t+ , d+ ]+showInodeCache (InodeCache (InodeCachePrim inode size (MTimeLowRes mtime))) =+ unwords+ [ show inode+ , show size+ , show mtime+ ]++readInodeCache :: String -> Maybe InodeCache+readInodeCache s = case words s of+ (inode:size:mtime:[]) -> do+ i <- readish inode+ sz <- readish size+ t <- readish mtime+ return $ InodeCache $ InodeCachePrim i sz (MTimeLowRes t)+ (inode:size:mtime:mtimedecimal:_) -> do+ i <- readish inode+ sz <- readish size+ t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal+ return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t)+ _ -> Nothing++genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache)+genInodeCache f delta = catchDefaultIO Nothing $+ toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f++toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache)+toInodeCache (TSDelta getdelta) f s+ | isRegularFile s = do+ delta <- getdelta+ sz <- getFileSize' f s+#ifdef mingw32_HOST_OS+ mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f+#else+ let mtime = modificationTimeHiRes s+#endif+ return $ Just $ InodeCache $ InodeCachePrim (fileID s) sz (MTimeHighRes (mtime + highResTime delta))+ | otherwise = pure Nothing++{- Some filesystem get new random inodes each time they are mounted.+ - To detect this and other problems, a sentinal file can be created.+ - Its InodeCache at the time of its creation is written to the cache file,+ - so changes can later be detected. -}+data SentinalFile = SentinalFile+ { sentinalFile :: RawFilePath+ , sentinalCacheFile :: RawFilePath+ }+ deriving (Show)++{- On Windows, the mtime of a file appears to change when the time zone is+ - changed. To deal with this, a TSDelta can be used; the delta is added to+ - the mtime when generating an InodeCache. The current delta can be found+ - by looking at the SentinalFile. Effectively, this makes all InodeCaches+ - use the same time zone that was in use when the sential file was+ - originally written. -}+newtype TSDelta = TSDelta (IO EpochTime)++noTSDelta :: TSDelta+noTSDelta = TSDelta (pure 0)++writeSentinalFile :: SentinalFile -> IO ()+writeSentinalFile s = do+ writeFile (fromRawFilePath (sentinalFile s)) ""+ maybe noop (writeFile (fromRawFilePath (sentinalCacheFile s)) . showInodeCache)+ =<< genInodeCache (sentinalFile s) noTSDelta++data SentinalStatus = SentinalStatus+ { sentinalInodesChanged :: Bool+ , sentinalTSDelta :: TSDelta+ } ++{- Checks if the InodeCache of the sentinal file is the same+ - as it was when it was originally created.+ -+ - On Windows, time stamp differences are ignored, since they change+ - with the timezone.+ -+ - When the sential file does not exist, InodeCaches canot reliably be+ - compared, so the assumption is that there is has been a change.+ -}+checkSentinalFile :: SentinalFile -> IO SentinalStatus+checkSentinalFile s = do+ mold <- loadoldcache+ case mold of+ Nothing -> return dummy+ (Just old) -> do+ mnew <- gennewcache+ case mnew of+ Nothing -> return dummy+ Just new -> return $ calc old new+ where+ loadoldcache = catchDefaultIO Nothing $+ readInodeCache <$> readFile (fromRawFilePath (sentinalCacheFile s))+ gennewcache = genInodeCache (sentinalFile s) noTSDelta+ calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) =+ SentinalStatus (not unchanged) tsdelta+ where+#ifdef mingw32_HOST_OS+ -- Since mtime can appear to change when the time zone is+ -- changed in windows, we cannot look at the mtime for the+ -- sentinal file.+ unchanged = oldinode == newinode && oldsize == newsize && (newmtime == newmtime)+ tsdelta = TSDelta $ do+ -- Run when generating an InodeCache, + -- to get the current delta.+ mnew <- gennewcache+ return $ case mnew of+ Just (InodeCache (InodeCachePrim _ _ currmtime)) ->+ lowResTime oldmtime - lowResTime currmtime+ Nothing -> 0+#else+ unchanged = oldinode == newinode && oldsize == newsize && oldmtime == newmtime+ tsdelta = noTSDelta+#endif+ dummy = SentinalStatus True noTSDelta++sentinalFileExists :: SentinalFile -> IO Bool+sentinalFileExists s = allM R.doesPathExist [sentinalCacheFile s, sentinalFile s]++instance Arbitrary InodeCache where+ arbitrary =+ let prim = InodeCachePrim+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ in InodeCache <$> prim++instance Arbitrary MTime where+ arbitrary = frequency+ -- timestamp is not usually negative+ [ (50, MTimeLowRes <$> (abs . fromInteger <$> arbitrary))+ , (50, MTimeHighRes <$> arbitrary)+ ]++#ifdef mingw32_HOST_OS+instance Arbitrary FileID where+ arbitrary = fromIntegral <$> (arbitrary :: Gen Word64)+#endif++prop_read_show_inodecache :: InodeCache -> Bool+prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of+ Nothing -> False+ Just c' -> compareStrong c c'
Utility/Misc.hs view
@@ -11,6 +11,7 @@ hGetContentsStrict, readFileStrict, separate,+ separate', firstLine, firstLine', segment,@@ -53,6 +54,13 @@ unbreak r@(a, b) | null b = r | otherwise = (a, tail b)++separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)+separate' c l = unbreak $ S.break c l+ where+ unbreak r@(a, b)+ | S.null b = r+ | otherwise = (a, S.tail b) {- Breaks out the first line. -} firstLine :: String -> String
Utility/Path.hs view
@@ -41,7 +41,7 @@ import Utility.Monad import Utility.UserInfo-import Utility.Directory+import Utility.SystemDirectory import Utility.Split import Utility.FileSystemEncoding @@ -74,6 +74,8 @@ {- Makes a path absolute. -+ - Also simplifies it using simplifyPath.+ - - The first parameter is a base directory (ie, the cwd) to use if the path - is not already absolute, and should itsef be absolute. -@@ -124,12 +126,19 @@ {- Converts a filename into an absolute path. -+ - Also simplifies it using simplifyPath.+ - - Unlike Directory.canonicalizePath, this does not require the path - already exists. -} absPath :: FilePath -> IO FilePath-absPath file = do- cwd <- getCurrentDirectory- return $ absPathFrom cwd file+absPath file+ -- Avoid unncessarily getting the current directory when the path+ -- is already absolute. absPathFrom uses simplifyPath+ -- so also used here for consistency.+ | isAbsolute file = return $ simplifyPath file+ | otherwise = do+ cwd <- getCurrentDirectory+ return $ absPathFrom cwd file {- Constructs a relative path from the CWD to a file. -
Utility/Process.hs view
@@ -1,7 +1,7 @@ {- System.Process enhancements, including additional ways of running - processes, and logging. -- - Copyright 2012-2015 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -53,6 +53,7 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad+import qualified Data.ByteString as S type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -85,25 +86,20 @@ -> [String] -> Maybe [(String, String)] -> (Maybe (Handle -> IO ()))- -> (Maybe (Handle -> IO ()))- -> IO String-writeReadProcessEnv cmd args environ writestdin adjusthandle = do+ -> IO S.ByteString+writeReadProcessEnv cmd args environ writestdin = do (Just inh, Just outh, _, pid) <- createProcess p - maybe (return ()) (\a -> a inh) adjusthandle- maybe (return ()) (\a -> a outh) adjusthandle- -- fork off a thread to start consuming the output- output <- hGetContents outh outMVar <- newEmptyMVar- _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()+ _ <- forkIO $ putMVar outMVar =<< S.hGetContents outh -- now write and flush any input maybe (return ()) (\a -> a inh >> hFlush inh) writestdin hClose inh -- done with stdin -- wait on the output- takeMVar outMVar+ output <- takeMVar outMVar hClose outh -- wait on the process
+ Utility/RawFilePath.hs view
@@ -0,0 +1,50 @@+{- Portability shim around System.Posix.Files.ByteString+ -+ - On unix, this makes syscalls using RawFilesPaths as efficiently as+ - possible.+ -+ - On Windows, filenames are in unicode, so RawFilePaths have to be+ - decoded. So this library will work, but less efficiently than using+ - FilePath would.+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.RawFilePath (+ RawFilePath,+ readSymbolicLink,+ getFileStatus,+ getSymbolicLinkStatus,+ doesPathExist,+) where++#ifndef mingw32_HOST_OS+import Utility.FileSystemEncoding (RawFilePath)+import System.Posix.Files.ByteString++doesPathExist :: RawFilePath -> IO Bool+doesPathExist = fileExist++#else+import qualified Data.ByteString as B+import System.PosixCompat (FileStatus)+import qualified System.PosixCompat as P+import qualified System.Directory as D+import Utility.FileSystemEncoding++readSymbolicLink :: RawFilePath -> IO RawFilePath+readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f)++getFileStatus :: RawFilePath -> IO FileStatus+getFileStatus = P.getFileStatus . fromRawFilePath++getSymbolicLinkStatus :: RawFilePath -> IO FileStatus+getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath++doesPathExist :: RawFilePath -> IO Bool+doesPathExist = D.doesPathExist . fromRawFilePath+#endif
+ Utility/TimeStamp.hs view
@@ -0,0 +1,58 @@+{- timestamp parsing and formatting+ -+ - Copyright 2015-2019 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++module Utility.TimeStamp (+ parserPOSIXTime,+ parsePOSIXTime,+ formatPOSIXTime,+) where++import Utility.Data++import Data.Time.Clock.POSIX+import Data.Time+import Data.Ratio+import Control.Applicative+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Attoparsec.ByteString as A+import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8)++{- Parses how POSIXTime shows itself: "1431286201.113452s"+ - (The "s" is included for historical reasons and is optional.)+ - Also handles the format with no decimal seconds. -}+parserPOSIXTime :: A.Parser POSIXTime+parserPOSIXTime = mkPOSIXTime+ <$> signed decimal+ <*> (declen <|> pure (0, 0))+ <* optional (char 's')+ where+ declen :: A.Parser (Integer, Int)+ declen = do+ _ <- char '.'+ b <- A.takeWhile isDigit_w8+ let len = B.length b+ d <- either fail pure $+ A.parseOnly (decimal <* A.endOfInput) b+ return (d, len)++parsePOSIXTime :: String -> Maybe POSIXTime+parsePOSIXTime s = eitherToMaybe $ + A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s)++{- This implementation allows for higher precision in a POSIXTime than+ - supported by the system's Double, and avoids the complications of+ - floating point. -}+mkPOSIXTime :: Integer -> (Integer, Int) -> POSIXTime+mkPOSIXTime n (d, dlen)+ | n < 0 = fromIntegral n - fromRational r+ | otherwise = fromIntegral n + fromRational r+ where+ r = d % (10 ^ dlen)++formatPOSIXTime :: String -> POSIXTime -> String+formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)
git-repair.1 view
@@ -9,7 +9,7 @@ This can fix a corrupt or broken git repository, which git fsck would only complain has problems. .PP-It does by deleting all corrupt objects, and retreiving all missing+It does by deleting all corrupt objects, and retrieving all missing objects that it can from the remotes of the repository. .PP If that is not sufficient to fully recover the repository, it can also
git-repair.cabal view
@@ -1,16 +1,16 @@ Name: git-repair-Version: 1.20200102-Cabal-Version: >= 1.8+Version: 1.20200504+Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess Stability: Stable-Copyright: 2013 Joey Hess+Copyright: 2013-2020 Joey Hess License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility-Synopsis: repairs a damanged git repisitory+Synopsis: repairs a damaged git repository Description: git-repair can repair various forms of damage to git repositories. .@@ -28,6 +28,7 @@ custom-setup Setup-Depends: base (>= 4.11.1.0 && < 5.0), hslogger, split, unix-compat, process, unix, filepath,+ filepath-bytestring (>= 1.4.2.1.1), exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal @@ -37,8 +38,9 @@ Executable git-repair Main-Is: git-repair.hs- GHC-Options: -threaded -Wall -fno-warn-tabs- Extensions: LambdaCase+ GHC-Options: -threaded -Wall -fno-warn-tabs -O2+ Default-Language: Haskell98+ Default-Extensions: LambdaCase Build-Depends: split, hslogger, directory, filepath, containers, mtl, unix-compat (>= 0.5), bytestring, exceptions (>= 0.6), transformers, base (>= 4.11.1.0 && < 5.0), IfElse, text, process, time, QuickCheck,@@ -103,6 +105,7 @@ Utility.Format Utility.HumanNumber Utility.HumanTime+ Utility.InodeCache Utility.Metered Utility.Misc Utility.Monad@@ -112,11 +115,13 @@ Utility.Process Utility.Process.Shim Utility.QuickCheck+ Utility.RawFilePath Utility.Rsync Utility.SafeCommand Utility.Split Utility.SystemDirectory Utility.ThreadScheduler+ Utility.TimeStamp Utility.Tmp Utility.Tmp.Dir Utility.Tuple