Work on git pack protocol, not done yet

This is a lot of code, better save now than sorry later when something
gets deleted by mistake.

Either way, the code will move later - once tested and organized
properly - into its own package.

src/Data/Binary/Get/Local.hs

@@ -0,0 +1,90 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Data.Binary.Get.Local
+    ( getHexDigit
+    , getHex16
+    , getDecimal
+    --TODO i added more functions below, didnt export yet
+    )
+where
+
+-- | Read an ASCII character representing a hexadecimal digit, and convert to
+-- the integral value of the digit (i.e. a number between 0 and 15).
+getHexDigit :: Get Word8
+getHexDigit =
+    let fromHex w
+            | 48 <= w && w <= 57  = return $ w - 48 -- 0-9
+            | 65 <= w && w <= 70  = return $ w - 55 -- A-F
+            | 97 <= w && w <= 102 = return $ w - 87 -- a-f
+            | otherwise           = fail "Not an ASCII hex digit"
+    in  getWord8 >>= fromHex
+
+-- | Efficienty convert 'Word8' to 'Int'.
+toInt :: Word8 -> Int
+toInt w =
+    fromMaybe (error "Huh? Converting Word8 to Int failed!") $
+    toIntegralSized w
+
+-- | Read 4 ASCII hex digits and parse them as a hex string into the integer it
+-- represents. Since each hex digit is 4 bits, 4 such digits form a 16-bit
+-- integer (but this function reads 4 bytes which are 32 bits).
+--
+-- The resulting 16-bit integer is returned as an 'Int' because it is used
+-- below with a function which takes an 'Int' parameter.
+getHex16 :: Get Int
+getHex16 = do
+    let sl n = unsafeShiftL n . toInt
+    hh <- sl 12 <$> getHexDigit
+    h  <- sl  8 <$> getHexDigit
+    l  <- sl  4 <$> getHexDigit
+    ll <- toInt <$> getHexDigit
+    return $ hh .&. h .&. l .&. ll
+
+-- Read a string of given size representing an integer in decimal, and parse
+-- the integer.
+getDecimal :: Num a => Int -> Get a
+getDecimal len = do
+    s <- getByteString len
+    case fromDecimal s
+        Nothing -> fail "s doesn't represent a decimal integer"
+        Just n  -> return n
+
+-- | Get a word which satisfies the predicate, otherwise fail.
+requireWord8 :: (Word8 -> Bool) -> Get Word8
+requireWord8 p = do
+    w <- getWord8
+    if p w
+        then return w
+        else fail "Word doesn't satisfy predicate"
+
+requireSpace :: Get ()
+requireSpace = void $ requireWord8 (== 32)
+
+attemptByteString :: ByteString -> Get Bool
+attemptByteString s = fmap isJust . lookAheadM $ do
+    b <- getByteString $ length s
+    if b == s
+        then return $ Just b
+        else return Nothing
+
+-- | Read a bytestring of the same length as the parameter, and fail if they
+-- aren't equal. If equal, return the given value.
+requireByteString :: ByteString -> a -> Get a
+requireByteString s v = fmap isJust $ lookAheadM $ do
+    b <- getByteString $ length s
+    if b == s
+        then return v
+        else fail "Didn't get the expected bytestring"

src/Data/Binary/Put/Local.hs

@@ -0,0 +1,62 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Data.Binary.Put.Local
+    ( putNull
+    , putLF
+    , putSpace
+    , putHexDigit
+    , putHex16
+    )
+where
+
+putNull :: Put
+putNull = putWord8 0
+
+putLF :: Put
+putLF = putWord8 10
+
+putSpace :: Put
+putSpace = putWord8 32
+
+-- | Efficiently convert an 'Int' between 0 and 127 to 'Word8'.
+toWord8 :: Int -> Word8
+toWord8 i =
+    fromMaybe (error "Converting Int to Word8 failed") $
+    toIntegralSized i
+
+-- | Take an integral value of a hex digit (i.e. between 0 and 15). Put the
+-- ASCII character representing the digit in lowecase hexadecimal.
+putHexDigit :: Word8 -> Put
+putHexDigit w
+    | 0 <= w && w <= 9   =
+    | 10 <= w && w <= 15 =
+    | otherwise          =
+
+-- | Takes a number which must be a 16-bit non-negative integer. Generates a
+-- 4-byte ASCII hexadecimal representation of the number's value and puts it.
+putHex16 :: Int -> Put
+putHex16 n =
+    let (rem1, ll) = n    `divMod` 16
+        (rem2, l)  = rem1 `divMod` 16
+        (rem3, h)  = rem2 `divMod` 16
+        (rem4, hh) = rem3 `divMod` 16
+    in  if rem4 /= 0
+            then fail "Hex integer to put is too large, must be 16 bit"
+            else do
+                putHexDigit $ toWord8 hh
+                putHexDigit $ toWord8 h
+                putHexDigit $ toWord8 l
+                putHexDigit $ toWord8 ll

