{-# LANGUAGE DerivingStrategies #-}

-- | Dereferencing 
module Puppy.Protocol.ActivityPub.Fetch (
  Dereference (..),
  Fetch,
  runFetch,
) where

import Control.Applicative (Alternative (..), optional)
import Control.Monad (when)
import Data.Aeson (Key, FromJSON)
import Data.Aeson.KeyMap ((!?))
import Data.ByteString.Lazy (fromStrict)
import Data.Function ((&))
import Data.Maybe (fromJust)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic (interpret)
import Effectful.Fail (Fail (..))
import Effectful.NonDet (NonDet, runNonDet, OnEmptyPolicy (..))
import Effectful.Reader.Static
import Puppy.Crypto.RSA
import Puppy.Protocol.ActivityStreams
import Puppy.Protocol.HTTP
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Text.Encoding as T

-- | A restricted monad for writing dereferencing "scripts".
newtype Fetch o
  = Fetch { eff :: Eff '[Reader State, NonDet, Sign, HTTP, Fail] o }
  deriving newtype (Functor, Applicative, Alternative, Monad, MonadFail)

data State = State { value :: JSON.Value, depth :: Int }

runFetch
  :: (HTTP :> es, Sign :> es, Fail :> es)
  => JSON.Value
  -> Fetch o
  -> Eff es o
runFetch json (Fetch eff) = do
  -- `inject` narrows the list of effects expected by `runNonDet`
  -- to the restricted subset of `eff` (see the `toPoly` example
  -- in the haddocs for `inject`)
  result <- inject eff
    & runBacktrack
    -- Keeping the state is more efficient according to the docs
    & runNonDet OnEmptyKeep
    & runReader (State json 0)
  case result of
    Left _ -> fail "Failed to fetch"
    Right ok -> do
      -- TODO: Add caching here
      pure ok
  where
    -- | Backtrack on failures by triggering NonDet.
    runBacktrack = interpret $ \_ (Fail _) -> empty

class Dereference o where
  dereferencer :: Fetch o

-- | Depth limit to prevent attacks against the dereferencer.
limit :: Int
limit = 10

-- | Fetch a URL from the interwebs.
fetch :: (FromJSON o) => Text -> Fetch o
fetch url = Fetch $ do
  response <- get url
  case JSON.eitherDecode (fromStrict response.body) of
    Left err -> fail ("Error with decoding response: " <> err <> "; data: " <> show response.body)
    Right value -> pure value

deref :: (Dereference o) => Key -> Fetch o
deref key = Fetch $ do
  -- Increment the depth so we don't end up in a dereferencing loop
  local (\st -> st { depth = st.depth + 1 }) $ do
    -- Check depth limiter
    current <- asks depth
    when (current >= limit) $ do
      fail "Depth limit exceeded"
    -- Extract the url to request the data from
    val <- (parse key).eff
    result <- case val of
      JSON.String url -> (fetch url).eff
      JSON.Object _ -> pure val
      _ -> fail ("No url at key " <> show key)
    -- Execute the dereferencer
    runFetch result dereferencer 

parse :: (FromJSON o) => Key -> Fetch o
parse key = Fetch $ do
  val <- asks value
  case extract val >>= decoder of
    Just x  -> pure x
    Nothing -> fail ("Failed to parse field " <> show key)
  where
    decoder = JSON.parseMaybe JSON.parseJSON
    extract = \case { JSON.Object obj -> obj !? key; _ -> Nothing }

focus :: Key -> Fetch o -> Fetch o
focus key action = Fetch $ do
  val <- asks value
  obj <- case val of
    JSON.Object obj -> case obj !? key of
      Just value -> pure value
      Nothing -> fail ("Expected " <> show key <> " to be present")
    -- TODO: catch this case earlier
    _ -> fail "Expected an object"
  local
    (\st -> st { value = obj }) 
    action.eff

instance Dereference o => Dereference (Activity o) where
  dereferencer = Activity
    <$> parse "id"
    <*> parse "actor"
    <*> deref "object"
    <*> (parse "to" <|> pure [])
    <*> (parse "cc" <|> pure [])
    <*> optional (parse "published")
    <*> parse "type"

instance Dereference Actor where
  dereferencer = do
    publicKey <- focus "publicKey" $ do
      PublicKey <$> parse "id" 
                <*> parse "owner"
                <*> (fromJust . decodePublicKey . T.encodeUtf8 <$> parse "publicKeyPem")
    Actor
      <$> parse "id"
      <*> optional (parse "inbox")
      <*> optional (parse "outbox")
      <*> optional (parse "followers")
      <*> optional (parse "following")
      <*> parse "preferredUsername"
      <*> optional (parse "name")
      <*> optional (parse "summary")
      <*> return publicKey
      <*> (parse "manuallyApprovesFollowers" <|> pure True)
      <*> parse "type"

instance Dereference Document where
  dereferencer = Document
    <$> parse "id"
    <*> optional (parse "content")
    <*> optional (parse "summary")
    <*> (parse "type" <|> pure Note)

instance Dereference Object where
  dereferencer = 
    (toObject <$> (dereferencer :: Fetch Actor)) <|>
    (toObject <$> (dereferencer :: Fetch (Activity Object))) <|>
    (toObject <$> (dereferencer :: Fetch Document))