diff --git a/src/Data/Binary/Get/Local.hs b/src/Data/Binary/Get/Local.hs new file mode 100644 index 0000000..a277cc6 --- /dev/null +++ b/src/Data/Binary/Get/Local.hs @@ -0,0 +1,90 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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" diff --git a/src/Data/Binary/Put/Local.hs b/src/Data/Binary/Put/Local.hs new file mode 100644 index 0000000..a988734 --- /dev/null +++ b/src/Data/Binary/Put/Local.hs @@ -0,0 +1,62 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Data/ByteString/Local.hs b/src/Data/ByteString/Local.hs new file mode 100644 index 0000000..87f4ef6 --- /dev/null +++ b/src/Data/ByteString/Local.hs @@ -0,0 +1,40 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index 44f89d3..68f90ed 100644 --- a/src/Data/Git/Local.hs +++ b/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 diff --git a/src/GitPackProto.hs b/src/GitPackProto.hs new file mode 100644 index 0000000..8edfec4 --- /dev/null +++ b/src/GitPackProto.hs @@ -0,0 +1,308 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/GitPackProto2.hs b/src/GitPackProto2.hs new file mode 100644 index 0000000..9d82f8a --- /dev/null +++ b/src/GitPackProto2.hs @@ -0,0 +1,29 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +{-# 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 diff --git a/src/Network/Git/Local.hs b/src/Network/Git/Local.hs new file mode 100644 index 0000000..046a29d --- /dev/null +++ b/src/Network/Git/Local.hs @@ -0,0 +1,20 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Git.Local + ( + ) +where + diff --git a/src/Network/Git/Local/Get.hs b/src/Network/Git/Local/Get.hs new file mode 100644 index 0000000..8f93e12 --- /dev/null +++ b/src/Network/Git/Local/Get.hs @@ -0,0 +1,47 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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 [] diff --git a/src/Network/Git/Local/Put.hs b/src/Network/Git/Local/Put.hs new file mode 100644 index 0000000..65cce67 --- /dev/null +++ b/src/Network/Git/Local/Put.hs @@ -0,0 +1,63 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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 diff --git a/src/Network/Git/Local/RefDiscovery.hs b/src/Network/Git/Local/RefDiscovery.hs new file mode 100644 index 0000000..0a1224a --- /dev/null +++ b/src/Network/Git/Local/RefDiscovery.hs @@ -0,0 +1,22 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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 diff --git a/src/Network/Git/Local/RefDiscovery/Put.hs b/src/Network/Git/Local/RefDiscovery/Put.hs new file mode 100644 index 0000000..c4e75a7 --- /dev/null +++ b/src/Network/Git/Local/RefDiscovery/Put.hs @@ -0,0 +1,67 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Network/Git/Local/RefDiscovery/Types.hs b/src/Network/Git/Local/RefDiscovery/Types.hs new file mode 100644 index 0000000..0c4b92e --- /dev/null +++ b/src/Network/Git/Local/RefDiscovery/Types.hs @@ -0,0 +1,45 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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] + } diff --git a/src/Network/Git/Local/ShallowUpdate/Put.hs b/src/Network/Git/Local/ShallowUpdate/Put.hs new file mode 100644 index 0000000..317dd4d --- /dev/null +++ b/src/Network/Git/Local/ShallowUpdate/Put.hs @@ -0,0 +1,41 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Network/Git/Local/ShallowUpdate/Types.hs b/src/Network/Git/Local/ShallowUpdate/Types.hs new file mode 100644 index 0000000..fed93d4 --- /dev/null +++ b/src/Network/Git/Local/ShallowUpdate/Types.hs @@ -0,0 +1,24 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Network.Git.Local.ShallowUpdate.Types + ( ShallowUpdate (..) + ) +where + +data ShallowUpdate = ShallowUpdate + { suShallows :: [ObjId] + , suUnshallows :: [ObjId] + } diff --git a/src/Network/Git/Local/Types.hs b/src/Network/Git/Local/Types.hs new file mode 100644 index 0000000..b4df8fb --- /dev/null +++ b/src/Network/Git/Local/Types.hs @@ -0,0 +1,27 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Network/Git/Local/UploadRequest.hs b/src/Network/Git/Local/UploadRequest.hs new file mode 100644 index 0000000..a455dd4 --- /dev/null +++ b/src/Network/Git/Local/UploadRequest.hs @@ -0,0 +1,22 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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 diff --git a/src/Network/Git/Local/UploadRequest/Get.hs b/src/Network/Git/Local/UploadRequest/Get.hs new file mode 100644 index 0000000..45ddfd7 --- /dev/null +++ b/src/Network/Git/Local/UploadRequest/Get.hs @@ -0,0 +1,77 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 + } diff --git a/src/Network/Git/Local/UploadRequest/Types.hs b/src/Network/Git/Local/UploadRequest/Types.hs new file mode 100644 index 0000000..33a9fc9 --- /dev/null +++ b/src/Network/Git/Local/UploadRequest/Types.hs @@ -0,0 +1,28 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 + } diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index 10b8e06..0ee9366 100644 --- a/src/Vervis/Ssh.hs +++ b/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 SessionB = LoggingT (ReaderT ConnectionPool IO) +type ChannelBase = LoggingT (ReaderT ConnectionPool IO) +type SessionBase = LoggingT (ReaderT ConnectionPool IO) type Backend = SqlBackend -type Channel = ChannelT ChannelB -type Session = SessionT SessionB ChannelB +type Channel = ChannelT ChannelBase +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 diff --git a/vervis.cabal b/vervis.cabal index 076169d..4b69393 100644 --- a/vervis.cabal +++ b/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