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
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 (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 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 (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
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 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 _ = error "TODO implement getSharerInboxR"

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"
    body <- requireJsonBody
    now <- liftIO getCurrentTime
    result <- go now contentTypes body
    recordActivity now result contentTypes body
    case result of
        Left _ -> sendResponseStatus badRequest400 ()
        Right _ -> return ()
    where
    go now ctypes (WithValue raw (Doc hActivity activity)) = runExceptT $ do
        verifyContentType
        HttpSigVerResult result <-
            ExceptT $
                first (T.pack . displayException) <$>
                    verifyRequestSignature now
        ActorDetail uSender iid _raid <- ExceptT $ pure $ first T.pack result
        let (hSender, luSender) = f2l uSender
        unless (hSender == hActivity) $
            throwE $ T.concat
                [ "Activity host <", hActivity
                , "> doesn't match signature key host <", hSender, ">"
                ]
        unless (activityActor activity == luSender) $
            throwE $ T.concat
                [ "Activity's actor <"
                , renderFedURI $ l2f hActivity $ activityActor activity
                , "> != Signature key's actor <", renderFedURI uSender, ">"
                ]
        handleSharerInbox now shrRecip iid raw activity
        where
        verifyContentType =
            case ctypes of
                [] -> throwE "Content-Type not specified"
                [x] | x == typeAS -> return ()
                    | x == typeAS2 -> return ()
                    | otherwise ->
                        throwE $ "Not a recognized AP Content-Type: " <>
                            case decodeUtf8' x of
                                Left _ -> T.pack (show x)
                                Right t -> t
                _ -> throwE "More than one Content-Type specified"
            where
            typeAS = "application/activity+json"
            typeAS2 =
                "application/ld+json; \
                \profile=\"https://www.w3.org/ns/activitystreams\""
    recordActivity now result contentTypes body = do
        acts <- getsYesod appActivities
        liftIO $ atomically $ modifyTVar' acts $ \ vec ->
            let msg = either id id result
                formattedBody = encodePretty $ wvRaw body
                item = ActivityReport now msg contentTypes formattedBody
                vec' = item `V.cons` vec
            in  if V.length vec' > 10
                    then V.init vec'
                    else vec'

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