From 59ce05694ee89d351588e53cb98acb7a65111487 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 10 Oct 2019 16:41:34 +0000 Subject: [PATCH] In darcs post-apply hook, send a Push object to Vervis --- hook-darcs/main.hs | 4 +- src/Vervis/Hook.hs | 194 ++++++++++++++++++++++++++++++++++------- src/Vervis/Ssh.hs | 2 + src/Web/ActivityPub.hs | 6 +- vervis.cabal | 3 + 5 files changed, 174 insertions(+), 35 deletions(-) diff --git a/hook-darcs/main.hs b/hook-darcs/main.hs index 1d1de3f..c44191d 100644 --- a/hook-darcs/main.hs +++ b/hook-darcs/main.hs @@ -13,5 +13,7 @@ - . -} +import Vervis.Hook + main :: IO () -main = putStrLn "Hello, I'm the posthook!" +main = postApply diff --git a/src/Vervis/Hook.hs b/src/Vervis/Hook.hs index 95c0113..be200ec 100644 --- a/src/Vervis/Hook.hs +++ b/src/Vervis/Hook.hs @@ -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 , 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 diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index 366147f..1b63b1a 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -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" diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 2f0cefc..77434e3 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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) diff --git a/vervis.cabal b/vervis.cabal index d5dddfa..c389a26 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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