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

Add route getMessageR, returns an Activity Note for any locally created Message

Browse source
This commit is contained in:
fr33domlover 2019-03-22 20:46:42 +00:00
parent 6c186355f3
commit 88d4c976ee
11 changed files with 188 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
config/models
View file

@ -12,7 +12,7 @@
-- with this software. If not, see
-- <http://creativecommons.org/publicdomain/zero/1.0/>.
RawObject
RemoteRawObject
content Value
received UTCTime
@ -206,6 +206,7 @@ Ticket
discuss DiscussionId
UniqueTicket project number
UniqueTicketDiscussion discuss
TicketDependency
parent TicketId
@ -223,6 +224,14 @@ TicketClaimRequest
Discussion
RemoteDiscussion
instance InstanceId
ident LocalURI
discuss DiscussionId
UniqueRemoteDiscussionIdent instance ident
UniqueRemoteDiscussion discuss
Message
created UTCTime
content Text -- Assume this is Pandoc Markdown
@ -240,7 +249,7 @@ RemoteMessage
instance InstanceId
ident LocalURI
rest MessageId
raw RawObjectId
raw RemoteRawObjectId
lostParent FedURI Maybe
UniqueRemoteMessageIdent instance ident

4
config/routes
View file

@ -112,6 +112,8 @@
/s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c/!new WorkflowEnumCtorNewR GET
/s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c/#Text WorkflowEnumCtorR PUT DELETE POST
/s/#ShrIdent/m/#Text MessageR GET
/s/#ShrIdent/p/#PrjIdent/t TicketsR GET POST
/s/#ShrIdent/p/#PrjIdent/t/!tree TicketTreeR GET
/s/#ShrIdent/p/#PrjIdent/t/!new TicketNewR GET
@ -128,7 +130,7 @@
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d TicketDiscussionR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Text TicketMessageR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Text TicketMessageR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Text/reply TicketReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET POST

12
migrations/2019_03_19.model
View file

@ -1,7 +1,15 @@
RawObject
RemoteRawObject
content Value
received UTCTime
RemoteDiscussion
instance InstanceId
ident Text
discuss DiscussionId
UniqueRemoteDiscussionIdent instance ident
UniqueRemoteDiscussion discuss
LocalMessage
author PersonId
rest MessageId
@ -13,7 +21,7 @@ RemoteMessage
instance InstanceId
ident Text
rest MessageId
raw RawObjectId
raw RemoteRawObjectId
lostParent Text Maybe
UniqueRemoteMessageIdent instance ident

6
src/Vervis/Federation.hs
View file

@ -146,7 +146,7 @@ handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience spe
rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
m E.^. MessageRoot `op` E.val did
return (rm E.^. RemoteMessageId, m E.^. MessageId)
handleCreate iidActor hActor rsidActor raw audience (Note luNote muParent muContext mpublished content) = do
handleCreate iidActor hActor rsidActor raw audience (Note luNote _luAttrib muParent muContext mpublished content) = do
(shr, prj) <- do
uRecip <- parseAudience audience
parseProject uRecip
@ -198,7 +198,7 @@ handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience spe
done "Got Create Note replying to remote message which belongs to a different discussion"
return $ Just $ Left mid
now <- liftIO getCurrentTime
roid <- lift $ insert $ RawObject raw now
rroid <- lift $ insert $ RemoteRawObject raw now
mid <- lift $ insert Message
{ messageCreated = published
, messageContent = content
@ -213,7 +213,7 @@ handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience spe
, remoteMessageInstance = iidActor
, remoteMessageIdent = luNote
, remoteMessageRest = mid
, remoteMessageRaw = roid
, remoteMessageRaw = rroid
, remoteMessageLostParent =
case meparent of
Just (Right uParent) -> Just uParent

2
src/Vervis/Foundation.hs
View file

@ -893,6 +893,8 @@ instance YesodBreadcrumbs App where
WorkflowEnumCtorsR shr wfl enm
)
MessageR shr lmhid -> ("#" <> lmhid, Just $ SharerR shr)
TicketsR shar proj -> ( "Tickets"
, Just $ ProjectR shar proj
)

77
src/Vervis/Handler/Discussion.hs
View file

