sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2025-03-20 04:46:22 +09:00
Code Issues 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
src/Data
Binary
Get
Local.hs
Put
Local.hs
Git
Local.hs
Graph/Inductive
Local.hs

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)