Switch postOutboxR to the new handler

src/Vervis/Handler/Inbox.hs

@@ -43,6 +43,7 @@ import Data.Bifunctor (first, second)
 import Data.Foldable (for_)
 import Data.HashMap.Strict (HashMap)
 import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe
 import Data.PEM (PEM (..))
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
@@ -203,15 +204,32 @@ fedUriField = Field
     , fieldEnctype = UrlEncoded
     }
 
-activityForm :: Form (FedURI, Maybe FedURI, Maybe FedURI, Text)
+ticketField
-activityForm = renderDivs $ (,,,)
+    :: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent, Int)
-    <$> areq fedUriField "To"          (Just defto)
+ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
-    <*> aopt fedUriField "Replying on" (Just $ Just defctx)
-    <*> aopt fedUriField "Context"     (Just $ Just defctx)
-    <*> areq textField   "Message"     (Just defmsg)
     where
-    defto = FedURI "forge.angeley.es" "/s/fr33/p/sandbox" ""
+    toTicket uTicket = runExceptT $ do
-    defctx = FedURI "forge.angeley.es" "/s/fr33/p/sandbox/t/1" ""
+        let (hTicket, luTicket) = f2l uTicket
+        route <-
+            case decodeRouteLocal luTicket of
+                Nothing -> throwE ("Not a valid route" :: Text)
+                Just r -> return r
+        case route of
+            TicketR shr prj num -> return (hTicket, shr, prj, num)
+            _ -> throwE "Not a ticket route"
+    fromTicket (h, shr, prj, num) =
+        l2f h $ encodeRouteLocal $ TicketR shr prj num
+
+activityForm :: Form ((Text, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
+activityForm html = do
+    enc <- getEncodeRouteLocal
+    flip renderDivs html $ (,,)
+        <$> areq (ticketField enc) "Ticket"      (Just deft)
+        <*> aopt fedUriField       "Replying to" (Just $ Just defp)
+        <*> areq textField         "Message"     (Just defmsg)
+    where
+    deft = ("forge.angeley.es", text2shr "fr33", text2prj "sandbox", 1)
+    defp = FedURI "forge.angeley.es" "/s/fr33/m/2f1a7" ""
     defmsg = "Hi! I'm testing federation. Can you see my message? :)"
 
 activityWidget :: ShrIdent -> Widget -> Enctype -> Widget
@@ -245,69 +263,51 @@ getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
 getOutboxItemR = error "Not implemented yet"
 
 postOutboxR :: ShrIdent -> Handler Html
-postOutboxR shr = do
+postOutboxR shrAuthor = do
     federation <- getsYesod $ appFederation . appSettings
     unless federation badMethod
     ((result, widget), enctype) <- runFormPost activityForm
-    case result of
+    elmid <- runExceptT $ do
-        FormMissing -> setMessage "Field(s) missing"
+        ((hTicket, shrTicket, prj, num), muParent, msg) <-
-        FormFailure _l -> setMessage "Invalid input, see below"
+            case result of
-        FormSuccess (to, mparent, mcontext, msg) -> do
+                FormMissing -> throwE "Field(s) missing"
-            renderUrl <- getUrlRender
+                FormFailure _l -> throwE "Invalid input, see below"
-            route2uri <- getEncodeRouteFed
+                FormSuccess r -> return r
-            now <- liftIO getCurrentTime
+        encodeRouteFed <- getEncodeRouteFed
-            let (h, actor) = f2l $ route2uri $ SharerR shr
+        encodeRouteLocal <- getEncodeRouteLocal
-                actorID = renderUrl $ SharerR shr
+        let encodeRecipRoute = l2f hTicket . encodeRouteLocal
-                appendPath u t = u { luriPath = luriPath u <> t }
+            uTicket = encodeRecipRoute $ TicketR shrTicket prj num
-                activity = Activity
+        now <- liftIO getCurrentTime
-                    { activityId       = appendPath actor "/fake-activity"
+        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
-                    , activityActor    = actor
+            recips =
-                    , activityAudience = deliverTo to
+                [ ProjectR shrTicket prj
-                    , activitySpecific = CreateActivity Create
+                , TicketParticipantsR shrTicket prj num
-                        { createObject = Note
+                , TicketTeamR shrTicket prj num
-                            { noteId        = Just $ appendPath actor "/fake-note"
-                            , noteAttrib    = actor
-                            , noteAudience  = deliverTo to
-                            , noteReplyTo   = mparent
-                            , noteContext   = mcontext
-                            , notePublished = Just now
-                            , noteContent   = msg
-                            }
-                        }
-                    }
-            manager <- getsYesod appHttpManager
-            let (host, lto) = f2l to
-            minbox <- fetchInboxURI manager host lto
-            for_ minbox $ \ inbox -> do
-                (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
-                let (keyID, akey) =
-                        if new1
-                            then (renderUrl ActorKey1R, akey1)
-                            else (renderUrl ActorKey2R, akey2)
-                    sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
-                eres' <- httpPostAP manager (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID $ Doc h activity
-                case eres' of
-                    Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
-                    Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."
-    defaultLayout $ activityWidget shr widget enctype
-    where
-    fetchInboxURI :: Manager -> Text -> LocalURI -> Handler (Maybe LocalURI)
-    fetchInboxURI manager h lto = do
-        iid <- runDB $ either entityKey id <$> insertBy' (Instance h)
-        result <- fetchRemoteActor iid h lto
-        case result of
-            Left err -> setErrorMsg $ displayException err
-            Right (Left err) -> setErrorMsg $ show err
-            Right (Right (Entity _ ra)) -> return $ Just $ remoteActorInbox ra
-        where
-        setErrorMsg err = do
-            setMessage $ toHtml $ T.concat
-                [ "Tried to fetch recipient actor <"
-                , renderFedURI $ l2f h lto
-                , "> and got an error: "
-                , T.pack err
                 ]
-            return Nothing
+            note = Note
+                { noteId        = Nothing
+                , noteAttrib    = luAuthor
+                , noteAudience  = Audience
+                    { audienceTo      = map encodeRecipRoute recips
+                    , audienceBto     = []
+                    , audienceCc      = []
+                    , audienceBcc     = []
+                    , audienceGeneral = []
+                    }
+                , noteReplyTo   = Just $ fromMaybe uTicket muParent
+                , noteContext   = Just uTicket
+                , notePublished = Just now
+                , noteContent   = msg
+                }
+        ExceptT $ handleOutboxNote hLocal note
+    case elmid of
+        Left err -> setMessage $ toHtml err
+        Right lmid -> do
+            lmkhid <- encodeKeyHashid lmid
+            renderUrl <- getUrlRender
+            let u = renderUrl $ MessageR shrAuthor lmkhid
+            setMessage $ toHtml $ "Message created! ID: " <> u
+    defaultLayout $ activityWidget shrAuthor widget enctype
 
 getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
 getActorKey choose route = selectRep $ provideAP $ do