module Okapi.HTTP.Response.Body (
    Body (..),
    IsoJson,
    ParseError (..),
    parser,
    printer,
    raw,
    json,
    html,
    noContent,
) where

import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as LBS
import Data.Kind (Type)
import Data.OpenApi (ToSchema)
import Lucid (Html, renderBS)
import Okapi.Tree (Failure, Parser, Printer, Context)
import Okapi.Tree qualified as Tree
import Okapi.Tree (Tree (..))
import Okapi.Tree qualified as Tree

type IsoJson a = (Aeson.FromJSON a, Aeson.ToJSON a, ToSchema a)

type Body :: Type -> Type
data Body a where
    Raw       :: Body (IO LBS.ByteString)
    Json      :: IsoJson a => Body (IO a)
    NoContent :: Body (IO ())
    Html      :: Body (IO (Html ()))

data ParseError = ParseError deriving (ParseError -> ParseError -> Bool
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
/= :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseError -> ShowS
showsPrec :: Int -> ParseError -> ShowS
$cshow :: ParseError -> String
show :: ParseError -> String
$cshowList :: [ParseError] -> ShowS
showList :: [ParseError] -> ShowS
Show)

type instance Context Body = IO LBS.ByteString
type instance Failure Body = ParseError

jsonDecode :: IsoJson a => LBS.ByteString -> IO a
jsonDecode :: forall a. IsoJson a => ByteString -> IO a
jsonDecode ByteString
bs = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
bs of
    Left String
err -> String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right a
x  -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

parser :: Tree Body i o -> Parser Body o
parser :: forall i o. Tree Body i o -> Parser Body o
parser = (forall a. Body a -> Parser Body a)
-> Tree Body i o
-> Context Body
-> (Either (Failure Body) o, Context Body)
forall (t :: * -> *) i o.
(forall a. t a -> Parser t a) -> Tree t i o -> Parser t o
Tree.parser Body a -> Parser Body a
forall a. Body a -> Parser Body a
alg
  where
    alg :: Body a -> Parser Body a
    alg :: forall a. Body a -> Parser Body a
alg Body a
Raw       Context Body
ioLbs = (a -> Either ParseError a
forall a b. b -> Either a b
Right a
Context Body
ioLbs,                  ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty)
    alg Body a
Json      Context Body
ioLbs = (a -> Either ParseError a
forall a b. b -> Either a b
Right (IO ByteString
Context Body
ioLbs IO ByteString -> (ByteString -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO a
forall a. IsoJson a => ByteString -> IO a
jsonDecode), ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty)
    alg Body a
Html      Context Body
_     = (ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
ParseError,              ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty)
    alg Body a
NoContent Context Body
_     = (a -> Either ParseError a
forall a b. b -> Either a b
Right (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()),              ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty)

printer :: Tree Body i o -> Printer Body i
printer :: forall i o. Tree Body i o -> Printer Body i
printer = (forall a. Body a -> Printer Body a)
-> Tree Body i o -> i -> Context Body
forall (t :: * -> *) i o.
Monoid (Context t) =>
(forall a. t a -> Printer t a) -> Tree t i o -> Printer t i
Tree.printer Body a -> Printer Body a
forall a. Body a -> Printer Body a
alg
  where
    alg :: Body a -> Printer Body a
    alg :: forall a. Body a -> Printer Body a
alg Body a
Raw       a
ioLbs = a
Context Body
ioLbs
    alg Body a
Json      a
ioA   = a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (a -> ByteString) -> IO a -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a
IO a
ioA
    alg Body a
Html      a
ioH   = Html () -> ByteString
forall a. Html a -> ByteString
renderBS (Html () -> ByteString) -> IO (Html ()) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a
IO (Html ())
ioH
    alg Body a
NoContent a
_     = ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty

raw :: Tree Body (IO LBS.ByteString) (IO LBS.ByteString)
raw :: Tree Body (IO ByteString) (IO ByteString)
raw = Body (IO ByteString) -> Tree Body (IO ByteString) (IO ByteString)
forall (t :: * -> *) i. t i -> Tree t i i
Node Body (IO ByteString)
Raw

json :: IsoJson a => Tree Body (IO a) (IO a)
json :: forall a. IsoJson a => Tree Body (IO a) (IO a)
json = Body (IO a) -> Tree Body (IO a) (IO a)
forall (t :: * -> *) i. t i -> Tree t i i
Node Body (IO a)
forall a. IsoJson a => Body (IO a)
Json

html :: Tree Body (IO (Html ())) (IO (Html ()))
html :: Tree Body (IO (Html ())) (IO (Html ()))
html = Body (IO (Html ())) -> Tree Body (IO (Html ())) (IO (Html ()))
forall (t :: * -> *) i. t i -> Tree t i i
Node Body (IO (Html ()))
Html

noContent :: Tree Body (IO ()) (IO ())
noContent :: Tree Body (IO ()) (IO ())
noContent = Body (IO ()) -> Tree Body (IO ()) (IO ())
forall (t :: * -> *) i. t i -> Tree t i i
Node Body (IO ())
NoContent