{- 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.ActivityPub
    ( ActorType (..)
    , Algorithm (..)
    , PublicKey (..)
    , Actor (..)
    )
where

import Prelude

import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.PEM
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.URI

import qualified Data.Text as T (unpack)
import qualified Data.Vector as V (fromList)

frg :: Text
frg = "https://forgefed.angeley.es/ns#"

context :: Value
context = Array $ V.fromList
    [ String "https://www.w3.org/ns/activitystreams"
    , String "https://w3id.org/security/v1"
    ]

parseURI' :: Text -> Parser URI
parseURI' t =
    case parseURI $ T.unpack t of
        Nothing -> fail "Invalid absolute URI"
        Just u ->
            if uriScheme u == "https:"
                then return u
                else fail "URI scheme isn't https"

renderURI :: URI -> String
renderURI u = uriToString id u ""

data ActorType = ActorTypePerson | ActorTypeOther Text

instance FromJSON ActorType where
    parseJSON = withText "ActorType" $ \ t ->
        pure $ case t of
            "Person" -> ActorTypePerson
            _        -> ActorTypeOther t

instance ToJSON ActorType where
    toJSON = error "toJSON ActorType"
    toEncoding at =
        toEncoding $ case at of
            ActorTypePerson  -> "Person"
            ActorTypeOther t -> t

data Algorithm = AlgorithmEd25519 | AlgorithmOther Text

instance FromJSON Algorithm where
    parseJSON = withText "Algorithm" $ \ t ->
        pure $ if t == frg <> "ed25519"
            then AlgorithmEd25519
            else AlgorithmOther t

instance ToJSON Algorithm where
    toJSON = error "toJSON Algorithm"
    toEncoding algo =
        toEncoding $ case algo of
            AlgorithmEd25519 -> frg <> "ed25519"
            AlgorithmOther t -> t

data PublicKey = PublicKey
    { publicKeyId    :: URI
    , publicKeyOwner :: URI
    , publicKeyPem   :: PEM
    , publicKeyAlgo  :: Maybe Algorithm
    }

instance FromJSON PublicKey where
    parseJSON = withObject "PublicKey" $ \ o ->
        PublicKey
            <$> (parseURI' =<< o .: "id")
            <*> (parseURI' =<< o .: "owner")
            <*> (parsePEM =<< o .: "publicKeyPem")
            <*> o .:? (frg <> "algorithm")
        where
        parsePEM t =
            case pemParseBS $ encodeUtf8 t of
                Left e   -> fail $ "PEM parsing failed: " ++ e
                Right xs ->
                    case xs of
                        []  -> fail "Empty PEM"
                        [x] -> pure x
                        _   -> fail "Multiple PEM sections"

instance ToJSON PublicKey where
    toJSON = error "toJSON PublicKey"
    toEncoding (PublicKey id_ owner pem malgo) =
        pairs
            $  "id"           .= renderURI id_
            <> "owner"        .= renderURI owner
            <> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
            <> maybe mempty ((frg <> "algorithm") .=) malgo

data Actor = Actor
    { actorId        :: URI
    , actorType      :: ActorType
    , actorUsername  :: Text
    , actorInbox     :: URI
    , actorPublicKey :: PublicKey
    }

instance FromJSON Actor where
    parseJSON = withObject "Actor" $ \ o ->
        Actor
            <$> (parseURI' =<< o .: "id")
            <*> o .: "type"
            <*> o .: "preferredUsername"
            <*> (parseURI' =<< o .: "inbox")
            <*> o .: "publicKey"

instance ToJSON Actor where
    toJSON = error "toJSON Actor"
    toEncoding (Actor id_ typ username inbox pkey) =
        pairs
            $  "@context"          .= context
            <> "id"                .= renderURI id_
            <> "type"              .= typ
            <> "preferredUsername" .= username
            <> "inbox"             .= renderURI inbox
            <> "publicKey"         .= pkey