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

import Data.Bool
import Data.Eq (Eq(..))
import Data.Functor (Functor)
import Data.Kind (Constraint)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.String (String)
import Prelude (and, pure)
import System.IO (IO)
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_Query     repr
 -- , HTTP_BasicAuth 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'.
-- Used to get alternative commands from a 'Client'
-- or to supply alternative handlers to a 'Server'.
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' si asked by a 'Client' but given to 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

-- * Type family 'HttpApiData'
-- | Either 'Web.ToHttpApiData' for a 'Client',
-- or 'Web.FromHttpApiData' for a 'Server'.
type family HttpApiData (repr:: * -> * -> *) :: * -> Constraint

-- * Class 'HTTP_Path'
class HTTP_Path repr where
	segment :: Segment -> repr k k
	capture' ::
	 HttpApiData repr 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 =>
 HttpApiData repr 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_Query'
class HTTP_Query repr where
	queryParams' ::
	 HttpApiData repr a =>
	 QueryName -> repr ([a] -> k) k
	queryFlag ::
	 HttpApiData repr Bool =>
	 QueryName -> repr (Bool -> k) k
	default queryFlag ::
	 Pro repr =>
	 HttpApiData repr Bool =>
	 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 =>
 HttpApiData repr a =>
 QueryName -> repr ([a] -> k) k
queryParams = queryParams'
{-# INLINE queryParams #-}

-- * Class 'HTTP_Auth'
-- | <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>
class HTTP_BasicAuth repr where
	type BasicAuthable repr :: * -> * -> Constraint
	basicAuth' ::
	 BasicAuthable repr context a =>
	 BasicAuthRealm -> context -> repr (a -> k) k

basicAuth ::
 forall a context k repr.
 HTTP_BasicAuth repr =>
 BasicAuthable repr context a =>
 BasicAuthRealm ->
 context -> repr (a -> k) k
basicAuth = basicAuth' @repr @context @a
{-# INLINE basicAuth #-}

-- ** Type 'BasicAuth'
data BasicAuth usr
 =   BasicAuth_Authorized usr
 |   BasicAuth_BadPassword
 |   BasicAuth_NoSuchUser
 |   BasicAuth_Unauthorized
 deriving (Eq, Show, Functor)

type BasicAuthRealm = BS.ByteString
type BasicAuthName  = BS.ByteString
type BasicAuthPass  = BS.ByteString

-- * 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

-- * 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   #-}