mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-03-20 04:46:22 +09:00
781 lines
32 KiB
Haskell
781 lines
32 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Vervis.Handler.Inbox
|
|
( getInboxR
|
|
, getSharerInboxR
|
|
, getProjectInboxR
|
|
, postSharerInboxR
|
|
, postProjectInboxR
|
|
, getPublishR
|
|
, getSharerOutboxR
|
|
, getSharerOutboxItemR
|
|
, postSharerOutboxR
|
|
, getProjectOutboxR
|
|
, getProjectOutboxItemR
|
|
, getActorKey1R
|
|
, getActorKey2R
|
|
, getNotificationsR
|
|
, postNotificationsR
|
|
)
|
|
where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
|
|
import Control.Exception hiding (Handler)
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.Logger.CallStack
|
|
import Control.Monad.STM (atomically)
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Maybe
|
|
import Crypto.Error (CryptoFailable (..))
|
|
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
|
|
import Data.Aeson
|
|
import Data.Aeson.Encode.Pretty
|
|
import Data.Bifunctor
|
|
import Data.Bitraversable
|
|
import Data.Foldable (for_)
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.List
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import Data.Maybe
|
|
import Data.PEM (PEM (..))
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8')
|
|
import Data.Text.Lazy.Encoding (decodeUtf8)
|
|
import Data.Time.Clock
|
|
import Data.Time.Interval (TimeInterval, toTimeUnit)
|
|
import Data.Time.Units (Second)
|
|
import Data.Traversable
|
|
import Database.Persist
|
|
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
|
|
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
|
|
import Network.HTTP.Types.Header (hDate, hHost)
|
|
import Network.HTTP.Types.Status
|
|
import Text.Blaze.Html (Html, preEscapedToHtml)
|
|
import Text.Blaze.Html.Renderer.Text
|
|
import Text.HTML.SanitizeXSS
|
|
import Text.Shakespeare.I18N (RenderMessage)
|
|
import UnliftIO.Exception (try)
|
|
import Yesod.Auth (requireAuth)
|
|
import Yesod.Core
|
|
import Yesod.Core.Json (requireJsonBody)
|
|
import Yesod.Core.Handler
|
|
import Yesod.Form.Fields
|
|
import Yesod.Form.Functions
|
|
import Yesod.Form.Types
|
|
import Yesod.Persist.Core
|
|
|
|
import qualified Data.ByteString.Char8 as BC (unpack)
|
|
import qualified Data.CaseInsensitive as CI (mk)
|
|
import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy as TL (toStrict)
|
|
import qualified Data.Text.Lazy.Builder as TLB
|
|
import qualified Data.Vector as V
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
|
|
|
|
import Network.HTTP.Signature hiding (Algorithm (..))
|
|
import Yesod.HttpSignature (verifyRequestSignature)
|
|
|
|
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
|
|
|
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.RenderSource
|
|
|
|
import qualified Data.Aeson.Encode.Pretty.ToEncoding as AEP
|
|
|
|
import Data.Aeson.Local
|
|
import Data.Either.Local
|
|
import Data.EventTime.Local
|
|
import Data.Paginate.Local
|
|
import Data.Time.Clock.Local
|
|
import Database.Persist.Local
|
|
import Yesod.Persist.Local
|
|
|
|
import Vervis.ActivityPub
|
|
import Vervis.ActorKey
|
|
import Vervis.API
|
|
import Vervis.Federation
|
|
import Vervis.Federation.Auth
|
|
import Vervis.Foundation
|
|
import Vervis.Model hiding (Ticket)
|
|
import Vervis.Model.Ident
|
|
import Vervis.Paginate
|
|
import Vervis.RemoteActorStore
|
|
import Yesod.RenderSource
|
|
import Vervis.Settings
|
|
|
|
getInboxR :: Handler Html
|
|
getInboxR = do
|
|
acts <-
|
|
liftIO . readTVarIO . snd =<< maybe notFound return =<< getsYesod appActivities
|
|
defaultLayout
|
|
[whamlet|
|
|
<p>
|
|
Welcome to the ActivityPub inbox test page! Activities received
|
|
by this Vervis instance are listed here for testing and
|
|
debugging. To test, go to another Vervis instance and publish
|
|
something that supports federation (currently, only ticket
|
|
comments), either through the regular UI or via the /publish
|
|
page, and then come back here to see the result. Activities that
|
|
aren't understood or their processing fails get listed here too,
|
|
with a report of what exactly happened.
|
|
<p>Last 10 activities posted:
|
|
<ul>
|
|
$forall ActivityReport time msg ctypes body <- acts
|
|
<li>
|
|
<div>#{show time}
|
|
<div>#{msg}
|
|
<div><code>#{intercalate " | " $ map BC.unpack ctypes}
|
|
<div><pre>#{decodeUtf8 body}
|
|
|]
|
|
|
|
getInbox :: Route App -> AppDB InboxId -> Handler TypedContent
|
|
getInbox here getInboxId = do
|
|
(total, pages, mpage) <- runDB $ do
|
|
ibid <- getInboxId
|
|
getPageAndNavCount
|
|
(countItems ibid)
|
|
(\ off lim -> map adaptItem <$> getItems ibid off lim)
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRoutePageLocal <- getEncodeRoutePageLocal
|
|
let pageUrl = encodeRoutePageLocal here
|
|
host <- getsYesod $ appInstanceHost . appSettings
|
|
selectRep $
|
|
case mpage of
|
|
Nothing -> do
|
|
provideAP $ pure $ Doc host $ Collection
|
|
{ collectionId = encodeRouteLocal here
|
|
, collectionType = CollectionTypeOrdered
|
|
, collectionTotalItems = Just total
|
|
, collectionCurrent = Nothing
|
|
, collectionFirst = Just $ pageUrl 1
|
|
, collectionLast = Just $ pageUrl pages
|
|
, collectionItems = [] :: [Text]
|
|
}
|
|
provideRep (redirectFirstPage here :: Handler Html)
|
|
Just (items, navModel) -> do
|
|
let current = nmCurrent navModel
|
|
provideAP $ pure $ Doc host $ CollectionPage
|
|
{ collectionPageId = pageUrl current
|
|
, collectionPageType = CollectionPageTypeOrdered
|
|
, collectionPageTotalItems = Nothing
|
|
, collectionPageCurrent = Just $ pageUrl current
|
|
, collectionPageFirst = Just $ pageUrl 1
|
|
, collectionPageLast = Just $ pageUrl pages
|
|
, collectionPagePartOf = encodeRouteLocal here
|
|
, collectionPagePrev =
|
|
if current > 1
|
|
then Just $ pageUrl $ current - 1
|
|
else Nothing
|
|
, collectionPageNext =
|
|
if current < pages
|
|
then Just $ pageUrl $ current + 1
|
|
else Nothing
|
|
, collectionPageStartIndex = Nothing
|
|
, collectionPageItems = map fromEither items
|
|
}
|
|
provideRep $
|
|
let pageNav = navWidget navModel
|
|
in defaultLayout $(widgetFile "person/inbox")
|
|
where
|
|
countItems ibid =
|
|
(+) <$> count [InboxItemLocalInbox ==. ibid]
|
|
<*> count [InboxItemRemoteInbox ==. ibid]
|
|
getItems ibid off lim =
|
|
E.select $ E.from $
|
|
\ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do
|
|
E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId
|
|
E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
|
|
E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId
|
|
E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
|
|
E.where_
|
|
$ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
|
|
ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
|
|
)
|
|
E.&&.
|
|
( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
|
|
ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
|
|
)
|
|
E.orderBy [E.desc $ ib E.^. InboxItemId]
|
|
E.offset $ fromIntegral off
|
|
E.limit $ fromIntegral lim
|
|
return
|
|
( ib E.^. InboxItemId
|
|
, ob E.?. OutboxItemActivity
|
|
, ract E.?. RemoteActivityContent
|
|
)
|
|
adaptItem (E.Value ibid, E.Value mact, E.Value mobj) =
|
|
case (mact, mobj) of
|
|
(Nothing, Nothing) ->
|
|
error $
|
|
"InboxItem #" ++ show ibid ++ " neither local nor remote"
|
|
(Just _, Just _) ->
|
|
error $ "InboxItem #" ++ show ibid ++ " both local and remote"
|
|
(Just act, Nothing) -> Left $ persistJSONValue act
|
|
(Nothing, Just obj) -> Right $ persistJSONValue obj
|
|
|
|
getSharerInboxR :: ShrIdent -> Handler TypedContent
|
|
getSharerInboxR shr = getInbox here getInboxId
|
|
where
|
|
here = SharerInboxR shr
|
|
getInboxId = do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
p <- getValBy404 $ UniquePersonIdent sid
|
|
return $ personInbox p
|
|
|
|
getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
|
|
getProjectInboxR shr prj = getInbox here getInboxId
|
|
where
|
|
here = ProjectInboxR shr prj
|
|
getInboxId = do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
j <- getValBy404 $ UniqueProject prj sid
|
|
return $ projectInbox j
|
|
|
|
postSharerInboxR :: ShrIdent -> Handler ()
|
|
postSharerInboxR shrRecip = do
|
|
federation <- getsYesod $ appFederation . appSettings
|
|
unless federation badMethod
|
|
contentTypes <- lookupHeaders "Content-Type"
|
|
now <- liftIO getCurrentTime
|
|
result <- runExceptT $ do
|
|
(auth, body) <- authenticateActivity now
|
|
(actbObject body,) <$> handleSharerInbox now shrRecip auth body
|
|
recordActivity now result contentTypes
|
|
case result of
|
|
Left _ -> sendResponseStatus badRequest400 ()
|
|
Right _ -> return ()
|
|
|
|
recordActivity now result contentTypes = do
|
|
macts <- getsYesod appActivities
|
|
for_ macts $ \ (size, acts) ->
|
|
liftIO $ atomically $ modifyTVar' acts $ \ vec ->
|
|
let (msg, body) =
|
|
case result of
|
|
Left t -> (t, "{?}")
|
|
Right (o, t) -> (t, encodePretty o)
|
|
item = ActivityReport now msg contentTypes body
|
|
vec' = item `V.cons` vec
|
|
in if V.length vec' > size
|
|
then V.init vec'
|
|
else vec'
|
|
|
|
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
|
|
postProjectInboxR shrRecip prjRecip = do
|
|
federation <- getsYesod $ appFederation . appSettings
|
|
unless federation badMethod
|
|
contentTypes <- lookupHeaders "Content-Type"
|
|
now <- liftIO getCurrentTime
|
|
result <- runExceptT $ do
|
|
(auth, body) <- authenticateActivity now
|
|
(actbObject body,) <$>
|
|
handleProjectInbox now shrRecip prjRecip auth body
|
|
recordActivity now result contentTypes
|
|
case result of
|
|
Left _ -> sendResponseStatus badRequest400 ()
|
|
Right _ -> return ()
|
|
|
|
{-
|
|
jsonField :: (FromJSON a, ToJSON a) => Field Handler a
|
|
jsonField = checkMMap fromTextarea toTextarea textareaField
|
|
where
|
|
toTextarea = Textarea . TL.toStrict . encodePrettyToLazyText
|
|
fromTextarea = return . first T.pack . eitherDecodeStrict' . encodeUtf8 . unTextarea
|
|
-}
|
|
|
|
fedUriField
|
|
:: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
|
|
fedUriField = Field
|
|
{ fieldParse = parseHelper $ \ t ->
|
|
case parseFedURI t of
|
|
Left e -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
|
|
Right u -> Right u
|
|
, fieldView = \theId name attrs val isReq ->
|
|
[whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderFedURI val}>|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
|
|
ticketField
|
|
:: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent, Int)
|
|
ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
|
|
where
|
|
toTicket uTicket = runExceptT $ do
|
|
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
|
|
|
|
projectField
|
|
:: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent)
|
|
projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
|
|
where
|
|
toProject u = runExceptT $ do
|
|
let (h, lu) = f2l u
|
|
route <-
|
|
case decodeRouteLocal lu of
|
|
Nothing -> throwE ("Not a valid route" :: Text)
|
|
Just r -> return r
|
|
case route of
|
|
ProjectR shr prj -> return (h, shr, prj)
|
|
_ -> throwE "Not a project route"
|
|
fromProject (h, shr, prj) = l2f h $ encodeRouteLocal $ ProjectR shr prj
|
|
|
|
publishCommentForm
|
|
:: Form ((Text, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
|
|
publishCommentForm 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? :)"
|
|
|
|
openTicketForm
|
|
:: Form ((Text, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
|
|
openTicketForm html = do
|
|
enc <- getEncodeRouteLocal
|
|
flip renderDivs html $ (,,)
|
|
<$> areq (projectField enc) "Project" (Just defj)
|
|
<*> ( TextHtml . sanitizeBalance <$>
|
|
areq textField "Title" (Just deft)
|
|
)
|
|
<*> ( TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
|
|
areq textareaField "Description" (Just defd)
|
|
)
|
|
where
|
|
defj = ("forge.angeley.es", text2shr "fr33", text2prj "sandbox")
|
|
deft = "Time slows down when tasting coconut ice-cream"
|
|
defd = "Is that slow-motion effect intentional? :)"
|
|
|
|
activityWidget :: ShrIdent -> Widget -> Enctype -> Widget -> Enctype -> Widget
|
|
activityWidget shr widget1 enctype1 widget2 enctype2 =
|
|
[whamlet|
|
|
<h1>Publish a ticket comment
|
|
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype1}>
|
|
^{widget1}
|
|
<input type=submit>
|
|
|
|
<h1>Open a new ticket
|
|
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype2}>
|
|
^{widget2}
|
|
<input type=submit>
|
|
|]
|
|
|
|
getUserShrIdent :: Handler ShrIdent
|
|
getUserShrIdent = do
|
|
Entity _ p <- requireVerifiedAuth
|
|
s <- runDB $ get404 $ personIdent p
|
|
return $ sharerIdent s
|
|
|
|
getPublishR :: Handler Html
|
|
getPublishR = do
|
|
shr <- getUserShrIdent
|
|
((_result1, widget1), enctype1) <-
|
|
runFormPost $ identifyForm "f1" publishCommentForm
|
|
((_result2, widget2), enctype2) <-
|
|
runFormPost $ identifyForm "f2" openTicketForm
|
|
defaultLayout $ activityWidget shr widget1 enctype1 widget2 enctype2
|
|
|
|
getOutbox :: Route App -> AppDB OutboxId -> Handler TypedContent
|
|
getOutbox here getObid = do
|
|
(total, pages, mpage) <- runDB $ do
|
|
obid <- getObid
|
|
let countAllItems = count [OutboxItemOutbox ==. obid]
|
|
selectItems off lim = selectList [OutboxItemOutbox ==. obid] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
|
|
getPageAndNavCount countAllItems selectItems
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRoutePageLocal <- getEncodeRoutePageLocal
|
|
let pageUrl = encodeRoutePageLocal here
|
|
host <- getsYesod $ appInstanceHost . appSettings
|
|
selectRep $
|
|
case mpage of
|
|
Nothing -> do
|
|
provideAP $ pure $ Doc host $ Collection
|
|
{ collectionId = encodeRouteLocal here
|
|
, collectionType = CollectionTypeOrdered
|
|
, collectionTotalItems = Just total
|
|
, collectionCurrent = Nothing
|
|
, collectionFirst = Just $ pageUrl 1
|
|
, collectionLast = Just $ pageUrl pages
|
|
, collectionItems = [] :: [Text]
|
|
}
|
|
provideRep (redirectFirstPage here :: Handler Html)
|
|
Just (items, navModel) -> do
|
|
let current = nmCurrent navModel
|
|
provideAP $ pure $ Doc host $ CollectionPage
|
|
{ collectionPageId = pageUrl current
|
|
, collectionPageType = CollectionPageTypeOrdered
|
|
, collectionPageTotalItems = Nothing
|
|
, collectionPageCurrent = Just $ pageUrl current
|
|
, collectionPageFirst = Just $ pageUrl 1
|
|
, collectionPageLast = Just $ pageUrl pages
|
|
, collectionPagePartOf = encodeRouteLocal here
|
|
, collectionPagePrev =
|
|
if current > 1
|
|
then Just $ pageUrl $ current - 1
|
|
else Nothing
|
|
, collectionPageNext =
|
|
if current < pages
|
|
then Just $ pageUrl $ current + 1
|
|
else Nothing
|
|
, collectionPageStartIndex = Nothing
|
|
, collectionPageItems = map (persistJSONValue . outboxItemActivity . entityVal) items
|
|
}
|
|
provideRep $ do
|
|
let pageNav = navWidget navModel
|
|
now <- liftIO getCurrentTime
|
|
let showTime =
|
|
showEventTime .
|
|
intervalToEventTime .
|
|
FriendlyConvert .
|
|
diffUTCTime now
|
|
defaultLayout $(widgetFile "person/outbox")
|
|
|
|
getOutboxItem
|
|
:: Route App
|
|
-> AppDB OutboxId
|
|
-> KeyHashid OutboxItem
|
|
-> Handler TypedContent
|
|
getOutboxItem here getObid obikhid = do
|
|
obiid <- decodeKeyHashid404 obikhid
|
|
Doc h act <- runDB $ do
|
|
obid <- getObid
|
|
obi <- get404 obiid
|
|
unless (outboxItemOutbox obi == obid) notFound
|
|
return $ persistJSONValue $ outboxItemActivity obi
|
|
provideHtmlAndAP' h act $ redirect (here, [("prettyjson", "true")])
|
|
|
|
getSharerOutboxR :: ShrIdent -> Handler TypedContent
|
|
getSharerOutboxR shr = getOutbox here getObid
|
|
where
|
|
here = SharerOutboxR shr
|
|
getObid = do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
p <- getValBy404 $ UniquePersonIdent sid
|
|
return $ personOutbox p
|
|
|
|
getSharerOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
|
|
getSharerOutboxItemR shr obikhid = getOutboxItem here getObid obikhid
|
|
where
|
|
here = SharerOutboxItemR shr obikhid
|
|
getObid = do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
p <- getValBy404 $ UniquePersonIdent sid
|
|
return $ personOutbox p
|
|
|
|
postSharerOutboxR :: ShrIdent -> Handler Html
|
|
postSharerOutboxR shrAuthor = do
|
|
federation <- getsYesod $ appFederation . appSettings
|
|
unless federation badMethod
|
|
|
|
((result1, widget1), enctype1) <-
|
|
runFormPost $ identifyForm "f1" publishCommentForm
|
|
((result2, widget2), enctype2) <-
|
|
runFormPost $ identifyForm "f2" openTicketForm
|
|
let result = Left <$> result1 <|> Right <$> result2
|
|
|
|
eid <- runExceptT $ do
|
|
input <-
|
|
case result of
|
|
FormMissing -> throwE "Field(s) missing"
|
|
FormFailure _l -> throwE "Invalid input, see below"
|
|
FormSuccess r -> return r
|
|
bitraverse publishComment openTicket input
|
|
case eid of
|
|
Left err -> setMessage $ toHtml err
|
|
Right id_ ->
|
|
case id_ of
|
|
Left lmid -> do
|
|
lmkhid <- encodeKeyHashid lmid
|
|
renderUrl <- getUrlRender
|
|
let u = renderUrl $ MessageR shrAuthor lmkhid
|
|
setMessage $ toHtml $ "Message created! ID: " <> u
|
|
Right _obiid ->
|
|
setMessage "Ticket offer published!"
|
|
defaultLayout $ activityWidget shrAuthor widget1 enctype1 widget2 enctype2
|
|
where
|
|
publishComment ((hTicket, shrTicket, prj, num), muParent, msg) = do
|
|
encodeRouteFed <- getEncodeRouteHome
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
let msg' = T.filter (/= '\r') msg
|
|
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
|
|
let encodeRecipRoute = l2f hTicket . encodeRouteLocal
|
|
uTicket = encodeRecipRoute $ TicketR shrTicket prj num
|
|
(hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
|
|
collections =
|
|
[ ProjectFollowersR shrTicket prj
|
|
, TicketParticipantsR shrTicket prj num
|
|
, TicketTeamR shrTicket prj num
|
|
]
|
|
recips = ProjectR shrTicket prj : collections
|
|
note = Note
|
|
{ noteId = Nothing
|
|
, noteAttrib = luAuthor
|
|
, noteAudience = Audience
|
|
{ audienceTo = map encodeRecipRoute recips
|
|
, audienceBto = []
|
|
, audienceCc = []
|
|
, audienceBcc = []
|
|
, audienceGeneral = []
|
|
, audienceNonActors = map encodeRecipRoute collections
|
|
}
|
|
, noteReplyTo = Just $ fromMaybe uTicket muParent
|
|
, noteContext = Just uTicket
|
|
, notePublished = Nothing
|
|
, noteSource = msg'
|
|
, noteContent = contentHtml
|
|
}
|
|
ExceptT $ createNoteC hLocal note
|
|
openTicket ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteFed <- getEncodeRouteFed
|
|
local <- hostIsLocal h
|
|
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
|
summary <-
|
|
TextHtml . TL.toStrict . renderHtml <$>
|
|
withUrlRenderer
|
|
[hamlet|
|
|
<p>
|
|
<a href=@{SharerR shrAuthor}>
|
|
#{shr2text shrAuthor}
|
|
\ offered a ticket to project #
|
|
$if local
|
|
<a href=@{ProjectR shr prj}>
|
|
./s/#{shr2text shr}/p/#{prj2text prj}
|
|
$else
|
|
<a href=#{renderFedURI $ encodeRouteFed h $ ProjectR shr prj}>
|
|
#{h}/s/#{shr2text shr}/p/#{prj2text prj}
|
|
: #{preEscapedToHtml title}.
|
|
|]
|
|
let recipsA = [ProjectR shr prj]
|
|
recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
|
|
ticket = Ticket
|
|
{ ticketLocal = Nothing
|
|
, ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
|
|
, ticketPublished = Nothing
|
|
, ticketUpdated = Nothing
|
|
, ticketName = Nothing
|
|
, ticketSummary = TextHtml title
|
|
, ticketContent = TextHtml descHtml
|
|
, ticketSource = TextPandocMarkdown desc
|
|
, ticketAssignedTo = Nothing
|
|
, ticketIsResolved = False
|
|
, ticketDependsOn = []
|
|
, ticketDependedBy = []
|
|
}
|
|
offer = Offer
|
|
{ offerObject = ticket
|
|
, offerTarget = encodeRouteFed h $ ProjectR shr prj
|
|
}
|
|
audience = Audience
|
|
{ audienceTo =
|
|
map (encodeRouteFed h) $ recipsA ++ recipsC
|
|
, audienceBto = []
|
|
, audienceCc = []
|
|
, audienceBcc = []
|
|
, audienceGeneral = []
|
|
, audienceNonActors = map (encodeRouteFed h) recipsC
|
|
}
|
|
ExceptT $ offerTicketC shrAuthor summary audience offer
|
|
|
|
getProjectOutboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
|
|
getProjectOutboxR shr prj = getOutbox here getObid
|
|
where
|
|
here = ProjectOutboxR shr prj
|
|
getObid = do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
j <- getValBy404 $ UniqueProject prj sid
|
|
return $ projectOutbox j
|
|
|
|
getProjectOutboxItemR
|
|
:: ShrIdent -> PrjIdent -> KeyHashid OutboxItem -> Handler TypedContent
|
|
getProjectOutboxItemR shr prj obikhid = getOutboxItem here getObid obikhid
|
|
where
|
|
here = ProjectOutboxItemR shr prj obikhid
|
|
getObid = do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
j <- getValBy404 $ UniqueProject prj sid
|
|
return $ projectOutbox j
|
|
|
|
getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
|
|
getActorKey choose route = do
|
|
actorKey <-
|
|
liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
|
|
getsYesod appActorKeys
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
let key = PublicKey
|
|
{ publicKeyId = encodeRouteLocal route
|
|
, publicKeyExpires = Nothing
|
|
, publicKeyOwner = OwnerInstance
|
|
, publicKeyMaterial = actorKey
|
|
}
|
|
provideHtmlAndAP key $ redirect (route, [("prettyjson", "true")])
|
|
|
|
getActorKey1R :: Handler TypedContent
|
|
getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R
|
|
|
|
getActorKey2R :: Handler TypedContent
|
|
getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R
|
|
|
|
notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool))
|
|
notificationForm defs = renderDivs $ mk
|
|
<$> aopt hiddenField (name "Inbox Item ID#") (fmap fst <$> defs)
|
|
<*> aopt hiddenField (name "New unread flag") (fmap snd <$> defs)
|
|
where
|
|
name t = FieldSettings "" Nothing Nothing (Just t) []
|
|
mk Nothing Nothing = Nothing
|
|
mk (Just ibid) (Just unread) = Just (ibid, unread)
|
|
mk _ _ = error "Missing hidden field?"
|
|
|
|
getNotificationsR :: ShrIdent -> Handler Html
|
|
getNotificationsR shr = do
|
|
items <- runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
p <- getValBy404 $ UniquePersonIdent sid
|
|
let ibid = personInbox p
|
|
map adaptItem <$> getItems ibid
|
|
notifications <- for items $ \ (ibid, activity) -> do
|
|
((_result, widget), enctype) <-
|
|
runFormPost $ notificationForm $ Just $ Just (ibid, False)
|
|
return (activity, widget, enctype)
|
|
((_result, widgetAll), enctypeAll) <-
|
|
runFormPost $ notificationForm $ Just Nothing
|
|
defaultLayout $(widgetFile "person/notifications")
|
|
where
|
|
getItems ibid =
|
|
E.select $ E.from $
|
|
\ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do
|
|
E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId
|
|
E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
|
|
E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId
|
|
E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
|
|
E.where_
|
|
$ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
|
|
ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
|
|
)
|
|
E.&&.
|
|
( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
|
|
ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
|
|
)
|
|
E.&&.
|
|
ib E.^. InboxItemUnread E.==. E.val True
|
|
E.orderBy [E.desc $ ib E.^. InboxItemId]
|
|
return
|
|
( ib E.^. InboxItemId
|
|
, ob E.?. OutboxItemActivity
|
|
, ract E.?. RemoteActivityContent
|
|
)
|
|
adaptItem (E.Value ibid, E.Value mact, E.Value mobj) =
|
|
case (mact, mobj) of
|
|
(Nothing, Nothing) ->
|
|
error $
|
|
"InboxItem #" ++ show ibid ++ " neither local nor remote"
|
|
(Just _, Just _) ->
|
|
error $ "InboxItem #" ++ show ibid ++ " both local and remote"
|
|
(Just act, Nothing) -> (ibid, Left $ persistJSONValue act)
|
|
(Nothing, Just obj) -> (ibid, Right $ persistJSONValue obj)
|
|
|
|
postNotificationsR :: ShrIdent -> Handler Html
|
|
postNotificationsR shr = do
|
|
((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing
|
|
case result of
|
|
FormSuccess mitem -> do
|
|
(multi, markedUnread) <- runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
p <- getValBy404 $ UniquePersonIdent sid
|
|
let ibid = personInbox p
|
|
case mitem of
|
|
Nothing -> do
|
|
ibiids <- map E.unValue <$> getItems ibid
|
|
updateWhere
|
|
[InboxItemId <-. ibiids]
|
|
[InboxItemUnread =. False]
|
|
return (True, False)
|
|
Just (ibiid, unread) -> do
|
|
mibl <- getValBy $ UniqueInboxItemLocalItem ibiid
|
|
mibr <- getValBy $ UniqueInboxItemRemoteItem ibiid
|
|
mib <-
|
|
requireEitherM
|
|
mibl
|
|
mibr
|
|
"Unused InboxItem"
|
|
"InboxItem used more than once"
|
|
let samePid =
|
|
case mib of
|
|
Left ibl ->
|
|
inboxItemLocalInbox ibl == ibid
|
|
Right ibr ->
|
|
inboxItemRemoteInbox ibr == ibid
|
|
if samePid
|
|
then do
|
|
update ibiid [InboxItemUnread =. unread]
|
|
return (False, unread)
|
|
else
|
|
permissionDenied
|
|
"Notification belongs to different user"
|
|
setMessage $
|
|
if multi
|
|
then "Items marked as read."
|
|
else if markedUnread
|
|
then "Item marked as unread."
|
|
else "Item marked as read."
|
|
FormMissing -> do
|
|
setMessage "Field(s) missing"
|
|
FormFailure l -> do
|
|
setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l)
|
|
redirect $ NotificationsR shr
|
|
where
|
|
getItems ibid =
|
|
E.select $ E.from $
|
|
\ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do
|
|
E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem
|
|
E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem
|
|
E.where_
|
|
$ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||.
|
|
ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid)
|
|
)
|
|
E.&&.
|
|
( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||.
|
|
ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid)
|
|
)
|
|
E.&&.
|
|
ib E.^. InboxItemUnread E.==. E.val True
|
|
return $ ib E.^. InboxItemId
|
|
-- TODO copied from Vervis.Federation, put this in 1 place
|
|
requireEitherM
|
|
:: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
|
|
requireEitherM mx my f t =
|
|
case requireEither mx my of
|
|
Left b -> liftIO $ throwIO $ userError $ if b then t else f
|
|
Right exy -> return exy
|