{- 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
    , postInboxR
    )
where

import Prelude

import Control.Applicative ((<|>))
import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
import Control.Exception (displayException)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.STM (atomically)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Crypto.Error (CryptoFailable (..))
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
import Data.Aeson (Value (String, Object))
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Bifunctor (first, second)
import Data.HashMap.Strict (HashMap)
import Data.PEM (pemContent)
import Data.Text (Text)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Interval (TimeInterval, toTimeUnit)
import Data.Time.Units (Second)
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
import Network.URI (URI (uriFragment), parseURI)
import Text.Blaze.Html (Html)
import UnliftIO.Exception (try)
import Yesod.Core (ContentType, defaultLayout, whamlet)
import Yesod.Core.Json (requireJsonBody)
import Yesod.Core.Handler

import qualified Data.ByteString.Char8 as BC (unpack)
import qualified Data.CaseInsensitive as CI (mk)
import qualified Data.HashMap.Strict as M (lookup)
import qualified Data.Text as T (unpack)
import qualified Data.Vector as V (length, cons, init)
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 Vervis.ActivityPub
import Vervis.Foundation (App (..), HttpSigVerResult (..), Handler)
import Vervis.Settings (AppSettings (appHttpSigTimeLimit))

getInboxR :: Handler Html
getInboxR = do
    acts <- liftIO . readTVarIO =<< getsYesod appActivities
    defaultLayout
        [whamlet|
            <p>
              Welcome to the ActivityPub inbox test page! It's the beginning of
              federation support in Vervis. Currently POSTing activities
              doesn't do anything, they're just verified and the results are
              displayed on this page. Here's how to POST an activity
              successfully:
            <p>
              (NOTE: Currently only Ed25519 signatures are supported, which is
              incompatible with the default RSA-SHA256 used on the Fediverse)
            <ol>
              <li>
                Publish an actor JSON document. That's like a regular
                ActivityPub actor, except its <var>publicKey</var> object
                should have one extra field named
                <code>https://forgefed.angeley.es/ns#algorithm</code> and its
                value should be
                <code>https://forgefed.angeley.es/ns#ed25519</code>. The actual
                key PEM should indeed be an Ed25519 public key, rather than
                RSA.
              <li>
                Prepare an activity JSON document.
              <li>
                POST it to this page's URL, with an HTTP signature in a
                Signature header, and use at least the headers Host, Date and
                (request-target).
            <p>
              I'm aware these instructions aren't exactly clear and
              self-contained. Soon I'll either clarify them or further
              development will make things easier. In particular, by using one
              Vervis instance to POST an activity to another Vervis instance.
            <p>Last 10 activities posted:
            <ul>
              $forall (time, result) <- acts
                <li>
                  <div>#{show time}
                  $case result
                    $of Left e
                      <div>#{e}
                    $of Right (ct, o)
                      <div><code>#{BC.unpack ct}
                      <div><pre>#{decodeUtf8 o}
        |]

postInboxR :: Handler ()
postInboxR = do
    now <- liftIO getCurrentTime
    r <- runExceptT $ getActivity now
    let item = (now, second (second encodePretty) r)
    acts <- getsYesod appActivities
    liftIO $ atomically $ modifyTVar' acts $ \ vec ->
        let vec' = item `V.cons` vec
        in  if V.length vec' > 10
                then V.init vec'
                else vec'
    case r of
        Right _ -> return ()
        Left _ -> notAuthenticated
    where
    liftE = ExceptT . pure
    getActivity :: UTCTime -> ExceptT String Handler (ContentType, HashMap Text Value)
    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
        uActor <- liftE result
        o <- requireJsonBody
        activityActor <-
            liftE $
            case M.lookup "actor" o of
                Nothing -> Left "Activity has no actor member"
                Just v -> case v of
                    String t -> case parseURI $ T.unpack t of
                        Nothing -> Left "Activity actor URI parsing failed"
                        Just uri -> Right uri
                    _ -> Left "Activity actor isn't a JSON string"
        liftE $ if activityActor == uActor
            then Right ()
            else Left "Activity's actor != Signature key's actor"
        liftE $ case M.lookup "object" o of
            Nothing -> Right ()
            Just v -> case v of
                Object obj -> case M.lookup "actor" obj <|> M.lookup "attributedTo" obj of
                    Nothing -> Right ()
                    Just v' -> case v' of
                        String t -> case parseURI $ T.unpack t of
                            Nothing -> Left "Activity actor URI parsing failed"
                            Just uri ->
                                if uri == uActor
                                    then Right ()
                                    else Left "Activity object's actor doesn't match activity's actor"
                        _ -> Left "Activity actor isn't a JSON string"
                _ -> Left "Activity's object isn't a JSON object"
        return (contentType, o)