vervis/src/Vervis/Handler/Inbox.hs

{- 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.Bifunctor (first, second)
import Data.Foldable (for_)
import Data.HashMap.Strict (HashMap)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.PEM (PEM (..))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
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 (Entity (..), getBy, insertBy, insert_)
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.HTTP.Types.Header (hDate, hHost)
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 (runDB, get404)

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.Vector as V
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 Data.Aeson.Encode.Pretty.ToEncoding
import Data.Aeson.Local
import Database.Persist.Local
import Network.FedURI
import Web.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids

import Vervis.ActorKey
import Vervis.Federation
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.RemoteActorStore
import Vervis.Settings

getInboxR :: Handler Html
getInboxR = do
    acts <- liftIO . readTVarIO =<< 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 (time, report) <- acts
                <li>
                  <div>#{show time}
                  $case report
                    $of ActivityReportHandlerError e
                      <div>Handler error:
                      <div>#{e}
                    $of ActivityReportWorkerError ct o e
                      <div><code>#{BC.unpack ct}
                      <div><pre>#{decodeUtf8 o}
                      <div>#{displayException e}
                    $of ActivityReportUsed msg
                      <div>#{msg}
                    $of ActivityReportUnused ct o msg
                      <div><code>#{BC.unpack ct}
                      <div><pre>#{decodeUtf8 o}
                      <div>#{msg}
        |]

getSharerInboxR :: ShrIdent -> Handler TypedContent
getSharerInboxR _ = error "TODO implement getSharerInboxR"

getProjectInboxR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectInboxR _ _ = error "TODO implement getProjectInboxR"

postInboxR :: Handler ()
postInboxR = do
    federation <- getsYesod $ appFederation . appSettings
    unless federation badMethod
    now <- liftIO getCurrentTime
    r <- runExceptT $ getActivity now
    case r of
        Right (ct, (WithValue raw d@(Doc h a), (iid, rsid))) ->
            forkHandler (handleWorkerError now ct d) $ do
                (msg, stored) <- handleInboxActivity raw h iid rsid a
                if stored
                    then recordUsed now msg
                    else recordUnused now ct d msg
        Left e -> do
            recordError now e
            notAuthenticated
    where
    liftE = ExceptT . pure
    handleWorkerError now ct d e = do
        logError $ "postInboxR worker error: " <> T.pack (displayException e)
        recordActivity now $ ActivityReportWorkerError ct (encodePretty d) e
    recordActivity now item = do
        acts <- getsYesod appActivities
        liftIO $ atomically $ modifyTVar' acts $ \ vec ->
            let vec' = (now, item) `V.cons` vec
            in  if V.length vec' > 10
                    then V.init vec'
                    else vec'
    recordUsed now msg = recordActivity now $ ActivityReportUsed msg
    recordUnused now ct d msg = recordActivity now $ ActivityReportUnused ct (encodePretty d) msg
    recordError now e = recordActivity now $ ActivityReportHandlerError e
    getActivity :: UTCTime -> ExceptT String Handler (ContentType, (WithValue (Doc Activity), (InstanceId, RemoteActorId)))
    getActivity now = do
        contentType <- do
            ctypes <- lookupHeaders "Content-Type"
            liftE $ case ctypes of
                [] -> Left "Content-Type not specified"
                [x] -> case x of
                    "application/activity+json" -> Right x
                    "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" -> Right x
                    _ -> Left "Unknown Content-Type"
                _ -> Left "More than one Content-Type given"
        HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
        (h, luActor) <- f2l . actorDetailId <$> liftE result
        ActorDetail uActor iid rsid <- liftE result
        let (h, luActor) = f2l uActor
        wv@(WithValue _ (Doc h' a)) <- requireJsonBody
        unless (h == h') $
            throwE "Activity host doesn't match signature key host"
        unless (activityActor a == luActor) $
            throwE "Activity's actor != Signature key's actor"
        return (contentType, (wv, (iid, rsid)))

postSharerInboxR :: ShrIdent -> Handler ()
postSharerInboxR _ = error "TODO implement postSharerInboxR"

postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
postProjectInboxR _ _ = error "TODO implement postProjectInboxR"

{-
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
        now <- liftIO getCurrentTime
        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
            recips =
                [ ProjectR shrTicket prj
                , TicketParticipantsR shrTicket prj num
                , TicketTeamR shrTicket prj num
                ]
            note = Note
                { noteId        = Nothing
                , noteAttrib    = luAuthor
                , noteAudience  = Audience
                    { audienceTo      = map encodeRecipRoute recips
                    , audienceBto     = []
                    , audienceCc      = []
                    , audienceBcc     = []
                    , audienceGeneral = []
                    }
                , noteReplyTo   = Just $ fromMaybe uTicket muParent
                , noteContext   = Just uTicket
                , notePublished = Just now
                , 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