forge/Vervis
1
0
Fork 0
Code Pull requests Activity

In darcs post-apply hook, send a Push object to Vervis

Browse source
This commit is contained in:
fr33domlover 2019-10-10 16:41:34 +00:00
parent 6cb86ebbf1
commit 59ce05694e
5 changed files with 174 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
hook-darcs/main.hs
View file

@ -13,5 +13,7 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
import Vervis.Hook
main :: IO ()
main = putStrLn "Hello, I'm the posthook!"
main = postApply

194
src/Vervis/Hook.hs
View file

@ -24,9 +24,11 @@ module Vervis.Hook
, Push (..)
, writeHookConfig
, postReceive
, postApply
)
where
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
@ -35,18 +37,21 @@ import Crypto.Random
import Data.Aeson
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Char
import Data.Git hiding (Commit)
import Data.Git.Ref
import Data.Git.Types hiding (Commit)
import Data.Git.Graph
import Data.Git.Harder
import Data.Graph.Inductive.Graph -- (noNodes)
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Query.Topsort
import Data.Int
import Data.Maybe
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Text (Text)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.Format
import Data.Word
import GHC.Generics
import Network.HTTP.Client
@ -58,9 +63,12 @@ import System.FilePath
import System.IO
import Text.Email.Aeson.Instances ()
import Text.Email.Validate
import Text.Read
import Text.XML.Light
import Time.Types
import Yesod.Core.Content
import qualified Data.Attoparsec.Text as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.DList as D
@ -73,6 +81,7 @@ import qualified Data.Text.IO as TIO
import Data.KeyFile
import Network.FedURI
import Control.Monad.Trans.Except.Local
import Data.DList.Local
import Data.List.NonEmpty.Local
@ -130,7 +139,7 @@ data Push = Push
, pushRepo :: Text
, pushBranch :: Maybe Text
, pushBefore :: Maybe Text
, pushAfter :: Text
, pushAfter :: Maybe Text
, pushInit :: NonEmpty Commit
, pushLast :: Maybe (Int, NonEmpty Commit)
}
@ -152,6 +161,45 @@ writeHookConfig config = do
createDirectoryIfMissing True cachePath
encodeFile (cachePath </> hookConfigFileName) config
splitCommits
:: Monad m
=> Config
-> NonEmpty a
-> ExceptT Text m (NonEmpty a, Maybe (Int, NonEmpty a))
splitCommits config commits =
if length commits <= maxCommits
then return (commits, Nothing)
else do
let half = maxCommits `div` 2
middle = length commits - 2 * half
(e, r) = NE.splitAt half commits
l = drop middle r
eNE <- nonEmptyE e "early is empty"
lNE <- nonEmptyE l "late is empty"
return (eNE, Just (middle, lNE))
where
maxCommits = configMaxCommits config
sendPush :: Config -> Manager -> Push -> ExceptT Text IO (Response ())
sendPush config manager push = do
let uri :: ObjURI Dev
uri =
ObjURI
(Authority "localhost" (Just $ configPort config))
(LocalURI "/post-receive")
req <- requestFromURI $ uriFromObjURI uri
let req' =
setRequestCheckStatus $
consHeader hContentType typeJson $
req { method = "POST"
, requestBody = RequestBodyLBS $ encode push
}
ExceptT $ first adaptErr <$> try (httpNoBody req' manager)
where
adaptErr :: HttpException -> Text
adaptErr = T.pack . displayException
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
reportNewCommits :: Config -> Text -> Text -> IO ()
reportNewCommits config sharer repo = do
user <- read <$> getEnv "VERVIS_SSH_USER"
@ -199,17 +247,7 @@ reportNewCommits config sharer repo = do
nonEmptyE before "No new commits"
let commits = NE.map (uncurry makeCommit) historyNew
maxCommits = configMaxCommits config
(early, late) <-
if length commits <= maxCommits
then return (commits, Nothing)
else do
let half = maxCommits `div` 2
middle = length commits - 2 * half
(e, r) = NE.splitAt half commits
l = drop middle r
eNE <- nonEmptyE e "early is empty"
lNE <- nonEmptyE l "late is empty"
return (eNE, Just (middle, lNE))
(early, late) <- splitCommits config commits
let push = Push
{ pushSecret = configSecret config
, pushUser = user
@ -217,32 +255,16 @@ reportNewCommits config sharer repo = do
, pushRepo = repo
, pushBranch = Just branch
, pushBefore = old <$ moldRef
, pushAfter = new
, pushAfter = Just new
, pushInit = early
, pushLast = late
}
uri :: ObjURI Dev
uri =
ObjURI
(Authority "localhost" (Just $ configPort config))
(LocalURI "/post-receive")
req <- requestFromURI $ uriFromObjURI uri
let req' =
setRequestCheckStatus $
consHeader hContentType typeJson $
req { method = "POST"
, requestBody = RequestBodyLBS $ encode push
}
ExceptT $
first adaptErr <$> try (httpNoBody req' manager)
sendPush config manager push
case result of
Left e -> TIO.hPutStrLn stderr $ "HOOK ERROR: " <> e
Right _resp -> return ()
loop user manager git
where
adaptErr :: HttpException -> Text
adaptErr = T.pack . displayException
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
parseRef t =
if t == nullRef
then return Nothing
@ -296,3 +318,113 @@ postReceive = do
[s, r] -> return (T.pack s, T.pack r)
_ -> die "Unexpected number of arguments"
reportNewCommits config sharer repo
reportNewPatches :: Config -> Text -> Text -> IO ()
reportNewPatches config sharer repo = do
user <- read <$> getEnv "VERVIS_SSH_USER"
manager <- newManager defaultManagerSettings
melem <- parseXMLDoc <$> getEnv "DARCS_PATCHES_XML"
result <- runExceptT $ do
push <- ExceptT . pure . runExcept $ do
elem <- fromMaybeE melem "parseXMLDoc failed"
children <- nonEmptyE (elChildren elem) "No patches"
patches <- traverse xml2patch children
(early, late) <- splitCommits config patches
return Push
{ pushSecret = configSecret config
, pushUser = user
, pushSharer = sharer
, pushRepo = repo
, pushBranch = Nothing
, pushBefore = Nothing
, pushAfter = Nothing
, pushInit = early
, pushLast = late
}
sendPush config manager push
case result of
Left e -> dieT $ "Post-apply hook error: " <> e
Right _resp -> return ()
where
dieT err = TIO.hPutStrLn stderr err >> exitFailure
xml2patch elem = do
unless (elName elem == QName "patch" Nothing Nothing) $
throwE $
"Expected <patch>, found: " <> T.pack (show $ elName elem)
(name, email) <- do
t <- T.pack <$> findAttrE "author" elem
parseOnlyE authorP t "author"
date <- do
s <- findAttrE "date" elem
case parseTimeM False defaultTimeLocale "%Y%m%d%H%M%S" s of
Nothing -> throwE $ "Date parsing failed: " <> T.pack s
Just t -> return t
hash <- do
t <- T.pack <$> findAttrE "hash" elem
unless (T.length t == 40) $
throwE $ "Expected a hash string of length 40, got: " <> t
return t
inverted <- do
s <- findAttrE "inverted" elem
readMaybeE s $ "Unrecognized inverted value: " <> T.pack s
when inverted $ throwE $ "Found inverted patch " <> hash
title <- T.pack . strContent <$> findChildE "name" elem
description <- do
t <- T.pack . strContent <$> findChildE "comment" elem
parseOnlyE commentP t "comment"
return Commit
{ commitWritten = (Author name email, date)
, commitCommitted = Nothing
, commitHash = hash
, commitTitle = title
, commitDescription = description
}
where
readMaybeE s e = fromMaybeE (readMaybe s) e
findAttrE q e =
let ms = findAttr (QName q Nothing Nothing) e
in fromMaybeE ms $ "Couldn't find attr \"" <> T.pack q <> "\""
findChildE q e =
case findChildren (QName q Nothing Nothing) e of
[] -> throwE $ "No children named " <> T.pack q
[c] -> return c
_ -> throwE $ "Multiple children named " <> T.pack q
authorP = (,)
<$> (T.stripEnd <$> A.takeWhile1 (/= '<'))
<* A.skip (== '<')
<*> (A.takeWhile1 (/= '>') >>= emailP)
<* A.skip (== '>')
where
emailP
= maybe (fail "Invalid email") pure
. emailAddress
. TE.encodeUtf8
commentP
= A.string "Ignore-this: "
*> A.takeWhile1 isHexDigit
*> (fromMaybe T.empty <$>
optional (A.endOfLine *> A.endOfLine *> A.takeText)
)
parseOnlyE p t n =
case A.parseOnly (p <* A.endOfInput) t of
Left e ->
throwE $ T.concat ["Parsing ", n, " failed: ", T.pack e]
Right a -> return a
postApply :: IO ()
postApply = do
cachePath <- getVervisCachePath
config <- do
mc <- decodeFileStrict' $ cachePath </> hookConfigFileName
case mc of
Nothing -> die "Parsing hook config failed"
Just c -> return c
args <- getArgs
(sharer, repo) <-
case args of
[s, r] -> return (T.pack s, T.pack r)
_ -> die "Unexpected number of arguments"
reportNewPatches config sharer repo

2
src/Vervis/Ssh.hs
View file

@ -251,6 +251,8 @@ runAction repoDir _wantReply action =
can <- canPushTo sharer repo
if can
then whenDarcsRepoExists True repoPath $ do
pid <- authId <$> askAuthDetails
liftIO $ setEnv "VERVIS_SSH_USER" (show $ fromSqlKey pid)
execute "darcs" ["apply", "--all", "--repodir", repoPath]
return ARProcess
else return $ ARFail "You can't push to this repository"

6
src/Web/ActivityPub.hs
View file

@ -1052,7 +1052,7 @@ data Push u = Push
, pushCommitsTotal :: Int
, pushTarget :: LocalURI
, pushHashBefore :: Maybe Text
, pushHashAfter :: Text
, pushHashAfter :: Maybe Text
}
parsePush :: UriMode u => Authority u -> Object -> Parser (Push u)
@ -1064,7 +1064,7 @@ parsePush a o = do
<*> c .: "totalItems"
<*> withAuthorityO a (o .: "target")
<*> o .:? "hashBefore"
<*> o .: "hashAfter"
<*> o .:? "hashAfter"
encodePush :: UriMode u => Authority u -> Push u -> Series
encodePush a (Push lateCommits earlyCommits total target before after)
@ -1076,7 +1076,7 @@ encodePush a (Push lateCommits earlyCommits total target before after)
)
<> "target" .= ObjURI a target
<> "hashBefore" .=? before
<> "hashAfter" .= after
<> "hashAfter" .=? after
where
objectList items = listEncoding (pairs . toSeries a) (NE.toList items)

3
vervis.cabal
View file

@ -367,6 +367,9 @@ library
, warp
-- for encoding and decoding of crypto public keys
, x509
-- for parsing darcs apply's changes XML from env var in
-- the vervis post-apply hook program
, xml
, xss-sanitize
, yaml
, yesod