C2S: Implement real C2S access via outbox POSTing and OAuth2

src/Vervis/API.hs

@@ -155,7 +155,7 @@ noteC
     :: Entity Person
     -> Sharer
     -> Note URIMode
-    -> Handler (Either Text LocalMessageId)
+    -> ExceptT Text Handler OutboxItemId
 noteC person sharer note = do
     let shrUser = sharerIdent sharer
     summary <-
@@ -170,7 +170,7 @@ noteC person sharer note = do
                       $nothing
                         \ commented.
                 |]
-    createNoteC person sharer summary (noteAudience note) note
+    createNoteC person sharer (Just summary) (noteAudience note) note Nothing
 
 -- | Handle a Note submitted by a local user to their outbox. It can be either
 -- a comment on a local ticket, or a comment on some remote context. Return an
@@ -178,20 +178,22 @@ noteC person sharer note = do
 createNoteC
     :: Entity Person
     -> Sharer
-    -> TextHtml
+    -> Maybe TextHtml
     -> Audience URIMode
     -> Note URIMode
-    -> Handler (Either Text LocalMessageId)
+    -> Maybe FedURI
-createNoteC (Entity pidUser personUser) sharerUser summary audience note = runExceptT $ do
+    -> ExceptT Text Handler OutboxItemId
+createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarget = do
     let shrUser = sharerIdent sharerUser
     noteData@(muParent, mparent, uContext, context, source, content) <- checkNote shrUser note
+    verifyNothingE muTarget "Create Note has 'target'"
     (localRecips, remoteRecips) <- do
         mrecips <- parseAudience audience
         fromMaybeE mrecips "Create Note with no recipients"
     checkFederation remoteRecips
     verifyContextRecip context localRecips remoteRecips
     now <- liftIO getCurrentTime
