From 747bbd5f0c16fc34f661f0865c0290b689123de3 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 20 Mar 2019 12:01:10 +0000 Subject: [PATCH] Publish actor documents for projects, and add some new properties to Actor --- src/Vervis/Handler/Inbox.hs | 17 ++++++------ src/Vervis/Handler/Person.hs | 10 ++++--- src/Vervis/Handler/Project.hs | 51 +++++++++++++++++++++++++---------- src/Vervis/Handler/Sharer.hs | 8 +++--- src/Web/ActivityPub.hs | 22 +++++++++------ 5 files changed, 69 insertions(+), 39 deletions(-) diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index a2ca2b3..3600742 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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 $ - provideAP $ Doc host PublicKey - { publicKeyId = id_ - , publicKeyExpires = Nothing - , publicKeyOwner = OwnerInstance - , publicKeyMaterial = actorKey - --, publicKeyAlgo = Just AlgorithmEd25519 - } + return $ Doc host PublicKey + { publicKeyId = id_ + , publicKeyExpires = Nothing + , publicKeyOwner = OwnerInstance + , publicKeyMaterial = actorKey + --, publicKeyAlgo = Just AlgorithmEd25519 + } getActorKey1R :: Handler TypedContent getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 9d0bc0c..47c808a 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -127,8 +127,8 @@ getPersonNewR = redirect $ AuthR newAccountR else notFound -} -getPerson :: ShrIdent -> Person -> Handler TypedContent -getPerson shr person = do +getPerson :: ShrIdent -> Sharer -> Person -> Handler TypedContent +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 diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 4c776bd..8a547ab 100644 --- a/src/Vervis/Handler/Project.hs +++ b/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 shar proj = do - (project, workflow, wsharer, repos) <- runDB $ do - Entity sid s <- getBy404 $ UniqueSharer shar - Entity pid p <- getBy404 $ UniqueProject proj sid - w <- get404 $ projectWorkflow p - sw <- - if workflowSharer w == sid - then return s - else get404 $ workflowSharer w - rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] - return (p, w, sw, rs) - defaultLayout $(widgetFile "project/one") +getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent +getProjectR shar proj = selectRep $ do + provideRep $ do + (project, workflow, wsharer, repos) <- runDB $ do + Entity sid s <- getBy404 $ UniqueSharer shar + Entity pid p <- getBy404 $ UniqueProject proj sid + w <- get404 $ projectWorkflow p + sw <- + if workflowSharer w == sid + then return s + else get404 $ workflowSharer w + rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent] + 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 diff --git a/src/Vervis/Handler/Sharer.hs b/src/Vervis/Handler/Sharer.hs index 58f5462..f329d17 100644 --- a/src/Vervis/Handler/Sharer.hs +++ b/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 - runMaybeT + Entity sid sharer <- getBy404 $ UniqueSharer shr + 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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index ccc09ea..07b0706 100644 --- a/src/Web/ActivityPub.hs +++ b/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 v = do - let enc = toEncoding v +provideAP :: (Monad m, ToJSON a) => m a -> Writer (Endo [ProvidedRep m]) () +provideAP mk = + -- let enc = toEncoding v -- provideRepType typeActivityStreams2 $ return enc - provideRepType typeActivityStreams2LD $ return enc + provideRepType typeActivityStreams2LD $ toEncoding <$> mk data APGetError = APGetErrorHTTP HttpException