{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Symantic.HTTP.API
 ( module Symantic.HTTP.API
 ) where

import Data.Bool
import Prelude (and, pure)
import Data.Eq (Eq(..))
-- import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.String (String)
import Text.Show (Show(..))
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Network.HTTP.Types as HTTP
import qualified Web.HttpApiData as Web

import Symantic.HTTP.Media
import Symantic.HTTP.Mime

-- * Class 'HTTP_API'
class
 ( Cat              repr
 , Alt              repr
 -- , Pro              repr
 , HTTP_Version     repr
 , HTTP_Path        repr
 , HTTP_Method      repr
 , HTTP_Header      repr
 , HTTP_Accept      repr
 -- , HTTP_ContentType repr
 , HTTP_Query  repr
 , HTTP_Response    repr
 ) => HTTP_API (repr:: * -> * -> *)

-- * Class 'Cat'
class Cat repr where
	(<.>) :: repr a b -> repr b c -> repr a c; infixl 4 <.>
	-- (.>)  :: repr x y -> repr a c -> repr a c; infixl 4  .>

-- * Class 'Alt'
class Alt repr where
	{-
	type AltMerge repr :: * -> * -> *
	(<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
	-}
	(<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
	-- try :: repr k k -> repr k k
	-- option :: k -> repr k k -> repr k k

-- ** Type ':!:'
-- Like '(,)' but 'infixl'.
data (:!:) a b = a:!:b
infixl 3 :!:

-- * Class 'Pro'
-- | Mainly useful to write a combinator which a specialization of another,
-- by calling it instead of rewriting its logic.
-- Because 'a' is asked in a client but given in a server,
-- both @a->b@ and @b->a@ are used. This is reminiscent of a 'Profunctor'.
-- Hence the names 'Pro' and 'dimap'.
class Pro repr where
	dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k

-- * Class 'HTTP_Path'
class HTTP_Path repr where
	segment  :: Segment -> repr k k
	capture' ::
	 Web.FromHttpApiData a =>
	 Web.ToHttpApiData a =>
	 Name -> repr (a -> k) k
	captureAll :: repr ([Segment] -> k) k

-- | Like |capture'| but with the type variable 'a' first instead or 'repr'
-- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
capture ::
 forall a k repr.
 HTTP_Path repr =>
 Web.FromHttpApiData a =>
 Web.ToHttpApiData a =>
 Name -> repr (a -> k) k
capture = capture'
{-# INLINE capture #-}

type Segment     = T.Text
type Path        = [Segment]
type Name        = String

-- * Class 'HTTP_Method'
class HTTP_Method repr where
	method         :: HTTP.Method -> repr k k
	method_GET     :: repr k k
	method_POST    :: repr k k
	method_HEAD    :: repr k k
	method_PUT     :: repr k k
	method_DELETE  :: repr k k
	method_TRACE   :: repr k k
	method_CONNECT :: repr k k
	method_OPTIONS :: repr k k
	method_PATCH   :: repr k k
	method_GET     = method HTTP.methodGet
	method_HEAD    = method HTTP.methodHead
	method_PUT     = method HTTP.methodPut
	method_POST    = method HTTP.methodPost
	method_DELETE  = method HTTP.methodDelete
	method_TRACE   = method HTTP.methodTrace
	method_CONNECT = method HTTP.methodConnect
	method_OPTIONS = method HTTP.methodOptions
	method_PATCH   = method HTTP.methodPatch

-- * Class 'HTTP_Header'
class HTTP_Header repr where
	header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
type HeaderValue = BS.ByteString

-- * Class 'HTTP_Body'
class HTTP_Body repr where
	type BodyArg repr :: * -> * -> *
	body' ::
	 forall mt a k.
	 MimeUnserialize mt a =>
	 MimeSerialize mt a =>
	 repr (BodyArg repr mt a -> k) k

-- | Like |body'| but with the type variables 'a' and 'mt' first instead or 'repr'
-- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
body ::
 forall mt a k repr.
 HTTP_Body repr =>
 MimeUnserialize mt a =>
 MimeSerialize mt a =>
 repr (BodyArg repr mt a -> k) k
body = body' @repr @mt
{-# INLINE body #-}

-- * Class 'HTTP_Accept'
class HTTP_Accept repr where
	accept :: MediaTypeable mt => Proxy mt -> repr k k
	{-
	acceptCase :: Functor repr => Alt repr => [AcceptResponse repr a] -> repr BSL.ByteString
	acceptCase [] = tina $> BSL.empty
	acceptCase (AcceptResponse (mt,r) : rs) = try (accept mt r) <+> acceptCase rs
	-}
{-
data AcceptResponse repr a =
 forall mt. MimeSerialize mt a =>
 AcceptResponse (Proxy mt, repr a)
-}
-- * Class 'HTTP_Content'
class HTTP_ContentType repr where
	contentType :: MediaTypeable mt => Proxy mt -> repr k k

-- * Class 'HTTP_Query'
class HTTP_Query repr where
	queryParams' ::
	 Web.FromHttpApiData a =>
	 Web.ToHttpApiData a =>
	 QueryName -> repr ([a] -> k) k
	queryFlag :: QueryName -> repr (Bool -> k) k
	default queryFlag :: Pro repr => QueryName -> repr (Bool -> k) k
	queryFlag n = dimap and pure (queryParams' n)
type QueryName   = BS.ByteString
type QueryValue  = BS.ByteString

queryParams ::
 forall a k repr.
 HTTP_Query repr =>
 Web.FromHttpApiData a =>
 Web.ToHttpApiData a =>
 QueryName -> repr ([a] -> k) k
queryParams = queryParams'
{-# INLINE queryParams #-}

-- * Class 'HTTP_Version'
class HTTP_Version repr where
	version :: HTTP.HttpVersion -> repr k k

-- * Class 'HTTP_Status'
class HTTP_Status repr where
	status :: StatusIs -> repr (HTTP.Status -> k) k

-- ** Type 'StatusIs'
data StatusIs
 =   StatusIsInformational
 |   StatusIsSuccessful
 |   StatusIsRedirection
 |   StatusIsClientError
 |   StatusIsServerError
 |   StatusIs HTTP.Status
 deriving (Eq, Ord, Show)
statusIs :: StatusIs -> (HTTP.Status -> Bool)
statusIs = \case
 StatusIsInformational -> HTTP.statusIsInformational
 StatusIsSuccessful    -> HTTP.statusIsSuccessful
 StatusIsRedirection   -> HTTP.statusIsRedirection
 StatusIsClientError   -> HTTP.statusIsClientError
 StatusIsServerError   -> HTTP.statusIsServerError
 StatusIs x            -> \y -> HTTP.statusCode x == HTTP.statusCode y

status200 :: HTTP.Status
status200 = HTTP.mkStatus 200 "Success"
status400 :: HTTP.Status
status400 = HTTP.mkStatus 400 "Bad Request"
status404 :: HTTP.Status
status404 = HTTP.mkStatus 404 "Not Found"
status405 :: HTTP.Status
status405 = HTTP.mkStatus 405 "Method Not Allowed"
status406 :: HTTP.Status
status406 = HTTP.mkStatus 406 "Not Acceptable"
status415 :: HTTP.Status
status415 = HTTP.mkStatus 415 "Unsupported Media Type"

-- * Class 'HTTP_Response'
class HTTP_Response repr where
	type Response repr :: *
	type ResponseArg repr :: * -> * -> *
	response' ::
	 MimeUnserialize mt a =>
	 MimeSerialize mt a =>
	 k ~ Response repr =>
	 HTTP.Method ->
	 repr (ResponseArg repr mt a -> k) k

-- | Like |response'| but with the type variables 'a' and 'mt' first instead or 'repr'
-- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
response ::
 forall mt a k repr.
 HTTP_Response repr =>
 MimeUnserialize mt a =>
 MimeSerialize mt a =>
 k ~ Response repr =>
 HTTP.Method ->
 repr (ResponseArg repr mt a -> k) k
response = response'
{-# INLINE response #-}