Move reply authoring code from Vervis.Handler.Discussion to Vervis.Client

src/Vervis/Client.hs

@@ -14,7 +14,9 @@
  -}
 
 module Vervis.Client
-    ( follow
+    ( createThread
+    , createReply
+    , follow
     , followSharer
     , followProject
     , followTicket
@@ -22,25 +24,119 @@ module Vervis.Client
     )
 where
 
+import Control.Monad.Trans.Except
+import Database.Persist
+import Data.Text (Text)
 import Text.Blaze.Html.Renderer.Text
 import Text.Hamlet
 import Yesod.Core
 import Yesod.Core.Handler
+import Yesod.Persist.Core
 
+import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 
 import Network.FedURI
-import Web.ActivityPub
+import Web.ActivityPub hiding (Follow)
 import Yesod.FedURI
+import Yesod.Hashids
 import Yesod.MonadSite
+import Yesod.RenderSource
+
+import qualified Web.ActivityPub as AP
+
+import Database.Persist.Local
 
 import Vervis.FedURI
 import Vervis.Foundation
+import Vervis.Model
 import Vervis.Model.Ident
 
+createThread
+    :: (MonadSite m, SiteEnv m ~ App)
+    => ShrIdent
+    -> TextPandocMarkdown
+    -> Host
+    -> [Route App]
+    -> [Route App]
+    -> Route App
+    -> m (Either Text (Note URIMode))
+createThread shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context = runExceptT $ do
+    encodeRouteLocal <- getEncodeRouteLocal
+    let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
+    contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
+    let uContext = encodeRecipRoute context
+        recips = recipsA ++ recipsC
+    return Note
+        { noteId        = Nothing
+        , noteAttrib    = encodeRouteLocal $ SharerR shrAuthor
+        , noteAudience  = Audience
+            { audienceTo        = map encodeRecipRoute recips
+            , audienceBto       = []
+            , audienceCc        = []
+            , audienceBcc       = []
+            , audienceGeneral   = []
+            , audienceNonActors = map encodeRecipRoute recipsC
+            }
+        , noteReplyTo   = Just uContext
+        , noteContext   = Just uContext
+        , notePublished = Nothing
+        , noteSource    = msg
+        , noteContent   = contentHtml
+        }
+
+createReply
+    :: ShrIdent
+    -> TextPandocMarkdown
+    -> Host
+    -> [Route App]
+    -> [Route App]
+    -> Route App
+    -> MessageId
+    -> Handler (Either Text (Note URIMode))
+createReply shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context midParent = runExceptT $ do
+    encodeRouteHome <- getEncodeRouteHome
+    encodeRouteLocal <- getEncodeRouteLocal
+    let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
+    uParent <- lift $ runDB $ do
+        _m <- get404 midParent
+        mlocal <- getBy $ UniqueLocalMessage midParent
+        mremote <- getValBy $ UniqueRemoteMessage midParent
+        case (mlocal, mremote) of
+            (Nothing, Nothing) -> error "Message with no author"
+            (Just _, Just _) -> error "Message used as both local and remote"
+            (Just (Entity lmidParent lm), Nothing) -> do
+                p <- getJust $ localMessageAuthor lm
+                s <- getJust $ personIdent p
+                lmkhid <- encodeKeyHashid lmidParent
+                return $ encodeRouteHome $ MessageR (sharerIdent s) lmkhid
+            (Nothing, Just rm) -> do
+                i <- getJust $ remoteMessageInstance rm
+                return $ ObjURI (instanceHost i) (remoteMessageIdent rm)
+    contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
+    let uContext = encodeRecipRoute context
+        recips = recipsA ++ recipsC
+    return Note
+        { noteId        = Nothing
+        , noteAttrib    = encodeRouteLocal $ SharerR shrAuthor
+        , noteAudience  = Audience
+            { audienceTo        = map encodeRecipRoute recips
+            , audienceBto       = []
+            , audienceCc        = []
+            , audienceBcc       = []
+            , audienceGeneral   = []
+            , audienceNonActors = map encodeRecipRoute recipsC
+            }
+        , noteReplyTo   = Just uParent
+        , noteContext   = Just uContext
+        , notePublished = Nothing
+        , noteSource    = msg
+        , noteContent   = contentHtml
+        }
+
 follow
     :: (MonadHandler m, HandlerSite m ~ App)
-    => ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+    => ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
 follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do
     summary <-
         TextHtml . TL.toStrict . renderHtml <$>
@@ -54,7 +150,7 @@ follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do
                           #{renderAuthority hObject}#{localUriPath luObject}
                       \.
                 |]
-    let followAP = Follow
+    let followAP = AP.Follow
             { followObject  = uObject
             , followContext =
                 if uObject == uRecip
@@ -67,7 +163,7 @@ follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do
 
 followSharer
     :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
-    => ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+    => ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
 followSharer shrAuthor shrObject hide = do
     encodeRouteHome <- getEncodeRouteHome
     let uObject = encodeRouteHome $ SharerR shrObject
@@ -75,7 +171,7 @@ followSharer shrAuthor shrObject hide = do
 
 followProject
     :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
-    => ShrIdent -> ShrIdent -> PrjIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+    => ShrIdent -> ShrIdent -> PrjIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
 followProject shrAuthor shrObject prjObject hide = do
     encodeRouteHome <- getEncodeRouteHome
     let uObject = encodeRouteHome $ ProjectR shrObject prjObject
@@ -83,7 +179,7 @@ followProject shrAuthor shrObject prjObject hide = do
 
 followTicket
     :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
-    => ShrIdent -> ShrIdent -> PrjIdent -> Int -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+    => ShrIdent -> ShrIdent -> PrjIdent -> Int -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
 followTicket shrAuthor shrObject prjObject numObject hide = do
     encodeRouteHome <- getEncodeRouteHome
     let uObject = encodeRouteHome $ TicketR shrObject prjObject numObject
@@ -92,7 +188,7 @@ followTicket shrAuthor shrObject prjObject numObject hide = do
 
 followRepo
     :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
-    => ShrIdent -> ShrIdent -> RpIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
+    => ShrIdent -> ShrIdent -> RpIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
 followRepo shrAuthor shrObject rpObject hide = do
     encodeRouteHome <- getEncodeRouteHome
     let uObject = encodeRouteHome $ RepoR shrObject rpObject

src/Vervis/Handler/Discussion.hs

@@ -46,14 +46,17 @@ import Data.Aeson.Encode.Pretty.ToEncoding
 import Database.Persist.JSON
 import Network.FedURI
 import Web.ActivityPub
+import Yesod.ActivityPub
 import Yesod.Auth.Unverified
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.MonadSite
 
 import Database.Persist.Local
 import Yesod.Persist.Local
 
 import Vervis.API
+import Vervis.Client
 import Vervis.Discussion
 import Vervis.Federation
 import Vervis.FedURI
@@ -197,35 +200,13 @@ postTopReply hDest recipsA recipsC context replyP after = do
         msg <- case result of
             FormMissing -> throwE "Field(s) missing."
             FormFailure _l -> throwE "Message submission failed, see errors below."
-            FormSuccess nm -> return $ nmContent nm
+            FormSuccess nm ->
-        encodeRouteFed <- getEncodeRouteHome
+                return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
-        encodeRouteLocal <- getEncodeRouteLocal
-        let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
         shrAuthor <- do
             Entity _ p <- requireVerifiedAuth
             lift $ runDB $ sharerIdent <$> get404 (personIdent p)
-        let msg' = T.filter (/= '\r') msg
+        hLocal <- asksSite siteInstanceHost
-        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
+        note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context
-        let ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
-            uContext = encodeRecipRoute context
-            recips = recipsA ++ recipsC
-            note = Note
-                { noteId        = Nothing
-                , noteAttrib    = luAuthor
-                , noteAudience  = Audience
-                    { audienceTo        = map encodeRecipRoute recips
-                    , audienceBto       = []
-                    , audienceCc        = []
-                    , audienceBcc       = []
-                    , audienceGeneral   = []
-                    , audienceNonActors = map encodeRecipRoute recipsC
-                    }
-                , noteReplyTo   = Just uContext
-                , noteContext   = Just uContext
-                , notePublished = Nothing
-                , noteSource    = msg'
-                , noteContent   = contentHtml
-                }
         ExceptT $ createNoteC hLocal note
     case elmid of
         Left e -> do
@@ -264,51 +245,13 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
         msg <- case result of
             FormMissing -> throwE "Field(s) missing."
             FormFailure _l -> throwE "Message submission failed, see errors below."
-            FormSuccess nm -> return $ nmContent nm
+            FormSuccess nm ->
-        encodeRouteFed <- getEncodeRouteHome
+                return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
-        encodeRouteLocal <- getEncodeRouteLocal
+        shrAuthor <- do
-        let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
-        (shrAuthor, uParent) <- do
             Entity _ p <- requireVerifiedAuth
-            lift $ runDB $ do
+            lift $ runDB $ sharerIdent <$> get404 (personIdent p)
-                _m <- get404 midParent
+        hLocal <- asksSite siteInstanceHost
-                shr <- sharerIdent <$> get404 (personIdent p)
+        note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent
-                mlocal <- getBy $ UniqueLocalMessage midParent
-                mremote <- getValBy $ UniqueRemoteMessage midParent
-                parent <- case (mlocal, mremote) of
-                    (Nothing, Nothing) -> error "Message with no author"
-                    (Just _, Just _) -> error "Message used as both local and remote"
-                    (Just (Entity lmidParent lm), Nothing) -> do
-                        p <- getJust $ localMessageAuthor lm
-                        s <- getJust $ personIdent p
-                        lmkhid <- encodeKeyHashid lmidParent
-                        return $ encodeRouteFed $ MessageR (sharerIdent s) lmkhid
-                    (Nothing, Just rm) -> do
-                        i <- getJust $ remoteMessageInstance rm
-                        return $ ObjURI (instanceHost i) (remoteMessageIdent rm)
-                return (shr, parent)
-        let msg' = T.filter (/= '\r') msg
-        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
-        let ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
-            uContext = encodeRecipRoute context
-            recips = recipsA ++ recipsC
-            note = Note
-                { noteId        = Nothing
-                , noteAttrib    = luAuthor
-                , noteAudience  = Audience
-                    { audienceTo        = map encodeRecipRoute recips
-                    , audienceBto       = []
-                    , audienceCc        = []
-                    , audienceBcc       = []
-                    , audienceGeneral   = []
-                    , audienceNonActors = map encodeRecipRoute recipsC
-                    }
-                , noteReplyTo   = Just uParent
-                , noteContext   = Just uContext
-                , notePublished = Nothing
-                , noteSource    = msg'
-                , noteContent   = contentHtml
-                }
         ExceptT $ createNoteC hLocal note
     case elmid of
         Left e -> do