mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 17:14:52 +09:00
Remove some old code and adapt to hit-graph
This commit is contained in:
fr33domlover
parent
135e8e7502
commit
b68428d9b6
7 changed files with 28 additions and 292 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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 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
|
||||
|
|
|
|||
|
|
@ -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: {}
|
||||
|
|
|
|||
13
vervis.cabal
13
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue