{-# LANGUAGE DisambiguateRecordFields #-}

-- | Exposes an effect for actions involving the ActivityPub protocol.
module Puppy.Protocol.ActivityPub (
  module Puppy.Protocol.ActivityStreams,
  ActivityPub,
  runActivityPub,
  dereference,
  perform,
  deliver,
  genId,
  doDeliverTask,
  doPerformTask,
) where

import Data.Functor ((<&>))
import Effectful
import Effectful.Concurrent.Async (forConcurrently_, Concurrent)
import Effectful.Dispatch.Dynamic
import Effectful.Fail (Fail, runFail)
import Puppy.Context
import Puppy.Crypto.RNG (RNG, genBytes)
import Puppy.Database (DB)
import Puppy.Logging
import Puppy.Protocol.ActivityStreams
import Puppy.Protocol.HTTP (HTTP, post, get, Response (..), Sign)
import Puppy.TaskQueue
import Puppy.Types (Channel (..), ChannelSettings (..))
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.URL as BS
import qualified Puppy.Database as DB
import qualified Puppy.Protocol.ActivityPub.Fetch as F

-- | An effect for talking to other nodes over ActivityPub.
data ActivityPub :: Effect where
  Resolve :: forall obj m. (F.Dereference obj) => Either JSON.Value Id -> ActivityPub m obj
  Perform :: Activity Object -> Channel -> ActivityPub m ()
  Deliver :: Activity Object -> Channel -> ActivityPub m ()

type instance DispatchOf ActivityPub = 'Dynamic

-- | Resolve an `Id` to an ActivityStreams object.
resolve :: (ActivityPub :> es, F.Dereference obj) => Id -> Eff es obj
resolve = send . Resolve . Right

-- | Assume that the given `Value` is the JSON representation of `obj` and attempt to parse it.
dereference :: (ActivityPub :> es, F.Dereference obj) => JSON.Value -> Eff es obj
dereference = send . Resolve . Left

-- | Schedule a perform task for the given activity, using the given channel for request
-- signatures.
perform :: (ActivityPub :> es) => Activity Object -> Channel -> Eff es ()
perform activity channel = send (Perform activity channel)

-- | Schedule a deliver task for the given activity, using the given channel for request
-- signatures.
deliver :: (ActivityPub :> es) => Activity Object -> Channel -> Eff es ()
deliver activity channel = send (Deliver activity channel)

-- | Generate an ActivityPub ID.
genId :: (ServerInfo :> es, RNG :> es) => Eff es Id
genId = do
  suffix <- BS.encodeBase64 <$> genBytes 32
  localId ("/ap/o/" <> suffix)

-- | Run the ActivityPub effect. Object resolution goes through HTTP, whereas the tasks for performing and
-- delivering activities are sent to their associated worker threads.
runActivityPub
  :: (
    TaskQueue DeliverTask :> es,
    TaskQueue PerformTask :> es,
    Fail :> es,
    HTTP :> es,
    Sign :> es,
    Log :> es
  ) => Eff (ActivityPub : es) a
    -> Eff es a
runActivityPub = interpret $ \_ -> \case
  Resolve (Left json) -> F.runFetch json F.dereferencer
  Resolve (Right (Id url)) -> do
    json <- get url >>= parseJSON
    F.runFetch json F.dereferencer
  Perform activity channel -> enqueue (PerformTask activity channel)
  Deliver activity channel -> enqueue (DeliverTask activity channel)
  where
    parseJSON :: (Fail :> es) => Response -> Eff es JSON.Value
    parseJSON (Response { body }) =
      case JSON.decode (BS.fromStrict body) of
        Just value -> pure value
        Nothing -> fail "Couldn't decode body"


doDeliverTask
  :: (
    Concurrent :> es,
    HTTP :> es,
    Sign :> es,
    Log :> es
  ) => Activity Object
    -> Eff es ()
doDeliverTask activity = scope "deliver" $ do
  let payload = preparePayload activity
  -- TODO: Add retry mechanism
  forConcurrently_ (activity.to <> activity.cc) $ \(Inbox inbox) -> do
    debug ("Delivering to: " <> inbox)
    runFail (post payload inbox) >>= \case
      Left _ -> warn ("Failed to deliver to " <> inbox)
      Right resp
        | resp.statusCode > 299 -> warn "Encountered non-200 status code"
        | otherwise -> debug "Delivery OK"
  where
    -- Prepare a payload by folding the `object` field into just the id of the
    -- object instead of the entire thing, and then converting the entire thing
    -- to a JSON value.
    preparePayload :: Activity Object -> JSON.Value
    preparePayload aty = JSON.toJSON $ aty <&> (.id)

doPerformTask
  :: (
    ActivityPub :> es,
    Log :> es,
    DB :> es,
    Fail :> es,
    RNG :> es,
    ServerInfo :> es
  ) => Activity Object
    -> Eff es ()
doPerformTask a = scope "perform" $ do
  DB.storeActivity a
  case a.subtype of
    -- Handle requests to follow between actors.
    Follow | Just (followee :: Actor) <- fromObject a.object
      -> do
        DB.insertFollowRequest (a.actor, followee.id)
        DB.getChannelByActorId followee.id >>= \case
          -- If the channel has follow autoaccept turned on, proceed to automatically accept
          -- the follow request.
          Just channel | channel.settings.autoAcceptFollows -> acceptFollow channel
          Just _  -> debug "Not automatically accepting follow request due to channel settings"
          Nothing -> debug "Follow request does not target a channel, not doing anything"
    Accept | Just o@Activity { subtype = Follow } <- fromObject a.object,
             Just (followee :: Actor) <- fromObject o.object
      -> do
        debug ("Accepting follow request: " <> o.actor.url <> " to " <> followee.id.url)
        DB.acceptFollowRequest (o.actor, followee.id)
    Undo | Just o@Activity { subtype = Follow } <- fromObject a.object,
           Just (followee :: Actor) <- fromObject o.object
      -> do
        debug "Cancelling follow request"
        DB.cancelFollowRequest (o.actor, followee.id)
    ty -> do
      fail ("Combination of activity type " <> show ty <> " and object type unknown")
  where
    -- | Autoaccept a follow request targeting `channel`.
    acceptFollow channel = do
      debug "Automatically accepting follow request for channel"
      reply <- do
        activityId <- genId
        follower :: Actor <- resolve a.actor
        target <- case follower.inbox of
          Just inbox -> pure inbox
          Nothing -> fail "No inbox available for follow requester"
        pure (Activity {
          id      = activityId,
          actor   = Id channel.linkedActorId,
          object  = toObject a,
          to      = [target],
          cc      = [],
          time    = Nothing,
          subtype = Accept
        })
      deliver reply channel
      perform reply channel