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

import Data.Bool
import Data.Eq (Eq(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.String (String)
import Prelude (and, pure)
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.Mime

-- * Class 'HTTP_API'
class
 ( Cat              repr
 , Alt              repr
 -- , Pro              repr
 , HTTP_Version     repr
 , HTTP_Path        repr
 , HTTP_Header      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 is 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

-- | Convenient wrapper of 'segment'.
(</>) :: Cat repr => HTTP_Path repr => Segment -> repr a b -> repr a b
(</>) n = (segment n <.>); infixr 5 </>

-- | 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_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 a mt k.
	 MimeUnserialize a mt =>
	 MimeSerialize a mt =>
	 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 a mt k repr.
 HTTP_Body repr =>
 MimeUnserialize a mt =>
 MimeSerialize a mt =>
 repr (BodyArg repr mt a -> k) k
body = body' @repr
{-# INLINE body #-}

{-
data AcceptResponse repr a =
 forall mt. MimeSerialize a mt =>
 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 a mt =>
	 MimeSerialize a mt =>
	 k ~ Response repr =>
	 HTTP.Method ->
	 repr (ResponseArg repr mt a -> k) k

-- | Wrap 'response' by giving it the corresponding 'HTTP.Method',
-- and put the type variables 'a' then 'mt' first instead or 'repr'
-- so they can be passed using 'TypeApplications'
-- without adding a '@_' for 'repr'.
get,head,put,post,delete,trace,connect,options,patch ::
 forall a mt k repr.
 HTTP_Response repr =>
 MimeUnserialize a mt =>
 MimeSerialize a mt =>
 k ~ Response repr =>
 repr (ResponseArg repr mt a -> k) k
get     = response HTTP.methodGet
head    = response HTTP.methodHead
put     = response HTTP.methodPut
post    = response HTTP.methodPost
delete  = response HTTP.methodDelete
trace   = response HTTP.methodTrace
connect = response HTTP.methodConnect
options = response HTTP.methodOptions
patch   = response HTTP.methodPatch
{-# INLINE get     #-}
{-# INLINE head    #-}
{-# INLINE put     #-}
{-# INLINE post    #-}
{-# INLINE delete  #-}
{-# INLINE trace   #-}
{-# INLINE connect #-}
{-# INLINE options #-}
{-# INLINE patch   #-}