refactor
This commit is contained in:
parent
ac5cff3668
commit
6c0155efb7
4 changed files with 77 additions and 51 deletions
|
@ -13,7 +13,6 @@ module Git.CatFile (
|
|||
catObject
|
||||
) where
|
||||
|
||||
import System.Cmd.Utils
|
||||
import System.IO
|
||||
import qualified Data.ByteString.Char8 as S
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
|
@ -22,20 +21,18 @@ import Common
|
|||
import Git
|
||||
import Git.Sha
|
||||
import Git.Command
|
||||
import qualified Utility.CoProcess as CoProcess
|
||||
|
||||
type CatFileHandle = (PipeHandle, Handle, Handle)
|
||||
type CatFileHandle = CoProcess.CoProcessHandle
|
||||
|
||||
{- Starts git cat-file running in batch mode in a repo and returns a handle. -}
|
||||
catFileStart :: Repo -> IO CatFileHandle
|
||||
catFileStart repo = hPipeBoth "git" $ toCommand $
|
||||
catFileStart repo = CoProcess.start "git" $ toCommand $
|
||||
gitCommandLine [Param "cat-file", Param "--batch"] repo
|
||||
|
||||
{- Stops git cat-file. -}
|
||||
catFileStop :: CatFileHandle -> IO ()
|
||||
catFileStop (pid, from, to) = do
|
||||
hClose to
|
||||
hClose from
|
||||
forceSuccess pid
|
||||
catFileStop = CoProcess.stop
|
||||
|
||||
{- Reads a file from a specified branch. -}
|
||||
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
|
||||
|
@ -44,23 +41,23 @@ catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ file
|
|||
{- Uses a running git cat-file read the content of an object.
|
||||
- Objects that do not exist will have "" returned. -}
|
||||
catObject :: CatFileHandle -> Ref -> IO L.ByteString
|
||||
catObject (_, from, to) object = do
|
||||
hPutStrLn to $ show object
|
||||
hFlush to
|
||||
catObject h object = CoProcess.query h send receive
|
||||
where
|
||||
send to = hPutStrLn to $ show object
|
||||
receive from = do
|
||||
header <- hGetLine from
|
||||
case words header of
|
||||
[sha, objtype, size]
|
||||
| length sha == shaSize &&
|
||||
validobjtype objtype -> handle size
|
||||
validobjtype objtype ->
|
||||
case reads size of
|
||||
[(bytes, "")] -> readcontent bytes from
|
||||
_ -> dne
|
||||
| otherwise -> dne
|
||||
_
|
||||
| header == show object ++ " missing" -> dne
|
||||
| otherwise -> error $ "unknown response from git cat-file " ++ header
|
||||
where
|
||||
handle size = case reads size of
|
||||
[(bytes, "")] -> readcontent bytes
|
||||
_ -> dne
|
||||
readcontent bytes = do
|
||||
readcontent bytes from = do
|
||||
content <- S.hGet from bytes
|
||||
c <- hGetChar from
|
||||
when (c /= '\n') $
|
||||
|
|
|
@ -11,8 +11,9 @@ import Common
|
|||
import Git
|
||||
import Git.Command
|
||||
import qualified Git.Version
|
||||
import qualified Utility.CoProcess as CoProcess
|
||||
|
||||
type CheckAttrHandle = (PipeHandle, Handle, Handle, [Attr], String)
|
||||
type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], String)
|
||||
|
||||
type Attr = String
|
||||
|
||||
|
@ -21,11 +22,10 @@ type Attr = String
|
|||
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
|
||||
checkAttrStart attrs repo = do
|
||||
cwd <- getCurrentDirectory
|
||||
(pid, from, to) <- hPipeBoth "git" $ toCommand $
|
||||
h <- CoProcess.start "git" $ toCommand $
|
||||
gitCommandLine params repo
|
||||
fileEncoding from
|
||||
fileEncoding to
|
||||
return (pid, from, to, attrs, cwd)
|
||||
CoProcess.query h fileEncoding fileEncoding
|
||||
return (h, attrs, cwd)
|
||||
where
|
||||
params =
|
||||
[ Param "check-attr"
|
||||
|
@ -35,24 +35,21 @@ checkAttrStart attrs repo = do
|
|||
|
||||
{- Stops git check-attr. -}
|
||||
checkAttrStop :: CheckAttrHandle -> IO ()
|
||||
checkAttrStop (pid, from, to, _, _) = do
|
||||
hClose to
|
||||
hClose from
|
||||
forceSuccess pid
|
||||
checkAttrStop (h, _, _) = CoProcess.stop h
|
||||
|
||||
{- Gets an attribute of a file. -}
|
||||
checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String
|
||||
checkAttr (_, from, to, attrs, cwd) want file = do
|
||||
hPutStr to $ file' ++ "\0"
|
||||
hFlush to
|
||||
pairs <- forM attrs $ \attr -> do
|
||||
l <- hGetLine from
|
||||
return (attr, attrvalue attr l)
|
||||
checkAttr (h, attrs, cwd) want file = do
|
||||
pairs <- CoProcess.query h send receive
|
||||
let vals = map snd $ filter (\(attr, _) -> attr == want) pairs
|
||||
case vals of
|
||||
[v] -> return v
|
||||
_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
|
||||
where
|
||||
send to = hPutStr to $ file' ++ "\0"
|
||||
receive from = forM attrs $ \attr -> do
|
||||
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.
|
||||
|
|
|
@ -10,16 +10,16 @@ module Git.HashObject where
|
|||
import Common
|
||||
import Git
|
||||
import Git.Command
|
||||
import qualified Utility.CoProcess as CoProcess
|
||||
|
||||
type HashObjectHandle = (PipeHandle, Handle, Handle)
|
||||
type HashObjectHandle = CoProcess.CoProcessHandle
|
||||
|
||||
{- Starts git hash-object and returns a handle. -}
|
||||
hashObjectStart :: Repo -> IO HashObjectHandle
|
||||
hashObjectStart repo = do
|
||||
r@(_, _, toh) <- hPipeBoth "git" $
|
||||
toCommand $ gitCommandLine params repo
|
||||
fileEncoding toh
|
||||
return r
|
||||
h <- CoProcess.start "git" $ toCommand $ gitCommandLine params repo
|
||||
CoProcess.query h fileEncoding (const $ return ())
|
||||
return h
|
||||
where
|
||||
params =
|
||||
[ Param "hash-object"
|
||||
|
@ -29,14 +29,11 @@ hashObjectStart repo = do
|
|||
|
||||
{- Stops git hash-object. -}
|
||||
hashObjectStop :: HashObjectHandle -> IO ()
|
||||
hashObjectStop (pid, from, to) = do
|
||||
hClose to
|
||||
hClose from
|
||||
forceSuccess pid
|
||||
hashObjectStop = CoProcess.stop
|
||||
|
||||
{- Injects a file into git, returning the shas of the objects. -}
|
||||
hashFile :: HashObjectHandle -> FilePath -> IO Sha
|
||||
hashFile (_, from, to) file = do
|
||||
hPutStrLn to file
|
||||
hFlush to
|
||||
Ref <$> hGetLine from
|
||||
hashFile h file = CoProcess.query h send receive
|
||||
where
|
||||
send to = hPutStrLn to file
|
||||
receive from = Ref <$> hGetLine from
|
||||
|
|
35
Utility/CoProcess.hs
Normal file
35
Utility/CoProcess.hs
Normal file
|
@ -0,0 +1,35 @@
|
|||
{- Interface for running a shell command as a coprocess,
|
||||
- sending it queries and getting back results.
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Utility.CoProcess (
|
||||
CoProcessHandle,
|
||||
start,
|
||||
stop,
|
||||
query
|
||||
) where
|
||||
|
||||
import System.Cmd.Utils
|
||||
|
||||
import Common
|
||||
|
||||
type CoProcessHandle = (PipeHandle, Handle, Handle)
|
||||
|
||||
start :: FilePath -> [String] -> IO CoProcessHandle
|
||||
start command params = hPipeBoth command params
|
||||
|
||||
stop :: CoProcessHandle -> IO ()
|
||||
stop (pid, from, to) = do
|
||||
hClose to
|
||||
hClose from
|
||||
forceSuccess pid
|
||||
|
||||
query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
|
||||
query (_, from, to) send receive = do
|
||||
_ <- send to
|
||||
hFlush to
|
||||
receive from
|
Loading…
Reference in a new issue