From 2c18660a3b5cb9fa44ba6b1e66cf7de8dbf40b2c Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 6 Aug 2019 13:23:11 +0000 Subject: [PATCH] Provide AP representation of commits, and support committer field --- src/Data/Aeson/Local.hs | 6 ++ src/Vervis/ActivityPub.hs | 55 ++++++++++++++++- src/Vervis/Darcs.hs | 11 +++- src/Vervis/Git.hs | 29 ++++++--- src/Vervis/Handler/Repo.hs | 2 +- src/Vervis/Handler/Repo/Darcs.hs | 29 ++++----- src/Vervis/Handler/Repo/Git.hs | 23 ++++--- src/Vervis/Patch.hs | 11 +++- src/Web/ActivityPub.hs | 101 +++++++++++++++++++++++++++++++ templates/repo/patch.hamlet | 15 ++++- 10 files changed, 238 insertions(+), 44 deletions(-) diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 8891aa6..03e18a1 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -24,6 +24,7 @@ module Data.Aeson.Local , (.=?) , (.=%) , (.=+) + , (.=+?) , WithValue (..) ) where @@ -87,6 +88,11 @@ infixr 8 .=+ k .=+ Left x = k .= x k .=+ Right y = k .= y +infixr 8 .=+? +(.=+?) :: (ToJSON a, ToJSON b) => Text -> Maybe (Either a b) -> Series +k .=+? Nothing = mempty +k .=+? (Just v) = k .=+ v + data WithValue a = WithValue { wvRaw :: Object , wvParsed :: a diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 63a6493..21b0de3 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -39,6 +39,7 @@ module Vervis.ActivityPub , getProjectAndDeps , deliverRemoteDB' , deliverRemoteHttp + , serveCommit ) where @@ -88,7 +89,7 @@ import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub +import Web.ActivityPub hiding (Author (..)) import Yesod.ActivityPub import Yesod.MonadSite import Yesod.FedURI @@ -106,8 +107,12 @@ import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Patch import Vervis.RemoteActorStore import Vervis.Settings +import Vervis.Time +import Vervis.Widget.Repo +import Vervis.Widget.Sharer hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings @@ -637,3 +642,51 @@ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do Right _ -> delete udlid where logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", renderAuthority h, t] + +serveCommit + :: ShrIdent + -> RpIdent + -> Text + -> Patch + -> [Text] + -> Handler TypedContent +serveCommit shr rp ref patch parents = do + (msharerWritten, msharerCommitted) <- runDB $ (,) + <$> getSharer (patchWritten patch) + <*> maybe (pure Nothing) getSharer (patchCommitted patch) + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let (author, written) = patchWritten patch + mcommitter = patchCommitted patch + patchAP = AP.Commit + { commitId = + encodeRouteLocal $ RepoPatchR shr rp ref + , commitRepository = encodeRouteLocal $ RepoR shr rp + , commitAuthor = + makeAuthor encodeRouteHome msharerWritten author + , commitCommitter = + makeAuthor encodeRouteHome msharerCommitted . fst <$> + mcommitter + , commitTitle = patchTitle patch + , commitHash = Hash $ encodeUtf8 ref + , commitDescription = + let desc = patchDescription patch + in if T.null desc + then Nothing + else Just desc + , commitWritten = written + , commitCommitted = snd <$> patchCommitted patch + } + provideHtmlAndAP patchAP $ + let number = zip ([1..] :: [Int]) + in $(widgetFile "repo/patch") + where + getSharer (author, _time) = do + mp <- getBy $ UniquePersonEmail $ authorEmail author + for mp $ \ (Entity _ person) -> getJust $ personIdent person + makeAuthor _ Nothing author = Left AP.Author + { AP.authorName = authorName author + , AP.authorEmail = authorEmail author + } + makeAuthor encodeRouteHome (Just sharer) _ = + Right $ encodeRouteHome $ SharerR $ sharerIdent sharer diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index 8e49d8b..3347b28 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -279,9 +279,14 @@ readPatch path hash = do either error id $ A.parseOnly (author <* A.endOfInput) $ piAuthor pi return Patch - { patchAuthorName = an - , patchAuthorEmail = ae - , patchTime = piTime pi + { patchWritten = + ( Author + { authorName = an + , authorEmail = ae + } + , piTime pi + ) + , patchCommitted = Nothing , patchTitle = piTitle pi , patchDescription = fromMaybe "" $ piDescription pi , patchDiff = diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 60def2a..21c39c6 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -195,15 +195,11 @@ listRefs path = G.withRepo (fromString path) $ \ git -> patch :: [Edit] -> Commit SHA1 -> Patch patch edits c = Patch - { patchAuthorName = decodeUtf8 $ personName $ commitAuthor c - , patchAuthorEmail = - let b = personEmail $ commitAuthor c - in case emailAddress b of - Nothing -> error $ "Invalid email " ++ T.unpack (decodeUtf8 b) - Just e -> e - , patchTime = - let Elapsed (Seconds t) = gitTimeUTC $ personTime $ commitAuthor c - in posixSecondsToUTCTime $ fromIntegral t + { patchWritten = makeAuthor $ commitAuthor c + , patchCommitted = + if commitAuthor c == commitCommitter c + then Nothing + else Just $ makeAuthor $ commitCommitter c , patchTitle = title , patchDescription = desc , patchDiff = edits @@ -214,6 +210,19 @@ patch edits c = Patch in (T.strip l, T.strip r) (title, desc) = split $ decodeUtf8 $ commitMessage c + makeAuthor (Person name email time) = + ( Author + { authorName = decodeUtf8 name + , authorEmail = + case emailAddress email of + Nothing -> + error $ "Invalid email " ++ T.unpack (decodeUtf8 email) + Just e -> e + } + , let Elapsed (Seconds t) = gitTimeUTC time + in posixSecondsToUTCTime $ fromIntegral t + ) + ep2fp :: EntPath -> FilePath ep2fp = T.unpack . decodeUtf8 . B.intercalate "/" . map getEntNameBytes diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index d31eab1..6c215e7 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -263,7 +263,7 @@ getRepoChangesR shar repo ref = do VCSDarcs -> getDarcsRepoChanges shar repo ref VCSGit -> getGitRepoChanges shar repo ref -getRepoPatchR :: ShrIdent -> RpIdent -> Text -> Handler Html +getRepoPatchR :: ShrIdent -> RpIdent -> Text -> Handler TypedContent getRepoPatchR shr rp ref = do repository <- runDB $ selectRepo shr rp case repoVcs repository of diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index 6c72469..ba77ec0 100644 --- a/src/Vervis/Handler/Repo/Darcs.hs +++ b/src/Vervis/Handler/Repo/Darcs.hs @@ -26,7 +26,7 @@ import Control.Monad.IO.Class (liftIO) import Data.List (inits) import Data.Maybe import Data.Text (Text, unpack) -import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding import Data.Text.Encoding.Error (lenientDecode) import Data.Traversable (for) import Database.Esqueleto @@ -41,25 +41,34 @@ import Yesod.Persist.Core (runDB, get404) import Yesod.AtomFeed (atomFeed) import Yesod.RssFeed (rssFeed) +import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.DList as D import qualified Data.Set as S (member) -import qualified Data.Text as T (unpack) +import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) +import Data.MediaType +import Web.ActivityPub +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.RenderSource + import Data.ByteString.Char8.Local (takeLine) import Text.FilePath.Local (breakExt) + +import qualified Darcs.Local.Repository as D (createRepo) + +import Vervis.ActivityPub import Vervis.ChangeFeed (changeFeed) import Vervis.Form.Repo import Vervis.Foundation import Vervis.Path -import Data.MediaType import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Paginate import Vervis.Patch import Vervis.Readme -import Yesod.RenderSource import Vervis.Settings import Vervis.SourceTree import Vervis.Style @@ -68,8 +77,6 @@ import Vervis.Widget (buttonW) import Vervis.Widget.Repo import Vervis.Widget.Sharer -import qualified Darcs.Local.Repository as D (createRepo) -import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Vervis.Darcs as D (readSourceView, readChangesView, readPatch) getDarcsRepoSource :: Repo -> ShrIdent -> RpIdent -> [Text] -> Handler Html @@ -120,16 +127,10 @@ getDarcsDownloadR shar repo dir = do then sendFile typeOctet filePath else notFound -getDarcsPatch :: ShrIdent -> RpIdent -> Text -> Handler Html +getDarcsPatch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent getDarcsPatch shr rp ref = do path <- askRepoDir shr rp mpatch <- liftIO $ D.readPatch path ref case mpatch of Nothing -> notFound - Just patch -> do - let parents = [] :: [Text] - msharer <- runDB $ do - mp <- getBy $ UniquePersonEmail $ patchAuthorEmail patch - for mp $ \ (Entity _ person) -> get404 $ personIdent person - let number = zip ([1..] :: [Int]) - defaultLayout $(widgetFile "repo/patch") + Just patch -> serveCommit shr rp ref patch [] diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index 8e93b41..ffc1c16 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/src/Vervis/Handler/Repo/Git.hs @@ -35,7 +35,7 @@ import Data.Graph.Inductive.Query.Topsort import Data.List (inits) import Data.Maybe import Data.Text (Text, unpack) -import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding import Data.Text.Encoding.Error (lenientDecode) import Data.Traversable (for) import Database.Esqueleto @@ -53,23 +53,32 @@ import Yesod.RssFeed (rssFeed) import qualified Data.DList as D import qualified Data.Set as S (member) +import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With) +import Data.MediaType +import Web.ActivityPub hiding (Commit, Author) +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.RenderSource + +import qualified Web.ActivityPub as AP + import Data.ByteString.Char8.Local (takeLine) import Data.Git.Local import Text.FilePath.Local (breakExt) + +import Vervis.ActivityPub import Vervis.ChangeFeed (changeFeed) import Vervis.Form.Repo import Vervis.Foundation import Vervis.Path -import Data.MediaType import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Paginate import Vervis.Patch import Vervis.Readme -import Yesod.RenderSource import Vervis.Settings import Vervis.SourceTree import Vervis.Style @@ -122,12 +131,8 @@ getGitRepoChanges shar repo ref = do provideRep $ rssFeed feed else notFound -getGitPatch :: ShrIdent -> RpIdent -> Text -> Handler Html +getGitPatch :: ShrIdent -> RpIdent -> Text -> Handler TypedContent getGitPatch shr rp ref = do path <- askRepoDir shr rp (patch, parents) <- liftIO $ G.readPatch path ref - msharer <- runDB $ do - mp <- getBy $ UniquePersonEmail $ patchAuthorEmail patch - for mp $ \ (Entity _ person) -> get404 $ personIdent person - let number = zip ([1..] :: [Int]) - defaultLayout $(widgetFile "repo/patch") + serveCommit shr rp ref patch parents diff --git a/src/Vervis/Patch.hs b/src/Vervis/Patch.hs index a1b2e49..ad05533 100644 --- a/src/Vervis/Patch.hs +++ b/src/Vervis/Patch.hs @@ -21,6 +21,7 @@ module Vervis.Patch ( Hunk (..) , Edit (..) + , Author (..) , Patch (..) ) where @@ -51,10 +52,14 @@ data Edit | TextToBinary FilePath [Text] Word32 Int64 Word32 | BinaryToText FilePath Int64 Word32 [Text] Word32 +data Author = Author + { authorName :: Text + , authorEmail :: EmailAddress + } + data Patch = Patch - { patchAuthorName :: Text - , patchAuthorEmail :: EmailAddress - , patchTime :: UTCTime + { patchWritten :: (Author, UTCTime) + , patchCommitted :: Maybe (Author, UTCTime) , patchTitle :: Text , patchDescription :: Text , patchDiff :: [Edit] diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 9755b18..1760da1 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -45,6 +45,9 @@ module Web.ActivityPub , TextPandocMarkdown (..) , TicketLocal (..) , Ticket (..) + , Author (..) + , Hash (..) + , Commit (..) -- * Activity , Accept (..) @@ -91,6 +94,7 @@ import Data.Aeson.Encoding (pair) import Data.Aeson.Types (Parser, typeMismatch, listEncoding) import Data.Bifunctor import Data.ByteString (ByteString) +import Data.Char import Data.Foldable (for_) import Data.List import Data.List.NonEmpty (NonEmpty (..)) @@ -104,18 +108,21 @@ import Network.HTTP.Client hiding (Proxy, proxy) import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Simple (JSONException) import Network.HTTP.Types.Header (HeaderName, hContentType) +import Text.Email.Parser (EmailAddress) import Text.HTML.SanitizeXSS import Yesod.Core.Content (ContentType) import Yesod.Core.Handler (ProvidedRep, provideRepType) import Network.HTTP.Client.Signature +import qualified Data.Attoparsec.ByteString as A import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Data.Vector as V import qualified Network.HTTP.Signature as S +import qualified Text.Email.Parser as E import Crypto.PublicVerifKey import Network.FedURI @@ -821,6 +828,100 @@ instance ActivityPub Ticket where <> "assignedTo" .=? assignedTo <> "isResolved" .= isResolved +data Author = Author + { authorName :: Text + , authorEmail :: EmailAddress + } + +instance FromJSON Author where + parseJSON = withObject "Author" $ \ o -> + Author + <$> o .: "name" + <*> (parseMailto =<< o .: "mbox") + where + parseMailto = + either fail return . + A.parseOnly (A.string "mailto:" *> E.addrSpec <* A.endOfInput) . + encodeUtf8 + +instance ToJSON Author where + toJSON = error "toJSON Author" + toEncoding (Author name email) = + pairs + $ "name" .= name + <> "mbox" .= ("mailto:" <> decodeUtf8 (E.toByteString email)) + +newtype Hash = Hash ByteString + +instance FromJSON Hash where + parseJSON = withText "Hash" $ \ t -> + let b = encodeUtf8 t + in if not (BC.null b) && BC.all isHexDigit b + then return $ Hash b + else fail "Hash should be a non-empty hex string" + +instance ToJSON Hash where + toJSON (Hash b) = toJSON $ decodeUtf8 b + toEncoding (Hash b) = toEncoding $ decodeUtf8 b + +data Commit u = Commit + { commitId :: LocalURI + , commitRepository :: LocalURI + , commitAuthor :: Either Author (ObjURI u) + , commitCommitter :: Maybe (Either Author (ObjURI u)) + , commitTitle :: Text + , commitHash :: Hash + , commitDescription :: Maybe Text + , commitWritten :: UTCTime + , commitCommitted :: Maybe UTCTime + } + +instance ActivityPub Commit where + jsonldContext _ = [as2Context, forgeContext, extContext] + parseObject o = do + typ <- o .: "type" + unless (typ == ("Commit" :: Text)) $ + fail "type isn't Commit" + + mdesc <- o .:? "description" + mdescContent <- for mdesc $ \ desc -> do + descType <- desc .: "mediaType" + unless (descType == ("text/plain" :: Text)) $ + fail "description mediaType isn't \"text/plain\"" + desc .: "content" + + ObjURI a id_ <- o .: "id" + fmap (a,) $ + Commit id_ + <$> withAuthorityO a (o .: "repository") + <*> o .:+ "attributedTo" + <*> o .:+? "committedBy" + <*> o .: "name" + <*> o .: "hash" + <*> pure mdescContent + <*> o .: "created" + <*> o .:? "committed" + + toSeries authority + (Commit id_ repo author committer title hash mdesc written mcommitted) + = "id" .= ObjURI authority id_ + <> "type" .= ("Commit" :: Text) + <> "repository" .= ObjURI authority repo + <> "attributedTo" .=+ author + <> "committedBy" .=+? committer + <> "name" .= title + <> "hash" .= hash + <> maybe + mempty + (\ desc -> "description" .= object + [ "content" .= desc + , "mediaType" .= ("text/plain" :: Text) + ] + ) + mdesc + <> "created" .= written + <> "committed" .=? mcommitted + data Accept u = Accept { acceptObject :: ObjURI u , acceptResult :: LocalURI diff --git a/templates/repo/patch.hamlet b/templates/repo/patch.hamlet index a45a6b5..f7d75ab 100644 --- a/templates/repo/patch.hamlet +++ b/templates/repo/patch.hamlet @@ -16,13 +16,22 @@ $# . By - $maybe sharer <- msharer + $maybe sharer <- msharerWritten ^{sharerLinkW sharer} $nothing - #{patchAuthorName patch} + #{authorName author} + $maybe (committer, _) <- patchCommitted patch + ; + $maybe sharer <- msharerCommitted + ^{sharerLinkW sharer} + $nothing + #{authorName committer} At - #{showDate $ patchTime patch} + + #{showDate written} + $maybe (_, committed) <- patchCommitted patch + ; #{showDate committed} Title #{patchTitle patch}