Publish actor documents for projects, and add some new properties to Actor

src/Vervis/Handler/Inbox.hs

@@ -288,20 +288,19 @@ postOutboxR = do
             Right (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs
 
 getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
-getActorKey choose route = do
+getActorKey choose route = selectRep $ provideAP $ do
     actorKey <-
         liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
         getsYesod appActorKeys
     route2uri <- route2uri' <$> getUrlRender
     let (host, id_) = f2l $ route2uri route
-    selectRep $
+    return $ Doc host PublicKey
-        provideAP $ Doc host PublicKey
+        { publicKeyId       = id_
-            { publicKeyId       = id_
+        , publicKeyExpires  = Nothing
-            , publicKeyExpires  = Nothing
+        , publicKeyOwner    = OwnerInstance
-            , publicKeyOwner    = OwnerInstance
+        , publicKeyMaterial = actorKey
-            , publicKeyMaterial = actorKey
+        --, publicKeyAlgo    = Just AlgorithmEd25519
-            --, publicKeyAlgo    = Just AlgorithmEd25519
+        }
-            }
 
 getActorKey1R :: Handler TypedContent
 getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R

src/Vervis/Handler/Person.hs

@@ -127,8 +127,8 @@ getPersonNewR = redirect $ AuthR newAccountR
         else notFound
 -}
 
-getPerson :: ShrIdent -> Person -> Handler TypedContent
+getPerson :: ShrIdent -> Sharer -> Person -> Handler TypedContent
-getPerson shr person = do
+getPerson shr sharer person = do
     route2fed <- getEncodeRouteFed
     route2local <- getEncodeRouteLocal
     let (host, me) = f2l $ route2fed $ SharerR shr
@@ -136,10 +136,12 @@ getPerson shr person = do
         provideRep $ do
             secure <- getSecure
             defaultLayout $(widgetFile "person")
