Vervis/src/Web/ActivityPub.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 Web.ActivityPub
    ( -- * Type-safe manipulation tools
      --
      -- Types and functions that make handling URIs and JSON-LD contexts less
      -- error-prone and safer by recording safety checks in the type and
      -- placing the checks in a single clear place.
      ActivityPub (..)
    , Doc (..)

      -- * Actor
      --
      -- ActivityPub actor document including a public key, with a 'FromJSON'
      -- instance for fetching and a 'ToJSON' instance for publishing.
    , ActorType (..)
    --, Algorithm (..)
    , Owner (..)
    , PublicKey (..)
    , Actor (..)
    , Project (..)
    , CollectionType (..)
    , Collection (..)
    , CollectionPageType (..)
    , CollectionPage (..)
    , Recipient (..)

      -- * Content objects
    , Note (..)
    , TextHtml (..)
    , TextPandocMarkdown (..)
    , TicketLocal (..)
    , Ticket (..)

      -- * Activity
    , Accept (..)
    , Create (..)
    , Follow (..)
    , Offer (..)
    , Reject (..)
    , Audience (..)
    , SpecificActivity (..)
    , Activity (..)

      -- * Utilities
    , publicURI
    , hActivityPubActor
    , provideAP
    , APGetError (..)
    , httpGetAP
    , APPostError (..)
    , hActivityPubForwarder
    , hForwardingSignature
    , hForwardedSignature
    , httpPostAP
    , httpPostAPBytes
    , Fetched (..)
    , fetchAPID
    , fetchAPID'
    , fetchRecipient
    , keyListedByActor
    , fetchUnknownKey
    , fetchKnownPersonalKey
    , fetchKnownSharedKey
    )
where

import Control.Applicative ((<|>), optional)
import Control.Exception (Exception, displayException, try)
import Control.Monad (when, unless, (<=<), join)
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer (Writer)
import Crypto.Hash hiding (Context)
import Data.Aeson
import Data.Aeson.Encoding (pair)
import Data.Aeson.Types (Parser, typeMismatch, listEncoding)
import Data.Bifunctor
import Data.Bitraversable (bitraverse)
import Data.ByteString (ByteString)
import Data.Foldable (for_)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Proxy
import Data.PEM
import Data.Semigroup (Endo, First (..))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Traversable
import Data.Vector (Vector)
import Network.HTTP.Client hiding (Proxy, proxy)
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
import Network.HTTP.Simple (JSONException)
import Network.HTTP.Types.Header (HeaderName, hContentType)
import Network.URI
import Text.HTML.SanitizeXSS
import Yesod.Core.Content (ContentType)
import Yesod.Core.Handler (ProvidedRep, provideRepType)

import Network.HTTP.Client.Signature

import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T (pack, unpack)
import qualified Data.Vector as V
import qualified Network.HTTP.Signature as S

import Crypto.PublicVerifKey
import Network.FedURI
import Network.HTTP.Digest

import Data.Aeson.Local

proxy :: a -> Proxy a
proxy _ = Proxy

as2Context :: FedURI
as2Context = FedURI "www.w3.org" "/ns/activitystreams" ""

secContext :: FedURI
secContext = FedURI "w3id.org" "/security/v1" ""

forgeContext :: FedURI
forgeContext = FedURI "forgefed.peers.community" "/ns" ""

extContext :: FedURI
extContext = FedURI "angeley.es" "/as2-ext" ""

publicURI :: FedURI
publicURI = FedURI "www.w3.org" "/ns/activitystreams" "#Public"

publicT :: Text
publicT = renderFedURI publicURI

class ActivityPub a where
    jsonldContext :: Proxy a -> [FedURI]
    parseObject   :: Object -> Parser (Text, a)
    toSeries      :: Text -> a -> Series

data Doc a = Doc
    { docHost  :: Text
    , docValue :: a
    }

instance ActivityPub a => FromJSON (Doc a) where
    parseJSON = withObject "Doc" $ \ o -> uncurry Doc <$> parseObject o

instance ActivityPub a => ToJSON (Doc a) where
    toJSON = error "toJSON Doc"
    toEncoding (Doc h v) =
        pairs
            $  context (jsonldContext $ proxy v)
            <> toSeries h v
        where
        context []  = mempty
        context [t] = "@context" .= t
        context ts  = "@context" .= ts

data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
    deriving Eq

instance FromJSON ActorType where
    parseJSON = withText "ActorType" $ pure . parse
        where
        parse t
            | t == "Person"  = ActorTypePerson
            | t == "Project" = ActorTypeProject
            | otherwise      = ActorTypeOther t

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

data Owner = OwnerInstance | OwnerActor LocalURI

ownerShared :: Owner -> Bool
ownerShared OwnerInstance  = True
ownerShared (OwnerActor _) = False

data PublicKey = PublicKey
    { publicKeyId       :: LocalURI
    , publicKeyExpires  :: Maybe UTCTime
    , publicKeyOwner    :: Owner
    , publicKeyMaterial :: PublicVerifKey
    }

instance ActivityPub PublicKey where
    jsonldContext _ = [secContext, extContext]
    parseObject o = do
        mtyp <- optional $ o .: "@type" <|> o .: "type"
        for_ mtyp $ \ t ->
            when (t /= ("Key" :: Text)) $
                fail "PublicKey @type isn't Key"
        (host, id_) <- f2l <$> (o .: "@id" <|> o .: "id")
        shared <- o .:|? "isShared" .!= False
        fmap (host,) $
            PublicKey id_
                <$> o .:? "expires"
                <*> (mkOwner shared =<< withHost host o "owner")
                <*> (either fail return . decodePublicVerifKeyPEM =<<
                        o .: "publicKeyPem"
                    )
        where
        withHost h o t = do
            (h', lu) <- f2l <$> o .: t
            if h == h'
                then return lu
                else fail "URI host mismatch"
        mkOwner True  (LocalURI "" "") = return OwnerInstance
        mkOwner True  _                = fail "Shared key but owner isn't instance URI"
        mkOwner False lu               = return $ OwnerActor lu
    toSeries host (PublicKey id_ mexpires owner mat)
        =  "@id"          .=  l2f host id_
        <> "expires"      .=? mexpires
        <> "owner"        .=  mkOwner host owner
        <> "publicKeyPem" .=  encodePublicVerifKeyPEM mat
        <> "isShared"     .=  ownerShared owner
        where
        mkOwner h OwnerInstance   = FedURI h "" ""
        mkOwner h (OwnerActor lu) = l2f h lu

parsePublicKeySet :: Value -> Parser (Text, [Either LocalURI PublicKey])
parsePublicKeySet v =
    case v of
        Array a ->
            case V.toList a of
                [] -> fail "No public keys"
                k : ks -> do
                    (h, e) <- parseKey k
                    es <- traverse (withHost h . parseKey) ks
                    return (h, e : es)
        _ -> second (: []) <$> parseKey v
    where
    parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t)
    parseKey (Object o) = second Right <$> parseObject o
    parseKey v          = typeMismatch "PublicKeySet Item" v

encodePublicKeySet :: Text -> [Either LocalURI PublicKey] -> Encoding
encodePublicKeySet host es =
    case es of
        [e] -> renderKey e
        _   -> listEncoding renderKey es
    where
    renderKey (Left lu)  = toEncoding $ l2f host lu
    renderKey (Right pk) = pairs $ toSeries host pk

data Actor = Actor
    { actorId         :: LocalURI
    , actorType       :: ActorType
    , actorUsername   :: Maybe Text
    , actorName       :: Maybe Text
    , actorSummary    :: Maybe Text
    , actorInbox      :: LocalURI
    , actorOutbox     :: Maybe LocalURI
    , actorFollowers  :: Maybe LocalURI
    , actorPublicKeys :: [Either LocalURI PublicKey]
    }

instance ActivityPub Actor where
    jsonldContext _ = [as2Context, secContext, extContext]
    parseObject o = do
        (host, id_) <- f2l <$> o .: "id"
        fmap (host,) $
            Actor id_
                <$> o .: "type"
                <*> o .:? "preferredUsername"
                <*> o .:? "name"
                <*> o .:? "summary"
                <*> withHost host (f2l <$> o .: "inbox")
                <*> withHostMaybe host (fmap f2l <$> o .:? "outbox")
                <*> withHostMaybe host (fmap f2l <$> o .:? "followers")
                <*> withHost host (parsePublicKeySet =<< o .: "publicKey")
    toSeries host
        (Actor id_ typ musername mname msummary inbox outbox followers pkeys)
            =  "id"                .=     l2f host id_
            <> "type"              .=     typ
            <> "preferredUsername" .=?    musername
            <> "name"              .=?    mname
            <> "summary"           .=?    msummary
            <> "inbox"             .=     l2f host inbox
            <> "outbox"            .=?    (l2f host <$> outbox)
            <> "followers"         .=?    (l2f host <$> followers)
            <> "publicKey"         `pair` encodePublicKeySet host pkeys

data Project = Project
    { projectActor :: Actor
    , projectTeam  :: LocalURI
    }

instance ActivityPub Project where
    jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
    parseObject o = do
        (h, a) <- parseObject o
        unless (actorType a == ActorTypeProject) $
            fail "Actor type isn't Project"
        fmap (h,) $
            Project a
                <$> withHost h (f2l <$> o .:| "team")
    toSeries host (Project actor team)
        =  toSeries host actor
        <> "team" .= l2f host team

data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered

instance FromJSON CollectionType where
    parseJSON = withText "CollectionType" parse
        where
        parse "Collection"        = pure CollectionTypeUnordered
        parse "OrderedCollection" = pure CollectionTypeOrdered
        parse t = fail $ "Unknown collection type: " ++ T.unpack t

instance ToJSON CollectionType where
    toJSON = error "toJSON CollectionType"
    toEncoding ct =
        toEncoding $ case ct of
            CollectionTypeUnordered -> "Collection" :: Text
            CollectionTypeOrdered   -> "OrderedCollection"

data Collection a = Collection
    { collectionId         :: LocalURI
    , collectionType       :: CollectionType
    , collectionTotalItems :: Maybe Int
    , collectionCurrent    :: Maybe LocalURI
    , collectionFirst      :: Maybe LocalPageURI
    , collectionLast       :: Maybe LocalPageURI
    , collectionItems      :: [a]
    }

instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where
    jsonldContext _ = [as2Context, forgeContext, extContext]
    parseObject o = do
        (host, id_) <- f2l <$> o .: "id"
        fmap (host,) $
            Collection id_
                <$> o .: "type"
                <*> o .:? "totalItems"
                <*> withHostMaybe host (fmap f2l <$> o .:? "current")
                <*> withHostMaybe host (fmap fp2lp <$> o .:? "first")
                <*> withHostMaybe host (fmap fp2lp <$> o .:? "last")
                <*> optional (o .: "items" <|> o .: "orderedItems") .!= []
    toSeries host (Collection id_ typ total curr firzt last items)
        =  "id"         .=  l2f host id_
        <> "type"       .=  typ
        <> "totalItems" .=? total
        <> "current"    .=? (l2f host <$> curr)
        <> "first"      .=? (lp2fp host <$> firzt)
        <> "last"       .=? (lp2fp host <$> last)
        <> "items"      .=% items

data CollectionPageType
    = CollectionPageTypeUnordered
    | CollectionPageTypeOrdered

instance FromJSON CollectionPageType where
    parseJSON = withText "CollectionPageType" parse
        where
        parse "CollectionPage"        = pure CollectionPageTypeUnordered
        parse "OrderedCollectionPage" = pure CollectionPageTypeOrdered
        parse t = fail $ "Unknown collection page type: " ++ T.unpack t

instance ToJSON CollectionPageType where
    toJSON = error "toJSON CollectionPageType"
    toEncoding ct =
        toEncoding $ case ct of
            CollectionPageTypeUnordered -> "CollectionPage" :: Text
            CollectionPageTypeOrdered   -> "OrderedCollectionPage"

data CollectionPage a = CollectionPage
    { collectionPageId         :: LocalPageURI
    , collectionPageType       :: CollectionPageType
    , collectionPageTotalItems :: Maybe Int
    , collectionPageCurrent    :: Maybe LocalPageURI
    , collectionPageFirst      :: Maybe LocalPageURI
    , collectionPageLast       :: Maybe LocalPageURI
    , collectionPagePartOf     :: LocalURI
    , collectionPagePrev       :: Maybe LocalPageURI
    , collectionPageNext       :: Maybe LocalPageURI
    , collectionPageStartIndex :: Maybe Int
    , collectionPageItems      :: [a]
    }

instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where
    jsonldContext _ = [as2Context, forgeContext, extContext]
    parseObject o = do
        (host, id_) <- fp2lp <$> o .: "id"
        fmap (host,) $
            CollectionPage id_
                <$> o .: "type"
                <*> o .:? "totalItems"
                <*> withHostMaybe host (fmap fp2lp <$> o .:? "current")
                <*> withHostMaybe host (fmap fp2lp <$> o .:? "first")
                <*> withHostMaybe host (fmap fp2lp <$> o .:? "last")
                <*> withHost host (f2l <$> o .: "partOf")
                <*> withHostMaybe host (fmap fp2lp <$> o .:? "prev")
                <*> withHostMaybe host (fmap fp2lp <$> o .:? "next")
                <*> o .:? "startIndex"
                <*> optional (o .: "items" <|> o .: "orderedItems") .!= []
    toSeries host (CollectionPage id_ typ total curr firzt last partOf prev next ind items)
        =  "id"         .=  lp2fp host id_
        <> "type"       .=  typ
        <> "totalItems" .=? total
        <> "current"    .=? (lp2fp host <$> curr)
        <> "first"      .=? (lp2fp host <$> firzt)
        <> "last"       .=? (lp2fp host <$> last)
        <> "partOf"     .=  (l2f host partOf)
        <> "prev"       .=? (lp2fp host <$> prev)
        <> "next"       .=? (lp2fp host <$> next)
        <> "startIndex" .=? ind
        <> "items"      .=% items

data Recipient = RecipientActor Actor | RecipientCollection (Collection FedURI)

instance ActivityPub Recipient where
    jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
    parseObject o =
        second RecipientActor <$> parseObject o <|>
        second RecipientCollection <$> parseObject o
    toSeries h (RecipientActor a)      = toSeries h a
    toSeries h (RecipientCollection c) = toSeries h c

data Audience = Audience
    { audienceTo        :: [FedURI]
    , audienceBto       :: [FedURI]
    , audienceCc        :: [FedURI]
    , audienceBcc       :: [FedURI]
    , audienceGeneral   :: [FedURI]
    , audienceNonActors :: [FedURI]
    }

newtype AdaptAudience = AdaptAudience
    { unAdapt :: FedURI
    }

instance FromJSON AdaptAudience where
    parseJSON = fmap AdaptAudience . parseJSON . adapt
        where
        adapt v =
            case v of
                String t
                    | t == "Public"    -> String publicT
                    | t == "as:Public" -> String publicT
                _ -> v

parseAudience :: Object -> Parser Audience
parseAudience o =
    Audience
        <$> o .:& "to"
        <*> o .:& "bto"
        <*> o .:& "cc"
        <*> o .:& "bcc"
        <*> o .:& "audience"
        <*> o .:|& "nonActors"
    where
    obj .:& key = do
        l <- obj .:? key .!= []
        return $ map unAdapt l
    obj .:|& key = do
        l <- obj .:|? key .!= []
        return $ map unAdapt l

encodeAudience :: Audience -> Series
encodeAudience (Audience to bto cc bcc aud nons)
    =  "to"        .=% to
    <> "bto"       .=% bto
    <> "cc"        .=% cc
    <> "bcc"       .=% bcc
    <> "audience"  .=% aud
    <> "nonActors" .=% nons

data Note = Note
    { noteId        :: Maybe LocalURI
    , noteAttrib    :: LocalURI
    , noteAudience  :: Audience
    , noteReplyTo   :: Maybe FedURI
    , noteContext   :: Maybe FedURI
    , notePublished :: Maybe UTCTime
    , noteSource    :: Text
    , noteContent   :: Text
    }

withHost h a = do
    (h', v) <- a
    if h == h'
        then return v
        else fail "URI host mismatch"

withHostMaybe h a = do
    mp <- a
    for mp $ \ (h', v) ->
        if h == h'
            then return v
            else fail "URI host mismatch"

instance ActivityPub Note where
    jsonldContext _ = [as2Context, extContext]
    parseObject o = do
        typ <- o .: "type"
        unless (typ == ("Note" :: Text)) $
            fail "type isn't Note"

        mediaType <- o .: "mediaType"
        unless (mediaType == ("text/html" :: Text)) $
            fail "mediaType isn't HTML"

        source <- o .: "source"
        sourceType <- source .: "mediaType"
        unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
            fail "source mediaType isn't Pandoc Markdown"

        (h, attrib) <- f2l <$> o .: "attributedTo"
        fmap (h,) $
            Note
                <$> withHostMaybe h (fmap f2l <$> o .:? "id")
                <*> pure attrib
                <*> parseAudience o
                <*> o .:? "inReplyTo"
                <*> o .:? "context"
                <*> o .:? "published"
                <*> source .: "content"
                <*> (sanitizeBalance <$> o .: "content")
    toSeries host (Note mid attrib aud mreply mcontext mpublished src content)
        =  "type"         .=  ("Note" :: Text)
        <> "id"           .=? (l2f host <$> mid)
        <> "attributedTo" .=  l2f host attrib
        <> encodeAudience aud
        <> "inReplyTo"    .=? mreply
        <> "context"      .=? mcontext
        <> "published"    .=? mpublished
        <> "source"       .=  object
                [ "content"   .= src
                , "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
                ]
        <> "content"      .=  content
        <> "mediaType"    .=  ("text/html" :: Text)

newtype TextHtml = TextHtml
    { unTextHtml :: Text
    }
    deriving (FromJSON, ToJSON)

newtype TextPandocMarkdown = TextPandocMarkdown
    { unTextPandocMarkdown :: Text
    }
    deriving (FromJSON, ToJSON)

data TicketLocal = TicketLocal
    { ticketId           :: LocalURI
    , ticketContext      :: LocalURI
    , ticketReplies      :: LocalURI
    , ticketParticipants :: LocalURI
    , ticketTeam         :: LocalURI
    , ticketEvents       :: LocalURI
    }

parseTicketLocal :: Object -> Parser (Maybe (Text, TicketLocal))
parseTicketLocal o = do
    mid <- fmap f2l <$> o .:? "id"
    case mid of
        Nothing -> do
            verifyNothing "context"
            verifyNothing "replies"
            verifyNothing "participants"
            verifyNothing "team"
            verifyNothing "history"
            return Nothing
        Just (h, id_) ->
            fmap (Just . (h,)) $
                TicketLocal
                    <$> pure id_
                    <*> withHost h (f2l <$> o .: "context")
                    <*> withHost h (f2l <$> o .: "replies")
                    <*> withHost h (f2l <$> o .: "participants")
                    <*> withHost h (f2l <$> o .: "team")
                    <*> withHost h (f2l <$> o .: "history")
    where
    verifyNothing t =
        if t `M.member` o
            then fail $ T.unpack t ++ " field found, expected none"
            else return ()

encodeTicketLocal :: Text -> TicketLocal -> Series
encodeTicketLocal h (TicketLocal id_ context replies participants team events)
    =  "id"           .= l2f h id_
    <> "context"      .= l2f h context
    <> "replies"      .= l2f h replies
    <> "participants" .= l2f h participants
    <> "team"         .= l2f h team
    <> "history"      .= l2f h events

data Ticket = Ticket
    { ticketLocal        :: Maybe (Text, TicketLocal)
    , ticketAttributedTo :: LocalURI
    , ticketPublished    :: Maybe UTCTime
    , ticketUpdated      :: Maybe UTCTime
    , ticketName         :: Maybe Text
    , ticketSummary      :: TextHtml
    , ticketContent      :: TextHtml
    , ticketSource       :: TextPandocMarkdown
    , ticketAssignedTo   :: Maybe FedURI
    , ticketIsResolved   :: Bool
    , ticketDependsOn    :: [FedURI]
    , ticketDependedBy   :: [FedURI]
    }

instance ActivityPub Ticket where
    jsonldContext _ = [as2Context, forgeContext, extContext]
    parseObject o = do
        typ <- o .: "type"
        unless (typ == ("Ticket" :: Text)) $
            fail "type isn't Ticket"

        mediaType <- o .: "mediaType"
        unless (mediaType == ("text/html" :: Text)) $
            fail "mediaType isn't HTML"

        source <- o .: "source"
        sourceType <- source .: "mediaType"
        unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
            fail "source mediaType isn't Pandoc Markdown"

        (h, attributedTo) <- f2l <$> o .: "attributedTo"

        fmap (h,) $
            Ticket
                <$> parseTicketLocal o
                <*> pure attributedTo
                <*> o .:? "published"
                <*> o .:? "updated"
                <*> o .:? "name"
                <*> (TextHtml . sanitizeBalance <$> o .: "summary")
                <*> (TextHtml . sanitizeBalance <$> o .: "content")
                <*> source .: "content"
                <*> o .:? "assignedTo"
                <*> o .: "isResolved"
                <*> o .:? "dependsOn" .!= []
                <*> o .:? "dependedBy" .!= []

    toSeries host
        (Ticket local attributedTo published updated name summary content
                source assignedTo isResolved dependsOn dependedBy)

            =   maybe mempty (uncurry encodeTicketLocal) local
            <> "type"         .=  ("Ticket" :: Text)
            <> "attributedTo" .=  l2f host attributedTo
            <> "published"    .=? published
            <> "updated"      .=? updated
            <> "name"         .=? name
            <> "summary"      .=  summary
            <> "content"      .=  content
            <> "mediaType"    .=  ("text/html" :: Text)
            <> "source"       .=  object
                    [ "content"   .= source
                    , "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
                    ]
            <> "assignedTo"   .=? assignedTo
            <> "isResolved"   .=  isResolved
            <> "dependsOn"    .=% dependsOn
            <> "dependedBy"   .=% dependedBy

data Accept = Accept
    { acceptObject :: FedURI
    }

parseAccept :: Object -> Parser Accept
parseAccept o = Accept <$> o .: "object"

encodeAccept :: Accept -> Series
encodeAccept (Accept obj) = "object" .= obj

data Create = Create
    { createObject :: Note
    }

parseCreate :: Object -> Text -> LocalURI -> Parser Create
parseCreate o h luActor = do
    note <- withHost h $ parseObject =<< o .: "object"
    unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib"
    return $ Create note

encodeCreate :: Text -> LocalURI -> Create -> Series
encodeCreate host actor (Create obj) =
    "object" `pair` pairs (toSeries host obj)

data Follow = Follow
    { followObject :: FedURI
    , followHide   :: Bool
    }

parseFollow :: Object -> Parser Follow
parseFollow o =
    Follow
        <$> o .: "object"
        <*> o .: "hide"

encodeFollow :: Follow -> Series
encodeFollow (Follow obj hide)
    =  "object" .= obj
    <> "hide"   .= hide

data Offer = Offer
    { offerObject :: Ticket
    , offerTarget :: FedURI
    }

parseOffer :: Object -> Text -> LocalURI -> Parser Offer
parseOffer o h luActor = do
    ticket <- withHost h $ parseObject =<< o .: "object"
    unless (luActor == ticketAttributedTo ticket) $
        fail "Offer actor != Ticket attrib"
    target <- o .: "target"
    for_ (ticketLocal ticket) $ \ (host, local) -> do
        let (hTarget, luTarget) = f2l target
        unless (hTarget == host) $
            fail "Offer target host != Ticket local host"
        unless (luTarget == ticketContext local) $
            fail "Offer target != Ticket context"
    return $ Offer ticket target

encodeOffer :: Text -> LocalURI -> Offer -> Series
encodeOffer host actor (Offer obj target)
    =  "object" `pair` pairs (toSeries host obj)
    <> "target" .= target

data Reject = Reject
    { rejectObject :: FedURI
    }

parseReject :: Object -> Parser Reject
parseReject o = Reject <$> o .: "object"

encodeReject :: Reject -> Series
encodeReject (Reject obj) = "object" .= obj

data SpecificActivity
    = AcceptActivity Accept
    | CreateActivity Create
    | FollowActivity Follow
    | OfferActivity  Offer
    | RejectActivity Reject

data Activity = Activity
    { activityId       :: Maybe LocalURI
    , activityActor    :: LocalURI
    , activitySummary  :: Maybe TextHtml
    , activityAudience :: Audience
    , activitySpecific :: SpecificActivity
    }

instance ActivityPub Activity where
    jsonldContext _ = [as2Context, forgeContext, extContext]
    parseObject o = do
        (h, actor) <- f2l <$> o .: "actor"
        fmap (h,) $
            Activity
                <$> withHostMaybe h (fmap f2l <$> o .:? "id")
                <*> pure actor
                <*> (fmap (TextHtml . sanitizeBalance) <$> o .:? "summary")
                <*> parseAudience o
                <*> do
                    typ <- o .: "type"
                    case typ of
                        "Accept" -> AcceptActivity <$> parseAccept o
                        "Create" -> CreateActivity <$> parseCreate o h actor
                        "Follow" -> FollowActivity <$> parseFollow o
                        "Offer"  -> OfferActivity  <$> parseOffer o h actor
                        "Reject" -> RejectActivity <$> parseReject o
                        _ ->
                            fail $
                                "Unrecognized activity type: " ++ T.unpack typ
    toSeries host (Activity id_ actor summary audience specific)
        =  "type"    .=  activityType specific
        <> "id"      .=? (l2f host <$> id_)
        <> "actor"   .=  l2f host actor
        <> "summary" .=? summary
        <> encodeAudience audience
        <> encodeSpecific host actor specific
        where
        activityType :: SpecificActivity -> Text
        activityType (AcceptActivity _) = "Accept"
        activityType (CreateActivity _) = "Create"
        activityType (FollowActivity _) = "Follow"
        activityType (OfferActivity _)  = "Offer"
        activityType (RejectActivity _) = "Reject"
        encodeSpecific _ _ (AcceptActivity a) = encodeAccept a
        encodeSpecific h u (CreateActivity a) = encodeCreate h u a
        encodeSpecific _ _ (FollowActivity a) = encodeFollow a
        encodeSpecific h u (OfferActivity a)  = encodeOffer h u a
        encodeSpecific _ _ (RejectActivity a) = encodeReject a

typeActivityStreams2 :: ContentType
typeActivityStreams2 = "application/activity+json"

typeActivityStreams2LD :: ContentType
typeActivityStreams2LD =
    "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\""

hActivityPubActor :: HeaderName
hActivityPubActor = "ActivityPub-Actor"

provideAP :: (Monad m, ToJSON a) => m a -> Writer (Endo [ProvidedRep m]) ()
provideAP mk =
    -- let enc = toEncoding v
    -- provideRepType typeActivityStreams2   $ return enc
    provideRepType typeActivityStreams2LD $ toEncoding <$> mk

data APGetError
    = APGetErrorHTTP HttpException
    | APGetErrorJSON JSONException
    | APGetErrorContentType Text
    deriving Show

instance Exception APGetError

-- | Perform an HTTP GET request to fetch an ActivityPub object.
--
-- * Verify the URI scheme is _https:_ and authority part is present
-- * Set _Accept_ request header
-- * Perform the GET request
-- * Verify the _Content-Type_ response header
-- * Parse the JSON response body
httpGetAP
    :: (MonadIO m, FromJSON a)
    => Manager
    -> FedURI
    -> m (Either APGetError (Response a))
httpGetAP manager uri =
    liftIO $
        mkResult <$> try (httpAPEither manager =<< requestFromURI (toURI uri))
    where
    lookup' x = map snd . filter ((== x) . fst)
    mkResult (Left e)  = Left $ APGetErrorHTTP e
    mkResult (Right r) =
        case lookup' hContentType $ responseHeaders r of
            []  -> Left $ APGetErrorContentType "No Content-Type"
            [b] -> if b == typeActivityStreams2LD || b == typeActivityStreams2
                        then case responseBody r of
                            Left e  -> Left $ APGetErrorJSON e
                            Right v -> Right $ v <$ r
                        else Left $ APGetErrorContentType $ "Non-AP Content-Type: " <> decodeUtf8 b
            _   -> Left $ APGetErrorContentType "Multiple Content-Type"

data APPostError
    = APPostErrorSig S.HttpSigGenError
    | APPostErrorHTTP HttpException
    deriving Show

instance Exception APPostError

hActivityPubForwarder :: HeaderName
hActivityPubForwarder = "ActivityPub-Forwarder"

hForwardingSignature :: HeaderName
hForwardingSignature = "Forwarding-Signature"

hForwardedSignature :: HeaderName
hForwardedSignature = "Forwarded-Signature"

-- | Perform an HTTP POST request to submit an ActivityPub object.
--
-- * Verify the URI scheme is _https:_ and authority part is present
-- * Set _Content-Type_ request header
-- * Set _ActivityPub-Actor_ request header
-- * Set _Digest_ request header using SHA-256 hash
-- * If recipient is given, set _ActivityPub-Forwarder_ header and compute
--   _Forwarding-Signature_ header
-- * If forwarded signature is given, set set _ActivityPub-Forwarder_ and
--   _Forwarded-Signature_ headers
-- * Compute HTTP signature and add _Signature_ request header
-- * Perform the POST request
-- * Verify the response status is 2xx
httpPostAP
    :: (MonadIO m, ToJSON a)
    => Manager
    -> FedURI
    -> NonEmpty HeaderName
    -> S.KeyId
    -> (ByteString -> S.Signature)
    -> Text
    -> Maybe (Either FedURI ByteString)
    -> a
    -> m (Either APPostError (Response ()))
httpPostAP manager uri headers keyid sign uSender mfwd value =
    httpPostAPBytes manager uri headers keyid sign uSender mfwd $ encode value

-- | Like 'httpPostAP', except it takes the object as a raw lazy
-- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
httpPostAPBytes
    :: MonadIO m
    => Manager
    -> FedURI
    -> NonEmpty HeaderName
    -> S.KeyId
    -> (ByteString -> S.Signature)
    -> Text
    -> Maybe (Either FedURI ByteString)
    -> BL.ByteString
    -> m (Either APPostError (Response ()))
httpPostAPBytes manager uri headers keyid sign uSender mfwd body =
    liftIO $ runExceptT $ do
        req <- requestFromURI $ toURI uri
        let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
            req' =
                setRequestCheckStatus $
                consHeader hContentType typeActivityStreams2LD $
                consHeader hActivityPubActor (encodeUtf8 uSender) $
                consHeader hDigest digest $
                req { method      = "POST"
                    , requestBody = RequestBodyLBS body
                    }
        req'' <- tryExceptT APPostErrorSig $ signRequest headers Nothing keyid sign Nothing req'
        req''' <-
            case mfwd of
                Nothing -> return req''
                Just (Left uRecip) ->
                    tryExceptT APPostErrorSig $
                        signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign Nothing $ consHeader hActivityPubForwarder (encodeUtf8 $ renderFedURI uRecip) req''
                Just (Right sig) ->
                    return $
                        consHeader hForwardedSignature sig $
                        consHeader hActivityPubForwarder (encodeUtf8 uSender)
                            req''
        tryExceptT APPostErrorHTTP $ httpNoBody req''' manager
    where
    consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
    tryExceptT adapt action = ExceptT $ first adapt <$> try action

-- | Result of GETing the keyId URI and processing the JSON document.
data Fetched = Fetched
    { fetchedPublicKey  :: PublicVerifKey
      -- ^ The Ed25519 or RSA public key corresponding to the URI we requested.
    , fetchedKeyExpires :: Maybe UTCTime
      -- ^ Optional expiration time declared for the key we received.
    , fetchedActorId    :: LocalURI
      -- ^ The @id URI of the actor for whom the key's signature applies.
    , fetchedActorName  :: Maybe Text
      -- ^ Name of the actor for whom the key's signature applies.
    , fetchedActorInbox :: LocalURI
      -- ^ The inbox URI of the actor for whom the key's signature applies.
    , fetchedKeyShared  :: Bool
      -- ^ Whether the key we received is shared. A shared key can sign
      --   requests for any actor on the same instance, while a personal key is
      --   only for one actor. Knowing whether the key is shared will allow us
      --   when receiving more requests, whether to accept signatures made on
      --   different actors, or allow only a single permanent actor for the key
      --   we received.
    }

fetchAP' :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT APGetError m a
fetchAP' m u = ExceptT $ second responseBody <$> httpGetAP m u

fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a
fetchAP m u = withExceptT displayException $ fetchAP' m u

{-
fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a
fetchAPH m h lu = do
    Doc h' v <- fetchAP m $ l2f h lu
    if h == h'
        then return v
        else throwE "Object @id URI's host doesn't match the URI we fetched"
-}

fetchAPID' :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either (Maybe APGetError) a)
fetchAPID' m getId h lu = runExceptT $ do
    Doc h' v <- withExceptT Just $ fetchAP' m $ l2f h lu
    if h == h' && getId v == lu
        then return v
        else throwE Nothing

fetchRecipient :: MonadIO m => Manager -> Text -> LocalURI -> m (Either (Maybe APGetError) Recipient)
fetchRecipient m = fetchAPID' m getId
    where
    getId (RecipientActor a)      = actorId a
    getId (RecipientCollection c) = collectionId c

fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a)
fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
    where
    showError Nothing  = "Object @id doesn't match the URI we fetched"
    showError (Just e) = displayException e

data FetchAPError
    = FetchAPErrorGet APGetError
    -- Object @id doesn't match the URI we fetched
    | FetchAPErrorIdMismatch
    -- Object @id URI's host doesn't match the URI we fetched
    | FetchAPErrorHostMismatch
    deriving Show

fetchAPIDOrH'
    :: (MonadIO m, ActivityPub a, ActivityPub b)
    => Manager
    -> (a -> LocalURI)
    -> Text
    -> LocalURI
    -> ExceptT FetchAPError m (Either a b)
fetchAPIDOrH' m getId h lu = do
    e <- withExceptT FetchAPErrorGet $ fetchAP' m $ l2f h lu
    case e of
        Left' (Doc h' x) ->
            if h == h' && getId x == lu
                then return $ Left x
                else throwE FetchAPErrorIdMismatch
        Right' (Doc h' y) ->
            if h == h'
                then return $ Right y
                else throwE FetchAPErrorHostMismatch

