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

hook-darcs/main.hs

@@ -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

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) <-
+                (early, late) <- 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))
                 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
+                sendPush config manager push
-                    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)
             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

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"

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)
 

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