{- 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