| By | fr33domlover |
| At | 2016-04-24 |
| Title | Partial git-fetch-over-HTTP request parsing, enough for trivial clones |
| Description |
Edit file hit-network.cabal 0 → 0
+ 35 Network.Git.Transport.HTTP.Fetch.UploadRequest
… … … … Edit file src/Data/Binary/Get/Local.hs 0 → 0
- 109 -- aren't equal. If equal, return the given value.
- 110 requireByteString :: ByteString -> a -> Get a
- 111 requireByteString s v = do
+ 109 -- aren't equal.
+ 110 requireByteString :: ByteString -> Get ()
+ 111 requireByteString s = do
- 114 then return v
+ 114 then return ()
… … … … Edit file src/Network/Git/Get.hs 0 → 0
+ 16 {-# LANGUAGE MultiWayIf #-}+ 17 {-# LANGUAGE OverloadedStrings #-}+ 18 - 25 , getCapabilities
+ 28 , getCapabilitiesFetch
+ 32 import Control.Monad (when)
+ 33 import Data.Binary.Get
+ 34 import Data.ByteString (ByteString)
+ 35 import Data.Git.Graph.Util (ObjId (..))
+ 36 import Data.Git.Ref (fromHex)
+ 37 + 38 import qualified Data.ByteString as B
+ 39 import qualified Data.ByteString.Char8 as BC
+ 40 + 41 import Data.Binary.Get.Local
+ 42 import Network.Git.Types
+ 43 … … … … - 69 getCapabilities :: Int -> Get [Capability]
- 70 getCapabilities n = do
- 71 getByteString n
- 72 return []
+ 84 parseSharedCapability :: ByteString -> Maybe SharedCapability
+ 85 parseSharedCapability b
+ 86 | b == "ofs-delta" = Just CapOfsDelta
+ 87 | b == "side-band-64k" = Just CapSideBand64k
+ 88 | "agent=" `B.isPrefixOf` b = Just $ CapAgent $ B.drop 6 b
+ 89 | otherwise = Nothing
+ 90 + 91 parseFetchCapability :: ByteString -> Maybe FetchCapability
+ 92 parseFetchCapability b =
+ 93 case b of
+ 94 "multi_ack" -> Just CapMultiAck
+ 95 "multi_ack_detailed" -> Just CapMultiAckDetailed
+ 96 "no-done" -> Just CapNoDone
+ 97 "thin-pack" -> Just $ CapThinPack True
+ 98 "no-thin" -> Just $ CapThinPack False
+ 99 "side-band" -> Just CapSideBand
+ 100 "shallow" -> Just CapShallow
+ 101 "no-progres" -> Just CapNoProgress
+ 102 "include-tag" -> Just CapIncludeTag
+ 103 "allow-tip-sha1-in-want" -> Just CapAllowTipSHA1InWant
+ 104 "allow-reachable-sha1-in-want" -> Just CapAllowReachableSha1InWant
+ 105 _ -> Nothing
+ 106 + 107 getCapabilitiesFetch
+ 108 :: Int -> Get (Either ByteString ([SharedCapability], [FetchCapability]))
+ 109 getCapabilitiesFetch n = do
+ 110 b <- getByteString n
+ 111 let loop [] scaps fcaps = Right (scaps, fcaps)
+ 112 loop (w:ws) scaps fcaps =
+ 113 case (parseSharedCapability w, parseFetchCapability w) of
+ 114 (Just sc, _) -> loop ws (sc : scaps) fcaps
+ 115 (Nothing, Just fc) -> loop ws scaps (fc : fcaps)
+ 116 (Nothing, Nothing) -> Left b
+ 117 return $ loop (BC.words b) [] []
… … … … Add file src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs 0
Edit file src/Network/Git/Transport/HTTP/Fetch/UploadRequest.hs 0 → 0
+ 1 {- This file is part of hit-network.+ 2 -
+ 3 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ 4 -
+ 5 - ♡ Copying is an act of love. Please copy, reuse and share.
+ 6 -
+ 7 - The author(s) have dedicated all copyright and related and neighboring
+ 8 - rights to this software to the public domain worldwide. This software is
+ 9 - distributed without any warranty.
+ 10 -
+ 11 - You should have received a copy of the CC0 Public Domain Dedication along
+ 12 - with this software. If not, see
+ 13 - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ 14 -}
+ 15 + 16 {-# LANGUAGE OverloadedStrings #-}+ 17 + 18 module Network.Git.Transport.HTTP.Fetch.UploadRequest
+ 19 ( -- * Types
+ 20 UploadRequest (..)
+ 21 -- * Get
+ 22 , getUploadRequest
+ 23 )
+ 24 where
+ 25 + 26 import Control.Applicative (many)
+ 27 import Data.Binary.Get
+ 28 import Data.Git.Graph.Util (ObjId)
+ 29 + 30 import qualified Data.ByteString.Char8 as BC (unpack)
+ 31 + 32 import Data.Binary.Get.Local
+ 33 import Network.Git.Get
+ 34 import Network.Git.Types
+ 35 + 36 -------------------------------------------------------------------------------
+ 37 -- Types
+ 38 -------------------------------------------------------------------------------
+ 39 + 40 data UploadRequest = UploadRequest
+ 41 { urSharedCaps :: [SharedCapability]+ 42 , urFetchCaps :: [FetchCapability]
+ 43 , urWants :: [ObjId]
+ 44 }
+ 45 + 46 -------------------------------------------------------------------------------
+ 47 -- Get
+ 48 -------------------------------------------------------------------------------
+ 49 + 50 getFirstWant :: Get ([SharedCapability], [FetchCapability], ObjId)
+ 51 getFirstWant = getDataPkt $ \ len -> do
+ 52 requireByteString "want"
+ 53 requireSpace
+ 54 oid <- getObjId
+ 55 ecaps <- getCapabilitiesFetch $ len - 45
+ 56 case ecaps of
+ 57 Left b -> fail $ "Unrecognized capability: " ++ BC.unpack b
+ 58 Right (scaps, fcaps) -> return (scaps, fcaps, oid)
+ 59 + 60 getWants :: Get ([SharedCapability], [FetchCapability], [ObjId])
+ 61 getWants = do
+ 62 (scaps, fcaps, oid) <- getFirstWant
+ 63 oids <- many $ getTaggedObjId "want"
+ 64 return (scaps, fcaps, oid:oids)
+ 65 + 66 getDone :: Get ()
+ 67 getDone = getDataPkt $ \ len ->
+ 68 case len of
+ 69 4 -> requireByteString "done"
+ 70 5 -> requireByteString "done" >> requireNewline
+ 71 _ -> fail "Invalid length for a \"done\" pkt-line"
+ 72 + 73 getUploadRequest :: Get UploadRequest
+ 74 getUploadRequest = do
+ 75 (scaps, fcaps, oids) <- getWants
+ 76 getFlushPkt
+ 77 getDone
+ 78 return UploadRequest
+ 79 { urSharedCaps = scaps+ 80 , urFetchCaps = fcaps
+ 81 , urWants = oids
+ 82 }
… … … …