{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StrictData #-}
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.String (String)
import Data.Text (Text)
import Prelude (and, pure)
import Text.Show (Show(..))
import qualified Data.ByteString as BS
import qualified Network.HTTP.Types as HTTP

-- * 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 type @a@ is 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

-- * Class 'HTTP_Path'
class HTTP_Path repr where
	type PathConstraint repr a :: Constraint
	type PathConstraint repr a = ()
	segment :: Segment -> repr k k
	capture' ::
	 PathConstraint 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 =>
 PathConstraint repr a =>
 Name -> repr (a -> k) k
capture = capture'
{-# INLINE capture #-}

type Segment = 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 :: * -> [*] -> *
	type BodyConstraint repr a (ts::[*]) :: Constraint
	type BodyConstraint repr a ts = ()
	body' ::
	 forall a (ts::[*]) k.
	 BodyConstraint repr a ts =>
	 repr (BodyArg repr a ts -> k) k

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

-- * Class 'HTTP_Query'
class HTTP_Query repr where
	type QueryConstraint repr a :: Constraint
	type QueryConstraint repr a = ()
	queryParams' ::
	 QueryConstraint repr a =>
	 QueryName -> repr ([a] -> k) k
	queryFlag ::
	 QueryConstraint repr Bool =>
	 QueryName -> repr (Bool -> k) k
	default queryFlag ::
	 Pro repr =>
	 QueryConstraint 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 =>
 QueryConstraint repr a =>
 QueryName -> repr ([a] -> k) k
queryParams = queryParams'
{-# INLINE queryParams #-}

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

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

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

type BasicAuthRealm = Text
type BasicAuthUser  = Text
type BasicAuthPass  = Text

-- * 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 ResponseConstraint repr a (ts::[*]) :: Constraint
	type ResponseConstraint repr a ts = ()
	type ResponseArgs repr a (ts::[*]) :: *
	type Response repr :: *
	response ::
	 ResponseConstraint repr a ts =>
	 HTTP.Method ->
	 repr (ResponseArgs repr a ts)
	      (Response repr)

-- | Wrap 'response' by giving it the corresponding 'HTTP.Method',
-- and put the type variables 'a' then 'ts' 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 ts repr.
 HTTP_Response repr =>
 ResponseConstraint repr a ts =>
 repr (ResponseArgs repr a ts)
      (Response repr)
get     = response @repr @a @ts HTTP.methodGet
head    = response @repr @a @ts HTTP.methodHead
put     = response @repr @a @ts HTTP.methodPut
post    = response @repr @a @ts HTTP.methodPost
delete  = response @repr @a @ts HTTP.methodDelete
trace   = response @repr @a @ts HTTP.methodTrace
connect = response @repr @a @ts HTTP.methodConnect
options = response @repr @a @ts HTTP.methodOptions
patch   = response @repr @a @ts HTTP.methodPatch
{-# INLINE get     #-}
{-# INLINE head    #-}
{-# INLINE put     #-}
{-# INLINE post    #-}
{-# INLINE delete  #-}
{-# INLINE trace   #-}
{-# INLINE connect #-}
{-# INLINE options #-}
{-# INLINE patch   #-}