finished where indentation changes
This commit is contained in:
parent
b77290cecc
commit
f87a781aa6
68 changed files with 1619 additions and 1628 deletions
|
@ -33,11 +33,11 @@ similarityFloor = 7
|
|||
fuzzymatches :: String -> (c -> String) -> [c] -> [c]
|
||||
fuzzymatches input showchoice choices = fst $ unzip $
|
||||
sortBy comparecost $ filter similarEnough $ zip choices costs
|
||||
where
|
||||
distance = restrictedDamerauLevenshteinDistance gitEditCosts input
|
||||
costs = map (distance . showchoice) choices
|
||||
comparecost a b = compare (snd a) (snd b)
|
||||
similarEnough (_, cst) = cst < similarityFloor
|
||||
where
|
||||
distance = restrictedDamerauLevenshteinDistance gitEditCosts input
|
||||
costs = map (distance . showchoice) choices
|
||||
comparecost a b = compare (snd a) (snd b)
|
||||
similarEnough (_, cst) = cst < similarityFloor
|
||||
|
||||
{- Takes action based on git's autocorrect configuration, in preparation for
|
||||
- an autocorrected command being run. -}
|
||||
|
@ -49,23 +49,23 @@ prepare input showmatch matches r =
|
|||
| n < 0 -> warn
|
||||
| otherwise -> sleep n
|
||||
Nothing -> list
|
||||
where
|
||||
list = error $ unlines $
|
||||
[ "Unknown command '" ++ input ++ "'"
|
||||
, ""
|
||||
, "Did you mean one of these?"
|
||||
] ++ map (\m -> "\t" ++ showmatch m) matches
|
||||
warn =
|
||||
hPutStr stderr $ unlines
|
||||
[ "WARNING: You called a command named '" ++
|
||||
input ++ "', which does not exist."
|
||||
, "Continuing under the assumption that you meant '" ++
|
||||
showmatch (Prelude.head matches) ++ "'"
|
||||
]
|
||||
sleep n = do
|
||||
warn
|
||||
hPutStrLn stderr $ unwords
|
||||
[ "in"
|
||||
, show (fromIntegral n / 10 :: Float)
|
||||
, "seconds automatically..."]
|
||||
threadDelay (n * 100000) -- deciseconds to microseconds
|
||||
where
|
||||
list = error $ unlines $
|
||||
[ "Unknown command '" ++ input ++ "'"
|
||||
, ""
|
||||
, "Did you mean one of these?"
|
||||
] ++ map (\m -> "\t" ++ showmatch m) matches
|
||||
warn =
|
||||
hPutStr stderr $ unlines
|
||||
[ "WARNING: You called a command named '" ++
|
||||
input ++ "', which does not exist."
|
||||
, "Continuing under the assumption that you meant '" ++
|
||||
showmatch (Prelude.head matches) ++ "'"
|
||||
]
|
||||
sleep n = do
|
||||
warn
|
||||
hPutStrLn stderr $ unwords
|
||||
[ "in"
|
||||
, show (fromIntegral n / 10 :: Float)
|
||||
, "seconds automatically..."]
|
||||
threadDelay (n * 100000) -- deciseconds to microseconds
|
||||
|
|
|
@ -36,10 +36,10 @@ current r = do
|
|||
currentUnsafe :: Repo -> IO (Maybe Git.Ref)
|
||||
currentUnsafe r = parse . firstLine
|
||||
<$> pipeReadStrict [Param "symbolic-ref", Param "HEAD"] r
|
||||
where
|
||||
parse l
|
||||
| null l = Nothing
|
||||
| otherwise = Just $ Git.Ref l
|
||||
where
|
||||
parse l
|
||||
| null l = Nothing
|
||||
| otherwise = Just $ Git.Ref l
|
||||
|
||||
{- Checks if the second branch has any commits not present on the first
|
||||
- branch. -}
|
||||
|
@ -47,12 +47,12 @@ changed :: Branch -> Branch -> Repo -> IO Bool
|
|||
changed origbranch newbranch repo
|
||||
| origbranch == newbranch = return False
|
||||
| otherwise = not . null <$> diffs
|
||||
where
|
||||
diffs = pipeReadStrict
|
||||
[ Param "log"
|
||||
, Param (show origbranch ++ ".." ++ show newbranch)
|
||||
, Params "--oneline -n1"
|
||||
] repo
|
||||
where
|
||||
diffs = pipeReadStrict
|
||||
[ Param "log"
|
||||
, Param (show origbranch ++ ".." ++ show newbranch)
|
||||
, Params "--oneline -n1"
|
||||
] repo
|
||||
|
||||
{- Given a set of refs that are all known to have commits not
|
||||
- on the branch, tries to update the branch by a fast-forward.
|
||||
|
@ -70,23 +70,23 @@ fastForward branch (first:rest) repo =
|
|||
( no_ff
|
||||
, maybe no_ff do_ff =<< findbest first rest
|
||||
)
|
||||
where
|
||||
no_ff = return False
|
||||
do_ff to = do
|
||||
run "update-ref"
|
||||
[Param $ show branch, Param $ show to] repo
|
||||
return True
|
||||
findbest c [] = return $ Just c
|
||||
findbest c (r:rs)
|
||||
| c == r = findbest c rs
|
||||
| otherwise = do
|
||||
better <- changed c r repo
|
||||
worse <- changed r c repo
|
||||
case (better, worse) of
|
||||
(True, True) -> return Nothing -- divergent fail
|
||||
(True, False) -> findbest r rs -- better
|
||||
(False, True) -> findbest c rs -- worse
|
||||
(False, False) -> findbest c rs -- same
|
||||
where
|
||||
no_ff = return False
|
||||
do_ff to = do
|
||||
run "update-ref"
|
||||
[Param $ show branch, Param $ show to] repo
|
||||
return True
|
||||
findbest c [] = return $ Just c
|
||||
findbest c (r:rs)
|
||||
| c == r = findbest c rs
|
||||
| otherwise = do
|
||||
better <- changed c r repo
|
||||
worse <- changed r c repo
|
||||
case (better, worse) of
|
||||
(True, True) -> return Nothing -- divergent fail
|
||||
(True, False) -> findbest r rs -- better
|
||||
(False, True) -> findbest c rs -- worse
|
||||
(False, False) -> findbest c rs -- same
|
||||
|
||||
{- Commits the index into the specified branch (or other ref),
|
||||
- with the specified parent refs, and returns the committed sha -}
|
||||
|
@ -99,5 +99,5 @@ commit message branch parentrefs repo = do
|
|||
message repo
|
||||
run "update-ref" [Param $ show branch, Param $ show sha] repo
|
||||
return sha
|
||||
where
|
||||
ps = concatMap (\r -> ["-p", show r]) parentrefs
|
||||
where
|
||||
ps = concatMap (\r -> ["-p", show r]) parentrefs
|
||||
|
|
|
@ -48,28 +48,28 @@ catObject h object = maybe L.empty fst <$> catObjectDetails h object
|
|||
{- Gets both the content of an object, and its Sha. -}
|
||||
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha))
|
||||
catObjectDetails h object = CoProcess.query h send receive
|
||||
where
|
||||
send to = do
|
||||
fileEncoding to
|
||||
hPutStrLn to $ show object
|
||||
receive from = do
|
||||
fileEncoding from
|
||||
header <- hGetLine from
|
||||
case words header of
|
||||
[sha, objtype, size]
|
||||
| length sha == shaSize &&
|
||||
isJust (readObjectType objtype) ->
|
||||
case reads size of
|
||||
[(bytes, "")] -> readcontent bytes from sha
|
||||
_ -> dne
|
||||
| otherwise -> dne
|
||||
_
|
||||
| header == show object ++ " missing" -> dne
|
||||
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
|
||||
readcontent bytes from sha = do
|
||||
content <- S.hGet from bytes
|
||||
c <- hGetChar from
|
||||
when (c /= '\n') $
|
||||
error "missing newline from git cat-file"
|
||||
return $ Just (L.fromChunks [content], Ref sha)
|
||||
dne = return Nothing
|
||||
where
|
||||
send to = do
|
||||
fileEncoding to
|
||||
hPutStrLn to $ show object
|
||||
receive from = do
|
||||
fileEncoding from
|
||||
header <- hGetLine from
|
||||
case words header of
|
||||
[sha, objtype, size]
|
||||
| length sha == shaSize &&
|
||||
isJust (readObjectType objtype) ->
|
||||
case reads size of
|
||||
[(bytes, "")] -> readcontent bytes from sha
|
||||
_ -> dne
|
||||
| otherwise -> dne
|
||||
_
|
||||
| header == show object ++ " missing" -> dne
|
||||
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, object)
|
||||
readcontent bytes from sha = do
|
||||
content <- S.hGet from bytes
|
||||
c <- hGetChar from
|
||||
when (c /= '\n') $
|
||||
error "missing newline from git cat-file"
|
||||
return $ Just (L.fromChunks [content], Ref sha)
|
||||
dne = return Nothing
|
||||
|
|
|
@ -24,12 +24,12 @@ checkAttrStart attrs repo = do
|
|||
cwd <- getCurrentDirectory
|
||||
h <- gitCoProcessStart params repo
|
||||
return (h, attrs, cwd)
|
||||
where
|
||||
params =
|
||||
[ Param "check-attr"
|
||||
, Params "-z --stdin"
|
||||
] ++ map Param attrs ++
|
||||
[ Param "--" ]
|
||||
where
|
||||
params =
|
||||
[ Param "check-attr"
|
||||
, Params "-z --stdin"
|
||||
] ++ map Param attrs ++
|
||||
[ Param "--" ]
|
||||
|
||||
checkAttrStop :: CheckAttrHandle -> IO ()
|
||||
checkAttrStop (h, _, _) = CoProcess.stop h
|
||||
|
@ -42,26 +42,26 @@ checkAttr (h, attrs, cwd) want file = do
|
|||
case vals of
|
||||
[v] -> return v
|
||||
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
|
||||
where
|
||||
send to = do
|
||||
fileEncoding to
|
||||
hPutStr to $ file' ++ "\0"
|
||||
receive from = forM attrs $ \attr -> do
|
||||
fileEncoding from
|
||||
l <- hGetLine from
|
||||
return (attr, attrvalue attr l)
|
||||
{- Before git 1.7.7, git check-attr worked best with
|
||||
- absolute filenames; using them worked around some bugs
|
||||
- with relative filenames.
|
||||
-
|
||||
- With newer git, git check-attr chokes on some absolute
|
||||
- filenames, and the bugs that necessitated them were fixed,
|
||||
- so use relative filenames. -}
|
||||
oldgit = Git.Version.older "1.7.7"
|
||||
file'
|
||||
| oldgit = absPathFrom cwd file
|
||||
| otherwise = relPathDirToFile cwd $ absPathFrom cwd file
|
||||
attrvalue attr l = end bits !! 0
|
||||
where
|
||||
bits = split sep l
|
||||
sep = ": " ++ attr ++ ": "
|
||||
where
|
||||
send to = do
|
||||
fileEncoding to
|
||||
hPutStr to $ file' ++ "\0"
|
||||
receive from = forM attrs $ \attr -> do
|
||||
fileEncoding from
|
||||
l <- hGetLine from
|
||||
return (attr, attrvalue attr l)
|
||||
{- Before git 1.7.7, git check-attr worked best with
|
||||
- absolute filenames; using them worked around some bugs
|
||||
- with relative filenames.
|
||||
-
|
||||
- With newer git, git check-attr chokes on some absolute
|
||||
- filenames, and the bugs that necessitated them were fixed,
|
||||
- so use relative filenames. -}
|
||||
oldgit = Git.Version.older "1.7.7"
|
||||
file'
|
||||
| oldgit = absPathFrom cwd file
|
||||
| otherwise = relPathDirToFile cwd $ absPathFrom cwd file
|
||||
attrvalue attr l = end bits !! 0
|
||||
where
|
||||
bits = split sep l
|
||||
sep = ": " ++ attr ++ ": "
|
||||
|
|
|
@ -17,11 +17,11 @@ import qualified Utility.CoProcess as CoProcess
|
|||
{- Constructs a git command line operating on the specified repo. -}
|
||||
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
|
||||
gitCommandLine params Repo { location = l@(Local _ _ ) } = setdir : settree ++ params
|
||||
where
|
||||
setdir = Param $ "--git-dir=" ++ gitdir l
|
||||
settree = case worktree l of
|
||||
Nothing -> []
|
||||
Just t -> [Param $ "--work-tree=" ++ t]
|
||||
where
|
||||
setdir = Param $ "--git-dir=" ++ gitdir l
|
||||
settree = case worktree l of
|
||||
Nothing -> []
|
||||
Just t -> [Param $ "--work-tree=" ++ t]
|
||||
gitCommandLine _ repo = assertLocal repo $ error "internal"
|
||||
|
||||
{- Runs git in the specified repo. -}
|
||||
|
@ -49,8 +49,8 @@ pipeReadLazy params repo = assertLocal repo $ do
|
|||
fileEncoding h
|
||||
c <- hGetContents h
|
||||
return (c, checkSuccessProcess pid)
|
||||
where
|
||||
p = gitCreateProcess params repo
|
||||
where
|
||||
p = gitCreateProcess params repo
|
||||
|
||||
{- Runs a git subcommand, and returns its output, strictly.
|
||||
-
|
||||
|
@ -63,8 +63,8 @@ pipeReadStrict params repo = assertLocal repo $
|
|||
output <- hGetContentsStrict h
|
||||
hClose h
|
||||
return output
|
||||
where
|
||||
p = gitCreateProcess params repo
|
||||
where
|
||||
p = gitCreateProcess params repo
|
||||
|
||||
{- Runs a git subcommand, feeding it input, and returning its output,
|
||||
- which is expected to be fairly small, since it's all read into memory
|
||||
|
@ -85,8 +85,8 @@ pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)
|
|||
pipeNullSplit params repo = do
|
||||
(s, cleanup) <- pipeReadLazy params repo
|
||||
return (filter (not . null) $ split sep s, cleanup)
|
||||
where
|
||||
sep = "\0"
|
||||
where
|
||||
sep = "\0"
|
||||
|
||||
|
||||
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]
|
||||
|
|
|
@ -48,18 +48,18 @@ reRead r = read' $ r
|
|||
-}
|
||||
read' :: Repo -> IO Repo
|
||||
read' repo = go repo
|
||||
where
|
||||
go Repo { location = Local { gitdir = d } } = git_config d
|
||||
go Repo { location = LocalUnknown d } = git_config d
|
||||
go _ = assertLocal repo $ error "internal"
|
||||
git_config d = withHandle StdoutHandle createProcessSuccess p $
|
||||
hRead repo
|
||||
where
|
||||
params = ["config", "--null", "--list"]
|
||||
p = (proc "git" params)
|
||||
{ cwd = Just d
|
||||
, env = gitEnv repo
|
||||
}
|
||||
where
|
||||
go Repo { location = Local { gitdir = d } } = git_config d
|
||||
go Repo { location = LocalUnknown d } = git_config d
|
||||
go _ = assertLocal repo $ error "internal"
|
||||
git_config d = withHandle StdoutHandle createProcessSuccess p $
|
||||
hRead repo
|
||||
where
|
||||
params = ["config", "--null", "--list"]
|
||||
p = (proc "git" params)
|
||||
{ cwd = Just d
|
||||
, env = gitEnv repo
|
||||
}
|
||||
|
||||
{- Gets the global git config, returning a dummy Repo containing it. -}
|
||||
global :: IO (Maybe Repo)
|
||||
|
@ -73,9 +73,9 @@ global = do
|
|||
return $ Just repo'
|
||||
, return Nothing
|
||||
)
|
||||
where
|
||||
params = ["config", "--null", "--list", "--global"]
|
||||
p = (proc "git" params)
|
||||
where
|
||||
params = ["config", "--null", "--list", "--global"]
|
||||
p = (proc "git" params)
|
||||
|
||||
{- Reads git config from a handle and populates a repo with it. -}
|
||||
hRead :: Repo -> Handle -> IO Repo
|
||||
|
@ -133,10 +133,10 @@ parse s
|
|||
| all ('=' `elem`) (take 1 ls) = sep '=' ls
|
||||
-- --null --list output separates keys from values with newlines
|
||||
| otherwise = sep '\n' $ split "\0" s
|
||||
where
|
||||
ls = lines s
|
||||
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
|
||||
map (separate (== c))
|
||||
where
|
||||
ls = lines s
|
||||
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
|
||||
map (separate (== c))
|
||||
|
||||
{- Checks if a string from git config is a true value. -}
|
||||
isTrue :: String -> Maybe Bool
|
||||
|
@ -144,8 +144,8 @@ isTrue s
|
|||
| s' == "true" = Just True
|
||||
| s' == "false" = Just False
|
||||
| otherwise = Nothing
|
||||
where
|
||||
s' = map toLower s
|
||||
where
|
||||
s' = map toLower s
|
||||
|
||||
isBare :: Repo -> Bool
|
||||
isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r
|
||||
|
|
236
Git/Construct.hs
236
Git/Construct.hs
|
@ -33,15 +33,15 @@ import Utility.UserInfo
|
|||
- directory. -}
|
||||
fromCwd :: IO Repo
|
||||
fromCwd = getCurrentDirectory >>= seekUp checkForRepo
|
||||
where
|
||||
norepo = error "Not in a git repository."
|
||||
seekUp check dir = do
|
||||
r <- check dir
|
||||
case r of
|
||||
Nothing -> case parentDir dir of
|
||||
"" -> norepo
|
||||
d -> seekUp check d
|
||||
Just loc -> newFrom loc
|
||||
where
|
||||
norepo = error "Not in a git repository."
|
||||
seekUp check dir = do
|
||||
r <- check dir
|
||||
case r of
|
||||
Nothing -> case parentDir dir of
|
||||
"" -> norepo
|
||||
d -> seekUp check d
|
||||
Just loc -> newFrom loc
|
||||
|
||||
{- Local Repo constructor, accepts a relative or absolute path. -}
|
||||
fromPath :: FilePath -> IO Repo
|
||||
|
@ -55,21 +55,21 @@ fromAbsPath dir
|
|||
ifM (doesDirectoryExist dir') ( ret dir' , hunt )
|
||||
| otherwise =
|
||||
error $ "internal error, " ++ dir ++ " is not absolute"
|
||||
where
|
||||
ret = newFrom . LocalUnknown
|
||||
{- Git always looks for "dir.git" in preference to
|
||||
- to "dir", even if dir ends in a "/". -}
|
||||
canondir = dropTrailingPathSeparator dir
|
||||
dir' = canondir ++ ".git"
|
||||
{- When dir == "foo/.git", git looks for "foo/.git/.git",
|
||||
- and failing that, uses "foo" as the repository. -}
|
||||
hunt
|
||||
| "/.git" `isSuffixOf` canondir =
|
||||
ifM (doesDirectoryExist $ dir </> ".git")
|
||||
( ret dir
|
||||
, ret $ takeDirectory canondir
|
||||
)
|
||||
| otherwise = ret dir
|
||||
where
|
||||
ret = newFrom . LocalUnknown
|
||||
{- Git always looks for "dir.git" in preference to
|
||||
- to "dir", even if dir ends in a "/". -}
|
||||
canondir = dropTrailingPathSeparator dir
|
||||
dir' = canondir ++ ".git"
|
||||
{- When dir == "foo/.git", git looks for "foo/.git/.git",
|
||||
- and failing that, uses "foo" as the repository. -}
|
||||
hunt
|
||||
| "/.git" `isSuffixOf` canondir =
|
||||
ifM (doesDirectoryExist $ dir </> ".git")
|
||||
( ret dir
|
||||
, ret $ takeDirectory canondir
|
||||
)
|
||||
| otherwise = ret dir
|
||||
|
||||
{- Remote Repo constructor. Throws exception on invalid url.
|
||||
-
|
||||
|
@ -85,9 +85,9 @@ fromUrlStrict :: String -> IO Repo
|
|||
fromUrlStrict url
|
||||
| startswith "file://" url = fromAbsPath $ uriPath u
|
||||
| otherwise = newFrom $ Url u
|
||||
where
|
||||
u = fromMaybe bad $ parseURI url
|
||||
bad = error $ "bad url " ++ url
|
||||
where
|
||||
u = fromMaybe bad $ parseURI url
|
||||
bad = error $ "bad url " ++ url
|
||||
|
||||
{- Creates a repo that has an unknown location. -}
|
||||
fromUnknown :: IO Repo
|
||||
|
@ -100,21 +100,23 @@ localToUrl reference r
|
|||
| not $ repoIsUrl reference = error "internal error; reference repo not url"
|
||||
| repoIsUrl r = r
|
||||
| otherwise = r { location = Url $ fromJust $ parseURI absurl }
|
||||
where
|
||||
absurl =
|
||||
Url.scheme reference ++ "//" ++
|
||||
Url.authority reference ++
|
||||
repoPath r
|
||||
where
|
||||
absurl = concat
|
||||
[ Url.scheme reference
|
||||
, "//"
|
||||
, Url.authority reference
|
||||
, repoPath r
|
||||
]
|
||||
|
||||
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
|
||||
fromRemotes :: Repo -> IO [Repo]
|
||||
fromRemotes repo = mapM construct remotepairs
|
||||
where
|
||||
filterconfig f = filter f $ M.toList $ config repo
|
||||
filterkeys f = filterconfig (\(k,_) -> f k)
|
||||
remotepairs = filterkeys isremote
|
||||
isremote k = startswith "remote." k && endswith ".url" k
|
||||
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
|
||||
where
|
||||
filterconfig f = filter f $ M.toList $ config repo
|
||||
filterkeys f = filterconfig (\(k,_) -> f k)
|
||||
remotepairs = filterkeys isremote
|
||||
isremote k = startswith "remote." k && endswith ".url" k
|
||||
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
|
||||
|
||||
{- Sets the name of a remote when constructing the Repo to represent it. -}
|
||||
remoteNamed :: String -> IO Repo -> IO Repo
|
||||
|
@ -126,50 +128,48 @@ remoteNamed n constructor = do
|
|||
"remote.foo.url". -}
|
||||
remoteNamedFromKey :: String -> IO Repo -> IO Repo
|
||||
remoteNamedFromKey k = remoteNamed basename
|
||||
where
|
||||
basename = join "." $ reverse $ drop 1 $
|
||||
reverse $ drop 1 $ split "." k
|
||||
where
|
||||
basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k
|
||||
|
||||
{- Constructs a new Repo for one of a Repo's remotes using a given
|
||||
- location (ie, an url). -}
|
||||
fromRemoteLocation :: String -> Repo -> IO Repo
|
||||
fromRemoteLocation s repo = gen $ calcloc s
|
||||
where
|
||||
gen v
|
||||
| scpstyle v = fromUrl $ scptourl v
|
||||
| urlstyle v = fromUrl v
|
||||
| otherwise = fromRemotePath v repo
|
||||
-- insteadof config can rewrite remote location
|
||||
calcloc l
|
||||
| null insteadofs = l
|
||||
| otherwise = replacement ++ drop (length bestvalue) l
|
||||
where
|
||||
replacement = drop (length prefix) $
|
||||
take (length bestkey - length suffix) bestkey
|
||||
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
|
||||
longestvalue (_, a) (_, b) = compare b a
|
||||
insteadofs = filterconfig $ \(k, v) ->
|
||||
startswith prefix k &&
|
||||
endswith suffix k &&
|
||||
startswith v l
|
||||
filterconfig f = filter f $
|
||||
concatMap splitconfigs $
|
||||
M.toList $ fullconfig repo
|
||||
splitconfigs (k, vs) = map (\v -> (k, v)) vs
|
||||
(prefix, suffix) = ("url." , ".insteadof")
|
||||
urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
|
||||
-- git remotes can be written scp style -- [user@]host:dir
|
||||
-- but foo::bar is a git-remote-helper location instead
|
||||
scpstyle v = ":" `isInfixOf` v
|
||||
&& not ("//" `isInfixOf` v)
|
||||
&& not ("::" `isInfixOf` v)
|
||||
scptourl v = "ssh://" ++ host ++ slash dir
|
||||
where
|
||||
(host, dir) = separate (== ':') v
|
||||
slash d | d == "" = "/~/" ++ d
|
||||
| "/" `isPrefixOf` d = d
|
||||
| "~" `isPrefixOf` d = '/':d
|
||||
| otherwise = "/~/" ++ d
|
||||
where
|
||||
gen v
|
||||
| scpstyle v = fromUrl $ scptourl v
|
||||
| urlstyle v = fromUrl v
|
||||
| otherwise = fromRemotePath v repo
|
||||
-- insteadof config can rewrite remote location
|
||||
calcloc l
|
||||
| null insteadofs = l
|
||||
| otherwise = replacement ++ drop (length bestvalue) l
|
||||
where
|
||||
replacement = drop (length prefix) $
|
||||
take (length bestkey - length suffix) bestkey
|
||||
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
|
||||
longestvalue (_, a) (_, b) = compare b a
|
||||
insteadofs = filterconfig $ \(k, v) ->
|
||||
startswith prefix k &&
|
||||
endswith suffix k &&
|
||||
startswith v l
|
||||
filterconfig f = filter f $
|
||||
concatMap splitconfigs $ M.toList $ fullconfig repo
|
||||
splitconfigs (k, vs) = map (\v -> (k, v)) vs
|
||||
(prefix, suffix) = ("url." , ".insteadof")
|
||||
urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
|
||||
-- git remotes can be written scp style -- [user@]host:dir
|
||||
-- but foo::bar is a git-remote-helper location instead
|
||||
scpstyle v = ":" `isInfixOf` v
|
||||
&& not ("//" `isInfixOf` v)
|
||||
&& not ("::" `isInfixOf` v)
|
||||
scptourl v = "ssh://" ++ host ++ slash dir
|
||||
where
|
||||
(host, dir) = separate (== ':') v
|
||||
slash d | d == "" = "/~/" ++ d
|
||||
| "/" `isPrefixOf` d = d
|
||||
| "~" `isPrefixOf` d = '/':d
|
||||
| otherwise = "/~/" ++ d
|
||||
|
||||
{- Constructs a Repo from the path specified in the git remotes of
|
||||
- another Repo. -}
|
||||
|
@ -191,25 +191,25 @@ repoAbsPath d = do
|
|||
|
||||
expandTilde :: FilePath -> IO FilePath
|
||||
expandTilde = expandt True
|
||||
where
|
||||
expandt _ [] = return ""
|
||||
expandt _ ('/':cs) = do
|
||||
v <- expandt True cs
|
||||
return ('/':v)
|
||||
expandt True ('~':'/':cs) = do
|
||||
h <- myHomeDir
|
||||
return $ h </> cs
|
||||
expandt True ('~':cs) = do
|
||||
let (name, rest) = findname "" cs
|
||||
u <- getUserEntryForName name
|
||||
return $ homeDirectory u </> rest
|
||||
expandt _ (c:cs) = do
|
||||
v <- expandt False cs
|
||||
return (c:v)
|
||||
findname n [] = (n, "")
|
||||
findname n (c:cs)
|
||||
| c == '/' = (n, cs)
|
||||
| otherwise = findname (n++[c]) cs
|
||||
where
|
||||
expandt _ [] = return ""
|
||||
expandt _ ('/':cs) = do
|
||||
v <- expandt True cs
|
||||
return ('/':v)
|
||||
expandt True ('~':'/':cs) = do
|
||||
h <- myHomeDir
|
||||
return $ h </> cs
|
||||
expandt True ('~':cs) = do
|
||||
let (name, rest) = findname "" cs
|
||||
u <- getUserEntryForName name
|
||||
return $ homeDirectory u </> rest
|
||||
expandt _ (c:cs) = do
|
||||
v <- expandt False cs
|
||||
return (c:v)
|
||||
findname n [] = (n, "")
|
||||
findname n (c:cs)
|
||||
| c == '/' = (n, cs)
|
||||
| otherwise = findname (n++[c]) cs
|
||||
|
||||
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
|
||||
checkForRepo dir =
|
||||
|
@ -217,28 +217,28 @@ checkForRepo dir =
|
|||
check gitDirFile $
|
||||
check isBareRepo $
|
||||
return Nothing
|
||||
where
|
||||
check test cont = maybe cont (return . Just) =<< test
|
||||
checkdir c = ifM c
|
||||
( return $ Just $ LocalUnknown dir
|
||||
, return Nothing
|
||||
)
|
||||
isRepo = checkdir $ gitSignature $ ".git" </> "config"
|
||||
isBareRepo = checkdir $ gitSignature "config"
|
||||
<&&> doesDirectoryExist (dir </> "objects")
|
||||
gitDirFile = do
|
||||
c <- firstLine <$>
|
||||
catchDefaultIO "" (readFile $ dir </> ".git")
|
||||
return $ if gitdirprefix `isPrefixOf` c
|
||||
then Just $ Local
|
||||
{ gitdir = absPathFrom dir $
|
||||
drop (length gitdirprefix) c
|
||||
, worktree = Just dir
|
||||
}
|
||||
else Nothing
|
||||
where
|
||||
gitdirprefix = "gitdir: "
|
||||
gitSignature file = doesFileExist $ dir </> file
|
||||
where
|
||||
check test cont = maybe cont (return . Just) =<< test
|
||||
checkdir c = ifM c
|
||||
( return $ Just $ LocalUnknown dir
|
||||
, return Nothing
|
||||
)
|
||||
isRepo = checkdir $ gitSignature $ ".git" </> "config"
|
||||
isBareRepo = checkdir $ gitSignature "config"
|
||||
<&&> doesDirectoryExist (dir </> "objects")
|
||||
gitDirFile = do
|
||||
c <- firstLine <$>
|
||||
catchDefaultIO "" (readFile $ dir </> ".git")
|
||||
return $ if gitdirprefix `isPrefixOf` c
|
||||
then Just $ Local
|
||||
{ gitdir = absPathFrom dir $
|
||||
drop (length gitdirprefix) c
|
||||
, worktree = Just dir
|
||||
}
|
||||
else Nothing
|
||||
where
|
||||
gitdirprefix = "gitdir: "
|
||||
gitSignature file = doesFileExist $ dir </> file
|
||||
|
||||
newFrom :: RepoLocation -> IO Repo
|
||||
newFrom l = return Repo
|
||||
|
|
|
@ -39,23 +39,23 @@ get = do
|
|||
unless (d `dirContains` cwd) $
|
||||
changeWorkingDirectory d
|
||||
return $ addworktree wt r
|
||||
where
|
||||
pathenv s = do
|
||||
v <- getEnv s
|
||||
case v of
|
||||
Just d -> do
|
||||
unsetEnv s
|
||||
Just <$> absPath d
|
||||
Nothing -> return Nothing
|
||||
configure Nothing r = Git.Config.read r
|
||||
configure (Just d) r = do
|
||||
r' <- Git.Config.read r
|
||||
-- Let GIT_DIR override the default gitdir.
|
||||
absd <- absPath d
|
||||
return $ changelocation r' $ Local
|
||||
{ gitdir = absd
|
||||
, worktree = worktree (location r')
|
||||
}
|
||||
addworktree w r = changelocation r $
|
||||
Local { gitdir = gitdir (location r), worktree = w }
|
||||
changelocation r l = r { location = l }
|
||||
where
|
||||
pathenv s = do
|
||||
v <- getEnv s
|
||||
case v of
|
||||
Just d -> do
|
||||
unsetEnv s
|
||||
Just <$> absPath d
|
||||
Nothing -> return Nothing
|
||||
configure Nothing r = Git.Config.read r
|
||||
configure (Just d) r = do
|
||||
r' <- Git.Config.read r
|
||||
-- Let GIT_DIR override the default gitdir.
|
||||
absd <- absPath d
|
||||
return $ changelocation r' $ Local
|
||||
{ gitdir = absd
|
||||
, worktree = worktree (location r')
|
||||
}
|
||||
addworktree w r = changelocation r $
|
||||
Local { gitdir = gitdir (location r), worktree = w }
|
||||
changelocation r l = r { location = l }
|
||||
|
|
|
@ -29,17 +29,17 @@ hashObjectStop = CoProcess.stop
|
|||
{- Injects a file into git, returning the Sha of the object. -}
|
||||
hashFile :: HashObjectHandle -> FilePath -> IO Sha
|
||||
hashFile h file = CoProcess.query h send receive
|
||||
where
|
||||
send to = do
|
||||
fileEncoding to
|
||||
hPutStrLn to file
|
||||
receive from = getSha "hash-object" $ hGetLine from
|
||||
where
|
||||
send to = do
|
||||
fileEncoding to
|
||||
hPutStrLn to file
|
||||
receive from = getSha "hash-object" $ hGetLine from
|
||||
|
||||
{- Injects some content into git, returning its Sha. -}
|
||||
hashObject :: ObjectType -> String -> Repo -> IO Sha
|
||||
hashObject objtype content repo = getSha subcmd $ do
|
||||
s <- pipeWriteRead (map Param params) content repo
|
||||
return s
|
||||
where
|
||||
subcmd = "hash-object"
|
||||
params = [subcmd, "-t", show objtype, "-w", "--stdin"]
|
||||
where
|
||||
subcmd = "hash-object"
|
||||
params = [subcmd, "-t", show objtype, "-w", "--stdin"]
|
||||
|
|
|
@ -21,7 +21,7 @@ override index = do
|
|||
res <- getEnv var
|
||||
setEnv var index True
|
||||
return $ reset res
|
||||
where
|
||||
var = "GIT_INDEX_FILE"
|
||||
reset (Just v) = setEnv var v True
|
||||
reset _ = unsetEnv var
|
||||
where
|
||||
var = "GIT_INDEX_FILE"
|
||||
reset (Just v) = setEnv var v True
|
||||
reset _ = unsetEnv var
|
||||
|
|
|
@ -31,12 +31,12 @@ inRepo l = pipeNullSplit $ Params "ls-files --cached -z --" : map File l
|
|||
{- Scans for files at the specified locations that are not checked into git. -}
|
||||
notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
|
||||
notInRepo include_ignored l repo = pipeNullSplit params repo
|
||||
where
|
||||
params = [Params "ls-files --others"] ++ exclude ++
|
||||
[Params "-z --"] ++ map File l
|
||||
exclude
|
||||
| include_ignored = []
|
||||
| otherwise = [Param "--exclude-standard"]
|
||||
where
|
||||
params = [Params "ls-files --others"] ++ exclude ++
|
||||
[Params "-z --"] ++ map File l
|
||||
exclude
|
||||
| include_ignored = []
|
||||
| otherwise = [Param "--exclude-standard"]
|
||||
|
||||
{- Returns a list of all files that are staged for commit. -}
|
||||
staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
|
||||
|
@ -49,15 +49,15 @@ stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"]
|
|||
|
||||
staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)
|
||||
staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
|
||||
where
|
||||
prefix = [Params "diff --cached --name-only -z"]
|
||||
suffix = Param "--" : map File l
|
||||
where
|
||||
prefix = [Params "diff --cached --name-only -z"]
|
||||
suffix = Param "--" : map File l
|
||||
|
||||
{- Returns a list of files that have unstaged changes. -}
|
||||
changedUnstaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)
|
||||
changedUnstaged l = pipeNullSplit params
|
||||
where
|
||||
params = Params "diff --name-only -z --" : map File l
|
||||
where
|
||||
params = Params "diff --name-only -z --" : map File l
|
||||
|
||||
{- Returns a list of the files in the specified locations that are staged
|
||||
- for commit, and whose type has changed. -}
|
||||
|
@ -77,9 +77,9 @@ typeChanged' ps l repo = do
|
|||
let top = repoPath repo
|
||||
cwd <- getCurrentDirectory
|
||||
return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)
|
||||
where
|
||||
prefix = [Params "diff --name-only --diff-filter=T -z"]
|
||||
suffix = Param "--" : map File l
|
||||
where
|
||||
prefix = [Params "diff --name-only --diff-filter=T -z"]
|
||||
suffix = Param "--" : map File l
|
||||
|
||||
{- A item in conflict has two possible values.
|
||||
- Either can be Nothing, when that side deleted the file. -}
|
||||
|
@ -108,8 +108,8 @@ unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)
|
|||
unmerged l repo = do
|
||||
(fs, cleanup) <- pipeNullSplit params repo
|
||||
return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)
|
||||
where
|
||||
params = Params "ls-files --unmerged -z --" : map File l
|
||||
where
|
||||
params = Params "ls-files --unmerged -z --" : map File l
|
||||
|
||||
data InternalUnmerged = InternalUnmerged
|
||||
{ isus :: Bool
|
||||
|
@ -131,28 +131,28 @@ parseUnmerged s
|
|||
return $ InternalUnmerged (stage == 2) file
|
||||
(Just blobtype) (Just sha)
|
||||
_ -> Nothing
|
||||
where
|
||||
(metadata, file) = separate (== '\t') s
|
||||
where
|
||||
(metadata, file) = separate (== '\t') s
|
||||
|
||||
reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged]
|
||||
reduceUnmerged c [] = c
|
||||
reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
|
||||
where
|
||||
(rest, sibi) = findsib i is
|
||||
(blobtypeA, blobtypeB, shaA, shaB)
|
||||
| isus i = (iblobtype i, iblobtype sibi, isha i, isha sibi)
|
||||
| otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i)
|
||||
new = Unmerged
|
||||
{ unmergedFile = ifile i
|
||||
, unmergedBlobType = Conflicting blobtypeA blobtypeB
|
||||
, unmergedSha = Conflicting shaA shaB
|
||||
}
|
||||
findsib templatei [] = ([], deleted templatei)
|
||||
findsib templatei (l:ls)
|
||||
| ifile l == ifile templatei = (ls, l)
|
||||
| otherwise = (l:ls, deleted templatei)
|
||||
deleted templatei = templatei
|
||||
{ isus = not (isus templatei)
|
||||
, iblobtype = Nothing
|
||||
, isha = Nothing
|
||||
}
|
||||
where
|
||||
(rest, sibi) = findsib i is
|
||||
(blobtypeA, blobtypeB, shaA, shaB)
|
||||
| isus i = (iblobtype i, iblobtype sibi, isha i, isha sibi)
|
||||
| otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i)
|
||||
new = Unmerged
|
||||
{ unmergedFile = ifile i
|
||||
, unmergedBlobType = Conflicting blobtypeA blobtypeB
|
||||
, unmergedSha = Conflicting shaA shaB
|
||||
}
|
||||
findsib templatei [] = ([], deleted templatei)
|
||||
findsib templatei (l:ls)
|
||||
| ifile l == ifile templatei = (ls, l)
|
||||
| otherwise = (l:ls, deleted templatei)
|
||||
deleted templatei = templatei
|
||||
{ isus = not (isus templatei)
|
||||
, iblobtype = Nothing
|
||||
, isha = Nothing
|
||||
}
|
||||
|
|
|
@ -47,11 +47,11 @@ parseLsTree l = TreeItem
|
|||
, sha = s
|
||||
, file = Git.Filename.decode f
|
||||
}
|
||||
where
|
||||
-- l = <mode> SP <type> SP <sha> TAB <file>
|
||||
-- All fields are fixed, so we can pull them out of
|
||||
-- specific positions in the line.
|
||||
(m, past_m) = splitAt 7 l
|
||||
(t, past_t) = splitAt 4 past_m
|
||||
(s, past_s) = splitAt 40 $ Prelude.tail past_t
|
||||
f = Prelude.tail past_s
|
||||
where
|
||||
-- l = <mode> SP <type> SP <sha> TAB <file>
|
||||
-- All fields are fixed, so we can pull them out of
|
||||
-- specific positions in the line.
|
||||
(m, past_m) = splitAt 7 l
|
||||
(t, past_t) = splitAt 4 past_m
|
||||
(s, past_s) = splitAt 40 $ Prelude.tail past_t
|
||||
f = Prelude.tail past_s
|
||||
|
|
62
Git/Queue.hs
62
Git/Queue.hs
|
@ -86,30 +86,30 @@ new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
|
|||
addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
|
||||
addCommand subcommand params files q repo =
|
||||
updateQueue action different (length newfiles) q repo
|
||||
where
|
||||
key = actionKey action
|
||||
action = CommandAction
|
||||
{ getSubcommand = subcommand
|
||||
, getParams = params
|
||||
, getFiles = newfiles
|
||||
}
|
||||
newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)
|
||||
where
|
||||
key = actionKey action
|
||||
action = CommandAction
|
||||
{ getSubcommand = subcommand
|
||||
, getParams = params
|
||||
, getFiles = newfiles
|
||||
}
|
||||
newfiles = files ++ maybe [] getFiles (M.lookup key $ items q)
|
||||
|
||||
different (CommandAction { getSubcommand = s }) = s /= subcommand
|
||||
different _ = True
|
||||
different (CommandAction { getSubcommand = s }) = s /= subcommand
|
||||
different _ = True
|
||||
|
||||
{- Adds an update-index streamer to the queue. -}
|
||||
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
|
||||
addUpdateIndex streamer q repo =
|
||||
updateQueue action different 1 q repo
|
||||
where
|
||||
key = actionKey action
|
||||
-- the list is built in reverse order
|
||||
action = UpdateIndexAction $ streamer : streamers
|
||||
streamers = maybe [] getStreamers $ M.lookup key $ items q
|
||||
where
|
||||
key = actionKey action
|
||||
-- the list is built in reverse order
|
||||
action = UpdateIndexAction $ streamer : streamers
|
||||
streamers = maybe [] getStreamers $ M.lookup key $ items q
|
||||
|
||||
different (UpdateIndexAction _) = False
|
||||
different _ = True
|
||||
different (UpdateIndexAction _) = False
|
||||
different _ = True
|
||||
|
||||
{- Updates or adds an action in the queue. If the queue already contains a
|
||||
- different action, it will be flushed; this is to ensure that conflicting
|
||||
|
@ -118,15 +118,15 @@ updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue
|
|||
updateQueue !action different sizeincrease q repo
|
||||
| null (filter different (M.elems (items q))) = return $ go q
|
||||
| otherwise = go <$> flush q repo
|
||||
where
|
||||
go q' = newq
|
||||
where
|
||||
!newq = q'
|
||||
{ size = newsize
|
||||
, items = newitems
|
||||
}
|
||||
!newsize = size q' + sizeincrease
|
||||
!newitems = M.insertWith' const (actionKey action) action (items q')
|
||||
where
|
||||
go q' = newq
|
||||
where
|
||||
!newq = q'
|
||||
{ size = newsize
|
||||
, items = newitems
|
||||
}
|
||||
!newsize = size q' + sizeincrease
|
||||
!newitems = M.insertWith' const (actionKey action) action (items q')
|
||||
|
||||
{- Is a queue large enough that it should be flushed? -}
|
||||
full :: Queue -> Bool
|
||||
|
@ -153,8 +153,8 @@ runAction repo action@(CommandAction {}) =
|
|||
fileEncoding h
|
||||
hPutStr h $ join "\0" $ getFiles action
|
||||
hClose h
|
||||
where
|
||||
p = (proc "xargs" params) { env = gitEnv repo }
|
||||
params = "-0":"git":baseparams
|
||||
baseparams = toCommand $ gitCommandLine
|
||||
(Param (getSubcommand action):getParams action) repo
|
||||
where
|
||||
p = (proc "xargs" params) { env = gitEnv repo }
|
||||
params = "-0":"git":baseparams
|
||||
baseparams = toCommand $ gitCommandLine
|
||||
(Param (getSubcommand action):getParams action) repo
|
||||
|
|
70
Git/Ref.hs
70
Git/Ref.hs
|
@ -21,10 +21,10 @@ describe = show . base
|
|||
- Converts such a fully qualified ref into a base ref (eg: master). -}
|
||||
base :: Ref -> Ref
|
||||
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show
|
||||
where
|
||||
remove prefix s
|
||||
| prefix `isPrefixOf` s = drop (length prefix) s
|
||||
| otherwise = s
|
||||
where
|
||||
remove prefix s
|
||||
| prefix `isPrefixOf` s = drop (length prefix) s
|
||||
| otherwise = s
|
||||
|
||||
{- Given a directory such as "refs/remotes/origin", and a ref such as
|
||||
- refs/heads/master, yields a version of that ref under the directory,
|
||||
|
@ -40,51 +40,51 @@ exists ref = runBool "show-ref"
|
|||
{- Get the sha of a fully qualified git ref, if it exists. -}
|
||||
sha :: Branch -> Repo -> IO (Maybe Sha)
|
||||
sha branch repo = process <$> showref repo
|
||||
where
|
||||
showref = pipeReadStrict [Param "show-ref",
|
||||
Param "--hash", -- get the hash
|
||||
Param $ show branch]
|
||||
process [] = Nothing
|
||||
process s = Just $ Ref $ firstLine s
|
||||
where
|
||||
showref = pipeReadStrict [Param "show-ref",
|
||||
Param "--hash", -- get the hash
|
||||
Param $ show branch]
|
||||
process [] = Nothing
|
||||
process s = Just $ Ref $ firstLine s
|
||||
|
||||
{- List of (refs, branches) matching a given ref spec. -}
|
||||
matching :: Ref -> Repo -> IO [(Ref, Branch)]
|
||||
matching ref repo = map gen . lines <$>
|
||||
pipeReadStrict [Param "show-ref", Param $ show ref] repo
|
||||
where
|
||||
gen l = let (r, b) = separate (== ' ') l in
|
||||
(Ref r, Ref b)
|
||||
where
|
||||
gen l = let (r, b) = separate (== ' ') l
|
||||
in (Ref r, Ref b)
|
||||
|
||||
{- List of (refs, branches) matching a given ref spec.
|
||||
- Duplicate refs are filtered out. -}
|
||||
matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)]
|
||||
matchingUniq ref repo = nubBy uniqref <$> matching ref repo
|
||||
where
|
||||
uniqref (a, _) (b, _) = a == b
|
||||
where
|
||||
uniqref (a, _) (b, _) = a == b
|
||||
|
||||
{- Checks if a String is a legal git ref name.
|
||||
-
|
||||
- The rules for this are complex; see git-check-ref-format(1) -}
|
||||
legal :: Bool -> String -> Bool
|
||||
legal allowonelevel s = all (== False) illegal
|
||||
where
|
||||
illegal =
|
||||
[ any ("." `isPrefixOf`) pathbits
|
||||
, any (".lock" `isSuffixOf`) pathbits
|
||||
, not allowonelevel && length pathbits < 2
|
||||
, contains ".."
|
||||
, any (\c -> contains [c]) illegalchars
|
||||
, begins "/"
|
||||
, ends "/"
|
||||
, contains "//"
|
||||
, ends "."
|
||||
, contains "@{"
|
||||
, null s
|
||||
]
|
||||
contains v = v `isInfixOf` s
|
||||
ends v = v `isSuffixOf` s
|
||||
begins v = v `isPrefixOf` s
|
||||
where
|
||||
illegal =
|
||||
[ any ("." `isPrefixOf`) pathbits
|
||||
, any (".lock" `isSuffixOf`) pathbits
|
||||
, not allowonelevel && length pathbits < 2
|
||||
, contains ".."
|
||||
, any (\c -> contains [c]) illegalchars
|
||||
, begins "/"
|
||||
, ends "/"
|
||||
, contains "//"
|
||||
, ends "."
|
||||
, contains "@{"
|
||||
, null s
|
||||
]
|
||||
contains v = v `isInfixOf` s
|
||||
ends v = v `isSuffixOf` s
|
||||
begins v = v `isPrefixOf` s
|
||||
|
||||
pathbits = split "/" s
|
||||
illegalchars = " ~^:?*[\\" ++ controlchars
|
||||
controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
|
||||
pathbits = split "/" s
|
||||
illegalchars = " ~^:?*[\\" ++ controlchars
|
||||
controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
|
||||
|
|
16
Git/Sha.hs
16
Git/Sha.hs
|
@ -14,8 +14,8 @@ import Git.Types
|
|||
any trailing newline, returning the sha. -}
|
||||
getSha :: String -> IO String -> IO Sha
|
||||
getSha subcommand a = maybe bad return =<< extractSha <$> a
|
||||
where
|
||||
bad = error $ "failed to read sha from git " ++ subcommand
|
||||
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. -}
|
||||
|
@ -24,12 +24,12 @@ extractSha s
|
|||
| len == shaSize = val s
|
||||
| len == shaSize + 1 && length s' == shaSize = val s'
|
||||
| otherwise = Nothing
|
||||
where
|
||||
len = length s
|
||||
s' = firstLine s
|
||||
val v
|
||||
| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
|
||||
| otherwise = Nothing
|
||||
where
|
||||
len = length s
|
||||
s' = firstLine s
|
||||
val v
|
||||
| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
|
||||
| otherwise = Nothing
|
||||
|
||||
{- Size of a git sha. -}
|
||||
shaSize :: Int
|
||||
|
|
|
@ -62,11 +62,11 @@ doMerge ch differ repo streamer = do
|
|||
(diff, cleanup) <- pipeNullSplit (map Param differ) repo
|
||||
go diff
|
||||
void $ cleanup
|
||||
where
|
||||
go [] = noop
|
||||
go (info:file:rest) = mergeFile info file ch repo >>=
|
||||
maybe (go rest) (\l -> streamer l >> go rest)
|
||||
go (_:[]) = error $ "parse error " ++ show differ
|
||||
where
|
||||
go [] = noop
|
||||
go (info:file:rest) = mergeFile info file ch repo >>=
|
||||
maybe (go rest) (\l -> streamer l >> go rest)
|
||||
go (_:[]) = error $ "parse error " ++ show differ
|
||||
|
||||
{- Given an info line from a git raw diff, and the filename, generates
|
||||
- a line suitable for update-index that union merges the two sides of the
|
||||
|
@ -78,16 +78,16 @@ mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of
|
|||
shas -> use
|
||||
=<< either return (\s -> hashObject BlobObject (unlines s) repo)
|
||||
=<< calcMerge . zip shas <$> mapM getcontents shas
|
||||
where
|
||||
[_colonmode, _bmode, asha, bsha, _status] = words info
|
||||
use sha = return $ Just $
|
||||
updateIndexLine sha FileBlob $ asTopFilePath file
|
||||
-- We don't know how the file is encoded, but need to
|
||||
-- split it into lines to union merge. Using the
|
||||
-- FileSystemEncoding for this is a hack, but ensures there
|
||||
-- are no decoding errors. Note that this works because
|
||||
-- hashObject sets fileEncoding on its write handle.
|
||||
getcontents s = lines . encodeW8 . L.unpack <$> catObject h s
|
||||
where
|
||||
[_colonmode, _bmode, asha, bsha, _status] = words info
|
||||
use sha = return $ Just $
|
||||
updateIndexLine sha FileBlob $ asTopFilePath file
|
||||
-- We don't know how the file is encoded, but need to
|
||||
-- split it into lines to union merge. Using the
|
||||
-- FileSystemEncoding for this is a hack, but ensures there
|
||||
-- are no decoding errors. Note that this works because
|
||||
-- hashObject sets fileEncoding on its write handle.
|
||||
getcontents s = lines . encodeW8 . L.unpack <$> catObject h s
|
||||
|
||||
{- Calculates a union merge between a list of refs, with contents.
|
||||
-
|
||||
|
@ -98,7 +98,7 @@ calcMerge :: [(Ref, [String])] -> Either Ref [String]
|
|||
calcMerge shacontents
|
||||
| null reuseable = Right $ new
|
||||
| otherwise = Left $ fst $ Prelude.head reuseable
|
||||
where
|
||||
reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
|
||||
new = sorteduniq $ concat $ map snd shacontents
|
||||
sorteduniq = S.toList . S.fromList
|
||||
where
|
||||
reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents
|
||||
new = sorteduniq $ concat $ map snd shacontents
|
||||
sorteduniq = S.toList . S.fromList
|
||||
|
|
|
@ -38,12 +38,12 @@ streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
|
|||
fileEncoding h
|
||||
forM_ as (stream h)
|
||||
hClose h
|
||||
where
|
||||
params = map Param ["update-index", "-z", "--index-info"]
|
||||
stream h a = a (streamer h)
|
||||
streamer h s = do
|
||||
hPutStr h s
|
||||
hPutStr h "\0"
|
||||
where
|
||||
params = map Param ["update-index", "-z", "--index-info"]
|
||||
stream h a = a (streamer h)
|
||||
streamer h s = do
|
||||
hPutStr h s
|
||||
hPutStr h "\0"
|
||||
|
||||
{- A streamer that adds the current tree for a ref. Useful for eg, copying
|
||||
- and modifying branches. -}
|
||||
|
@ -52,8 +52,8 @@ lsTree (Ref x) repo streamer = do
|
|||
(s, cleanup) <- pipeNullSplit params repo
|
||||
mapM_ streamer s
|
||||
void $ cleanup
|
||||
where
|
||||
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
|
||||
where
|
||||
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
|
||||
|
||||
{- Generates a line suitable to be fed into update-index, to add
|
||||
- a given file with a given sha. -}
|
||||
|
|
22
Git/Url.hs
22
Git/Url.hs
|
@ -28,13 +28,13 @@ scheme repo = notUrl repo
|
|||
- <http://trac.haskell.org/network/ticket/40> -}
|
||||
uriRegName' :: URIAuth -> String
|
||||
uriRegName' a = fixup $ uriRegName a
|
||||
where
|
||||
fixup x@('[':rest)
|
||||
| rest !! len == ']' = take len rest
|
||||
| otherwise = x
|
||||
where
|
||||
len = length rest - 1
|
||||
fixup x = x
|
||||
where
|
||||
fixup x@('[':rest)
|
||||
| rest !! len == ']' = take len rest
|
||||
| otherwise = x
|
||||
where
|
||||
len = length rest - 1
|
||||
fixup x = x
|
||||
|
||||
{- Hostname of an URL repo. -}
|
||||
host :: Repo -> String
|
||||
|
@ -55,14 +55,14 @@ hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r
|
|||
{- The full authority portion an URL repo. (ie, "user@host:port") -}
|
||||
authority :: Repo -> String
|
||||
authority = authpart assemble
|
||||
where
|
||||
assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
|
||||
where
|
||||
assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
|
||||
|
||||
{- Applies a function to extract part of the uriAuthority of an URL repo. -}
|
||||
authpart :: (URIAuth -> a) -> Repo -> a
|
||||
authpart a Repo { location = Url u } = a auth
|
||||
where
|
||||
auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
|
||||
where
|
||||
auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
|
||||
authpart _ repo = notUrl repo
|
||||
|
||||
notUrl :: Repo -> a
|
||||
|
|
|
@ -26,13 +26,13 @@ normalize :: String -> Integer
|
|||
normalize = sum . mult 1 . reverse .
|
||||
extend precision . take precision .
|
||||
map readi . split "."
|
||||
where
|
||||
extend n l = l ++ replicate (n - length l) 0
|
||||
mult _ [] = []
|
||||
mult n (x:xs) = (n*x) : mult (n*10^width) xs
|
||||
readi :: String -> Integer
|
||||
readi s = case reads s of
|
||||
((x,_):_) -> x
|
||||
_ -> 0
|
||||
precision = 10 -- number of segments of the version to compare
|
||||
width = length "yyyymmddhhmmss" -- maximum width of a segment
|
||||
where
|
||||
extend n l = l ++ replicate (n - length l) 0
|
||||
mult _ [] = []
|
||||
mult n (x:xs) = (n*x) : mult (n*10^width) xs
|
||||
readi :: String -> Integer
|
||||
readi s = case reads s of
|
||||
((x,_):_) -> x
|
||||
_ -> 0
|
||||
precision = 10 -- number of segments of the version to compare
|
||||
width = length "yyyymmddhhmmss" -- maximum width of a segment
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue