mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-26 13:54:50 +09:00
In darcs post-apply hook, send a Push object to Vervis
This commit is contained in:
parent
6cb86ebbf1
commit
59ce05694e
5 changed files with 174 additions and 35 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue