module Puppy.Protocol.HTTP (
  HTTP,
  get,
  post,
  Response (..),
  runHTTP,
  runSign,
  Sign,
) where

import Control.Exception (catch)
import Control.Monad (when)
import Data.Functor ((<&>))
import Data.Maybe (fromJust)
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Fail (Fail, runFail)
import Network.HTTP.Conduit (httpLbs, responseBody, Manager, Request (..), RequestBody (RequestBodyBS), responseStatus, parseRequest, HttpException)
import Puppy.Config (version)
import Puppy.Logging
import qualified Data.Aeson                    as JSON
import qualified Data.ByteString               as BS
import qualified Data.ByteString.Lazy          as LBS
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as T
import qualified Puppy.Protocol.HTTP.Signature as S

data Response
  = Response {
    statusCode :: Int,
    body :: BS.ByteString
  }

data Req 
  = POST {
    url :: Text,
    payload :: LBS.ByteString
  }
  | GET {
    url :: Text
  }

data Sign :: Effect where
  GetKey :: Sign m S.Signer

type instance DispatchOf Sign = 'Dynamic

runSign :: S.KeySource s => s -> Eff (Sign : es) a -> Eff es a
runSign key = interpret $ \_ -> \case
  GetKey -> return (S.toSigner key)

-- * Effect

-- | An effect for performing actions related to the HTTP protocol, such as executing
-- requests.
data HTTP :: Effect where
  Exec :: Req -> S.Signer -> HTTP m (Either String Response)

type instance DispatchOf HTTP = 'Dynamic

-- * Actions

-- | POST a JSON payload to a URL.
post :: (HTTP :> es, Fail :> es, Sign :> es, JSON.ToJSON body) => body -> Text -> Eff es Response
post body url = do
  key <- send GetKey
  res <- send (Exec (POST { payload = JSON.encode body, url }) key)
  either fail return res

-- | GET a response from a URL.
get :: (HTTP :> es, Fail :> es, Sign :> es) => Text -> Eff es Response
get url = do
  key <- send GetKey
  res <- send (Exec (GET { url }) key)
  either fail return res

-- * Handlers

runHTTP
  :: (IOE :> es, Log :> es)
  => Manager
  -> Eff (HTTP : es) a
  -> Eff es a
runHTTP manager = interpret $ \_ -> \case
  Exec req signer -> runFail $ do
    request <- withSeqEffToIO (parse req.url)
    case req of
      GET {} -> execute signer request Nothing manager
      POST { payload } -> execute signer
        (request { method = "POST" })
        (Just $ BS.toStrict payload)
        manager
  where
    parse :: (IOE :> xs, Fail :> xs)
          => Text
          -> (forall r. Eff xs r -> IO r)
          -> IO Request
    parse url unlift = catch
      (parseRequest (T.unpack url))
      (\(exc :: HttpException) -> unlift (fail ("HTTP exception: " <> show exc)))
      

-- * Helpers

-- Actually execute an HTTP request.
execute
  :: (IOE :> es, Log :> es, Fail :> es)
  => S.Signer
  -> Request
  -- ^ URL
  -> Maybe BS.ByteString
  -- ^ Request body
  -> Manager
  -- ^ HTTP client
  -> Eff es Response
execute signer raw body client = do
  now <- liftIO getCurrentTime
  let attachBody r bytes = r {
         requestBody = RequestBodyBS bytes,
         requestHeaders = [
           ("content-type", "application/activity+json"),
           ("digest", S.makeDigestHeader bytes)
         ]
       }
      unsigned | Nothing <- body = raw
               | Just bytes <- body = raw `attachBody` bytes
      -- Propagate a failure
      unwrap = either fail pure
      mkParams | "POST" <- raw.method = S.POST (fromJust body)
               | otherwise = S.GET
      params = mkParams raw.host raw.path now
  req <- unwrap $ S.makeSignature signer params <&> \sig ->
    (unsigned {
      requestHeaders
        = ("accept", "application/activity+json")
        : ("date", S.fmtDateHeader now)
        : ("signature", S.fmtSignature sig)
        : ("user-agent", "ActivityPuppy/" <> version)
        : unsigned.requestHeaders
    })
  res <- withSeqEffToIO $ \unlift -> do
    httpLbs req client `catch` \(exc :: HttpException) -> do
      unlift (fail ("HTTP exception: " <> show exc))
  when (fromEnum (responseStatus res) `elem` [400 .. 599]) $ do
    warn ("Error response code: " <> T.pack (show (responseStatus res)))
    debug ("Error response body: " <> T.decodeUtf8 (BS.toStrict (responseBody res)))
  return (Response {
    body = BS.toStrict (responseBody res),
    statusCode = fromEnum (responseStatus res)
  })