-        provideAP $ Doc host Actor
+        provideAP $ pure $ Doc host Actor
             { actorId         = me
             , actorType       = ActorTypePerson
-            , actorUsername   = shr2text shr
+            , actorUsername   = Just $ shr2text shr
+            , actorName       = sharerName sharer
+            , actorSummary    = Nothing
             , actorInbox      = route2local InboxR
             , actorPublicKeys =
                 [ Left $ route2local ActorKey1R

src/Vervis/Handler/Project.hs

@@ -38,7 +38,7 @@ import Database.Persist
 import Database.Esqueleto hiding (delete, (%), (==.))
 import Text.Blaze.Html (Html)
 import Yesod.Auth (requireAuthId)
-import Yesod.Core (defaultLayout)
+import Yesod.Core
 import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
 import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
@@ -46,6 +46,10 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
 
 import qualified Database.Esqueleto as E
 
+import Network.FedURI
+import Web.ActivityPub
+import Yesod.FedURI
+
 import Vervis.Form.Project
 import Vervis.Foundation
 import Vervis.Model
@@ -106,19 +110,38 @@ getProjectNewR shr = do
     ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
     defaultLayout $(widgetFile "project/new")
 
-getProjectR :: ShrIdent -> PrjIdent -> Handler Html
+getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent
-getProjectR shar proj = do
+getProjectR shar proj = selectRep $ do
-    (project, workflow, wsharer, repos) <- runDB $ do
+    provideRep $ do
-        Entity sid s <- getBy404 $ UniqueSharer shar
+        (project, workflow, wsharer, repos) <- runDB $ do
-        Entity pid p <- getBy404 $ UniqueProject proj sid
+            Entity sid s <- getBy404 $ UniqueSharer shar
-        w <- get404 $ projectWorkflow p
+            Entity pid p <- getBy404 $ UniqueProject proj sid
-        sw <-
+            w <- get404 $ projectWorkflow p
-            if workflowSharer w == sid
+            sw <-
-                then return s
+                if workflowSharer w == sid
-                else get404 $ workflowSharer w
+                    then return s
-        rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
+                    else get404 $ workflowSharer w
-        return (p, w, sw, rs)
+            rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
-    defaultLayout $(widgetFile "project/one")
+            return (p, w, sw, rs)
+        defaultLayout $(widgetFile "project/one")
+    provideAP $ do
+        project <- runDB $ do
+            Entity sid _s <- getBy404 $ UniqueSharer shar
+            Entity _pid p <- getBy404 $ UniqueProject proj sid
+            return p
+        route2fed <- getEncodeRouteFed
+        route2local <- getEncodeRouteLocal
+        let (host, me) = f2l $ route2fed $ ProjectR shar proj
+        return $ Doc host Actor
+            { actorId         = me
+            , actorType       = ActorTypeProject
+            , actorUsername   = Nothing
+            , actorName       =
+                Just $ fromMaybe (prj2text proj) $ projectName project
+            , actorSummary    = projectDesc project
+            , actorInbox      = route2local InboxR
+            , actorPublicKeys = []
+            }
 
 putProjectR :: ShrIdent -> PrjIdent -> Handler Html
 putProjectR shr prj = do

src/Vervis/Handler/Sharer.hs

@@ -54,15 +54,15 @@ getSharersR = do
 getSharerR :: ShrIdent -> Handler TypedContent
 getSharerR shr = do
     ment <- runDB $ do
-        Entity sid _sharer <- getBy404 $ UniqueSharer shr
+        Entity sid sharer <- getBy404 $ UniqueSharer shr
-        runMaybeT
+        runMaybeT . fmap (sharer,)
             $   Left  <$> MaybeT (getBy $ UniquePersonIdent sid)
             <|> Right <$> MaybeT (getBy $ UniqueGroup sid)
     case ment of
         Nothing -> do
             $logWarn $ "Found non-person non-group sharer: " <> shr2text shr
             notFound
-        Just ent ->
+        Just (s, ent) ->
             case ent of
-                Left (Entity _ p) -> getPerson shr p
+                Left (Entity _ p) -> getPerson shr s p
                 Right (Entity _ g) -> getGroup shr g

src/Web/ActivityPub.hs

@@ -274,7 +274,9 @@ encodePublicKeySet host es =
 data Actor = Actor
     { actorId         :: LocalURI
     , actorType       :: ActorType
-    , actorUsername   :: Text
+    , actorUsername   :: Maybe Text
+    , actorName       :: Maybe Text
+    , actorSummary    :: Maybe Text
     , actorInbox      :: LocalURI
     , actorPublicKeys :: [Either LocalURI PublicKey]
     }
@@ -286,7 +288,9 @@ instance ActivityPub Actor where
         fmap (host,) $
             Actor id_
                 <$> o .: "type"
-                <*> o .: "preferredUsername"
+                <*> o .:? "preferredUsername"
+                <*> o .:? "name"
+                <*> o .:? "summary"
                 <*> withHost host (f2l <$> o .: "inbox")
                 <*> withHost host (parsePublicKeySet =<< o .: "publicKey")
         where
@@ -295,10 +299,12 @@ instance ActivityPub Actor where
             if h == h'
                 then return v
                 else fail "URI host mismatch"
-    toSeries host (Actor id_ typ username inbox pkeys)
+    toSeries host (Actor id_ typ musername mname msummary inbox pkeys)
         =  "id"                .=     l2f host id_
         <> "type"              .=     typ
-        <> "preferredUsername" .=     username
+        <> "preferredUsername" .=?    musername
+        <> "name"              .=?    mname
+        <> "summary"           .=?    msummary
         <> "inbox"             .=     l2f host inbox
         <> "publicKey"         `pair` encodePublicKeySet host pkeys
 
@@ -487,11 +493,11 @@ typeActivityStreams2LD =
 hActivityPubActor :: HeaderName
 hActivityPubActor = "ActivityPub-Actor"
 
-provideAP :: (Monad m, ToJSON a) => a -> Writer (Endo [ProvidedRep m]) ()
+provideAP :: (Monad m, ToJSON a) => m a -> Writer (Endo [ProvidedRep m]) ()
-provideAP v = do
+provideAP mk =
-    let enc = toEncoding v
+    -- let enc = toEncoding v
     -- provideRepType typeActivityStreams2   $ return enc
-    provideRepType typeActivityStreams2LD $ return enc
+    provideRepType typeActivityStreams2LD $ toEncoding <$> mk
 
 data APGetError
     = APGetErrorHTTP HttpException