diff --git a/src/Data/ByteString/Local.hs b/src/Data/ByteString/Local.hs index 87f4ef6..859504f 100644 --- a/src/Data/ByteString/Local.hs +++ b/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 diff --git a/src/GitPackProto.hs b/src/GitPackProto.hs index ee1fb21..7bf664f 100644 --- a/src/GitPackProto.hs +++ b/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" - diff --git a/src/GitPackProto2.hs b/src/GitPackProto2.hs deleted file mode 100644 index 9d82f8a..0000000 --- a/src/GitPackProto2.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- 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/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 9183f13..ec28497 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/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) ) diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index 094045e..392e987 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -13,8 +13,6 @@ - . -} -{-# 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 Session = SessionT SessionBase UserAuthId ChannelBase +type Channel = ChannelT {-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 (Password _ _) = return AuthFail +authorize :: Authorize -> Session Bool -- (AuthResult UserAuthId) +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 diff --git a/stack.yaml b/stack.yaml index 6aaa413..1dd6db3 100644 --- a/stack.yaml +++ b/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: {} diff --git a/vervis.cabal b/vervis.cabal index 6f709f0..e0ddebe 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -34,8 +34,7 @@ flag library-only default: False library - exposed-modules: - Data.ByteString.Char8.Local + exposed-modules: 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