sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-28 23:54:51 +09:00
Code Issues Activity

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

Browse source
This commit is contained in:
fr33domlover 2019-03-20 12:01:10 +00:00
parent ade1157a04
commit 747bbd5f0c
5 changed files with 69 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
src/Vervis/Handler/Inbox.hs
View file

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

10
src/Vervis/Handler/Person.hs
View file

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

51
src/Vervis/Handler/Project.hs
View file

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

8
src/Vervis/Handler/Sharer.hs
View file

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

22
src/Web/ActivityPub.hs
View file

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