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

config/models

@@ -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,8 +249,8 @@ RemoteMessage
     instance   InstanceId
     ident      LocalURI
     rest       MessageId
-    raw        RawObjectId
+    raw        RemoteRawObjectId
-    lostParent FedURI         Maybe
+    lostParent FedURI            Maybe
 
     UniqueRemoteMessageIdent instance ident
     UniqueRemoteMessage rest

config/routes

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

migrations/2019_03_19.model

@@ -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,8 +21,8 @@ RemoteMessage
     instance   InstanceId
     ident      Text
     rest       MessageId
-    raw        RawObjectId
+    raw        RemoteRawObjectId
-    lostParent Text           Maybe
+    lostParent Text              Maybe
 
     UniqueRemoteMessageIdent instance ident
     UniqueRemoteMessage rest

src/Vervis/Federation.hs

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

src/Vervis/Foundation.hs

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

src/Vervis/Handler/Discussion.hs

@@ -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
+getDiscussionMessage :: ShrIdent -> LocalMessageId -> Handler TypedContent
-    :: (MessageId -> Route App)
+getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
-    -> AppDB DiscussionId
+    sid <- getKeyBy404 $ UniqueSharer shr
-    -> LocalMessageId
+    pid <- getKeyBy404 $ UniquePersonIdent sid
-    -> Handler Html
+    lm <- get404 lmid
-getDiscussionMessage reply getdid lmid = do
+    unless (localMessageAuthor lm == pid) notFound
-    mtn <- runDB $ getNodeL getdid lmid
+    m <- getJust $ localMessageRest lm
-    now <- liftIO getCurrentTime
+    route2fed <- getEncodeRouteFed
-    defaultLayout $ messageW now mtn reply
+    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

src/Vervis/Handler/Ticket.hs

@@ -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
+getMessageR :: ShrIdent -> Text -> Handler TypedContent
-getTicketMessageR shar proj tnum hid = do
+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
+    getDiscussionMessage shr lmid
-        (TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
+        --(TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
-        (selectDiscussionId shar proj tnum)
+        --(selectDiscussionId shar proj tnum)
-        lmid
+        --lmid
 
 postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Text -> Handler Html
 postTicketMessageR shar proj tnum hid = do

src/Vervis/Migration.hs

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

src/Web/ActivityPub.hs

@@ -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"
+    note <- withHost h $ parseObject =<< o .: "object"
-    unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
+    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

src/Yesod/Persist/Local.hs

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

vervis.cabal

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