C2S: Implement real C2S access via outbox POSTing and OAuth2
This commit is contained in:
fr33domlover
parent
a0325da028
commit
5d25aba239
6 changed files with 164 additions and 97 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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\""
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue