Commits

Stefan Saasen committed 898f7a2

Basic clone implementation

* ls remote works, pack response parsing works
* Cabalized and cleaned up the source
* Implement very basic version of the 'patch-delta.c' functionality to restore delta encoded objects
* Code cleanup and docs
* Use coerce consistently

  • Participants
  • Parent commits aa2c5ca

Comments (0)

Files changed (32)

+:set -isrc
+:m + Test.QuickCheck
+:l Main
+:m + Main
+:set prompt ">> "
+:set -Wall
+
+dist
+*.lkshs

File Client.hs

-module Client where
-
-
-import Data.Bits
-import Network.Socket hiding (recv)
-import Network.Socket.ByteString (recv, sendAll)
-import qualified Data.ByteString.Char8 as C
-import Network.BSD
-import Data.List
-import System.IO
-
-type Request = String
-type Response = C.ByteString
-type Host = String
-type Port = Int
-{-client host port = -}
-
-{-client :: Host -> Port -> Request -> (Response -> ()) -}
-
-sendViaSocket host port payload = withSocketsDo $
-     do addrinfos <- getAddrInfo Nothing (Just host) (Just port)
-        let serveraddr = head addrinfos
-        sock <- socket (addrFamily serveraddr) Stream defaultProtocol
-        connect sock (addrAddress serveraddr)
-        sendAll sock $ C.pack payload
-        msg <- receive sock C.empty
-        sClose sock
-        return msg
-    where receive s acc = do
-            msg <- recv s 4096
-            if C.null msg then return acc else receive s $ C.append acc msg
-        

File LICENSE

Empty file added.

File PackProtocol.hs