src/Data/ByteString/Local.hs

@@ -0,0 +1,40 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Data.ByteString.Local
+    ( fromDecimal
+    )
+where
+
+import Prelude
+
+import Data.ByteString (ByteString)
+
+import qualified Data.ByteString as B
+
+-- | Given an ASCII string representing an integer in decimal, parse it and
+-- return the number. Return 'Nothing' on invalid digit chars and on an empty
+-- bytestring.
+--
+-- >>> fromDecimal "345"
+-- Just 345
+--
+-- >>> fromDecimal "a1b2c3"
+-- Nothing
+fromDecimal :: Num a => ByteString -> Maybe a
+fromDecimal s =
+    if (not . B.null) s && B.all (\ b -> 48 <= b && b <= 57) s
+        then Just $ B.foldl' (\ n b -> 10 * n + b - 48) 0 s
+        else Nothing

src/Data/Git/Local.hs

@@ -15,7 +15,10 @@
 
 -- | Git repo tools using the @hit@ package.
 module Data.Git.Local
-    ( loadCommits
+    ( resolveNameMaybe
+    , resolveName
+    , listReferences
+    , loadCommits
     , NodeLabel
     , EdgeLabel
     , CommitGraph
@@ -32,21 +35,45 @@ import Prelude
 
 import Control.Monad.IO.Class
 import Data.Foldable (foldl', foldlM)
+import Data.Git.Named (RefName (..))
 import Data.Git.Ref (Ref, toBinary)
-import Data.Git.Repository (getCommit, resolveRevision)
+import Data.Git.Repository (getCommit, resolveRevision, branchList, tagList)
 import Data.Git.Revision (Revision (..))
 import Data.Git.Storage (Git)
 import Data.Git.Types (Commit (..))
 import Data.Graph.Inductive.Graph (Graph (mkGraph), Node)
 import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.Hashable (Hashable (..))
+import Data.Maybe (catMaybes, fromMaybe)
 import Data.Ord (Down (..))
 
 import qualified Data.DList as D
 import qualified Data.HashMap.Strict as M
+import qualified Data.Set as S
 
 import Data.Graph.Inductive.Local
 
+-- | For a given ref name - HEAD or branch or tag - determine its ref hash.
+resolveNameMaybe :: Git -> String -> IO (Maybe Ref)
+resolveNameMaybe git name = resolveRevision git $ Revision name []
+
+-- | For a given ref name - HEAD or branch or tag - determine its ref hash.
+resolveName :: Git -> String -> IO Ref
+resolveName git name = do
+    mref <- resolveNameMaybe git name
+    return $ fromMaybe (error "No such ref name in the repo") mref
+
+-- | List the available references in a git repo, sorted by ref name. The list
+-- includes HEAD, branches and tags.
+listReferences :: Git -> IO [(Ref, String)]
+listReferences git = do
+    branches <- S.mapMonotonic refNameRaw <$> branchList git
+    tags <- S.mapMonotonic refNameRaw <$> tagList git
+    let names = S.toAscList $ S.insert "HEAD" $ S.union branches tags
+    mentries <-
+        traverse (\ name -> fmap (,name) <$> resolveNameMaybe git name) names
+    return $ catMaybes mentries
+
 instance Hashable Ref where
     hashWithSalt salt = hashWithSalt salt . toBinary
     hash = hash . toBinary

src/GitPackProto.hs

@@ -0,0 +1,308 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module GitPackProto
+    ( RepoSpec (..)
+    , Action (..)
+    , parseExec
+    )
+where
+
+import Prelude
+
+import Control.Applicative ((<|>))
+import Data.Attoparsec.Text
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.Bits
+import Data.ByteString (ByteString, unsnoc)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Word
+
+-- What is going on
+--
+-- When SSH authentication succeeds, you receive a request from the SSH client
+-- and need to respond. This module handles the following at the moment:
+--
+-- [~] Parse an Execute request using attoparsec into a Vervis action to run
+-- [ ] Using the binary package, implement the git pack protocol
+
+--hexdig :: Parser ?
+--nul :: Parser ?
+--zeroId :: Parser ?
+--objId :: Parser ?
+--hexdig :: Parser ?
+
+{-data RefName
+    = RefNameHead
+    | RefNamePath [ByteString]
+
+refname :: Parser ByteString
+refname =
+    let refnameHead = string "HEAD"
+        refsec = 
+        refnameHier = do
+            string "refs/"
+            refsec `sepBy` char '/'
+    in  refnameHead <|> refnameHier-}
+
+data RepoRef = RepoRef Text Text Text
+
+data RepoSpec
+    = SpecUserProjRepo Text Text Text
+    | SpecProjRepo Text Text
+    | SpecUserRepo Text Text
+    | SpecRepo Text
+    deriving Show
+
+data Action = UploadPack RepoSpec deriving Show
+
+repoSpecP :: Parser RepoSpec
+repoSpecP =
+        SpecRepo         <$> msep *> part
+    <|> SpecProjRepo     <$> msep *> part <* sep <*> part
+    <|> SpecUserRepo     <$> home *> part <* sep <*> part
+    <|> SpecUserProjRepo <$> msh  *> part <* sep <*> part <* sep <*> part
+    where
+    part = takeWhile1 $ \ c -> c /= '/' && c /= '\''
+    sep  = char '/'
+    msep = optional sep
+    home = char '~'
+    msh  = optional $ satisfy $ \ c -> c == '/' || c == '~'
+
+actionP :: Parser Action
+actionP = UploadPack <$> ("git-upload-pack '" *> repoSpecP <* char '\'')
+
+parseExec :: Text -> Either String Action
+parseExec input = parseOnly (actionP <* endOfInput) input
+
+-------------------------------------------------------------------------------
+-- Git pack protocol, using the 'binary' package
+--
+-- I /can/ use attoparsec instead. But I'm not sure yet which is better here.
+-- Since I never used either, I'll just try them, learn and experiment in the
+-- process, and eventually I'll be able to make an educated decision.
+-------------------------------------------------------------------------------
+
+data PktLine = DataPkt ByteString | FlushPkt
+
+getPktLine :: Bool -> Get PktLine
+getPktLine stripLF = do
+    pktLen <- getHex16
+    if  | pktLen == 0    -> return FlushPkt
+        | pktLen > 65524 -> fail "pkt-len is above the maximum allowed"
+        | pktLen <= 4    -> fail "pkt-len is below the possible minimum"
+        | otherwise      -> do
+            let len = pktLen - 4
+            payload <- getByteString len
+            case (stripLF, unsnoc payload) of
+                (True, Just (r, 10)) -> return $ DataPkt r
+                _                    -> return $ DataPkt payload
+
+
+putPktLine :: Bool -> PktLine -> Put
+putPktLine _     FlushPkt    = putByteString "0000"
+putPktLine addLF (DataPkt b) =
+    let len = B.length b + bool 0 1 addLF
+    in  if  | len == 0    = fail "tried to put an empty pkt-line"
+            | len > 65520 = fail "payload bigger than maximal pkt-len"
+            | otherwise   = do
+                putHex16 $ len + 4
+                putByteString b
+                when addLF $ putWord8 10
+
+data PktLine' a = DataPkt' a | FlushPkt'
+
+getPktLine' :: (Int -> Get a) -> Get (PktLine' a)
+getPktLine' getData = do
+    pktLen <- getHex16
+    if  | pktLen == 0    -> return FlushPkt
+        | pktLen > 65524 -> fail "pkt-len is above the maximum allowed"
+        | pktLen <= 4    -> fail "pkt-len is below the possible minimum"
+        | otherwise      -> do
+            let len = pktLen - 4
+            payload <- isolate len $ getData len
+            return $ DataPkt payload
+
+putPktLine' :: Bool -> (a -> (Int, Put)) -> PktLine' a -> Put
+putPktLine' _     _      FlushPkt          = putByteString "0000"
+putPktLine' addLF lenPut (DataPkt payload) =
+    let (len, putPayload) = first (bool id (+ 1) addLF) $ lenPut payload
+    in  if  | len == 0    = fail "tried to put an empty pkt-line"
+            | len > 65520 = fail "payload bigger than maximal pkt-len"
+            | otherwise   = do
+                putHex16 $ len + 4
+                putPayload
+                when addLF $ putWord8 10
+
+
+
+
+-- | A typeclass similar to 'Binary', which takes dynamic data lengths into
+-- account.
+--
+-- Putting a value also returns the number of bytes that are being put. This is
+-- useful for cases where you need to send the size of a data chunk as part of
+-- the chunk, which is somewhat common in low-level network protocols.
+--
+-- In the same manner, getting a value can take a length limit into account.
+-- For example, if you are parsing a network packet of known size you can (and
+-- perhaps sometimes you must) use the length to determine how many bytes you
+-- still need to read. It also needs to return how many bytes it read.
+class LengthBinary a where
+    lenPut :: a -> PutM Int
+    lenGet :: Int -> Get (Int, a)
+
+instance LengthBinary a => Binary a where
+    put = void lenPut
+
+-------------------------------------------------------------------------------
+-- Advertize refs
+-------------------------------------------------------------------------------
+
+-- steps for parsing last part of the line: take all remaining chars first.
+-- then remove last LF is present, and operate on the result...
+
+symRefP :: Parser SymRef
+symRefP =
+        SymRefHead   <$> string "HEAD"
+    <|> SymRefBranch <$> ("refs/heads/" *> takeWhile1
+
+headBS :: ByteString
+headBS = "HEAD"
+
+headLen :: ByteString
+headLen = B.length headBS
+
+branchPrefix :: ByteString
+branchPrefix = "refs/heads/"
+
+branchPrefixLen :: Int
+branchPrefixLen = B.length branchPrefix
+
+tagPrefix :: ByteString
+tagPrefix = "refs/tags/"
+
+tagPrefixLen :: Int
+tagPrefixLen = B.length tagPrefix
+
+instance SizedBinary SymRef where
+    sizePut SymRefHead = do
+        putByteString headBS
+        return headLen
+    sizePut (SymRefBranch b) = do
+        putByteString branchPrefix
+        putByteString b
+        return $ branchPrefixLen + B.length b
+    sizePut (SymRefTag b) = do
+        putByteString tagPrefix
+        putByteString b
+        return $ tagPrefixLen + B.length b
+    sizeGet lim =
+        let getHead =
+                if lim == headLen
+                    then do
+                        head <- getByteString headLen
+                        if head == headBS
+                            then return (lim, SymRefHead)
+                            else fail "4-byte symref that isn't HEAD"
+            getBranch =
+                if lim > branchPrefixLen
+                    then do
+                        prefix <- getByteString branchPrefixLen
+                        if prefix == branchPrefix
+                            then do
+                                name <- getByteString $ lim - branchPrefixLen
+                                return (lim, SymRefBranch name)
+                            else fail "symref too short to be a branch"
+            getTag =
+                if lim > tagPrefixLen
+                    then do
+                        prefix <- getByteString tagPrefixLen
+                        if prefix == tagPrefix
+                            then do
+                                name <- getByteString $ lim - tagPrefixLen
+                                return (lim, SymRefTag name)
+                            else fail "symref too short to be a tag"
+        in  getHead <|> getTag <|> getBranch
+
+newtype ObjId = ObjId Ref
+
+instance SizedBinary ObjId where
+    sizePut (ObjId ref) = do
+        let hex = toHex ref
+        putByteString hex
+        return $ B.length hex -- should be 40
+    sizeGet lim =
+        if lim >= 40
+            then do
+                hex <- getByteString 40
+                return (40, fromHex hex)
+            else fail "Not enough bytes to read ObjId"
+
+data RefAd = RefAd
+    { refAdId   :: ObjId
+    , refAdSym  :: SymRef
+    , refAdName :: ByteString
+    }
+
+data Space = Space
+
+instance SizedBinary Space where
+    sizePut Space = do
+        putWord8 32
+        return 1
+    sizeGet lim =
+        if lim >= 1
+            then do
+                w <- getWord8
+                if w == 32
+                    then return (1, Space)
+                    else fail "Read a byte that isn't space"
+            else fail "No bytes left to read"
+
+(.+.) :: (Applicative f, Num a) => f a -> f a -> f a
+(.+.) = liftA2 (+)
+
+infixl 6 .+.
+
+instance SizedBinary RefAd where
+    sizePut ad =
+            lenPut (refAdId ad)
+        .+. lenPut Space
+        .+. lenPut (refAdName ad)
+    sizeGet lim = do
+        (r, oid) <- sizeGet lim
+        let lim' = lim - r
+        (r', Space) <- sizeGet lim'
+        let lim'' = lim' - r'
+        (r'', sym) - sizeGet lim''
+
+        if lim > tagPrefixLen
+                    then do
+                        prefix <- getByteString tagPrefixLen
+                        if prefix == tagPrefix
+                            then do
+                                name <- getByteString $ lim - tagPrefixLen
+                                return (lim, SymRefTag name)
+                            else fail "symref too short to be a tag"
+
+-- pack protocol sequence
+--
+-- (1) Send the ref list
+-- (2) Wait for input
+--     (2a) If got flush-pkt, close channel
+--     (2b) TODO CONTINUE

src/GitPackProto2.hs

@@ -0,0 +1,29 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+{-# LANGUAGE MultiWayIf #-}
+
+module GitPackProto2 where
+
+import Prelude
+
+import Data.Binary.Put
+
+
+-- algo TODO REVISE TO PERFECTION
+--
+-- - send ref discovery
+-- - receive update request OR flush-pkt which means finish?
+-- - verify all listed objids in want lines appeared in ref discovery

src/Network/Git/Local.hs

@@ -0,0 +1,20 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local
+    (
+    )
+where
+

src/Network/Git/Local/Get.hs

@@ -0,0 +1,47 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | Helpers for getting git pack protocol elements.
+module Network.Git.Local.Get
+    ( requireFlushPkt
+    , attemptFlushPkt
+    , getDataPkt
+    --TODO export more stuff i added below
+    )
+where
+
+requireFlushPkt :: Get ()
+requireFlushPkt = requireByteString "0000"
+
+attemptFlushPkt :: Get Bool
+attemptFlushPkt = attemptByteString "0000"
+
+getDataPkt :: (Int -> Get a) -> Get a
+getDataPkt getPayload = do
+    pktLen <- getHex16
+    if  | pktLen == 0    -> fail "Expected regular pkt-line, got flush-pkt"
+        | pktLen > 65524 -> fail "pkt-len is above the maximum allowed"
+        | pktLen <= 4    -> fail "pkt-len is below the possible minimum"
+        | otherwise      ->
+            let len = pktLen - 4
+            in  isolate len $ getPayload len
+
+getObjId :: Get ObjId
+getObjId = ObjId . fromHex <$> getByteString 40
+
+getCapabilities :: Int -> Get [Capability]
+getCapabilities n = do
+    getByteString n
+    return []

src/Network/Git/Local/Put.hs

@@ -0,0 +1,63 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | Helpers for putting git pack protocol elements.
+module Network.Git.Local.Put
+    ( -- * Object ID
+      zeroObjId
+    , putObjId
+      -- * Capability
+    , putCapabilities
+    , lenCapabilities
+      -- * Pkt Line
+    , putFlushPkt
+    , putDataPkt
+    )
+where
+
+zeroObjId :: ObjId
+zeroObjId = ObjId $ fromHex $ B.replicate 40 48 -- 40 times '0'
+
+putObjId :: ObjId -> Put
+putObjId (ObjId ref) = putByteString $ toHex ref
+
+putCapability :: Capability -> Put
+putCapability Capability = putByteString "dummy"
+
+lenCapability :: Capability -> Int
+lenCapability Capability = 5
+
+putCapabilities :: [Capability] -> Put
+putCapabilities []     = return ()
+putCapabilities (c:cs) = do
+    putCapability c
+    traverse_ (\ d -> putSpace >> putCapability d) cs
+
+lenCapabilities :: [Capability] -> Int
+lenCapabilities []     = 0
+lenCapabilities (c:cs) = lenCapability c + sum (map ((+ 1) . lenCapability) cs)
+
+putFlushPkt :: Put
+putFlushPkt = putByteString "0000"
+
+putDataPkt :: Bool -> Int -> Put -> Put
+putDataPkt addLF payloadLen payloadPut =
+    let len = bool id (+1) addLF $ payloadLen
+    in  if  | len == 0    = fail "tried to put an empty pkt-line"
+            | len > 65520 = fail "payload bigger than maximal pkt-len"
+            | otherwise   = do
+                putHex16 $ len + 4
+                payloadPut
+                when addLF $ putLF

src/Network/Git/Local/RefDiscovery.hs

@@ -0,0 +1,22 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | When communication starts, the server sends the client the list of refs in
+-- the local repo. This is called ref advertisement. From the client side, it's
+-- called ref discovery.
+module Network.Git.Local.RefDiscovery
+    (
+    )
+where

src/Network/Git/Local/RefDiscovery/Put.hs

@@ -0,0 +1,67 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.RefDiscovery.Put
+    ( putRefDiscover
+    )
+where
+
+putSymRef :: SymRef -> Put
+putSymRef SymRefHead = putByteString "HEAD"
+putSymRef (SymRefBranch b) = do
+    putByteString "refs/heads/"
+    putByteString b
+putSymRef (SymRefTag b p) = do
+    putByteString "refs/tags/"
+    putByteString b
+    when p $ putByteString "^{}"
+
+putRefAd :: RefAd -> Put
+putRefAd ad = do
+    putObjId $ refAdId ad
+    putSpace
+    putByteString $ refAdName ad
+
+lenRefAd :: RefAd -> Int
+lenRefAd ad = 40 + 1 + B.length (refAdName ad)
+
+putRefAdLine :: RefAd -> Put
+putRefAdLine ad = putDataPkt True (lenRefAd ad) $ putRefAd ad
+
+putRefAdCapaLine :: RefAd -> [Capability] Put
+putRefAdCapaLine ad caps =
+    putDataPkt True (lenRefAd ad + 1 + lenCapabilities caps) $ do
+        putRefAd ad
+        putNull
+        putCapabilities caps
+
+putDummyRefAdCapaLine :: [Capability] -> Put
+putDummyRefAdCapaLine = putRefAdCapaLine $ RefAd
+    { refAdId   = zeroObjId
+    , refAdSym  = SymRefOther
+    , refAdName = "capabilities^{}"
+    }
+
+-- TODO: declare capabilities
+-- TODO: peel annotated tags (somewhere else, so that this list already gets
+--       the peeled tags)
+putRefDiscover :: RefDiscover -> Put
+putRefDiscover (RefDiscover [] caps) = do
+    putDummyRefAdCapaLine caps
+    putFlushPkt
+putRefDiscover (ReDiscover (a:as) caps) = do
+    putRefAdCapaLine a caps
+    traverse_ putRefAdLine as
+    putFlushPkt

src/Network/Git/Local/RefDiscovery/Types.hs

@@ -0,0 +1,45 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.RefDiscovery.Types
+    (
+    )
+where
+
+-- | A symbolic reference which refers to an object.
+data SymRef
+    -- | The current branch.
+    = SymRefHead
+    -- | A branch with the given name.
+    | SymRefBranch ByteString
+    -- | A tag with the given name, and whether it's a peeled tag.
+    | SymRefTag ByteString Bool
+    -- | Something else.
+    -- | SymRefOther
+
+-- | A ref advertisement. Used by one side to tell the other which refs it has
+-- locally.
+data RefAd = RefAd
+    { refAdId   :: ObjId
+    , refAdSym  :: SymRef
+    , refAdName :: ByteString
+    }
+
+-- | A message which allows the client to discover what the server side has and
+-- supports.
+data RefDiscover = RefDiscover
+    { rdAds  :: [RefAd]
+    , rdCaps :: [Capability]
+    }

src/Network/Git/Local/ShallowUpdate/Put.hs

@@ -0,0 +1,41 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.ShallowUpdate.Put
+    ( putShallowUpdate
+    )
+where
+
+putShallow :: ObjId -> Put
+putShallow oid = do
+    let len = 7 + 1 + 40
+    putDataPkt True len $ do
+        putByteString "shallow"
+        putSpace
+        putObjId oid
+
+putUnshallow :: ObjId -> Put
+putUnshallow oid = do
+    let len = 9 + 1 + 40
+    putDataPkt True len $ do
+        putByteString "unshallow"
+        putSpace
+        putObjId oid
+
+putShallowUpdate :: ShallowUpdate -> Put
+putShallowUpdate su = do
+    traverse_ putShallow $ suShallows su
+    traverse_ putUnshallow $ suUnshallows su
+    putFlushPkt

src/Network/Git/Local/ShallowUpdate/Types.hs

@@ -0,0 +1,24 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.ShallowUpdate.Types
+    ( ShallowUpdate (..)
+    )
+where
+
+data ShallowUpdate = ShallowUpdate
+    { suShallows   :: [ObjId]
+    , suUnshallows :: [ObjId]
+    }

src/Network/Git/Local/Types.hs

@@ -0,0 +1,27 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.Types
+    (
+    )
+where
+
+-- | A git object identifier. This is a SHA-1 hash. Its common textual
+-- representation is a 40-byte ASCII hexadecimal string.
+newtype ObjId = ObjId Ref
+
+-- | A git protocol capability. The server uses this to tell the client what it
+-- does and doesn't support.
+data Capability = Capability

src/Network/Git/Local/UploadRequest.hs

@@ -0,0 +1,22 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | After the client gets the advertised refs, it decides whether it needs to
+-- receive updates from the server. If yes, it sends a request which specifies
+-- exactly what it wants to receive.
+module Network.Git.Local.UploadRequest
+    (
+    )
+where

src/Network/Git/Local/UploadRequest/Get.hs

@@ -0,0 +1,77 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.UploadRequest.Get
+    ( getUploadRequest
+    )
+where
+
+getFirstWant :: Get ([Capability], ObjId)
+getFirstWant = getDataPkt $ \ len -> do
+    requireByteString "want"
+    requireSpace
+    oid <- getObjId
+    caps <- getCapabilities $ len - 45
+    return (caps, oid)
+
+attemptTaggedObjId :: ByteString -> Get (Maybe ObjId)
+attemptTaggedObjId s = lookAheahM $ getDataPkt $ \ _len -> do
+    b <- getByteString $ length s
+    if b == s
+        then do
+            requireSpace
+            Just <$> getObjId
+        else return Nothing
+
+-- unfoldM is from the monad-loops package
+getWants :: Get ([Capability], [ObjId])
+getWants = do
+    (caps, oid) <- getFirstWant
+    oids <- unfoldM $ attemptTaggedObjId "want"
+    return (caps, oid:oids)
+
+getShallows :: Get [ObjId]
+getShallows = unfoldM $ attemptTaggedObjId "shallow"
+
+attemptDepth :: Get (Maybe Int)
+attemptDepth = lookAheadM $ getDataPkt $ \ len -> do
+    b <- getByteString 6
+    if b == "deepen"
+        then do
+            requireSpace
+            d <- getByteString $ len - 7
+            let mn = case B.unsnoc d of
+                Just (i, 10) -> fromDecimal i
+                _            -> fromDecimal d
+            case mn of
+                Nothing -> fail "invalid depth string"
+                Just n  -> return $ Just n
+        else return Nothing
+
+getUploadRequest :: Get UploadRequest
+getUploadRequest = do
+    (caps, oids) <- getWants
+    shls <- getShallows
+    mdepth <- attemptDepth
+    requireFlushPkt
+    return UploadRequest
+        { urCaps     = caps
+        , urWants    = oids
+        , urShallows = shls
+        , urDepth    = case mdepth of
+            Nothing -> Nothing
+            Just 0  -> Nothing
+            Just d  -> Just d
+        }

src/Network/Git/Local/UploadRequest/Types.hs

@@ -0,0 +1,28 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Network.Git.Local.UploadRequest.Types
+    ( UploadRequest (..)
+    )
+where
+
+-- | Using this request, the client specifies which git data it wants from the
+-- server.
+data UploadRequest = UploadRequest
+    { urCaps     :: [Capability]
+    , urWants    :: [ObjId]
+    , urShallows :: [ObjId]
+    , urDepth    :: Maybe Int
+    }

src/Vervis/Ssh.hs

@@ -25,10 +25,10 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)
-import Data.ByteString.Char8 (ByteString, unpack)
+import Data.ByteString (ByteString)
 import Data.ByteString.Lazy (fromStrict)
 import Data.Foldable (find)
-import Data.Text (Text, pack)
+import Data.Text (Text, pack, unpack)
 import Database.Persist
 import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool)
 import Network.SSH
@@ -43,15 +43,15 @@ import Vervis.Settings
 -- TODO:
 -- [x] Implement serious logging (info, warning, error, etc.) with
 --     monad-logger, maybe see how loggin works in the scaffolding
--- [ ] See which git commands darcsden SSH supports and see if I can implement
+-- [ ] See which git commands gitolite SSH supports and see if I can implement
 --     them with Hit (i think it was git upload-pack)
 
-type ChannelB = LoggingT (ReaderT ConnectionPool IO)
+type ChannelBase = LoggingT (ReaderT ConnectionPool IO)
-type SessionB = LoggingT (ReaderT ConnectionPool IO)
+type SessionBase = LoggingT (ReaderT ConnectionPool IO)
 type Backend = SqlBackend
 
-type Channel = ChannelT ChannelB
+type Channel = ChannelT ChannelBase
-type Session = SessionT SessionB ChannelB
+type Session = SessionT SessionBase ChannelBase
 type SshChanDB = ReaderT Backend Channel
 type SshSessDB = ReaderT Backend Session
 
@@ -68,7 +68,7 @@ runSessDB action = do
     pool <- lift . lift $ ask
     runSqlPool action pool
 
-chanFail :: Bool -> ByteString -> Channel ()
+chanFail :: Bool -> Text -> Channel ()
 chanFail wantReply msg = do
     channelError $ unpack msg
     when wantReply channelFail
@@ -98,10 +98,31 @@ authorize (PublicKey name key) = do
                     $logInfoS src "Auth succeeded"
                     return True
 
+data Action = UploadPack () deriving Show
+
+detectAction :: ChannelRequest -> Maybe Action
+detectAction _ = Nothing
+
+runAction :: Bool -> Action -> Channel (Maybe Text)
+runAction _wantReply action =
+    case action of
+        UploadPack repo -> return $ Just "Doesn't work yet"
+
 handle :: Bool -> ChannelRequest -> Channel ()
 handle wantReply request = do
     $logDebugS src $ pack $ show request
-    chanFail wantReply "I don't execute any commands yet, come back later"
+    case detectAction request of
+        Nothing  -> err "Unsupported request"
+        Just act -> do
+            $logDebugS src $ pack $ show act
+            res <- runAction wantReply act
+            case res of
+                Nothing  -> do
+                    when wantReply channelSuccess
+                    channelDone
+                Just msg -> err msg
+    where
+    err = chanFail wantReply
 
 ready :: LogFunc -> IO ()
 ready = runLoggingT $ $logInfoS src "SSH server component starting"
@@ -110,7 +131,7 @@ mkConfig
     :: AppSettings
     -> ConnectionPool
     -> LogFunc
-    -> IO (Config SessionB ChannelB)
+    -> IO (Config SessionBase ChannelBase)
 mkConfig settings pool logFunc = do
     keyPair <- keyPairFromFile $ appSshKeyFile settings
     return $ Config

vervis.cabal

@@ -34,11 +34,17 @@ flag library-only
   default:     False
 
 library
-  exposed-modules:     Data.ByteString.Char8.Local
+  exposed-modules:     Data.Binary.Get.Local
+                       Data.Binary.Put.Local
+                       Data.ByteString.Char8.Local
+                       Data.ByteString.Local
                        Data.Char.Local
                        Data.Git.Local
                        Data.Graph.Inductive.Local
                        Data.List.Local
+                       Network.Git.Local
+                       Network.Git.Local.Get
+                       Network.Git.Local.Put
                        Network.SSH.Local
                        Vervis.Application
                        Vervis.Field.Key
@@ -95,6 +101,7 @@ library
   build-depends:       aeson
                      , base
                      , base64-bytestring
+                     , binary
                      , blaze-html
                      , bytestring
                      , case-insensitive