forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Move git protocol code away to separate package

Browse source
This commit is contained in:
fr33domlover 2016-04-08 21:10:33 +00:00
parent 372368f0a0
commit 50198a1906
24 changed files with 30 additions and 1173 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

96
src/Data/Binary/Get/Local.hs
View file

@ -1,96 +0,0 @@
{- 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"
attemptWord8 :: (Word8 -> Bool) -> Get (Maybe Word8)
attemptWord8 p = Just <$> requireWord8 p <|> pure Nothing
requireSpace :: Get ()
requireSpace = void $ requireWord8 (== 32)
requireNewline :: Get ()
requireNewline = void $ requireWord8 (== 10)
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"

62
src/Data/Binary/Put/Local.hs
View file

@ -1,62 +0,0 @@
{- 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

212
src/Data/Git/Local.hs
View file

@ -1,212 +0,0 @@
{- 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/>.
-}
-- | Git repo tools using the @hit@ package.
module Data.Git.Local
( resolveNameMaybe
, resolveName
, listReferences
, loadCommits
, NodeLabel
, EdgeLabel
, CommitGraph
, rootN
, loadCommitGraphByRef
, loadCommitGraphByNameMaybe
, loadCommitGraphByName
, loadCommitsTopsort
, loadCommitsTopsortList
)
where
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, 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
-- | Load the entire graph of commits which are ancestors of the given ref
-- (and that ref itself). Fold the commit structure into a value of type @a@
-- inside monad @m@.
--
-- This is a low-level function which operates on a commit tree, i.e. the same
-- ref may be visited more than once (if it has more than one child commit).
-- You can use the provided flexibility to implement graph algorithms over the
-- commits, or build a graph using some graph library and use that library's
-- tools for further processing.
loadCommits
:: MonadIO m
=> Git
-- ^ Open git repository context
-> ((Ref, Commit) -> Ref -> a -> m (a, Maybe Commit))
-- ^ Given a child commit, one of its parent commits and an @a@ value,
-- generate an updated @a@ value. The second returned value determines
-- whether traversal should proceed to the parent of the parent commit. If
-- you return 'Nothing', it won't. If you load the parent commit (e.g. with
-- 'getCommit') and return 'Just' it, traversal will proceed to its
-- parents.
-> a
-- ^ Initial value
-> Ref
-- ^ Hash of the commit whose ancestor graph should be loaded
-> Maybe Commit
-- ^ If you already read the commit for the ref passed as the previous
-- parameter, pass the commit here to avoid repeated loading of it.
-- Otherwise, pass 'Nothing' and it will be read from the repo.
-> m a
loadCommits git func val ref mcmt = readCommitMaybe ref mcmt >>= go val ref
where
readCommit = liftIO . getCommit git
readCommitMaybe r = maybe (readCommit r) return
--readRefCommit r = do
-- c <- readCommit r
-- return (r, c)
step p v r = do
(v', mc) <- func p r v
case mc of
Nothing -> return v'
Just c -> go v' r c
go v r c = foldlM (step (r, c)) v $ commitParents c
--let rs = commitParents c
--ps <- mapM readRefCommit rs
--foldlM (step (r, c)) v rs
-- | Each node in the commit graph represents a commit.
type NodeLabel = (Ref, Commit)
-- | Edges are tagged by numbers defining the order of parents of a commit. For
-- each commit, the out-edges pointing to its parents are numbered according to
-- the order in which the parents were specified in the 'commitParents' field.
--
-- The 'Down' wrapper reverses the comparison (the 'Ord' instance), so that
-- merged-from branches are inserted earlier into the sorted list than
-- merged-to branches.
type EdgeLabel = Down Int
type CommitGraph g = g NodeLabel EdgeLabel
-- | The node number of the root node in loaded commit graphs.
rootN :: Node
rootN = 1
-- | Use 'loadCommits' to build a directed acyclic graph of commits. There is a
-- single root node, which is the ref passed to this function.
loadCommitGraphByRef :: Graph g => Git -> Ref -> IO (CommitGraph g)
loadCommitGraphByRef git ref = do
let visit (_rChild, _cChild) rParent v@(nextNode, commits) =
if rParent `M.member` commits
then return (v, Nothing)
else do
cParent <- getCommit git rParent
let commits' = M.insert rParent (cParent, nextNode) commits
return ((nextNode + 1, commits'), Just cParent)
cmt <- getCommit git ref
(_, commits) <- loadCommits git visit (rootN + 1, M.empty) ref (Just cmt)
let commits' = M.insert ref (cmt, rootN) commits
nodeOf r = maybe (error "ref has no node") snd $ M.lookup r commits'
mkNode l r (c, n) = (n, (r, c)) : l
nodes = M.foldlWithKey' mkNode [] commits'
mkEdge n l (r, e) = (n, nodeOf r, e) : l
edgeNums = map Down [1..]
mkEdges l (c, n) = foldl' (mkEdge n) l $ zip (commitParents c) edgeNums
edges = M.foldl' mkEdges [] commits'
return $ mkGraph nodes edges
-- | Like 'loadCommitGraphByRef', but lets you specify a named ref, such as a
-- branch or tag name. Returns 'Nothing' if ref isn't found.
loadCommitGraphByNameMaybe ::
Graph g => Git -> String -> IO (Maybe (CommitGraph g))
loadCommitGraphByNameMaybe git name = do
mref <- resolveRevision git $ Revision name []
case mref of
Nothing -> return Nothing
Just ref -> Just <$> loadCommitGraphByRef git ref
-- | Like 'loadCommitGraphByNameMaybe', but throws an exception if the ref name
-- can't be resolved.
loadCommitGraphByName :: Graph g => Git -> String -> IO (CommitGraph g)
loadCommitGraphByName git name = do
mg <- loadCommitGraphByNameMaybe git name
case mg of
Nothing -> error "no such ref"
Just g -> return g
-- | Load a commit graph and topsort the commits. The resulting list starts
-- with the last commit in the repo and ends with the initial commit.
loadCommitsTopsort
:: (ResultList l, Functor l)
=> Git
-> String
-> IO (l (Ref, Commit))
loadCommitsTopsort git name = do
let load :: IO (CommitGraph Gr)
load = loadCommitGraphByName git name
graph <- load
let mnodes = topsortUnmixOrder graph (NodeStack [rootN])
nodes = case mnodes of
Nothing -> error "commit graph contains a cycle"
Just ns -> ns
return $ fmap (nodeLabel graph) nodes
instance ResultList D.DList where
emptyList = D.empty
appendItem = flip D.snoc
-- | Runs 'loadCommitsTopsort' with a 'D.DList', then converts to list and
-- returns it. At least at the time of writing, DList mapping and folding goes
-- through a regular list anyway.
loadCommitsTopsortList :: Git -> String -> IO [(Ref, Commit)]
loadCommitsTopsortList git name = D.toList <$> loadCommitsTopsort git name

176
src/Data/Graph/Inductive/Local.hs
View file

@ -1,176 +0,0 @@
{- 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/>.
-}
-- | Graph tools for use with the @fgl@ package.
module Data.Graph.Inductive.Local
( nodeLabel
, NodeSet (..)
, TraversalOrder (..)
, ResultList (..)
, topsortKahn
, NodeStack (..)
, topsortUnmix
, topsortUnmixOrder
)
where
import Prelude
import Data.Foldable (foldl')
import Data.Graph.Inductive.Graph
import Data.List (sortBy)
-- | Find the label for a 'Node', assuming you know the node exists in the
-- graph. If the node isn't found, an exception is thrown.
nodeLabel :: Graph g => g a b -> Node -> a
nodeLabel g n =
case lab g n of
Nothing -> error "node not found in graph"
Just l -> l
-- | A graph node container to be used with Kanh's topsort algorithm.
class NodeSet s where
-- | Take a graph node and a container, insert the node into it and return
-- the resulting container.
--insert :: LNode a -> s a -> s a
insertNode :: Node -> s -> s
-- | Remove a node from the container. Return the removed node and the
-- resulting container after removal. If the container is empty (i.e. there
-- is no node to remove), return 'Nothing'.
--extract :: s a -> Maybe (LNode a, s a)
extractNode :: s -> Maybe (Node, s)
-- | Specification of the order in which a node's outgoing edges should be
-- traversed.
data TraversalOrder b
-- | The order in which they're listed by FGL functions. The FGL
-- documentation doesn't seem to specify the order, which means it may
-- depend entirely on the 'Graph' instance you are using.
= InOrder
-- | Reverse of 'InOrder'.
| ReverseOrder
-- | Sort the outgoing edge list before traversal, using the given ordering
-- function. It takes two pairs, each pair having a labeled node and the
-- label of the edge, and determines the order they should be visited. 'LT'
-- means the first edge is visited first. 'GT' means the second edge is
-- visited first. 'EQ' means it doesn't matter and the implementation can
-- choose arbitrarily.
| SortedOrder ((Node, b) -> (Node, b) -> Ordering)
-- | Lets you reorder the edge list in an arbitrary way before it gets
-- traversed. Note that it's up to you to make sure the list you return
-- really contains all the items of the input list.
| CustomOrder ([(Node, b)] -> [(Node, b)])
sortNodes :: TraversalOrder b -> [(Node, b)] -> [(Node, b)]
sortNodes InOrder = id
sortNodes ReverseOrder = reverse
sortNodes (SortedOrder f) = sortBy f
sortNodes (CustomOrder f) = f
-- | A container for storing the result of the sorting. Kahn's algorithm begins
-- with an empty structure and then appends nodes to produce the result.
-- Therefore almost any sequence container could work.
--
-- You can also use a regular Haskell list. Implement 'append' using list
-- prepend and remember to 'reverse' the list returned by the algorithm.
class ResultList l where
emptyList :: l a
appendItem :: a -> l a -> l a
-- | Flexible topological sort using Kahn's algorithm.
--
-- It seems that Haskell graph libraries (and perhaps graph libraries in
-- general) tend to implement topological sort using depth-first search (DFS).
-- While it's probably easier (since these libraries also implement DFS), the
-- result is that you pass a graph to a function and get back the sorted list.
-- There is no room left for specifying variable parts of the algorithm, which
-- means you can't control which topsort order (out of potentially many orders
-- possible) you get. Sometimes you don't care, but sometimes you do.
--
-- Kahn's algorithm has room for variations in two places:
--
-- (1) When traversing a node's outgoing edges, the order in which this
-- traversal happens isn't specified.
-- (2) The internals of structure S, the set of nodes with no inbound edges,
-- aren't specified. Therefore, so is the order in which nodes are removed
-- from it.
--
-- https://en.wikipedia.org/wiki/Topological_sort#Kahn.27s_algorithm
topsortKahn
:: (DynGraph g, NodeSet s, ResultList l)
=> g a b
-- ^ Graph whose nodes to sort
-> s
-- ^ The set of graph nodes which don't have inbound edges
-> TraversalOrder b
-- ^ In which order to go over the outgoing edges of a node
-> Maybe (l Node)
-- ^ Topologically sorted list. For each edge from node @u@ to node @v@,
-- @u@ appears before @v@ in this list. If the graph is empty or the
-- initial node set is empty, an empty list is returned. If the graph
-- contains a cycle, 'Nothing' is returned.
topsortKahn graph set order = f graph set emptyList
where
nEdges = length . labEdges
sort = sortNodes order
visit n (g, s) m =
let g' = delEdge (n, m) g
s' =
if indeg g' m > 0
then s
else insertNode m s
in (g', s')
f g s l =
case extractNode s of
Nothing ->
if nEdges g > 0
then Nothing
else Just l
Just (n, s') ->
let l' = appendItem n l
children = map fst $ sort $ lsuc g n
(g', s'') = foldl' (visit n) (g, s') children
in f g' s'' l'
newtype NodeStack = NodeStack [Node]
instance NodeSet NodeStack where
insertNode n (NodeStack l) = NodeStack $ n : l
extractNode (NodeStack l) =
case l of
[] -> Nothing
(n:ns) -> Just (n, NodeStack ns)
-- | Topologically sort commits so that parallel lines of work, e.g. a master
-- branch and a short topic branch merged into it, don't get their commits
-- mixed in the sorted order.
topsortUnmix
:: (DynGraph g, ResultList l)
=> g a b
-> NodeStack
-> TraversalOrder b
-> Maybe (l Node)
topsortUnmix = topsortKahn
-- | Adds an additioal constraint to 'topsortUnmix': When traversing a node's
-- outgoing edges, do so using the 'Ord' instance of the labels of the edges.
topsortUnmixOrder
:: (Ord b, DynGraph g, ResultList l)
=> g a b
-> NodeStack
-> Maybe (l Node)
topsortUnmixOrder graph stack =
let order (_, i) (_, j) = compare i j
in topsortUnmix graph stack (SortedOrder order)

6
src/GitPackProto.hs
View file

@ -300,9 +300,3 @@ instance SizedBinary RefAd where
return (lim, SymRefTag name) return (lim, SymRefTag name)
else fail "symref too short to be a tag" 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

47
src/Network/Git/Local/Ack/Put.hs
View file

@ -1,47 +0,0 @@
{- 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.Ack.Put
( putAckMulti
, putAck
, putNak
)
where
putAckStatus :: AckStatus -> Put
putAckStatus AckContinue = putByteString "continue"
putAckStatus AckCommon = putByteString "common"
putAckStatus AckReady = putByteString "ready"
lenAckStatus :: AckStatus -> Int
lenAckStatus AckContinue = 8
lenAckStatus AckCommon = 6
lenAckStatus AckReady = 5
putAckMulti :: ObjId -> AckStatus -> Put
putAckMulti oid as = putDataPkt True (3 + 1 + 40 + lenAckStatus as) $ do
putByteString "ACK"
putSpace
putObjId oid
putAckStatus as
putAck :: ObjId -> Put
putAck oid = putDataPkt True (3 + 1 + 40) $ do
putByteString "ACK"
putSpace
putObjId oid
putNak :: Put
putNak = putDataPkt True 3 $ putByteString "NAK"

21
src/Network/Git/Local/Ack/Types.hs
View file

@ -1,21 +0,0 @@
{- 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.Ack.Types
( AckStatus (..)
)
where
data AckStatus = AckContinue | AckCommon | AckReady

59
src/Network/Git/Local/Get.hs
View file

@ -1,59 +0,0 @@
{- 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
getTaggedObjId :: ByteString -> Get ObjId
getTaggedObjId tag = getDataPkt $ \ len ->
let baselen = B.length tag + 1 + 40
in if len < baselen || baselen + 1 < len
then fail "Tagged obj id of unexpected length"
else do
requireByteString tag
requireSpace
oid <- getObjId
when (len == baselen + 1) requireNewline
return oid
getCapabilities :: Int -> Get [Capability]
getCapabilities n = do
getByteString n
return []

63
src/Network/Git/Local/Put.hs
View file

@ -1,63 +0,0 @@
{- 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

22
src/Network/Git/Local/RefDiscovery.hs
View file

@ -1,22 +0,0 @@
{- 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

67
src/Network/Git/Local/RefDiscovery/Put.hs
View file

@ -1,67 +0,0 @@
{- 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

45
src/Network/Git/Local/RefDiscovery/Types.hs
View file

@ -1,45 +0,0 @@
{- 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]
}

41
src/Network/Git/Local/ShallowUpdate/Put.hs
View file

@ -1,41 +0,0 @@
{- 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

24
src/Network/Git/Local/ShallowUpdate/Types.hs
View file

@ -1,24 +0,0 @@
{- 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]
}

27
src/Network/Git/Local/Types.hs
View file

@ -1,27 +0,0 @@
{- 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

38
src/Network/Git/Local/UploadHaves/Get.hs
View file

@ -1,38 +0,0 @@
{- 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.UploadHaves.Get
( getUploadHaves
)
where
getHaves :: Get [ObjId]
getHaves = many $ getTaggedObjId "have"
requireDone :: Get ()
requireDone = getDataPkt $ \ len ->
if len < 4 || len > 5
then fail "invalid pkt-len for a \"done\" line"
else do
requireByteString "done"
when (len == 5) requireNewline
getUploadHaves :: Get UploadHaves
getUploadHaves = do
haves <- getHaves
requireFlushPkt <|> requireDone
return UploadHaves
{ uhHave = haves
}

23
src/Network/Git/Local/UploadHaves/Types.hs
View file

@ -1,23 +0,0 @@
{- 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.UploadHaves.Types
( UploadHaves (..)
)
where
data UploadHaves = UploadHaves
{ uhHave :: [ObjId]
}

22
src/Network/Git/Local/UploadRequest.hs
View file

@ -1,22 +0,0 @@
{- 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

68
src/Network/Git/Local/UploadRequest/Get.hs
View file

@ -1,68 +0,0 @@
{- 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)
-- unfoldM is from the monad-loops package
getWants :: Get ([Capability], [ObjId])
getWants = do
(caps, oid) <- getFirstWant
oids <- many $ getTaggedObjId "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
}

28
src/Network/Git/Local/UploadRequest/Types.hs
View file

@ -1,28 +0,0 @@
{- 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
}

11
src/Vervis/Handler/Repo.hs
View file

@ -47,7 +47,6 @@ import System.Directory (createDirectoryIfMissing)
import System.Hourglass (dateCurrent) import System.Hourglass (dateCurrent)
import Data.ByteString.Char8.Local (takeLine) import Data.ByteString.Char8.Local (takeLine)
import Data.Git.Local (loadCommitsTopsortList)
import Vervis.Form.Repo import Vervis.Form.Repo
import Vervis.Foundation import Vervis.Foundation
import Vervis.Git (timeAgo') import Vervis.Git (timeAgo')
@ -110,8 +109,14 @@ getRepoR user proj repo = do
Entity _rid r <- getBy404 $ UniqueRepo repo pid Entity _rid r <- getBy404 $ UniqueRepo repo pid
return r return r
path <- askRepoDir user proj repo path <- askRepoDir user proj repo
pairs <- liftIO $ withRepo (fromString path) $ \ git -> pairs <- liftIO $ withRepo (fromString path) $ \ git -> do
loadCommitsTopsortList git $ unpack $ repoMainBranch repository oid <- resolveName git $ unpack $ repoMainBranch repository
graph <- loadCommitGraphPT git [oid]
let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
nodes = case mnodes of
Nothing -> error "commit graph contains a cycle"
Just ns -> ns
return $ D.toList $ fmap (nodeLabel graph) nodes
now <- liftIO dateCurrent now <- liftIO dateCurrent
let toText = decodeUtf8With lenientDecode let toText = decodeUtf8With lenientDecode
mkrow ref commit = mkrow ref commit =

35
src/Vervis/Ssh.hs
View file

@ -13,6 +13,8 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>. - <http://creativecommons.org/publicdomain/zero/1.0/>.
-} -}
{-# LANGUAGE StandaloneDeriving #-}
module Vervis.Ssh module Vervis.Ssh
( runSsh ( runSsh
) )
@ -41,17 +43,19 @@ import Vervis.Model
import Vervis.Settings import Vervis.Settings
-- TODO: -- TODO:
-- [x] Implement serious logging (info, warning, error, etc.) with
-- monad-logger, maybe see how loggin works in the scaffolding
-- [ ] See which git commands gitolite 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) -- them with Hit (i think it was git upload-pack)
deriving instance MonadBaseControl ChannelT
deriving instance MonadLogger ChannelT
type ChannelBase = LoggingT (ReaderT ConnectionPool IO) type ChannelBase = LoggingT (ReaderT ConnectionPool IO)
type SessionBase = LoggingT (ReaderT ConnectionPool IO) type SessionBase = LoggingT (ReaderT ConnectionPool IO)
type UserAuthId = PersonId
type Backend = SqlBackend type Backend = SqlBackend
type Channel = ChannelT ChannelBase type Channel = ChannelT UserAuthId ChannelBase
type Session = SessionT SessionBase ChannelBase type Session = SessionT SessionBase UserAuthId ChannelBase
type SshChanDB = ReaderT Backend Channel type SshChanDB = ReaderT Backend Channel
type SshSessDB = ReaderT Backend Session type SshSessDB = ReaderT Backend Session
@ -73,30 +77,31 @@ chanFail wantReply msg = do
channelError $ unpack msg channelError $ unpack msg
when wantReply channelFail when wantReply channelFail
authorize :: Authorize -> Session Bool authorize :: Authorize -> Session (AuthResult UserAuthId)
authorize (Password _ _) = return False authorize (Password _ _) = return AuthFail
authorize (PublicKey name key) = do authorize (PublicKey name key) = do
mkeys <- runSessDB $ do mpk <- runSessDB $ do
mp <- getBy $ UniquePersonLogin $ pack name mp <- getBy $ UniquePersonLogin $ pack name
case mp of case mp of
Nothing -> return Nothing Nothing -> return Nothing
Just (Entity pid _p) -> Just (Entity pid _p) -> do
fmap Just $ selectList [SshKeyPerson ==. pid] [] ks <- selectList [SshKeyPerson ==. pid] []
case mkeys of return $ Just (pid, ks)
case mpk of
Nothing -> do Nothing -> do
$logInfoS src "Auth failed: Invalid user" $logInfoS src "Auth failed: Invalid user"
return False return AuthFail
Just keys -> do Just (pid, keys) -> do
let eValue (Entity _ v) = v let eValue (Entity _ v) = v
matches = matches =
(== key) . blobToKey . fromStrict . sshKeyContent . eValue (== key) . blobToKey . fromStrict . sshKeyContent . eValue
case find matches keys of case find matches keys of
Nothing -> do Nothing -> do
$logInfoS src "Auth failed: No matching key found" $logInfoS src "Auth failed: No matching key found"
return False return AuthFail
Just match -> do Just match -> do
$logInfoS src "Auth succeeded" $logInfoS src "Auth succeeded"
return True return $ AuthSuccess pid
data Action = UploadPack () deriving Show data Action = UploadPack () deriving Show
@ -131,7 +136,7 @@ mkConfig
:: AppSettings :: AppSettings
-> ConnectionPool -> ConnectionPool
-> LogFunc -> LogFunc
-> IO (Config SessionBase ChannelBase) -> IO (Config SessionBase ChannelBase UserAuthId)
mkConfig settings pool logFunc = do mkConfig settings pool logFunc = do
keyPair <- keyPairFromFile $ appSshKeyFile settings keyPair <- keyPairFromFile $ appSshKeyFile settings
return $ Config return $ Config

2
stack.yaml
View file

@ -3,7 +3,7 @@
# Specifies the GHC version and set of packages available (e.g., lts-3.5, # Specifies the GHC version and set of packages available (e.g., lts-3.5,
# nightly-2015-09-21, ghc-7.10.2) # nightly-2015-09-21, ghc-7.10.2)
resolver: lts-5.5 resolver: lts-5.11
# Local packages, usually specified by relative directory name # Local packages, usually specified by relative directory name
packages: packages:

8
vervis.cabal
View file

@ -34,17 +34,11 @@ flag library-only
default: False default: False
library library
exposed-modules: Data.Binary.Get.Local exposed-modules:
Data.Binary.Put.Local
Data.ByteString.Char8.Local Data.ByteString.Char8.Local
Data.ByteString.Local Data.ByteString.Local
Data.Char.Local Data.Char.Local
Data.Git.Local
Data.Graph.Inductive.Local
Data.List.Local Data.List.Local
Network.Git.Local
Network.Git.Local.Get
Network.Git.Local.Put
Network.SSH.Local Network.SSH.Local
Vervis.Application Vervis.Application
Vervis.Field.Key Vervis.Field.Key