mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-03-20 04:46:22 +09:00
628 lines
26 KiB
Haskell
628 lines
26 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
|
|
, getOutboxR
|
|
, getOutboxItemR
|
|
, postOutboxR
|
|
, getActorKey1R
|
|
, getActorKey2R
|
|
, getNotificationsR
|
|
, postNotificationsR
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
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 (first, second)
|
|
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)
|
|
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.Auth.Unverified
|
|
import Yesod.FedURI
|
|
import Yesod.Hashids
|
|
|
|
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.ActorKey
|
|
import Vervis.Federation
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Model.Ident
|
|
import Vervis.Paginate
|
|
import Vervis.RemoteActorStore
|
|
import Vervis.Render
|
|
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}
|
|
|]
|
|
|
|
getSharerInboxR :: ShrIdent -> Handler TypedContent
|
|
getSharerInboxR shr = do
|
|
(total, pages, mpage) <- runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
pid <- getKeyBy404 $ UniquePersonIdent sid
|
|
getPageAndNavCount
|
|
(countItems pid)
|
|
(\ off lim -> map adaptItem <$> getItems pid off lim)
|
|
let here = SharerInboxR shr
|
|
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 pid =
|
|
(+) <$> count [InboxItemLocalPerson ==. pid]
|
|
<*> count [InboxItemRemotePerson ==. pid]
|
|
getItems pid 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.?. InboxItemRemotePerson) E.||.
|
|
ibr E.?. InboxItemRemotePerson E.==. E.just (E.val pid)
|
|
)
|
|
E.&&.
|
|
( E.isNothing (ibl E.?. InboxItemLocalPerson) E.||.
|
|
ibl E.?. InboxItemLocalPerson E.==. E.just (E.val pid)
|
|
)
|
|
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
|
|
|
|
getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
|
|
getProjectInboxR _ _ = error "TODO implement getProjectInboxR"
|
|
|
|
postSharerInboxR :: ShrIdent -> Handler ()
|
|
postSharerInboxR shrRecip = do
|
|
federation <- getsYesod $ appFederation . appSettings
|
|
unless federation badMethod
|
|
contentTypes <- lookupHeaders "Content-Type"
|
|
now <- liftIO getCurrentTime
|
|
result <- runExceptT $ do
|
|
(id_, _body, raw, activity) <- authenticateActivity now
|
|
let id' = second actdInstance id_
|
|
(raw,) <$> handleSharerInbox now shrRecip id' raw activity
|
|
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
|
|
(id_, body, raw, activity) <- authenticateActivity now
|
|
ActivityDetail uAuthor iidAuthor raidAuthor <-
|
|
case id_ of
|
|
Left _pid -> throwE "Project inbox got local forwarded activity"
|
|
Right d -> return d
|
|
let hAuthor = furiHost uAuthor
|
|
(raw,) <$> handleProjectInbox now shrRecip prjRecip iidAuthor hAuthor raidAuthor body raw activity
|
|
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
|
|
|
|
activityForm :: Form ((Text, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
|
|
activityForm 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? :)"
|
|
|
|
activityWidget :: ShrIdent -> Widget -> Enctype -> Widget
|
|
activityWidget shr widget enctype =
|
|
[whamlet|
|
|
<p>
|
|
This is a federation test page. Provide a recepient actor URI and
|
|
message text, and a Create activity creating a new Note will be sent
|
|
to the destination server.
|
|
<form method=POST action=@{OutboxR shr} enctype=#{enctype}>
|
|
^{widget}
|
|
<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
|
|
((_result, widget), enctype) <- runFormPost activityForm
|
|
defaultLayout $ activityWidget shr widget enctype
|
|
|
|
getOutboxR :: ShrIdent -> Handler TypedContent
|
|
getOutboxR shr = do
|
|
(total, pages, mpage) <- runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
pid <- getKeyBy404 $ UniquePersonIdent sid
|
|
let countAllItems = count [OutboxItemPerson ==. pid]
|
|
selectItems off lim = selectList [OutboxItemPerson ==. pid] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
|
|
getPageAndNavCount countAllItems selectItems
|
|
let here = OutboxR shr
|
|
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")
|
|
|
|
getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
|
|
getOutboxItemR shr obkhid = do
|
|
obid <- decodeKeyHashid404 obkhid
|
|
doc <- runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
pid <- getKeyBy404 $ UniquePersonIdent sid
|
|
ob <- get404 obid
|
|
unless (outboxItemPerson ob == pid) notFound
|
|
return $ persistJSONValue $ outboxItemActivity ob
|
|
selectRep $ do
|
|
provideAP $ pure doc
|
|
provideRep $ defaultLayout $
|
|
[whamlet|
|
|
<div><pre>#{AEP.encodePrettyToLazyText doc}
|
|
|]
|
|
|
|
postOutboxR :: ShrIdent -> Handler Html
|
|
postOutboxR shrAuthor = do
|
|
federation <- getsYesod $ appFederation . appSettings
|
|
unless federation badMethod
|
|
((result, widget), enctype) <- runFormPost activityForm
|
|
elmid <- runExceptT $ do
|
|
((hTicket, shrTicket, prj, num), muParent, msg) <-
|
|
case result of
|
|
FormMissing -> throwE "Field(s) missing"
|
|
FormFailure _l -> throwE "Invalid input, see below"
|
|
FormSuccess r -> return r
|
|
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 =
|
|
[ 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 $ handleOutboxNote hLocal note
|
|
case elmid of
|
|
Left err -> setMessage $ toHtml err
|
|
Right lmid -> do
|
|
lmkhid <- encodeKeyHashid lmid
|
|
renderUrl <- getUrlRender
|
|
let u = renderUrl $ MessageR shrAuthor lmkhid
|
|
setMessage $ toHtml $ "Message created! ID: " <> u
|
|
defaultLayout $ activityWidget shrAuthor widget enctype
|
|
|
|
getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
|
|
getActorKey choose route = selectRep $ provideAP $ do
|
|
actorKey <-
|
|
liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
|
|
getsYesod appActorKeys
|
|
route2uri <- getEncodeRouteHome
|
|
let (host, id_) = f2l $ route2uri route
|
|
return $ Doc host PublicKey
|
|
{ publicKeyId = id_
|
|
, publicKeyExpires = Nothing
|
|
, publicKeyOwner = OwnerInstance
|
|
, publicKeyMaterial = actorKey
|
|
--, publicKeyAlgo = Just AlgorithmEd25519
|
|
}
|
|
|
|
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
|
|
pid <- getKeyBy404 $ UniquePersonIdent sid
|
|
map adaptItem <$> getItems pid
|
|
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 pid =
|
|
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.?. InboxItemRemotePerson) E.||.
|
|
ibr E.?. InboxItemRemotePerson E.==. E.just (E.val pid)
|
|
)
|
|
E.&&.
|
|
( E.isNothing (ibl E.?. InboxItemLocalPerson) E.||.
|
|
ibl E.?. InboxItemLocalPerson E.==. E.just (E.val pid)
|
|
)
|
|
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
|
|
pid <- getKeyBy404 $ UniquePersonIdent sid
|
|
case mitem of
|
|
Nothing -> do
|
|
ibids <- map E.unValue <$> getItems pid
|
|
updateWhere
|
|
[InboxItemId <-. ibids]
|
|
[InboxItemUnread =. False]
|
|
return (True, False)
|
|
Just (ibid, unread) -> do
|
|
mibl <- getValBy $ UniqueInboxItemLocalItem ibid
|
|
mibr <- getValBy $ UniqueInboxItemRemoteItem ibid
|
|
mib <-
|
|
requireEitherM
|
|
mibl
|
|
mibr
|
|
"Unused InboxItem"
|
|
"InboxItem used more than once"
|
|
let samePid =
|
|
case mib of
|
|
Left ibl ->
|
|
inboxItemLocalPerson ibl == pid
|
|
Right ibr ->
|
|
inboxItemRemotePerson ibr == pid
|
|
if samePid
|
|
then do
|
|
update ibid [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 pid =
|
|
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.?. InboxItemRemotePerson) E.||.
|
|
ibr E.?. InboxItemRemotePerson E.==. E.just (E.val pid)
|
|
)
|
|
E.&&.
|
|
( E.isNothing (ibl E.?. InboxItemLocalPerson) E.||.
|
|
ibl E.?. InboxItemLocalPerson E.==. E.just (E.val pid)
|
|
)
|
|
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
|