@ -27,23 +27,32 @@ import Prelude
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.Maybe
import Data.Time.Clock (getCurrentTime)
import Database.Persist
import Database.Persist.Sql
import Data.Traversable
import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuthId)
import Yesod.Core (Route, defaultLayout)
import Yesod.Core
import Yesod.Core.Handler
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)
import Network.FedURI
import Web.ActivityPub
import Yesod.FedURI
import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.Discussion
import Vervis.Form.Discussion
import Vervis.Foundation (App, Handler, AppDB)
import Vervis.Foundation
import Vervis.Model
import Vervis.Settings (widgetFile)
import Vervis.Model.Ident
import Vervis.Settings
import Vervis.Widget.Discussion
getDiscussion
@ -75,6 +84,7 @@ getNode getdid mid = do
l2f (instanceHost i) (remoteSharerIdent rs)
return $ MessageTreeNode mid m author
{-
getNodeL :: AppDB DiscussionId -> LocalMessageId -> AppDB MessageTreeNode
getNodeL getdid lmid = do
did <- getdid
@ -85,16 +95,59 @@ getNodeL getdid lmid = do
p <- getJust $ localMessageAuthor lm
s <- getJust $ personIdent p
return $ MessageTreeNode mid m $ MessageTreeNodeLocal lmid s
-}
getDiscussionMessage
:: (MessageId -> Route App)
-> AppDB DiscussionId
-> LocalMessageId
-> Handler Html
getDiscussionMessage reply getdid lmid = do
mtn <- runDB $ getNodeL getdid lmid
now <- liftIO getCurrentTime
defaultLayout $ messageW now mtn reply
getDiscussionMessage :: ShrIdent -> LocalMessageId -> Handler TypedContent
getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
pid <- getKeyBy404 $ UniquePersonIdent sid
lm <- get404 lmid
unless (localMessageAuthor lm == pid) notFound
m <- getJust $ localMessageRest lm
route2fed <- getEncodeRouteFed
encodeHid <- getsYesod appHashidEncode
uContext <- do
let did = messageRoot m
mt <- getValBy $ UniqueTicketDiscussion did
mrd <- getValBy $ UniqueRemoteDiscussion did
case (mt, mrd) of
(Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context"
(Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts"
(Just t, Nothing) -> do
j <- getJust $ ticketProject t
s <- getJust $ projectSharer j
return $ route2fed $
TicketR (sharerIdent s) (projectIdent j) (ticketNumber t)
(Nothing, Just rd) -> do
i <- getJust $ remoteDiscussionInstance rd
return $ l2f (instanceHost i) (remoteDiscussionIdent rd)
muParent <- for (messageParent m) $ \ midParent -> do
mlocal <- getBy $ UniqueLocalMessage midParent
mremote <- getValBy $ UniqueRemoteMessage midParent
case (mlocal, mremote) of
(Nothing, Nothing) -> fail "Message with no author"
(Just _, Just _) -> fail "Message used as both local and remote"
(Just (Entity lmidParent lmParent), Nothing) -> do
p <- getJust $ localMessageAuthor lmParent
s <- getJust $ personIdent p
let lmhidParent = encodeHid $ fromSqlKey lmidParent
return $ route2fed $ MessageR (sharerIdent s) lmhidParent
(Nothing, Just rmParent) -> do
rs <- getJust $ remoteMessageAuthor rmParent
i <- getJust $ remoteSharerInstance rs
return $ l2f (instanceHost i) (remoteSharerIdent rs)
host <- getsYesod $ appInstanceHost . appSettings
route2local <- getEncodeRouteLocal
let lmhid = encodeHid $ fromSqlKey lmid
return $ Doc host Note
{ noteId = route2local $ MessageR shr lmhid
, noteAttrib = route2local $ SharerR shr
, noteReplyTo = Just $ fromMaybe uContext muParent
, noteContext = Just uContext
, notePublished = Just $ messageCreated m
, noteContent = messageContent m
}
getTopReply :: Route App -> Handler Html
getTopReply replyP = do

18
src/Vervis/Handler/Ticket.hs
View file

@ -38,7 +38,7 @@ module Vervis.Handler.Ticket
, getClaimRequestNewR
, getTicketDiscussionR
, postTicketDiscussionR
, getTicketMessageR
, getMessageR
, postTicketMessageR
, getTicketTopReplyR
, getTicketReplyR
@ -71,7 +71,7 @@ import Database.Persist hiding ((==.))
import Network.HTTP.Types (StdMethod (DELETE, POST))
import Text.Blaze.Html (Html, toHtml)
import Yesod.Auth (requireAuthId, maybeAuthId)
import Yesod.Core (defaultLayout)
import Yesod.Core
import Yesod.Core.Handler
import Yesod.Form.Functions (runFormGet, runFormPost)
import Yesod.Form.Types (FormResult (..))
@ -643,18 +643,18 @@ postTicketDiscussionR shar proj num =
(const $ TicketR shar proj num)
(selectDiscussionId shar proj num)
getTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Text -> Handler Html
getTicketMessageR shar proj tnum hid = do
getMessageR :: ShrIdent -> Text -> Handler TypedContent
getMessageR shr hid = do
decodeHid <- getsYesod appHashidDecode
encodeHid <- getsYesod appHashidEncode
--encodeHid <- getsYesod appHashidEncode
lmid <-
case toSqlKey <$> decodeHid hid of
Nothing -> notFound
Just k -> return k
getDiscussionMessage
(TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
(selectDiscussionId shar proj tnum)
lmid
getDiscussionMessage shr lmid
--(TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
--(selectDiscussionId shar proj tnum)
--lmid
postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Text -> Handler Html
postTicketMessageR shar proj tnum hid = do

2
src/Vervis/Migration.hs
View file

@ -208,6 +208,8 @@ changes =
insertMany_ $ map mklocal msgs
-- 48
, removeField "Message" "author"
-- 49
, addUnique "Ticket" $ Unique "UniqueTicketDiscussion" ["discuss"]
]
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

38
src/Web/ActivityPub.hs
View file

@ -317,7 +317,7 @@ instance ActivityPub Actor where
data Note = Note
{ noteId :: LocalURI
--, noteAttrib :: LocalURI
, noteAttrib :: LocalURI
--, noteTo :: FedURI
, noteReplyTo :: Maybe FedURI
, noteContext :: Maybe FedURI
@ -325,6 +325,35 @@ data Note = Note
, noteContent :: Text
}
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
instance ActivityPub Note where
jsonldContext _ = ContextAS2
parseObject o = do
typ <- o .: "type"
unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
(h, id_) <- f2l <$> o .: "id"
fmap (h,) $
Note id_
<$> withHost h (f2l <$> o .: "attributedTo")
<*> o .:? "inReplyTo"
<*> o .:? "context"
<*> o .:? "published"
<*> o .: "content"
toSeries host (Note id_ attrib mreply mcontext mpublished content)
= "type" .= ("Note" :: Text)
<> "id" .= l2f host id_
<> "attributedTo" .= l2f host attrib
<> "inReplyTo" .=? mreply
<> "context" .=? mcontext
<> "published" .=? mpublished
<> "content" .= content
{-
parseNote :: Value -> Parser (Text, (Note, LocalURI))
parseNote = withObject "Note" $ \ o -> do
typ <- o .: "type"
@ -355,6 +384,7 @@ encodeNote host (Note id_ mreply mcontext mpublished content) attrib =
<> "context" .=? mcontext
<> "published" .=? mpublished
<> "content" .= content
-}
data Accept = Accept
{ acceptObject :: FedURI
@ -372,8 +402,8 @@ data Create = Create
parseCreate :: Object -> Text -> LocalURI -> Parser Create
parseCreate o h luActor = do
(note, luAttrib) <- withHost h $ parseNote =<< o .: "object"
unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
note <- withHost h $ parseObject =<< o .: "object"
unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib"
return $ Create note
where
withHost h a = do
@ -384,7 +414,7 @@ parseCreate o h luActor = do
encodeCreate :: Text -> LocalURI -> Create -> Series
encodeCreate host actor (Create obj) =
"object" `pair` encodeNote host obj actor
"object" `pair` pairs (toSeries host obj)
data Follow = Follow
{ followObject :: FedURI

46
src/Yesod/Persist/Local.hs Normal file
View file

@ -0,0 +1,46 @@
{- This file is part of Vervis.
-
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Yesod.Persist.Local
( getKeyBy404
, getValBy404
)
where
import Prelude
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Database.Persist
import Yesod.Persist.Core
getKeyBy404
:: ( PersistUniqueRead backend
, PersistRecordBackend val backend
, MonadIO m
)
=> Unique val
-> ReaderT backend m (Key val)
getKeyBy404 u = entityKey <$> getBy404 u
getValBy404
:: ( PersistUniqueRead backend
, PersistRecordBackend val backend
, MonadIO m
)
=> Unique val
-> ReaderT backend m val
getValBy404 u = entityVal <$> getBy404 u

1
vervis.cabal
View file

@ -97,6 +97,7 @@ library
Yesod.Auth.Unverified.Internal
Yesod.FedURI
Yesod.Paginate.Local
Yesod.Persist.Local
Yesod.SessionEntity
Vervis.Access