diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index aeeef49..0d862d1 100644 --- a/src/Vervis/API.hs +++ b/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) -createNoteC (Entity pidUser personUser) sharerUser summary audience note = runExceptT $ do + -> Maybe FedURI + -> 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) -createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muTarget = runExceptT $ do + -> ExceptT Text Handler OutboxItemId +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) -followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = runExceptT $ do + -> ExceptT Text Handler OutboxItemId +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) -offerTicketC shrUser summary audience ticket uTarget = runExceptT $ do + -> ExceptT Text Handler OutboxItemId +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) -undoC shrUser summary audience undo@(Undo luObject) = runExceptT $ do + -> ExceptT Text Handler OutboxItemId +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) -pushCommitsC (eperson, sharer) summary push shrRepo rpRepo = runExceptT $ do + -> ExceptT Text Handler OutboxItemId +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 diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index f5fcece..4ec400a 100644 --- a/src/Vervis/ActivityPub.hs +++ b/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\"" diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index bf18812..68b0d98 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/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) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 776028b..7d5963c 100644 --- a/src/Vervis/Handler/Client.hs +++ b/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 _shrAuthor = do +postSharerOutboxR :: ShrIdent -> Handler Text +postSharerOutboxR shr = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod - - error - "ActivityPub C2S outbox POST not implemented yet, but you can post \ - \public activities via the /publish page" + (ep@(Entity pid person), sharer) <- runDB $ do + Entity sid s <- getBy404 $ UniqueSharer shr + (,s) <$> getBy404 (UniquePersonIdent sid) + (_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,16 +341,24 @@ postPublishR = do Left err -> setMessage $ toHtml err Right id_ -> case id_ of - Left (Left lmid) -> do - lmkhid <- encodeKeyHashid lmid - renderUrl <- getUrlRender - let u = renderUrl $ MessageR shrAuthor lmkhid - setMessage $ toHtml $ "Message created! ID: " <> u - Left (Right talid) -> do - talkhid <- encodeKeyHashid talid - renderUrl <- getUrlRender - let u = renderUrl $ SharerTicketR shrAuthor talkhid - setMessage $ toHtml $ "Ticket created! ID: " <> u + 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 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 + setMessage $ toHtml $ "Ticket created! ID: " <> u Right (Left _obiid) -> setMessage "Ticket offer published!" Right (Right _obiid) -> @@ -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." diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 9b1ad41..179521e 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/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 - case elmid of + noteC eperson sharer note + 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 - case elmid of + noteC eperson sharer note + 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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index a822557..9cdcde5 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/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
  • ^{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