Provide AP representation of commits, and support committer field

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

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

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
+            { patchWritten     =
-            , patchAuthorEmail = ae
+                ( Author
-            , patchTime        = piTime pi
+                    { authorName  = an
+                    , authorEmail = ae
+                    }
+                , piTime pi
+                )
+            , patchCommitted   = Nothing
             , patchTitle       = piTitle pi
             , patchDescription = fromMaybe "" $ piDescription pi
             , patchDiff        =

src/Vervis/Git.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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
+    { patchWritten     = makeAuthor $ commitAuthor c
-    , patchAuthorEmail =
+    , patchCommitted   =
-        let b = personEmail $ commitAuthor c
+        if commitAuthor c == commitCommitter c
-        in  case emailAddress b of
+            then Nothing
-                Nothing -> error $ "Invalid email " ++ T.unpack (decodeUtf8 b)
+            else Just $ makeAuthor $ commitCommitter c
-                Just e  -> e
-    , patchTime        =
-        let Elapsed (Seconds t) = gitTimeUTC $ personTime $ commitAuthor c
-        in  posixSecondsToUTCTime $ fromIntegral t
     , 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
 

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

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
+        Just patch -> serveCommit shr rp ref patch []
-            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")

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
+    serveCommit shr rp ref patch parents
-        mp <- getBy $ UniquePersonEmail $ patchAuthorEmail patch
-        for mp $ \ (Entity _ person) -> get404 $ personIdent person
-    let number = zip ([1..] :: [Int])
-    defaultLayout $(widgetFile "repo/patch")

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
+    { patchWritten     :: (Author, UTCTime)
-    , patchAuthorEmail :: EmailAddress
+    , patchCommitted   :: Maybe (Author, UTCTime)
-    , patchTime        :: UTCTime
     , patchTitle       :: Text
     , patchDescription :: Text
     , patchDiff        :: [Edit]

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

templates/repo/patch.hamlet

@@ -16,13 +16,22 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <tr>
     <td>By
     <td>
-      $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}
   <tr>
     <td>At
-    <td>#{showDate $ patchTime patch}
+    <td>
+      #{showDate written}
+      $maybe (_, committed) <- patchCommitted patch
+        ; #{showDate committed}
   <tr>
     <td>Title
     <td>#{patchTitle patch}