fetchAPIDOrH
    :: (MonadIO m, ActivityPub a, ActivityPub b)
    => Manager
    -> (a -> LocalURI)
    -> Text
    -> LocalURI
    -> ExceptT String m (Either a b)
fetchAPIDOrH m getId h lu = withExceptT show $ fetchAPIDOrH' m getId h lu

-- | Fetches the given actor and checks whether it lists the given key (as a
-- URI, not as an embedded object). If it does, returns 'Right' the fetched
-- actor. Otherwise, or if an error occurs during fetching, returns 'Left' an
-- error message.
keyListedByActor :: MonadIO m => Manager -> Text -> LocalURI -> LocalURI -> m (Either String Actor)
keyListedByActor manager host luKey luActor = runExceptT $ do
    actor <- ExceptT $ fetchAPID manager actorId host luActor
    if keyUriListed luKey actor
        then return actor
        else throwE "Actor publicKey has no URI matching pkey @id"
    where
    keyUriListed uk a =
        let match (Left uri) = uri == uk
            match (Right _)  = False
        in  any match $ actorPublicKeys a

matchKeyObj :: (Foldable f, Monad m) => LocalURI -> f (Either LocalURI PublicKey) -> ExceptT String m PublicKey
matchKeyObj luKey es =
    case find' (match luKey) es of
        Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
        Just pk -> return pk
    where
    find' :: Foldable f => (a -> Maybe b) -> f a -> Maybe b
    find' p = join . fmap getFirst . foldMap (Just . First . p)
    match _   (Left _)   = Nothing
    match luk (Right pk) =
        if publicKeyId pk == luk
            then Just pk
            else Nothing

verifyAlgo :: Maybe S.Algorithm -> PublicVerifKey -> Either String ()
verifyAlgo Nothing  _ = Right ()
verifyAlgo (Just a) k =
    case a of
        S.AlgorithmEd25519 ->
            case k of
                PublicVerifKeyEd25519 _ -> Right ()
                PublicVerifKeyRSA _ ->
                    Left "Algo mismatch, algo is Ed25519 but actual key is RSA"
        S.AlgorithmRsaSha256 ->
            case k of
                PublicVerifKeyEd25519 _ ->
                    Left
                        "Algo mismatch, algo is RSA-SHA256 but actual key is \
                        \Ed25519"
                PublicVerifKeyRSA _ -> Right ()
        S.AlgorithmOther b -> Left $ concat
            [ "Unrecognized algo "
            , BC.unpack b
            , ", actual key is "
            , case k of
                PublicVerifKeyEd25519 _ -> "Ed25519"
                PublicVerifKeyRSA     _ -> "RSA"
            ]

-- | Fetch a key we don't have cached locally.
fetchUnknownKey
    :: MonadIO m
    => Manager
    -- ^ Manager for making HTTP requests
    -> Maybe S.Algorithm
    -- ^ Signature algorithm possibly specified in the HTTP signature header
    -> Text
    -- ^ Instance host
    -> Maybe LocalURI
    -- ^ Actor URI possibly provided in the HTTP request's actor header
    -> LocalURI
    -- ^ Key URI provided in HTTP signature header
    -> ExceptT String m Fetched
fetchUnknownKey manager malgo host mluActor luKey = do
    obj <- fetchAPIDOrH manager publicKeyId host luKey
    fetched <-
        case obj of
            Left pkey -> do
                (oi, luActor) <-
                    case publicKeyOwner pkey of
                        OwnerInstance ->
                            case mluActor of
                                Nothing -> throwE "Key is shared but actor header not specified!"
                                Just u  -> return (True, u)
                        OwnerActor owner -> do
                            for_ mluActor $ \ lu ->
                                if owner == lu
                                    then return ()
                                    else throwE "Key's owner doesn't match actor header"
                            return (False, owner)
                actor <- ExceptT $ keyListedByActor manager host luKey luActor
                return Fetched
                    { fetchedPublicKey  = publicKeyMaterial pkey
                    , fetchedKeyExpires = publicKeyExpires pkey
                    , fetchedActorId    = luActor
                    , fetchedActorName  = actorName actor <|> actorUsername actor
                    , fetchedActorInbox = actorInbox actor
                    , fetchedKeyShared  = oi
                    }
            Right actor -> do
                if actorId actor == luKey { luriFragment = "" }
                    then return ()
                    else throwE "Actor ID doesn't match the keyid URI we fetched"
                for_ mluActor $ \ lu ->
                    if actorId actor == lu
                        then return ()
                        else throwE "Key's owner doesn't match actor header"
                pk <- matchKeyObj luKey $ actorPublicKeys actor
                owner <- case publicKeyOwner pk of
                    OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
                    OwnerActor owner ->
                        if owner == actorId actor
                            then return owner
                            else throwE "Actor's publicKey's owner doesn't match the actor's ID"
                return Fetched
                    { fetchedPublicKey  = publicKeyMaterial pk
                    , fetchedKeyExpires = publicKeyExpires pk
                    , fetchedActorId    = owner
                    , fetchedActorName  = actorName actor <|> actorUsername actor
                    , fetchedActorInbox = actorInbox actor
                    , fetchedKeyShared  = False
                    }
    ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched
    return fetched