-{-# LANGUAGE OverloadedStrings #-}
-
-
-module PackProtocol where
-
-
-import qualified Data.Attoparsec.Lazy as AL
-import qualified Data.Attoparsec.Char8 as AC
-import qualified Data.ByteString.Char8 as S
-import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.Text as T
-import Data.Attoparsec.Combinator
-import Data.Attoparsec.Char8 hiding (char, space, take)
-
-data PacketLine = FirstLine {
-    objId           :: S.ByteString
-   ,ref             :: S.ByteString
-   ,capabilities    :: [S.ByteString]
-} | RefLine {
-    objId           :: S.ByteString
-   ,ref             :: S.ByteString
-} | NullLine {
-    zeroId          :: S.ByteString
-} deriving (Show, Eq)
-
-parsePacketLine :: L.ByteString -> Maybe PacketLine
-parsePacketLine line = AL.maybeResult $ AL.parse parseLine line
-
-
-parseLine :: Parser PacketLine
-parseLine = choice [parseFirstLine, parseRef]
-
-
-parseFirstLine :: Parser PacketLine
-parseFirstLine = do
-    _ <- parseLength
-    objId' <- AC.take 40
-    space
-    ref' <- takeTill (== '\0')
-    nul
-    capabilities' <- takeTill (== '\n')
-    return $ FirstLine objId' ref' (S.split ' ' capabilities')
-
-parseRef :: Parser PacketLine
-parseRef = do
-    _ <- parseLength
-    objId' <- AC.take 40
-    space
-    ref' <- takeTill (== '\n')
-    return $ RefLine objId' ref'
-
-flushPacket :: Parser S.ByteString
-flushPacket = do
-    packet <- takeTill (== '\n') -- TODO must be "0000" or "0000\n"
-    return packet
-
-pipe, space, dash, colon, comma, quote, single, nul :: Parser Char
-pipe        = satisfy (== '|')
-space       = satisfy (== ' ')
-dash        = satisfy (== '-')
-colon       = satisfy (== ':')
-comma       = satisfy (== ',')
-quote       = satisfy (== '"')
-single      = satisfy (== '\'')
-nul         = satisfy (== '\0')
-
-
-parseLength :: Parser S.ByteString
-parseLength = do
-    hex <- AC.take 4
-    return $ hex
-
-logEntry :: Parser S.ByteString
-logEntry = do
-   entry <- takeTill (== '|')
-   pipe
-   space
-   return $ S.init entry
+import Distribution.Simple
+main = defaultMain
+

File TcpClient.hs

-import Network.Socket hiding (send, sendTo, recv, recvFrom)
-import Network.Socket.ByteString (send, recv)
-import qualified Data.ByteString.Char8 as B8
- 
-client' :: Int -> IO ()
-client' = client "localhost"
- 
-client :: String -> Int -> IO ()
-client host port = withSocketsDo $ do
-                addrInfo <- getAddrInfo Nothing (Just host) (Just $ show port)
-                let serverAddr = head addrInfo
-                sock <- socket (addrFamily serverAddr) Stream defaultProtocol
-                connect sock (addrAddress serverAddr)
-                msgSender sock
-                sClose sock
- 
-msgSender :: Socket -> IO ()
-msgSender sock = do
-  msg <- B8.getLine
-  send sock msg
-  rMsg <- recv sock 10
-  B8.putStrLn rMsg
-  if msg == B8.pack "q" then putStrLn "Disconnected!" else msgSender sock
+#!/bin/bash
+
+set -x
+
+
+#-threaded 
+
+ghc \
+   --make \
+   -dynamic \
+   Packfile.hs

File clone.hs

-module Main where
-
-import Data.Char
-import Text.Printf (printf)
-import Numeric
-
--- The git repository is made available via:
---  git daemon --reuseaddr --verbose  --base-path=. --export-all
--- in the parent directory of the git repository 'stash-scm-cache'
-
--- Run via: runhaskell clone.hs | nc -v localhost 9418
-
-toHex x = showIntAtBase 16 intToDigit x ""
-
-main = do
-    let cmd = "git-upload-pack /stash-scm-cache\0host=localhost\0"
-    printf "%04s%s" (toHex $ (length cmd) + 4) cmd
-    putStrLn "0000" -- Tell the server to disconnect

File example/pack-225db5b79ae469fff723e64a5126d803a864a08d.idx

Binary file added.

File example/pack-225db5b79ae469fff723e64a5126d803a864a08d.pack

Binary file added.

File example/pack-6e006075ba71fd8c811d95297d79fef21300c413.idx

Binary file added.

File example/pack-6e006075ba71fd8c811d95297d79fef21300c413.pack

Binary file added.
+Name:               hgit
+Version:            0.0.1
+License:            BSD3
+License-File:       LICENSE
+Author:             Stefan Saasen
+Maintainer:         Stefan Saasen
+Copyright:          Stefan Saasen
+Synopsis:           Exploring git in Haskell
+Category:           Development
+Description:        Exploring git, the git transfer protocols and the object store in Haskell
+Homepage:           https://bitbucket.org/ssaasen/git-bottom-up
+Cabal-Version:      >= 1.6
+Build-Type:         Simple
+
+Source-Repository   head
+  Type:             git
+  Location:         git@bitbucket.org:ssaasen/git-bottom-up.git
+
+Flag                small_base
+  Description:      Choose the new, split-up base package.
+
+test-suite hgit-testsuite
+  type:                     exitcode-stdio-1.0
+  main-is:                  TestRunner.hs
+  hs-source-dirs:           tests/src, src
+  ghc-options:              -fhpc
+  other-modules:            Git.CommonTests, Git.Common
+  build-depends:            base < 5 && >= 3,
+                            test-framework >= 0.3.3,
+                            test-framework-quickcheck2 >= 0.2.9,
+                            test-framework-hunit,
+                            HUnit,
+                            QuickCheck >= 2.4.0.1,
+                            filepath >= 1.3,
+                            zlib >= 0.5,
+                            filepath >= 1.3,
+                            directory >= 1.1,
+                            cryptohash >= 0.8,
+                            iteratee >= 0.8,
+                            iteratee-compress >= 0.3,
+                            bytestring >= 0.9,
+                            attoparsec >= 0.10,
+                            text >= 0.11,
+                            network >= 2.3
+
+executable  hgit
+  main-is:          Main.hs
+  other-modules:    Git.TcpClient, Git.ObjectStore, Git.Packfile, Git.PackProtocol, Git.Common, Git.Remote, Git.Delta
+  build-depends:
+                    base < 5 && >= 3,
+                    filepath >= 1.3,
+                    binary-strict >= 0.4,
+                    zlib >= 0.5,
+                    filepath >= 1.3,
+                    directory >= 1.1,
+                    cryptohash >= 0.8,
+                    iteratee >= 0.8,
+                    iteratee-compress >= 0.3,
+                    bytestring >= 0.9,
+                    attoparsec >= 0.10,
+                    text >= 0.11,
+                    network >= 2.3
+  ghc-options:
+                    -Wall
+                    -rtsopts
+                    -fno-warn-unused-do-bind
+                    -O2
+                    -- -fno-warn-missing-signatures
+
+  hs-source-dirs:
+                    src
+

File ls-remote-tcp.hs

-module Main where
-
-import Data.Char
-import Text.Printf (printf)
-import Numeric
-import Client
-import qualified Data.ByteString.Char8 as C
-
--- The git repository is made available via:
---  git daemon --reuseaddr --verbose  --base-path=. --export-all
--- in the parent directory of the git repository 'stash-scm-cache'
-
--- Run via: runhaskell ls-remote.hs | nc -v localhost 9418
-
-
-lsRemote :: String -> String
-lsRemote repo = (pktLine $ "git-upload-pack /stash-scm-cache\0host=localhost\0") ++ 
-                flush -- Tell the server to disconnect
-        where flush = "0000\n"
-              toHex x = showIntAtBase 16 intToDigit x ""
-              pktLine msg = (printf "%04s%s" (toHex $ (length msg) + 4) msg)::String
-
-main = do
-    {-conn <- openConnection "localhost" "9418"-}
-    {-sendPayload conn $ lsRemote "stash-scm-cache"-}
-    let payload = lsRemote "stash-scm-cache"
-    putStrLn payload
-    response <- sendViaSocket "localhost" "9418" $ payload
-    C.putStrLn response
-    {-closeConnection conn-}
-

File ls-remote.hs

-module Main where
-
-import Data.Char
-import Text.Printf (printf)
-import Numeric
-
--- The git repository is made available via:
---  git daemon --reuseaddr --verbose  --base-path=. --export-all
--- in the parent directory of the git repository 'stash-scm-cache'
-
--- Run via: runhaskell ls-remote.hs | nc -v localhost 9418
-
-toHex x = showIntAtBase 16 intToDigit x ""
-
-main = do
-    let cmd = "git-upload-pack /stash-scm-cache\0host=localhost\0"
-    printf "%04s%s" (toHex $ (length cmd) + 4) cmd
-    putStrLn "0000" -- Tell the server to disconnect

File src/Git/Common.hs

+-- | Common functions used throught the Git module.
+module Git.Common (
+    toHex
+  , pktLine
+  , flushPkt
+  , isMsbSet
+  , eitherToMaybe
+  , GitRepository(..)
+  , ObjectType(..)
+) where
+
+import Text.Printf      (printf)
+import Numeric          (showHex)
+import Data.Bits        (Bits, (.&.))
+import Data.Word        (Word8)
+
+data ObjectType = Commit | -- 1
+        Tree |  -- 2
+        Blob | -- 3
+        Tag | -- 4
+        OfsDelta Int | -- 6 -- offset is interpreted as a negative offset from the type-byte of the header of the ofs-delta entry 
+        RefDelta [Word8] deriving (Eq, Show, Ord) -- 7
+
+data GitRepository = GitRepository {
+    getName         :: String
+   ,getGitDirectory :: FilePath
+} deriving (Show, Eq)
+
+-- | Return a hex representation of the given Integral.
+toHex :: (Integral a, Show a) => a -> String
+toHex x = showHex x ""
+
+-- | Create a packet line prefixed with the overall length. Length is 4 byte,
+-- hexadecimal, padded with 0.
+pktLine :: String -> String 
+pktLine msg = printf "%04s%s" (toHex . (4 +) $ length msg) msg
+
+-- | Return the Git flush packet.
+flushPkt :: String
+flushPkt = "0000"
+
+-- | Check whether the most significant bit of an octet is set.
+isMsbSet :: Bits a => a -> Bool
+isMsbSet x = (x .&. 0x80) /= 0
+
+eitherToMaybe :: Either e a -> Maybe a
+eitherToMaybe (Right x) = Just x
+eitherToMaybe (Left _)  = Nothing

File src/Git/Delta.hs

+{-# LANGUAGE  DoAndIfThenElse #-}
+
+
+-- | Implementation of the delta encoding algorithm used in git. 
+-- The delta encoding used is a `copy/insert` based encoding algorithm inspired
+-- by the xdelta\/libxdiff (see <http://www.xmailserver.org/xdiff-lib.html> and
+-- <http://xdelta.org/>) algorithms.
+--
+-- The current implementation is based on the
+-- <https://github.com/git/git/blob/v1.8.1/patch-delta.c> implementation from
+-- the git source.
+-- 
+-- The delta implementation can be tested using the @test-delta@ binary from
+-- the git source. Create the binary in the git source using:
+--
+-- @
+--  make configure
+--  ./configure
+--  make test-delta
+-- @
+-- 
+-- To generate a test delta file run:
+--
+-- @
+--  ./test-delta -d test-delta-old.c test-delta-new.c out.delta
+-- @
+--
+-- The delta file @out.delta@ can be used to restore the content of the
+-- @test-delta-new.c@ file based on the source file @test-delta-old.c@.
+module Git.Delta (
+    patch
+) where
+
+import qualified Data.ByteString as B
+import Data.Binary.Strict.Get
+import Control.Monad                    (liftM, foldM)
+import Data.Bits                        (Bits, (.&.), (.|.), shiftL)
+import Git.Common                       (isMsbSet)
+import Data.Word
+
+-- | The DeltaHeader contains the length of the source, the length off the
+-- target and the offset of the actual delta payload in the delta buffer.
+data DeltaHeader = DeltaHeader {
+    sourceLength :: Int
+  , targetLength :: Int
+  , getOffset    :: Int
+} deriving (Show)
+
+{-
+runhaskell Git/Delta.hs ../test-delta.c ../out.delta
+diff target.file ../test-delta-new.c
+-}
+{-
+main :: IO ()
+main = do
+    (sourceFile:deltaFile:_) <- getArgs
+    source <- B.readFile sourceFile
+    delta <- B.readFile deltaFile
+    print $ B.length source
+    either putStrLn (B.writeFile "target.file") $ patch source delta
+-}
+
+-- | Patch the base with the given delta to produce a new target version
+-- This will return either the patched target or a Left with an appropriate
+-- error message.
+--
+-- @
+--     source <- B.readFile sourceFile
+--     delta <- B.readFile deltaFile
+--     either putStrLn (B.writeFile \"target.file\") $ patch source delta
+-- @
+patch :: B.ByteString -> B.ByteString -> Either String B.ByteString
+patch base delta = do
+        header <- decodeDeltaHeader delta
+        if B.length base == sourceLength header then
+            fst $ runGet (run (getOffset header) base delta) delta
+        else Left "Source length check failed"
+
+
+-- | Parse the delta file and transform the source into the target ByteString
+run :: Int -> B.ByteString -> B.ByteString -> Get B.ByteString
+run offset source delta = do
+    skip offset
+    cmd <- getWord8
+    runCommand cmd B.empty source delta
+
+-- =================================================================================
+
+-- | Return the delta header information consisting of the size of the source
+-- buffer, the size of the target buffer and the delta header length (offset
+-- from the start).
+decodeDeltaHeader :: Monad m => B.ByteString -> m DeltaHeader
+decodeDeltaHeader delta = do
+    let res1 = runGet (decodeSize 0) delta
+        (sourceBufferSize, offset) = either (const (0,0)) id $ fst res1
+        res2 = runGet (decodeSize offset) delta
+        (targetBufferSize, offset') = either (const (0,0)) id $ fst res2
+    return (DeltaHeader sourceBufferSize targetBufferSize offset')
+    where   decodeSize offset = do
+                skip offset
+                byte <- getWord8
+                let rv = fromIntegral $ byte .&. 0x7f
+                    shift = 7
+                next rv shift byte $ succ offset
+            next rv shift byte count | isMsbSet byte = do
+                 b <- getWord8
+                 let rv2 = rv .|. ((fromIntegral b .&. 127) `shiftL` shift)
+                 next rv2 (shift + 7) b $ succ count
+            next rv _ _ count                        = return (rv, count)
+
+-- =================================================================================
+
+
+-- | Execute the @copy/insert@ instructions defined in the delta buffer to
+-- restore the target buffer
+runCommand :: Word8 -> B.ByteString -> B.ByteString -> t -> Get B.ByteString
+runCommand cmd acc source delta = do
+    toAdd <- if cmd .&. 0x80 /= 0 then
+        copyCommand cmd source
+    else
+        insertCommand cmd
+    finished <- isEmpty
+    let acc' = B.append acc toAdd
+    if finished then return acc'
+       else do
+        cmd' <- getWord8
+        runCommand cmd' acc' source delta
+
+-- | Read @n@ bytes from the delta and insert them into the target buffer
+insertCommand :: Integral a => a -> Get B.ByteString
+insertCommand = getByteString . fromIntegral
+
+-- | Copy from the source into the target buffer
+copyCommand :: Word8 -> B.ByteString -> Get B.ByteString
+copyCommand cmd source = do
+        -- off -> offset in the source buffer where the copy will start
+        offset <- foldM f 0 $ zip [0x01, 0x02, 0x04, 0x08] [0,8..]
+        -- bytes to copy
+        size   <- foldM f 0 $ zip [0x10, 0x20, 0x40] [0,8..]
+        let size3 = if coerce size == 0 then 0x10000 else size
+        -- FIXME add guard condition from `patch-delta.c`: if (unsigned_add_overflows(cp_off, cp_size) || ...
+        return $ B.take (coerce size3) $ B.drop (coerce offset) source
+    where calculateVal off shift = if shift /= 0 then (\x -> off .|. (x `shiftL` shift)::Int) . fromIntegral else fromIntegral
+          f off (x, shift)       = if cmd .&. x /= 0 then liftM (calculateVal off shift) getWord8 else return off
+          coerce                 = toEnum . fromEnum

File src/Git/ObjectStore.hs

+{-# LANGUAGE OverloadedStrings, RecordWildCards, DoAndIfThenElse #-}
+
+module Git.ObjectStore (
+    createEmptyGitRepository
+  , encodeObject
+  , pathForObject
+  , pathForPack
+  , createGitRepositoryFromPackfile
+  , updateHead
+) where
+
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Codec.Compression.Zlib as Z
+import qualified Crypto.Hash.SHA1 as SHA1
+import qualified Data.Attoparsec.ByteString.Char8 as AC
+import Control.Applicative ((<|>))
+-- FIXME -> don't use isJust/fromJust
+import Data.Maybe                                           (isJust, fromJust)
+import Text.Printf                                          (printf)
+import Git.Packfile
+import Git.Delta                                            (patch)
+import Git.Common                                           (GitRepository(..), ObjectType(..), eitherToMaybe)
+import System.FilePath
+import System.Directory
+import Control.Monad                                        (unless, liftM)
+
+type ObjectId = String
+
+data Object = ResolvedObject {
+    getObjectType   :: ObjectType
+  , getContent      :: B.ByteString
+  , getSize         :: Int
+  , sha1            :: String
+} | UnresolvedObject {
+    getObjectType   :: ObjectType
+  , deltaData       :: B.ByteString
+  , getSize         :: Int
+}deriving (Show, Eq, Ord)
+
+createGitRepositoryFromPackfile :: GitRepository -> FilePath -> IO ()
+createGitRepositoryFromPackfile target packFile = do
+    pack <- packRead packFile
+    let repoName = getName target
+        repo = GitRepository repoName (repoName </> ".git")
+    unpackPackfile repo pack
+    updateHead repo pack
+
+-- TODO properly handle the error condition here
+unpackPackfile :: GitRepository -> Packfile -> IO ()
+unpackPackfile _ InvalidPackfile = error "Attempting to unpack an invalid packfile"
+unpackPackfile repo@GitRepository{..} (Packfile _ _ objs) = do
+        let encodedObjects = encodeObjects objs
+        unresolvedObjects <- writeObjects encodedObjects
+        _ <- writeDeltas repo unresolvedObjects
+        putStrLn "Done"
+    where   writeObjects (r@(ResolvedObject objType content size sha1):xs) = do
+                let (path, name) = pathForObject getName sha1
+                _ <- writeObject repo r
+                writeObjects xs
+            writeObjects (x@(UnresolvedObject{}):xs) = liftM (x:) (writeObjects xs)
+            writeObjects []     = return []
+            encodeObjects       = map encodeObject
+
+writeDeltas :: GitRepository -> [Object] -> IO ()
+writeDeltas repo (x:xs) = do
+    f <- writeDelta repo x
+    writeDeltas repo xs
+writeDeltas _ [] = return ()
+
+writeDelta :: GitRepository -> Object -> IO (Maybe FilePath)
+writeDelta repo (UnresolvedObject ty@(RefDelta baseObject) content size) = do
+        base <- case toObjectId ty of
+            Just sha -> readObject repo sha
+            _        -> return Nothing
+        if isJust base then
+            case patch (getContent $ fromJust base) content of
+                Right target -> do
+                                let base'        = fromJust base
+                                    (path, name) = pathForObject (getName repo) (sha1 base')
+                                    filename     = path </> name
+                                    header       = headerForBlob (objectTypeToString $ getObjectType base') target
+                                    blob         = header `BC.append` target
+                                    obj          = ResolvedObject (getObjectType base') blob (BC.length target) $ hsh blob
+                                _ <- writeObject repo obj
+                                return $ Just filename
+                Left msg     -> return Nothing
+        else return Nothing -- FIXME - base object doesn't exist yet
+
+
+updateHead :: GitRepository -> Packfile -> IO ()
+updateHead repo (Packfile _ _ objs) = do
+    let commits = filter isCommit objs
+    unless (null commits) $
+        let commit = head commits
+            ref = "refs/heads/master"
+            in
+            do
+                let obj = encodeObject commit
+                createRef repo ref (sha1 obj)
+                createSymRef repo "HEAD" ref
+    where isCommit ob = objectType ob == Commit
+
+-- ref: refs/heads/master
+createSymRef :: GitRepository -> String -> String -> IO ()
+createSymRef GitRepository{..} symName ref =
+        writeFile (getGitDirectory </> symName) $ "ref: " ++ ref ++ "\n"
+
+
+createRef :: GitRepository -> String -> String -> IO ()
+createRef GitRepository{..} ref sha = do
+    let (path, name) = splitFileName ref
+        dir          = getGitDirectory </> path
+    _ <- createDirectoryIfMissing True dir
+    writeFile (dir </> name) (sha ++ "\n")
+
+pathForPack :: GitRepository -> FilePath
+pathForPack GitRepository{..} = getGitDirectory </> ".git" </> "objects" </> "pack"
+
+pathForObject :: String -> String -> (FilePath, String)
+pathForObject repoName sha | length sha == 40 = (repoName </> ".git" </> "objects" </> pre, rest)
+    where pre  = take 2 sha
+          rest = drop 2 sha
+pathForObject _ _ = ("", "")
+
+type Repository = String
+
+-- header: "type size\0"
+-- sha1 $ header ++ content
+readObject :: GitRepository -> ObjectId -> IO (Maybe Object)
+readObject GitRepository{..} sha = do
+    let (path, name) = pathForObject getName sha
+        filename     = path </> name
+    exists <- doesFileExist filename
+    if exists then do
+        bs <- BC.readFile filename
+        return $ parseBlob $ inflate bs
+    else return Nothing
+    where parseBlob blob = eitherToMaybe $ AC.parseOnly (blobParser sha) blob
+          inflate blob = B.concat $ L.toChunks $ Z.decompress $ L.fromChunks [blob]
+
+-- header: "type size\0"
+-- sha1 $ header ++ content
+blobParser :: ObjectId -> AC.Parser Object
+blobParser sha1 = do
+   objType <- AC.string "commit" <|> AC.string "tree" <|> AC.string "blob" <|> AC.string "tag"
+   AC.char ' '
+   size <- AC.takeWhile AC.isDigit
+   AC.char '\0'
+   blob <- AC.takeByteString
+   return $ ResolvedObject (obj objType) blob (read $ BC.unpack size) sha1
+   where obj "commit"   = Commit
+         obj "tree"     = Tree
+         obj "blob"     = Blob
+         obj "tag"      = Tag
+
+
+
+-- header: "type size\0"
+-- sha1 $ header ++ content
+writeObject :: GitRepository -> Object -> IO ()
+writeObject _ (UnresolvedObject {}) = error "Can't write an UnresolvedObject"
+writeObject GitRepository{..} obj = do
+    let (path, name) = pathForObject getName $ sha1 obj
+        filename     = path </> name
+    _ <- createDirectoryIfMissing True path
+    L.writeFile filename $ compress (getContent obj)
+    where compress data' = Z.compress $ L.fromChunks [data'] -- FIXME should data be lazy in the first place?
+
+hsh :: B.ByteString -> String
+hsh = toHex . SHA1.hash
+
+objectTypeToString :: ObjectType -> B.ByteString
+objectTypeToString Commit = "commit"
+objectTypeToString Tree   = "tree"
+objectTypeToString Blob   = "blob"
+objectTypeToString Tag    = "tag"
+
+encodeObject :: PackfileObject -> Object
+encodeObject obj@(PackfileObject ot@(RefDelta _) size content) = UnresolvedObject ot content size
+encodeObject obj@(PackfileObject ot size _) =
+        ResolvedObject ot blob size (hsh blob)
+    where header obj' =
+            let blobType = objType obj'
+            in  headerForBlob blobType $ objectData obj'
+          blob                                   = header obj `BC.append` objectData obj
+          objType (PackfileObject Commit _ _)    = "commit"
+          objType (PackfileObject Blob _ _)      = "blob"
+          objType (PackfileObject Tree _ _)      = "tree"
+          objType (PackfileObject Tag _ _)       = "tag"
+
+headerForBlob :: B.ByteString -> B.ByteString -> B.ByteString
+headerForBlob objType content = objType `BC.append` " " `BC.append` BC.pack (show $ BC.length content) `BC.append` "\0"
+
+createEmptyGitRepository :: FilePath -> IO ()
+createEmptyGitRepository gitDir =
+        mapM_ (\dir -> createDirectoryIfMissing True (gitDir </> dir)) topLevelDirectories
+        where topLevelDirectories = ["objects", "refs", "hooks", "info"]
+
+toObjectId :: ObjectType -> Maybe ObjectId
+toObjectId (RefDelta base) = Just $ toHex $ B.pack base
+toObjectId _               = Nothing
+
+toHex :: BC.ByteString -> String
+toHex bytes = BC.unpack bytes >>= printf "%02x"

File src/Git/PackProtocol.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Git.PackProtocol(
+    parsePacket
+  , PacketLine(..)
+) where
+
+
+import qualified Data.Attoparsec.Lazy as AL
+import qualified Data.Attoparsec.Char8 as AC
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Attoparsec.Combinator
+import Data.Attoparsec.Char8 hiding (char, space, take)
+import Data.Maybe
+
+data PacketLine = FirstLine {
+    objId           :: C.ByteString
+   ,ref             :: C.ByteString
+   ,capabilities    :: [C.ByteString]
+} | RefLine {
+    objId           :: C.ByteString
+   ,ref             :: C.ByteString
+} | NullLine {
+    zeroId          :: C.ByteString
+} deriving (Show, Eq)
+
+parsePacket :: L.ByteString -> [PacketLine]
+parsePacket line = fromMaybe [] $ AL.maybeResult $ AL.parse parseLines line
+
+parseLines :: Parser [PacketLine]
+parseLines = parseLine `sepBy` AC.char '\n'
+
+parseLine :: Parser PacketLine
+parseLine = choice [parseFirstLine, parseRef]
+
+
+parseFirstLine :: Parser PacketLine
+parseFirstLine = do
+    objId' <- AC.take 40
+    space
+    ref' <- takeTill (== '\0')
+    nul
+    capabilities' <- takeTill (== '\n')
+    return $ FirstLine objId' ref' (C.split ' ' capabilities')
+
+parseRef :: Parser PacketLine
+parseRef = do
+    objId' <- AC.take 40
+    space
+    ref' <- takeTill (== '\n')
+    return $ RefLine objId' ref'
+
+space, nul :: Parser Char
+space       = satisfy (== ' ')
+nul         = satisfy (== '\0')
+

File src/Git/Packfile.hs

+{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}
+
+module Git.Packfile (
+    packRead
+  , Packfile(..)
+  , PackfileObject(..)
+) where
+
+
+import Control.Applicative
+import Data.ByteString (ByteString)
+import qualified Data.Iteratee as I
+import Data.Iteratee.Binary
+import Data.Iteratee.ZLib
+import Control.Monad                    (replicateM)
+import Data.Maybe
+import Data.Char                        (ord)
+import Data.Word                        (Word8,Word32)
+import Data.Bits
+import Git.Common                       (isMsbSet, ObjectType(..))
+
+type Content = ByteString
+
+-- | The pack file header that usually represents the first 12 bytes of a pack
+-- file. The first 4 bytes that contain the magic byte for the pack file
+-- ('PACK') are not included, the version is contained in the next 4 bytes and
+-- the number of objects in the last 4 bytes.
+data Packfile = Packfile {
+      version       :: Word32
+    , numObjects    :: Word32
+    , objects       :: [PackfileObject]
+    } | InvalidPackfile deriving (Show)
+
+data PackfileObject = PackfileObject {
+     objectType     :: ObjectType
+   , size           :: Int
+   , objectData     :: Content
+    } deriving (Show)
+
+parsePackFileObjectHeader :: I.Iteratee ByteString IO Packfile
+parsePackFileObjectHeader = do
+    magic       <- endianRead4 MSB -- 4 bytes
+    version     <- endianRead4 MSB
+    numObjects  <- endianRead4 MSB
+    if packMagic == magic
+                then parseObjects version numObjects
+                else return InvalidPackfile
+  where packMagic = fromOctets $ map (fromIntegral . ord) "PACK"
+
+parseObjects :: Word32 -> Word32 -> I.Iteratee ByteString IO Packfile
+parseObjects version num = do
+    objs <- catMaybes <$> replicateM (fromIntegral num) parsePackObject
+    return $ Packfile version num objs
+
+
+parsePackObject :: I.Iteratee ByteString IO (Maybe PackfileObject)
+parsePackObject = do
+    byte <- I.head -- read 1 byte
+    let objectType  = byte `shiftR` 4 .&. 7 -- shift right and masking the 4th least significtan bit
+        initial     = fromIntegral $ byte .&. 15
+    size <- if isMsbSet byte then parseObjectSize initial 0 else return initial
+    obj <- toObjectType objectType
+    content <- I.joinI $ enumInflate Zlib defaultDecompressParams I.stream2stream
+    return $ (\t -> PackfileObject t size content) <$> obj
+
+-- Parse the variable length size header part of the object entry
+parseObjectSize :: Int -> Int -> I.Iteratee ByteString IO Int
+parseObjectSize size iter = do
+    nextByte <- I.head
+    let add           = (coerce (nextByte .&. 127) :: Int) `shiftL` (4 + (iter * 7))
+        acc           = size + fromIntegral add
+    if isMsbSet nextByte then
+        parseObjectSize acc (iter + 1)
+    else
+        return acc
+    where coerce = toEnum . fromEnum
+
+
+packRead :: FilePath -> IO Packfile
+packRead = I.fileDriverRandom parsePackFileObjectHeader
+
+
+
+-- =================================================================================
+
+
+fromOctets :: [Word8] -> Word32
+fromOctets = foldl accum 0
+  where
+    accum a o = (a `shiftL` 8) .|. fromIntegral o
+
+-- Map the internal representation of the object type to the ObjectType
+toObjectType :: (Show a, Integral a) => a -> I.Iteratee ByteString IO (Maybe ObjectType)
+toObjectType 1  = return $ Just Commit
+toObjectType 2  = return $ Just Tree
+toObjectType 3  = return $ Just Blob
+toObjectType 4  = return $ Just Tag
+toObjectType 6  = do
+    offset <- readOffset 0 0
+    return $ Just (OfsDelta offset)
+toObjectType 7  = do 
+    baseObj <- replicateM 20 I.head -- 20-byte base object name SHA1
+    return $ Just (RefDelta baseObj)
+toObjectType _  = return Nothing
+
+
+-- offset encoding:
+--  n bytes with MSB set in all but the last one.
+--  The offset is then the number constructed by
+--  concatenating the lower 7 bit of each byte, and
+--  for n >= 2 adding 2^7 + 2^14 + ... + 2^(7*(n-1))
+--  to the result.
+readOffset :: Int -> Int -> I.Iteratee ByteString IO Int
+readOffset shft acc = do
+    x <- I.head
+    let bs = acc + ((coerce (x .&. 0x7f) :: Int) `shiftL` shft)
+    if isMsbSet x
+        then readOffset (shft+7) (bs+1)
+        else return bs
+    where coerce = toEnum . fromEnum

File src/Git/Remote.hs

+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+
+-- FIXME implement ls-remote because we already have it anyway
+
+module Git.Remote(
+    clone
+  , parseRemote
+  , Remote(..)
+) where
+
+import qualified Data.Attoparsec.Char8 as AC
+import Data.Attoparsec.Combinator
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as L
+import Control.Applicative                      ((<$>))
+import System.Directory                         (removeFile, createDirectoryIfMissing)
+import System.FilePath                          ((</>), takeFileName, dropExtension)
+import Network.Socket                           (withSocketsDo)
+import Data.Maybe
+import Data.List
+import Git.TcpClient
+import Git.PackProtocol
+import Git.Common
+import Git.ObjectStore
+
+refDiscovery :: String -> String -> String
+refDiscovery host repo = pktLine $ "git-upload-pack /" ++ repo ++ "\0host="++host++"\0" -- ++ flushPkt -- Tell the server to disconnect
+
+toObjId :: PacketLine -> Maybe String
+toObjId (FirstLine obj _ _) = Just $ C.unpack obj
+toObjId (RefLine obj _)     = Just $ C.unpack obj
+toObjId _                   = Nothing
+
+
+-- PKT-LINE("want" SP obj-id SP capability-list LF)
+-- PKT-LINE("want" SP obj-id LF)
+--
+-- FIXME - filter heads/tags
+createNegotiationRequest :: [String] -> [PacketLine] -> String
+createNegotiationRequest capabilities = concatMap (++ "") . nub . map (pktLine . (++ "\n")) . foldl' (\acc e -> if null acc then first acc e else additional acc e) [] . wants
+                    where wants = mapMaybe toObjId
+                          first acc obj      = acc ++ ["want " ++ obj ++ " " ++ unwords capabilities]
+                          additional acc obj = acc ++ ["want " ++ obj]
+
+data Remote = Remote {
+    getHost         :: String
+  , getPort         :: Maybe Int
+  , getRepository   :: String
+} deriving (Eq, Show)
+
+-- | Parse a URL using the git protocol format.
+-- E.g. git://git.apache.org:9418/foo.git
+--
+-- Schema:
+--   * git://host.xz[:port]/path/to/repo.git/
+--   * git://host.xz[:port]/~[user]/path/to/repo.git/
+--
+-- See the "GIT URLS" section on
+-- http://www.kernel.org/pub/software/scm/git/docs/git-clone.html
+parseRemote :: B.ByteString -> Maybe Remote
+parseRemote = eitherToMaybe . AC.parseOnly parser
+    where parser = do
+            host <- "git://" AC..*> domain
+            port <- option Nothing (Just <$> (":" AC..*> AC.decimal))
+            slash
+            repo <- AC.takeByteString
+            return $ Remote (C.unpack host) port (C.unpack repo)
+          domain = AC.takeTill (\x -> x == '/' || x == ':')
+          slash  = AC.satisfy (== '/')
+
+repositoryName :: Remote -> String
+repositoryName = takeFileName . dropExtension . getRepository
+
+clone :: String -> IO ()
+clone url =
+    case parseRemote $ C.pack url of
+        Just remote -> let gitRepoName = repositoryName remote
+                       in clone' (GitRepository gitRepoName gitRepoName) remote
+        _           -> putStrLn $ "Invalid URL" ++ url
+
+
+-- .git/objects/pack/tmp_pack_6bo2La
+clone' :: GitRepository -> Remote -> IO ()
+clone' repo Remote{..} = withSocketsDo $
+    withConnection getHost (show $ fromMaybe 9418 getPort) $ \sock -> do
+        let payload = refDiscovery getHost getRepository
+        send sock payload
+        putStrLn "Receiving..."
+        response <- receive sock
+        let pack = parsePacket $ L.fromChunks [response]
+            --wants = map toObjId pack
+        let request = createNegotiationRequest ["multi_ack_detailed", "agent=git/1.8.1"] pack ++ flushPkt ++ "0009done\n"
+        {-let request = (createNegotiationRequest ["multi_ack_detailed", "side-band-64k", "thin-pack", "ofs-delta", "agent=git/1.8.1"] pack) ++ flushPkt ++ "0009done\n"-}
+        send sock request
+        response2 <- receiveFully sock
+        putStrLn "Received bytes:"
+        print $ B.length response2
+        let packFile = B.drop 8 response2
+            dir = pathForPack repo
+            tmpPack = dir </> "tmp_pack_incoming"
+        _ <- createDirectoryIfMissing True dir
+        B.writeFile tmpPack packFile
+        createGitRepositoryFromPackfile repo tmpPack
+        removeFile tmpPack
+        putStrLn "Finished"

File src/Git/TcpClient.hs

+-- | A git compatible TcpClient that understands the git packet line format.
+module Git.TcpClient (
+   withConnection
+ , send
+ , receiveFully
+ , receive
+) where
+
+import qualified Data.ByteString.Char8 as C
+import Network.Socket hiding                    (recv, send)
+import Network.Socket.ByteString                (recv, sendAll)
+import Data.Monoid                              (mempty, mappend)
+import Numeric                                  (readHex)
+
+withConnection :: HostName -> ServiceName -> (Socket -> IO b) -> IO b
+withConnection host port consumer = do
+    sock <- openConnection host port
+    r <- consumer sock
+    sClose sock
+    return r
+
+
+send :: Socket -> String -> IO ()
+send sock msg = sendAll sock $ C.pack msg
+
+
+-- | Read from the socket until the peer closes its half side of the
+-- connection.
+receiveFully :: Socket -> IO C.ByteString
+receiveFully sock = receive' sock mempty
+   where receive' s acc = do
+            msg <- recv s 4096
+            if C.null msg then return acc else receive' s $ mappend acc msg
+
+
+-- | Read packet lines.
+receive :: Socket -> IO C.ByteString
+receive sock = receive' sock mempty
+    where receive' s acc = do
+            maybeLine <- readPacketLine s
+            maybe (return acc) (receive' s . mappend acc) maybeLine
+
+-- =================================================================================
+
+openConnection :: HostName -> ServiceName -> IO Socket
+openConnection host port = do
+        addrinfos <- getAddrInfo Nothing (Just host) (Just port)
+        let serveraddr = head addrinfos
+        sock <- socket (addrFamily serveraddr) Stream defaultProtocol
+        connect sock (addrAddress serveraddr)
+        return sock
+
+-- | Read a packet line
+readPacketLine :: Socket -> IO (Maybe C.ByteString)
+readPacketLine sock = do
+    msg <- recv sock 4 -- check for a zero length return -> disconnected
+    if C.null msg then return Nothing else
+        case readHex $ C.unpack msg of
+            ((l,_):_) | l > 4 -> do
+                 line <- recv sock (l-4)
+                 return $ Just line
+            _ -> return Nothing
+
+		Git installation
+
+Normally you can just do "make" followed by "make install", and that
+will install the git programs in your own ~/bin/ directory.  If you want
+to do a global install, you can do
+
+	$ make prefix=/usr all doc info ;# as yourself
+	# make prefix=/usr install install-doc install-html install-info ;# as root
+
+(or prefix=/usr/local, of course).  Just like any program suite
+that uses $prefix, the built results have some paths encoded,
+which are derived from $prefix, so "make all; make prefix=/usr
+install" would not work.
+
+The beginning of the Makefile documents many variables that affect the way
+git is built.  You can override them either from the command line, or in a
+config.mak file.
+
+Alternatively you can use autoconf generated ./configure script to
+set up install paths (via config.mak.autogen), so you can write instead
+
+	$ make configure ;# as yourself
+	$ ./configure --prefix=/usr ;# as yourself
+	$ make all doc ;# as yourself
+	# make install install-doc install-html;# as root
+
+If you're willing to trade off (much) longer build time for a later
+faster git you can also do a profile feedback build with
+
+	$ make prefix=/usr PROFILE=BUILD all
+	# make prefix=/usr PROFILE=BUILD install
+
+This will run the complete test suite as training workload and then
+rebuild git with the generated profile feedback. This results in a git
+which is a few percent faster on CPU intensive workloads.  This
+may be a good tradeoff for distribution packagers.
+
+Or if you just want to install a profile-optimized version of git into
+your home directory, you could run:
+
+	$ make PROFILE=BUILD install
+
+As a caveat: a profile-optimized build takes a *lot* longer since the
+git tree must be built twice, and in order for the profiling
+measurements to work properly, ccache must be disabled and the test
+suite has to be run using only a single CPU.  In addition, the profile
+feedback build stage currently generates a lot of additional compiler
+warnings.
+
+Issues of note:
+
+ - Ancient versions of GNU Interactive Tools (pre-4.9.2) installed a
+   program "git", whose name conflicts with this program.  But with
+   version 4.9.2, after long hiatus without active maintenance (since
+   around 1997), it changed its name to gnuit and the name conflict is no
+   longer a problem.
+
+   NOTE: When compiled with backward compatibility option, the GNU
+   Interactive Tools package still can install "git", but you can build it
+   with --disable-transition option to avoid this.
+
+ - You can use git after building but without installing if you want
+   to test drive it.  Simply run git found in bin-wrappers directory
+   in the build directory, or prepend that directory to your $PATH.
+   This however is less efficient than running an installed git, as
+   you always need an extra fork+exec to run any git subcommand.
+
+   It is still possible to use git without installing by setting a few
+   environment variables, which was the way this was done
+   traditionally.  But using git found in bin-wrappers directory in
+   the build directory is far simpler.  As a historical reference, the
+   old way went like this:
+
+	GIT_EXEC_PATH=`pwd`
+	PATH=`pwd`:$PATH
+	GITPERLLIB=`pwd`/perl/blib/lib
+	export GIT_EXEC_PATH PATH GITPERLLIB
+
+ - Git is reasonably self-sufficient, but does depend on a few external
+   programs and libraries.  Git can be used without most of them by adding
+   the approriate "NO_<LIBRARY>=YesPlease" to the make command line or
+   config.mak file.
+
+	- "zlib", the compression library. Git won't build without it.
+
+	- "ssh" is used to push and pull over the net.
+
+	- A POSIX-compliant shell is required to run many scripts needed
+	  for everyday use (e.g. "bisect", "pull").
+
+	- "Perl" version 5.8 or later is needed to use some of the
+	  features (e.g. preparing a partial commit using "git add -i/-p",
+	  interacting with svn repositories with "git svn").  If you can
+	  live without these, use NO_PERL.  Note that recent releases of
+	  Redhat/Fedora are reported to ship Perl binary package with some
+	  core modules stripped away (see http://lwn.net/Articles/477234/),
+	  so you might need to install additional packages other than Perl
+	  itself, e.g. Time::HiRes.
+
+	- "openssl" library is used by git-imap-send to use IMAP over SSL.
+	  If you don't need it, use NO_OPENSSL.
+
+	  By default, git uses OpenSSL for SHA1 but it will use it's own
+	  library (inspired by Mozilla's) with either NO_OPENSSL or
+	  BLK_SHA1.  Also included is a version optimized for PowerPC
+	  (PPC_SHA1).
+
+	- "libcurl" library is used by git-http-fetch and git-fetch.  You
+	  might also want the "curl" executable for debugging purposes.
+	  If you do not use http:// or https:// repositories, you do not
+	  have to have them (use NO_CURL).
+
+	- "expat" library; git-http-push uses it for remote lock
+	  management over DAV.  Similar to "curl" above, this is optional
+	  (with NO_EXPAT).
+
+	- "wish", the Tcl/Tk windowing shell is used in gitk to show the
+	  history graphically, and in git-gui.  If you don't want gitk or
+	  git-gui, you can use NO_TCLTK.
+
+	- A gettext library is used by default for localizing Git. The
+	  primary target is GNU libintl, but the Solaris gettext
+	  implementation also works.
+
+	  We need a gettext.h on the system for C code, gettext.sh (or
+	  Solaris gettext(1)) for shell scripts, and libintl-perl for Perl
+	  programs.
+
+	  Set NO_GETTEXT to disable localization support and make Git only
+	  use English. Under autoconf the configure script will do this
+	  automatically if it can't find libintl on the system.
+
+	- Python version 2.6 or later is needed to use the git-p4
+	  interface to Perforce.
+
+ - Some platform specific issues are dealt with Makefile rules,
+   but depending on your specific installation, you may not
+   have all the libraries/tools needed, or you may have
+   necessary libraries at unusual locations.  Please look at the
+   top of the Makefile to see what can be adjusted for your needs.
+   You can place local settings in config.mak and the Makefile
+   will include them.  Note that config.mak is not distributed;
+   the name is reserved for local settings.
+
+ - To build and install documentation suite, you need to have
+   the asciidoc/xmlto toolchain.  Because not many people are
+   inclined to install the tools, the default build target
+   ("make all") does _not_ build them.
+
+   "make doc" builds documentation in man and html formats; there are
+   also "make man", "make html" and "make info". Note that "make html"
+   requires asciidoc, but not xmlto. "make man" (and thus make doc)
+   requires both.
+
+   "make install-doc" installs documentation in man format only; there
+   are also "make install-man", "make install-html" and "make
+   install-info".
+
+   Building and installing the info file additionally requires
+   makeinfo and docbook2X.  Version 0.8.3 is known to work.
+
+   Building and installing the pdf file additionally requires
+   dblatex.  Version >= 0.2.7 is known to work.
+
+   All formats require at least asciidoc 8.4.1.
+
+   There are also "make quick-install-doc", "make quick-install-man"
+   and "make quick-install-html" which install preformatted man pages
+   and html documentation. To use these build targets, you need to
+   clone two separate git-htmldocs and git-manpages repositories next
+   to the clone of git itself.
+
+   It has been reported that docbook-xsl version 1.72 and 1.73 are
+   buggy; 1.72 misformats manual pages for callouts, and 1.73 needs
+   the patch in contrib/patches/docbook-xsl-manpages-charmap.patch
+
+   Users attempting to build the documentation on Cygwin may need to ensure
+   that the /etc/xml/catalog file looks something like this:
+
+   <?xml version="1.0"?>
+   <!DOCTYPE catalog PUBLIC
+      "-//OASIS//DTD Entity Resolution XML Catalog V1.0//EN"
+      "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"
+   >
+   <catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+     <rewriteURI
+       uriStartString = "http://docbook.sourceforge.net/release/xsl/current"
+       rewritePrefix = "/usr/share/sgml/docbook/xsl-stylesheets"
+     />
+     <rewriteURI
+       uriStartString="http://www.oasis-open.org/docbook/xml/4.5"
+       rewritePrefix="/usr/share/sgml/docbook/xml-dtd-4.5"
+     />
+  </catalog>
+
+  This can be achieved with the following two xmlcatalog commands:
+
+  xmlcatalog --noout \
+     --add rewriteURI \
+        http://docbook.sourceforge.net/release/xsl/current \
+        /usr/share/sgml/docbook/xsl-stylesheets \
+     /etc/xml/catalog
+
+  xmlcatalog --noout \
+     --add rewriteURI \
+         http://www.oasis-open.org/docbook/xml/4.5/xsl/current \
+         /usr/share/sgml/docbook/xml-dtd-4.5 \
+     /etc/xml/catalog
+module Main where
+
+import System.Environment (getArgs)
+import Git.Remote
+
+main :: IO ()
+main = do
+    args <- getArgs
+    case args of
+        (cmd:xs)    -> run cmd xs
+        _           -> error "Missing command"
+
+run :: String -> [String] -> IO ()
+run "clone" (url:_) = clone url
+run _ _             = error "Unknown command or missing arguments"
+

File src/ls-remote-tcp.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (
+    main
+) where
+
+import Git.Remote
+import Debug.Trace
+
+-- The git repository is made available via:
+--  git daemon --reuseaddr --verbose  --base-path=. --export-all
+-- in the parent directory of the git repository 'stash-scm-cache'
+
+-- Run via: runhaskell ls-remote.hs | nc -v localhost 9418
+
+
+{-repoName = "md5-identity" -- "haskell-package" -- "git-bottom-up"-}
+{-host = "127.0.0.1"-}
+{-port = "9418"-}
+
+{-repoName = "juretta/rabbit-tools.git" -- "haskell-package" -- "git-bottom-up"-}
+{-host = "github.com"-}
+{-port = "9418"-}
+
+{-repoName = "flex-utilities.git" -- "haskell-package" -- "git-bottom-up"-}
+{-host = "git.apache.org"-}
+{-port = "9418"-}
+
+main = clone "git://git.apache.org/flex-utilities.git"

File test-with-coverage.sh

+#!/bin/bash
+
+# http://www.haskell.org/ghc/docs/latest/html/users_guide/hpc.html
+
+cabal clean
+cabal configure --enable-tests --ghc-option=-fhpc
+cabal build && cabal test
+hpc markup dist/hpc/tix/hgit-testsuite/hgit-testsuite.tix
+:set -i../src -isrc
+:m + Test.QuickCheck
+:l Main
+:set prompt "test>> "
+:set -Wall
+

File tests/.gitignore

+dist
+*.tix
+.hpc

File tests/src/Git/CommonTests.hs

+{-# LANGUAGE BangPatterns #-}
+module Git.CommonTests
+  (
+    main
+  , test
+  ) where
+
+import qualified Test.HUnit as H
+import Git.Common
+import Test.QuickCheck hiding ((.&.))
+import Test.Framework (Test, defaultMain, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.Framework.Providers.HUnit
+import Data.Bits
+import Data.Word
+
+main :: IO ()
+main = defaultMain [test]
+
+test_isMsbSet = H.assertBool
+  "isMsbSet should be true if the most significant bit is set"
+  (isMsbSet (128::Word8))
+
+test_isMsbNotSet = H.assertBool
+  "isMsbSet should be false if the most significant bit is not set"
+  (not $ isMsbSet (127::Word8))
+
+test_pktLineEmpty = H.assertEqual
+    "Empty pktline should be 0004"
+    "0004"
+    (pktLine "")
+
+test_pktLineNotEmpty = H.assertEqual
+    "Should be prefixed with valid length (in hex)"
+    "0032want 40bcec379e1cde8d3a3e841e7f218cd84448cec5\n"
+    (pktLine "want 40bcec379e1cde8d3a3e841e7f218cd84448cec5\n")
+
+test_pktLineDone = H.assertEqual
+    "Done packet"
+    "0008done"
+    (pktLine "done")
+
+test_pktLineDoneLn = H.assertEqual
+    "Done packet"
+    "0009done\n"
+    (pktLine "done\n")
+
+test_toHex = H.assertEqual
+    "210 should be in hex"
+    "d2"
+    (toHex 210)
+
+test :: Test
+test = testGroup "Common"
+    [
+        testProperty "prop_isMsbSet" prop_isMsbSet
+       ,testCase "isMsbSet/1" test_isMsbSet
+       ,testCase "isMsbSet/2" test_isMsbNotSet
+       ,testCase "test_pktLineEmpty/1" test_pktLineEmpty
+       ,testCase "test_pktLineNotEmpty/1" test_pktLineNotEmpty
+       ,testCase "test_pktLineDone/1" test_pktLineDone
+       ,testCase "test_pktLineDoneLn/1" test_pktLineDoneLn
+       ,testCase "test_toHex/1" test_toHex
+    ]
+
+prop_isMsbSet :: Int -> Bool
+prop_isMsbSet x = testBit x 7 == isMsbSet x
+

File tests/src/Git/RemoteTests.hs

+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+module Git.RemoteTests
+  (
+    main
+  , test
+  ) where
+
+import qualified Test.HUnit as H
+import Git.Remote
+import Test.QuickCheck hiding ((.&.))
+import Test.Framework (Test, defaultMain, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.Framework.Providers.HUnit
+import Data.Bits
+import Data.Word
+
+main :: IO ()
+main = defaultMain [test]
+
+test_parseRemoteEmpty = H.assertEqual
+  "Try parse empty string"
+  Nothing
+  (parseRemote "")
+
+test_parseRemoteValid = H.assertEqual
+  "Parse a valid URL successfully"
+  (Just $ Remote "git.apache.org" Nothing "thrift.git")
+  (parseRemote "git://git.apache.org/thrift.git")
+
+test_parseRemoteValidWithPort = H.assertEqual
+  "Parse a valid URL (including the port) successfully"
+  (Just $ Remote "git.apache.org" (Just 9418) "thrift.git")
+  (parseRemote "git://git.apache.org:9418/thrift.git")
+
+test_parseRemoteValidWithPortAndUsername = H.assertEqual
+  "Parse a valid URL (including the port and username) successfully"
+  (Just $ Remote "git.apache.org" (Just 9418) "~ssaasen/thrift.git")
+  (parseRemote "git://git.apache.org:9418/~ssaasen/thrift.git")
+
+test :: Test
+test = testGroup "Common"
+    [
+        testCase "parseRemote/1" test_parseRemoteEmpty
+      , testCase "parseRemote/2" test_parseRemoteValid
+      , testCase "parseRemote/3" test_parseRemoteValidWithPort
+      , testCase "parseRemote/4" test_parseRemoteValidWithPortAndUsername
+    ]
+
+

File tests/src/TestRunner.hs

+module Main where
+
+import qualified Git.CommonTests
+import qualified Git.RemoteTests
+import Test.Framework
+
+main ::
+  IO ()
+main =
+  defaultMain tests
+
+tests ::
+  [Test]
+tests =
+  [
+    testGroup "Tests"
+      [
+         Git.CommonTests.test
+        ,Git.RemoteTests.test
+      ]
+  ]
+