diff --git a/config/models b/config/models index 1982245..761cdf0 100644 --- a/config/models +++ b/config/models @@ -12,7 +12,7 @@ -- with this software. If not, see -- . -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 - lostParent FedURI Maybe + raw RemoteRawObjectId + lostParent FedURI Maybe UniqueRemoteMessageIdent instance ident UniqueRemoteMessage rest diff --git a/config/routes b/config/routes index 4c87e8e..34b8450 100644 --- a/config/routes +++ b/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 diff --git a/migrations/2019_03_19.model b/migrations/2019_03_19.model index dd1a562..0425887 100644 --- a/migrations/2019_03_19.model +++ b/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 - lostParent Text Maybe + raw RemoteRawObjectId + lostParent Text Maybe UniqueRemoteMessageIdent instance ident UniqueRemoteMessage rest diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 93c6552..a758a25 100644 --- a/src/Vervis/Federation.hs +++ b/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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index a806063..03281c9 100644 --- a/src/Vervis/Foundation.hs +++ b/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 ) diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 62a41ef..9095aca 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/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 - :: (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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 566ceb6..59cc546 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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 -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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 8fe1b14..468c49c 100644 --- a/src/Vervis/Migration.hs +++ b/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)) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index ff9a462..35d3f01 100644 --- a/src/Web/ActivityPub.hs +++ b/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" - 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 diff --git a/src/Yesod/Persist/Local.hs b/src/Yesod/Persist/Local.hs new file mode 100644 index 0000000..24cd7d9 --- /dev/null +++ b/src/Yesod/Persist/Local.hs @@ -0,0 +1,46 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/vervis.cabal b/vervis.cabal index b9972af..8804f85 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -97,6 +97,7 @@ library Yesod.Auth.Unverified.Internal Yesod.FedURI Yesod.Paginate.Local + Yesod.Persist.Local Yesod.SessionEntity Vervis.Access