keyDetail pk = (publicKeyMaterial pk, publicKeyExpires pk)

-- | Fetch a personal key we already have cached locally, but we'd like to
-- refresh the local copy by fetching the key again from the server.
fetchKnownPersonalKey
    :: MonadIO m
    => Manager
    -- ^ Manager for making HTTP requests
    -> Maybe S.Algorithm
    -- ^ Signature algorithm possibly specified in the HTTP signature header
    -> Text
    -- ^ Instance host
    -> LocalURI
    -- ^ Key owner actor ID URI
    -> LocalURI
    -- ^ Key URI
    -> ExceptT String m (PublicVerifKey, Maybe UTCTime)
fetchKnownPersonalKey manager malgo host luOwner luKey = do
    obj <- fetchAPIDOrH manager publicKeyId host luKey
    (material, mexpires) <-
        case obj of
            Left pkey -> do
                case publicKeyOwner pkey of
                    OwnerInstance -> throwE "Personal key became shared"
                    OwnerActor owner ->
                        when (luOwner /= owner) $ throwE "Key owner changed"
                return $ keyDetail pkey
            Right actor -> do
                when (actorId actor /= luKey { luriFragment = "" }) $
                    throwE "Actor ID doesn't match the keyid URI we fetched"
                when (actorId actor /= luOwner) $
                    throwE "Key owner changed"
                pk <- matchKeyObj luKey $ actorPublicKeys actor
                case publicKeyOwner pk of
                    OwnerInstance -> throwE "Personal key became shared"
                    OwnerActor owner ->
                        when (owner /= luOwner) $
                            throwE "Actor's publicKey's owner doesn't match the actor's ID"
                return $ keyDetail pk
    ExceptT . pure $ verifyAlgo malgo material
    return (material, mexpires)

-- | Fetch a shared key we already have cached locally, but we'd like to
-- refresh the local copy by fetching the key again from the server.
fetchKnownSharedKey
    :: MonadIO m
    => Manager
    -- ^ Manager for making HTTP requests
    -> Maybe S.Algorithm
    -- ^ Signature algorithm possibly specified in the HTTP signature header
    -> Text
    -- ^ Instance host
    -> LocalURI
    -- ^ Actor ID from HTTP actor header
    -> LocalURI
    -- ^ Key URI
    -> ExceptT String m (PublicVerifKey, Maybe UTCTime)
fetchKnownSharedKey manager malgo host luActor luKey = do
    obj <- fetchAPIDOrH manager publicKeyId host luKey
    pkey <-
        case obj :: Either PublicKey Actor of
            Left pk -> return pk
            Right _actor -> throwE "Expected stand-alone key, got embedded key"
    case publicKeyOwner pkey of
        OwnerInstance -> return ()
        OwnerActor _owner -> throwE "Shared key became personal"
    let (material, mexpires) = keyDetail pkey
    ExceptT . pure $ verifyAlgo malgo material
    return (material, mexpires)