mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-03-20 04:46:22 +09:00
6d304b9307
- Allow client to specify recipients that don't need to be delivered to - When fetching recipient, recognize collections and don't try to deliver to them - Remember collections in DB, and use that to skip HTTP delivery
380 lines
15 KiB
Haskell
380 lines
15 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
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
|
|
import Control.Exception (displayException)
|
|
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 (UTCTime, getCurrentTime)
|
|
import Data.Time.Interval (TimeInterval, toTimeUnit)
|
|
import Data.Time.Units (Second)
|
|
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 (ContentType, defaultLayout, whamlet, toHtml, HandlerSite)
|
|
import Yesod.Core.Content (TypedContent)
|
|
import Yesod.Core.Json (requireJsonBody)
|
|
import Yesod.Core.Handler
|
|
import Yesod.Form.Fields (Textarea (..), textField, textareaField)
|
|
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 (pack, unpack, concat)
|
|
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 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.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
|
|
(items, navModel) <- getPageAndNav $ \ off lim -> runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
pid <- getKeyBy404 $ UniquePersonIdent sid
|
|
(,) <$> countItems pid
|
|
<*> (map adaptItem <$> getItems pid off lim)
|
|
let pageNav = navWidget navModel
|
|
selectRep $ provideRep $ 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 = error "Not implemented yet"
|
|
|
|
getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
|
|
getOutboxItemR = error "Not implemented yet"
|
|
|
|
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 <- getEncodeRouteFed
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
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
|
|
, noteContent = msg
|
|
}
|
|
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 <- getEncodeRouteFed
|
|
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
|