-    (lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
+    (_lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
         obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
         (mproject, did, meparent) <- getTopicAndParent context mparent
         lmid <- lift $ insertMessage now content source obiidCreate did meparent
@@ -252,7 +254,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
             lift $ deliverRemoteDB' (objUriAuthority uContext) obiidCreate remoteRecips moreRemoteRecips
         return (lmid, obiidCreate, docCreate, remoteRecipsHttpCreate)
     lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
-    return lmid
+    return obiid
     where
     checkNote shrUser (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do
         verifyNothingE mluNote "Note specifies an id"
@@ -487,7 +489,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
             create = Doc hLocal Activity
                 { activityId       = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
                 , activityActor    = luAttrib
-                , activitySummary  = Just summary
+                , activitySummary  = summary
                 , activityAudience = audience
                 , activitySpecific = CreateActivity Create
                     { createObject = CreateNote Note
@@ -512,12 +514,12 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note = runEx
 createTicketC
     :: Entity Person
     -> Sharer
-    -> TextHtml
+    -> Maybe TextHtml
     -> Audience URIMode
     -> AP.Ticket URIMode
     -> Maybe FedURI
-    -> Handler (Either Text TicketAuthorLocalId)
+    -> ExceptT Text Handler OutboxItemId
-createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = runExceptT $ do
+createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = do
     let shrUser = sharerIdent sharerUser
     ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget
     context <- parseTicketContext uContext
@@ -528,7 +530,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
     verifyProjectRecip context localRecips
     tracker <- fetchTracker context uTarget
     now <- liftIO getCurrentTime
-    (talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
+    (_talid, obiidCreate, docCreate, remotesHttpCreate, maybeAccept) <- runDBExcept $ do
         obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
         project <- prepareProject now tracker
         talid <- lift $ insertTicket now pidUser title desc source obiidCreate project
@@ -573,7 +575,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
         forkWorker "createTicketC: async HTTP Create delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidCreate docCreate remotesHttpCreate
         for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
             forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept
-    return talid
+    return obiidCreate
     where
     checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved mmr) mtarget = do
         verifyNothingE mlocal "Ticket with 'id'"
@@ -716,7 +718,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
             create = Doc hLocal Activity
                 { activityId       = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
                 , activityActor    = luAttrib
-                , activitySummary  = Just summary
+                , activitySummary  = summary
                 , activityAudience = audience
                 , activitySpecific = CreateActivity Create
                     { createObject = CreateTicket AP.Ticket
@@ -788,11 +790,11 @@ data Followee
 
 followC
     :: ShrIdent
-    -> TextHtml
+    -> Maybe TextHtml
     -> Audience URIMode
     -> AP.Follow URIMode
-    -> Handler (Either Text OutboxItemId)
+    -> ExceptT Text Handler OutboxItemId
-followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = runExceptT $ do
+followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
     (localRecips, remoteRecips) <- do
         mrecips <- parseAudience audience
         fromMaybeE mrecips "Follow with no recipients"
@@ -924,7 +926,7 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = run
         let activity mluAct = Doc hLocal Activity
                 { activityId       = mluAct
                 , activityActor    = encodeRouteLocal $ SharerR shrUser
-                , activitySummary  = Just summary
+                , activitySummary  = summary
                 , activityAudience = audience
                 , activitySpecific = FollowActivity follow
                 }
@@ -996,12 +998,12 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = run
 
 offerTicketC
     :: ShrIdent
-    -> TextHtml
+    -> Maybe TextHtml
     -> Audience URIMode
     -> AP.Ticket URIMode
     -> FedURI
-    -> Handler (Either Text OutboxItemId)
+    -> ExceptT Text Handler OutboxItemId
-offerTicketC shrUser summary audience ticket uTarget = runExceptT $ do
+offerTicketC shrUser summary audience ticket uTarget = do
     (hProject, shrProject, prjProject) <- parseTarget uTarget
     {-deps <- -}
     checkOffer hProject shrProject prjProject
@@ -1271,11 +1273,11 @@ offerTicketC shrUser summary audience ticket uTarget = runExceptT $ do
 
 undoC
     :: ShrIdent
-    -> TextHtml
+    -> Maybe TextHtml
     -> Audience URIMode
     -> Undo URIMode
-    -> Handler (Either Text OutboxItemId)
+    -> ExceptT Text Handler OutboxItemId
-undoC shrUser summary audience undo@(Undo luObject) = runExceptT $ do
+undoC shrUser summary audience undo@(Undo luObject) = do
     (localRecips, remoteRecips) <- do
         mrecips <- parseAudience audience
         fromMaybeE mrecips "Follow with no recipients"
@@ -1331,7 +1333,7 @@ undoC shrUser summary audience undo@(Undo luObject) = runExceptT $ do
         let activity mluAct = Doc hLocal Activity
                 { activityId       = mluAct
                 , activityActor    = encodeRouteLocal $ SharerR shrUser
-                , activitySummary  = Just summary
+                , activitySummary  = summary
                 , activityAudience = audience
                 , activitySpecific = UndoActivity undo
                 }
@@ -1354,8 +1356,8 @@ pushCommitsC
     -> Push URIMode
     -> ShrIdent
     -> RpIdent
-    -> Handler (Either Text OutboxItemId)
+    -> ExceptT Text Handler OutboxItemId
-pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do
+pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = do
     let dont = Authority "dont-do.any-forwarding" Nothing
     (obiid, doc, remotesHttp) <- runDBExcept $ do
         (obiid, doc) <- lift $ insertToOutbox

src/Vervis/ActivityPub.hs

@@ -50,6 +50,8 @@ module Vervis.ActivityPub
     , insertRemoteActivityToLocalInboxes
     , provideEmptyCollection
     , insertEmptyOutboxItem
+    , verifyContentTypeAP
+    , verifyContentTypeAP_E
     )
 where
 
@@ -1180,3 +1182,29 @@ insertEmptyOutboxItem obid now = do
         , outboxItemActivity  = persistJSONObjectFromDoc $ Doc h emptyActivity
         , outboxItemPublished = now
         }
+
+verifyContentTypeAP :: MonadHandler m => m ()
+verifyContentTypeAP = do
+    result <- runExceptT verifyContentTypeAP_E
+    case result of
+        Left e -> invalidArgs ["Content type error: " <> e]
+        Right () -> return ()
+
+verifyContentTypeAP_E :: MonadHandler m => ExceptT Text m ()
+verifyContentTypeAP_E = do
+    ctypes <- lookupHeaders "Content-Type"
+    case ctypes of
+        [] -> throwE "Content-Type not specified"
+        [x] | x == typeAS -> return ()
+            | x == typeAS2 -> return ()
+            | otherwise ->
+                throwE $ "Not a recognized AP Content-Type: " <>
+                    case decodeUtf8' x of
+                        Left _ -> T.pack (show x)
+                        Right t -> t
+        _ -> throwE "More than one Content-Type specified"
+    where
+    typeAS = "application/activity+json"
+    typeAS2 =
+        "application/ld+json; \
+        \profile=\"https://www.w3.org/ns/activitystreams\""

src/Vervis/Federation/Auth.hs

@@ -330,32 +330,6 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) =
         then ActivityAuthLocal <$> verifySelfSig luAuthor luKey input signature
         else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
 
-verifyContentTypeAP :: MonadHandler m => m ()
-verifyContentTypeAP = do
-    result <- runExceptT verifyContentTypeAP_E
-    case result of
-        Left e -> invalidArgs ["Content type error: " <> e]
-        Right () -> return ()
-
-verifyContentTypeAP_E :: MonadHandler m => ExceptT Text m ()
-verifyContentTypeAP_E = do
-    ctypes <- lookupHeaders "Content-Type"
-    case ctypes of
-        [] -> throwE "Content-Type not specified"
-        [x] | x == typeAS -> return ()
-            | x == typeAS2 -> return ()
-            | otherwise ->
-                throwE $ "Not a recognized AP Content-Type: " <>
-                    case decodeUtf8' x of
-                        Left _ -> T.pack (show x)
-                        Right t -> t
-        _ -> throwE "More than one Content-Type specified"
-    where
-    typeAS = "application/activity+json"
-    typeAS2 =
-        "application/ld+json; \
-        \profile=\"https://www.w3.org/ns/activitystreams\""
-
 authenticateActivity
     :: UTCTime
     -- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)

src/Vervis/Handler/Client.hs

@@ -60,6 +60,8 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Database.Esqueleto as E
 
+import Dvara
+
 import Database.Persist.JSON
 import Network.FedURI
 import Web.ActivityPub hiding (Ticket)
@@ -259,14 +261,51 @@ getPublishR = do
         activityWidget
             widget1 enctype1 widget2 enctype2 widget3 enctype3 widget4 enctype4
 
-postSharerOutboxR :: ShrIdent -> Handler Html
+postSharerOutboxR :: ShrIdent -> Handler Text
-postSharerOutboxR _shrAuthor = do
+postSharerOutboxR shr = do
     federation <- getsYesod $ appFederation . appSettings
     unless federation badMethod
-
+    (ep@(Entity pid person), sharer) <- runDB $ do
-    error
+        Entity sid s <- getBy404 $ UniqueSharer shr
-        "ActivityPub C2S outbox POST not implemented yet, but you can post \
+        (,s) <$> getBy404 (UniquePersonIdent sid)
-        \public activities via the /publish page"
+    (_app, mpid, _scopes) <- maybe notAuthenticated return =<< getDvaraAuth
+    pid' <-
+        maybe (permissionDenied "Not authorized to post as a user") return mpid
+    unless (pid == pid') $
+        permissionDenied "Can't post as other users"
+    verifyContentTypeAP
+    Doc h activity <- requireInsecureJsonBody
+    hl <- hostIsLocal h
+    unless hl $ invalidArgs ["Activity host isn't the instance host"]
+    result <- runExceptT $ handle ep sharer activity
+    case result of
+        Left err -> invalidArgs [err]
+        Right obiid -> do
+            obikhid <- encodeKeyHashid obiid
+            sendResponseCreated $ SharerOutboxItemR shr obikhid
+    where
+    handle eperson sharer (Activity _mid actor summary audience specific) = do
+        case decodeRouteLocal actor of
+            Just (SharerR shr') | shr' == shr -> return ()
+            _ -> throwE "Can't post activity sttributed to someone else"
+        case specific of
+            CreateActivity (Create obj mtarget) ->
+                case obj of
+                    CreateNote note ->
+                        createNoteC eperson sharer summary audience note mtarget
+                    CreateTicket ticket ->
+                        createTicketC eperson sharer summary audience ticket mtarget
+                    _ -> throwE "Unsupported Create 'object' type"
+            FollowActivity follow ->
+                followC shr summary audience follow
+            OfferActivity (Offer obj target) ->
+                case obj of
+                    OfferTicket ticket ->
+                        offerTicketC shr summary audience ticket target
+                    _ -> throwE "Unsupported Offer 'object' type"
+            UndoActivity undo ->
+                undoC shr summary audience undo
+            _ -> throwE "Unsupported activity type"
 
 postPublishR :: Handler Html
 postPublishR = do
@@ -302,12 +341,20 @@ postPublishR = do
         Left err -> setMessage $ toHtml err
         Right id_ ->
             case id_ of
-                Left (Left lmid) -> do
+                Left (Left obiid) -> do
+                    mlmid <- runDB $ getKeyBy $ UniqueLocalMessageCreate obiid
+                    case mlmid of
+                        Nothing -> error "noteC succeeded but no lmid found for obiid"
+                        Just lmid -> do
                             lmkhid <- encodeKeyHashid lmid
                             renderUrl <- getUrlRender
                             let u = renderUrl $ MessageR shrAuthor lmkhid
                             setMessage $ toHtml $ "Message created! ID: " <> u
-                Left (Right talid) -> do
+                Left (Right obiid) -> do
+                    mtalid <- runDB $ getKeyBy $ UniqueTicketAuthorLocalOpen obiid
+                    case mtalid of
+                        Nothing -> error "createTicketC succeeded but no talid found for obiid"
+                        Just talid -> do
                             talkhid <- encodeKeyHashid talid
                             renderUrl <- getUrlRender
                             let u = renderUrl $ SharerTicketR shrAuthor talkhid
@@ -355,7 +402,7 @@ postPublishR = do
                 , noteSource    = msg'
                 , noteContent   = contentHtml
                 }
-        ExceptT $ noteC eperson sharer note
+        noteC eperson sharer note
     publishTicket eperson sharer (target, context, title, desc) = do
         (summary, audience, create) <-
             ExceptT $ C.createTicket (sharerIdent sharer) title desc target context
@@ -364,7 +411,7 @@ postPublishR = do
                     CreateTicket t -> t
                     _ -> error "Create object isn't a ticket"
             target = createTarget create
-        ExceptT $ createTicketC eperson sharer summary audience ticket target
+        createTicketC eperson sharer (Just summary) audience ticket target
     openTicket shrAuthor ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteFed <- getEncodeRouteFed
@@ -412,11 +459,11 @@ postPublishR = do
                 , audienceGeneral   = []
                 , audienceNonActors = map (encodeRouteFed h) recipsC
                 }
-        ExceptT $ offerTicketC shrAuthor summary audience ticketAP target
+        offerTicketC shrAuthor (Just summary) audience ticketAP target
     follow shrAuthor (uObject@(ObjURI hObject luObject), uRecip) = do
         (summary, audience, followAP) <-
             C.follow shrAuthor uObject uRecip False
-        ExceptT $ followC shrAuthor summary audience followAP
+        followC shrAuthor (Just summary) audience followAP
 
 getBrowseR :: Handler Html
 getBrowseR = do
@@ -481,7 +528,7 @@ postSharerFollowR :: ShrIdent -> Handler ()
 postSharerFollowR shrObject = do
     shrAuthor <- getUserShrIdent
     (summary, audience, follow) <- followSharer shrAuthor shrObject False
-    eid <- followC shrAuthor summary audience follow
+    eid <- runExceptT $ followC shrAuthor (Just summary) audience follow
     setFollowMessage shrAuthor eid
     redirect $ SharerR shrObject
 
@@ -489,7 +536,7 @@ postProjectFollowR :: ShrIdent -> PrjIdent -> Handler ()
 postProjectFollowR shrObject prjObject = do
     shrAuthor <- getUserShrIdent
     (summary, audience, follow) <- followProject shrAuthor shrObject prjObject False
-    eid <- followC shrAuthor summary audience follow
+    eid <- runExceptT $ followC shrAuthor (Just summary) audience follow
     setFollowMessage shrAuthor eid
     redirect $ ProjectR shrObject prjObject
 
@@ -497,7 +544,7 @@ postProjectTicketFollowR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Han
 postProjectTicketFollowR shrObject prjObject tkhidObject = do
     shrAuthor <- getUserShrIdent
     (summary, audience, follow) <- followTicket shrAuthor shrObject prjObject tkhidObject False
-    eid <- followC shrAuthor summary audience follow
+    eid <- runExceptT $ followC shrAuthor (Just summary) audience follow
     setFollowMessage shrAuthor eid
     redirect $ ProjectTicketR shrObject prjObject tkhidObject
 
@@ -505,7 +552,7 @@ postRepoFollowR :: ShrIdent -> RpIdent -> Handler ()
 postRepoFollowR shrObject rpObject = do
     shrAuthor <- getUserShrIdent
     (summary, audience, follow) <- followRepo shrAuthor shrObject rpObject False
-    eid <- followC shrAuthor summary audience follow
+    eid <- runExceptT $ followC shrAuthor (Just summary) audience follow
     setFollowMessage shrAuthor eid
     redirect $ RepoR shrObject rpObject
 
@@ -526,7 +573,7 @@ postSharerUnfollowR shrFollowee = do
     eid <- runExceptT $ do
         (summary, audience, undo) <-
             ExceptT $ undoFollowSharer shrAuthor pidAuthor shrFollowee
-        ExceptT $ undoC shrAuthor summary audience undo
+        undoC shrAuthor (Just summary) audience undo
     setUnfollowMessage shrAuthor eid
     redirect $ SharerR shrFollowee
 
@@ -536,7 +583,7 @@ postProjectUnfollowR shrFollowee prjFollowee = do
     eid <- runExceptT $ do
         (summary, audience, undo) <-
             ExceptT $ undoFollowProject shrAuthor pidAuthor shrFollowee prjFollowee
-        ExceptT $ undoC shrAuthor summary audience undo
+        undoC shrAuthor (Just summary) audience undo
     setUnfollowMessage shrAuthor eid
     redirect $ ProjectR shrFollowee prjFollowee
 
@@ -546,7 +593,7 @@ postProjectTicketUnfollowR shrFollowee prjFollowee tkhidFollowee = do
     eid <- runExceptT $ do
         (summary, audience, undo) <-
             ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee tkhidFollowee
-        ExceptT $ undoC shrAuthor summary audience undo
+        undoC shrAuthor (Just summary) audience undo
     setUnfollowMessage shrAuthor eid
     redirect $ ProjectTicketR shrFollowee prjFollowee tkhidFollowee
 
@@ -556,7 +603,7 @@ postRepoUnfollowR shrFollowee rpFollowee = do
     eid <- runExceptT $ do
         (summary, audience, undo) <-
             ExceptT $ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee
-        ExceptT $ undoC shrAuthor summary audience undo
+        undoC shrAuthor (Just summary) audience undo
     setUnfollowMessage shrAuthor eid
     redirect $ RepoR shrFollowee rpFollowee
 
@@ -741,7 +788,7 @@ postProjectTicketsR shr prj = do
             then Right <$> do
                 (summary, audience, ticket, target) <-
                     ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
-                obiid <- ExceptT $ offerTicketC shrAuthor summary audience ticket target
+                obiid <- offerTicketC shrAuthor (Just summary) audience ticket target
                 ExceptT $ runDB $ do
                     mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
                     return $
@@ -760,7 +807,16 @@ postProjectTicketsR shr prj = do
                         case obj of
                             CreateTicket t -> t
                             _ -> error "Create object isn't a ticket"
-                ExceptT $ createTicketC eperson sharer summary audience ticket mtarget
+                obiid <- createTicketC eperson sharer (Just summary) audience ticket mtarget
+                ExceptT $ runDB $ do
+                    mtalid <- getKeyBy $ UniqueTicketAuthorLocalOpen obiid
+                    return $
+                        case mtalid of
+                            Nothing ->
+                                Left
+                                    "Create processed successfully but no ticket \
+                                    \created"
+                            Just v -> Right v
     case eid of
         Left e -> do
             setMessage $ toHtml e
@@ -772,7 +828,7 @@ postProjectTicketsR shr prj = do
             ltkhid <- encodeKeyHashid ltid
             eobiidFollow <- runExceptT $ do
                 (summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False
-                ExceptT $ followC shrAuthor summary audience follow
+                followC shrAuthor (Just summary) audience follow
             case eobiidFollow of
                 Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e
                 Right _ -> setMessage "Ticket created."

src/Vervis/Handler/Discussion.hs

@@ -217,30 +217,33 @@ postTopReply hDest recipsA recipsC context recipF replyP after = do
         s <- runDB $ get404 (personIdent p)
         return (ep, s)
     let shrAuthor = sharerIdent sharer
-    elmid <- runExceptT $ do
+    eobiid <- runExceptT $ do
         msg <- case result of
             FormMissing -> throwE "Field(s) missing."
             FormFailure _l -> throwE "Message submission failed, see errors below."
             FormSuccess nm ->
                 return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
         note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context
-        ExceptT $ noteC eperson sharer note
+        noteC eperson sharer note
-    case elmid of
+    case eobiid of
         Left e -> do
             setMessage $ toHtml e
             defaultLayout $(widgetFile "discussion/top-reply")
-        Right lmid -> do
+        Right obiid -> do
             setMessage "Message submitted."
 
             encodeRouteFed <- getEncodeRouteFed
             let encodeRecipRoute = encodeRouteFed hDest
             (summary, audience, follow) <- C.follow shrAuthor (encodeRecipRoute context) (encodeRecipRoute recipF) False
-            eobiidFollow <- followC shrAuthor summary audience follow
+            eobiidFollow <- runExceptT $ followC shrAuthor (Just summary) audience follow
             case eobiidFollow of
                 Left e -> setMessage $ toHtml $ "Following failed: " <> e
                 Right _ -> return ()
 
-            redirect $ after lmid
+            mlmid <- runDB $ getKeyBy $ UniqueLocalMessageCreate obiid
+            case mlmid of
+                Nothing -> error "noteC succeeded but no lmid found for obiid"
+                Just lmid -> redirect $ after lmid
 
 getReply
     :: (MessageId -> Route App)
@@ -273,29 +276,32 @@ postReply hDest recipsA recipsC context recipF replyG replyP after getdid midPar
         s <- runDB $ get404 (personIdent p)
         return (ep, s)
     let shrAuthor = sharerIdent sharer
-    elmid <- runExceptT $ do
+    eobiid <- runExceptT $ do
         msg <- case result of
             FormMissing -> throwE "Field(s) missing."
             FormFailure _l -> throwE "Message submission failed, see errors below."
             FormSuccess nm ->
                 return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
         note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent
-        ExceptT $ noteC eperson sharer note
+        noteC eperson sharer note
-    case elmid of
+    case eobiid of
         Left e -> do
             setMessage $ toHtml e
             mtn <- runDB $ getNode getdid midParent
             now <- liftIO getCurrentTime
             defaultLayout $(widgetFile "discussion/reply")
-        Right lmid -> do
+        Right obiid -> do
             setMessage "Message submitted."
 
             encodeRouteFed <- getEncodeRouteFed
             let encodeRecipRoute = encodeRouteFed hDest
             (summary, audience, follow) <- C.follow shrAuthor (encodeRecipRoute context) (encodeRecipRoute recipF) False
-            eobiidFollow <- followC shrAuthor summary audience follow
+            eobiidFollow <- runExceptT $ followC shrAuthor (Just summary) audience follow
             case eobiidFollow of
                 Left e -> setMessage $ toHtml $ "Following failed: " <> e
                 Right _ -> return ()
 
-            redirect $ after lmid
+            mlmid <- runDB $ getKeyBy $ UniqueLocalMessageCreate obiid
+            case mlmid of
+                Nothing -> error "noteC succeeded but no lmid found for obiid"
+                Just lmid -> redirect $ after lmid

src/Vervis/Handler/Repo.hs

@@ -45,6 +45,7 @@ where
 import Control.Exception hiding (Handler)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Logger (logWarn)
+import Control.Monad.Trans.Except
 import Data.Bifunctor
 import Data.Git.Graph
 import Data.Git.Harder
@@ -533,7 +534,7 @@ postPostReceiveR = do
                   $forall c <- lasts
                     <li>^{commitW c}
             |]
-    eid <- pushCommitsC user summary pushAP shr rp
+    eid <- runExceptT $ pushCommitsC user summary pushAP shr rp
     case eid of
         Left e -> liftIO $ throwIO $ userError $ T.unpack e
         Right obiid -> do