forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Provide AP representation of commits, and support committer field

Browse source
This commit is contained in:
fr33domlover 2019-08-06 13:23:11 +00:00
parent 50614359ab
commit 2c18660a3b
10 changed files with 238 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
src/Data/Aeson/Local.hs
View file

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

55
src/Vervis/ActivityPub.hs
View file

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

11
src/Vervis/Darcs.hs
View file

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

29
src/Vervis/Git.hs
View file

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

2
src/Vervis/Handler/Repo.hs
View file

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

29
src/Vervis/Handler/Repo/Darcs.hs
View file

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

23
src/Vervis/Handler/Repo/Git.hs
View file

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

11
src/Vervis/Patch.hs
View file

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

101
src/Web/ActivityPub.hs
View file

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

15
templates/repo/patch.hamlet
View file

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