Remove some old code and adapt to hit-graph

src/Data/ByteString/Local.hs

@@ -36,5 +36,5 @@ import qualified Data.ByteString as B
 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
+        then Just $ B.foldl' (\ n b -> 10 * n + fromIntegral b - 48) 0 s
         else Nothing

src/GitPackProto.hs

@@ -24,9 +24,6 @@ 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)
@@ -38,26 +35,6 @@ import Data.Word
 -- 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
 
@@ -88,215 +65,3 @@ 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"
-

src/GitPackProto2.hs

@@ -1,29 +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/>.
- -}
-
-{-# LANGUAGE MultiWayIf #-}
-
-module GitPackProto2 where
-
-import Prelude
-
-import Data.Binary.Put
-
-
--- algo TODO REVISE TO PERFECTION
---
--- - send ref discovery
--- - receive update request OR flush-pkt which means finish?
--- - verify all listed objids in want lines appeared in ref discovery

src/Vervis/Handler/Repo.hs

@@ -34,10 +34,14 @@ import ClassyPrelude.Conduit       hiding (unpack)
 import Yesod                       hiding (Header, parseTime, (==.))
 import Yesod.Auth
 
+import Data.Git.Graph
+import Data.Git.Graph.Util
 import Data.Git.Ref (toHex)
 import Data.Git.Repository (initRepo)
 import Data.Git.Storage (withRepo)
 import Data.Git.Types (Commit (..), Person (..))
+import Data.Graph.Inductive.Graph (noNodes)
+import Data.Graph.Inductive.Query.Topsort
 import Data.Text (unpack)
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -46,6 +50,8 @@ import Data.Hourglass (timeConvert)
 import System.Directory (createDirectoryIfMissing)
 import System.Hourglass (dateCurrent)
 
+import qualified Data.DList as D
+
 import Data.ByteString.Char8.Local (takeLine)
 import Vervis.Form.Repo
 import Vervis.Foundation
@@ -101,6 +107,10 @@ getRepoNewR user proj = do
             ["Vervis > People > ", user, " > Projects > ", proj, " > New Repo"]
         $(widgetFile "repo-new")
 
+instance ResultList D.DList where
+    emptyList = D.empty
+    appendItem = flip D.snoc
+
 getRepoR :: Text -> Text -> Text -> Handler Html
 getRepoR user proj repo = do
     repository <- runDB $ do
@@ -119,9 +129,9 @@ getRepoR user proj repo = do
         return $ D.toList $ fmap (nodeLabel graph) nodes
     now <- liftIO dateCurrent
     let toText = decodeUtf8With lenientDecode
-        mkrow ref commit =
+        mkrow oid commit =
             ( toText $ personName $ commitAuthor commit
-            , toText $ toHex ref
+            , toText $ toHex $ unObjId oid
             , toText $ takeLine $ commitMessage commit
             , timeAgo' now (timeConvert $ personTime $ commitAuthor commit)
             )

src/Vervis/Ssh.hs

@@ -13,8 +13,6 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-{-# LANGUAGE StandaloneDeriving #-}
-
 module Vervis.Ssh
     ( runSsh
     )
@@ -46,16 +44,13 @@ import Vervis.Settings
 -- [ ] See which git commands gitolite SSH supports and see if I can implement
 --     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 SessionBase = LoggingT (ReaderT ConnectionPool IO)
-type UserAuthId = PersonId
+--type UserAuthId = PersonId
 type Backend = SqlBackend
 
-type Channel = ChannelT UserAuthId ChannelBase
+type Channel = ChannelT {-UserAuthId-} ChannelBase
-type Session = SessionT SessionBase UserAuthId ChannelBase
+type Session = SessionT SessionBase {-UserAuthId-} ChannelBase
 type SshChanDB = ReaderT Backend Channel
 type SshSessDB = ReaderT Backend Session
 
@@ -77,8 +72,8 @@ chanFail wantReply msg = do
     channelError $ unpack msg
     when wantReply channelFail
 
-authorize :: Authorize -> Session (AuthResult UserAuthId)
+authorize :: Authorize -> Session Bool -- (AuthResult UserAuthId)
-authorize (Password  _    _)   = return AuthFail
+authorize (Password  _    _)   = return False -- AuthFail
 authorize (PublicKey name key) = do
     mpk <- runSessDB $ do
         mp <- getBy $ UniquePersonLogin $ pack name
@@ -90,7 +85,7 @@ authorize (PublicKey name key) = do
     case mpk of
         Nothing -> do
             $logInfoS src "Auth failed: Invalid user"
-            return AuthFail
+            return False -- AuthFail
         Just (pid, keys) -> do
             let eValue (Entity _ v) = v
                 matches =
@@ -98,10 +93,10 @@ authorize (PublicKey name key) = do
             case find matches keys of
                 Nothing -> do
                     $logInfoS src "Auth failed: No matching key found"
-                    return AuthFail
+                    return False -- AuthFail
                 Just match -> do
                     $logInfoS src "Auth succeeded"
-                    return $ AuthSuccess pid
+                    return True -- $ AuthSuccess pid
 
 data Action = UploadPack () deriving Show
 
@@ -136,7 +131,7 @@ mkConfig
     :: AppSettings
     -> ConnectionPool
     -> LogFunc
-    -> IO (Config SessionBase ChannelBase UserAuthId)
+    -> IO (Config SessionBase ChannelBase {-UserAuthId-})
 mkConfig settings pool logFunc = do
     keyPair <- keyPairFromFile $ appSshKeyFile settings
     return $ Config

stack.yaml

@@ -9,12 +9,16 @@ resolver: lts-5.11
 packages:
   - '.'
   - '/home/fr33domlover/Repos/other-work/ssh'
+  - '/home/fr33domlover/Repos/rel4tion/darcs/hit-graph'
 
 # Packages to be pulled from upstream that are not in the resolver (e.g.,
 # acme-missiles-0.3)
 extra-deps:
+  - hit-graph-0.1
   - SimpleAES-0.4.2
 #  - ssh-0.3.2
+  # Required for M.alter used in hit-graph
+  - unordered-containers-0.2.6.0
 
 # Override default flag values for local packages and extra-deps
 flags: {}

vervis.cabal

@@ -34,8 +34,7 @@ flag library-only
   default:     False
 
 library
-  exposed-modules:     
+  exposed-modules:     Data.ByteString.Char8.Local
-                       Data.ByteString.Char8.Local
                        Data.ByteString.Local
                        Data.Char.Local
                        Data.List.Local
@@ -83,15 +82,6 @@ library
                        ViewPatterns
                        TupleSections
                        RecordWildCards
-
-  --build-depends:       base                 >=4.8   && <5
-  --                   , directory-tree       >=0.12
-  --                   , esqueleto
-  --                   , filepath
-  --                   , hit                  >=0.6.3
-  --                   , hourglass
-  --                   , time-units
-  --                   , unordered-containers >=0.2.5
   build-depends:       aeson
                      , base
                      , base64-bytestring
@@ -113,6 +103,7 @@ library
                      , filepath
                      , hashable
                      , hit
+                     , hit-graph >= 0.1
                      , hjsmin
                      , hourglass
                      , http-conduit