{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StrictData #-}
-- | Combinators to build a Web API.
module Symantic.HTTP.API where

import Control.Monad (Monad(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Functor (Functor)
import Data.Kind (Constraint)
import Data.Proxy (Proxy)
import Data.String (String)
import Data.Text (Text)
import Prelude (and)
import System.IO (IO)
import Text.Show (Show(..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Network.HTTP.Types as HTTP

-- * Class 'Cat'
-- | A soft and cute animal asking strokes and croquettes.
-- Or rather here a composition of two combinators
-- (as in a category without an identity morphism).
--
-- Note that the order of combinators generally matters (the left one is applied first),
-- with the notable exception of the server instance
-- where some HTTP error codes must be prioritized.
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'
-- | There are two choices, either the right one or the left one.
-- The (':!:') data type will be used in the instances
-- to get multiple client callers or to supply multiple server handlers.
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
-- (eg. 'queryFlag' wrt. 'queryParams'),
-- by calling it directly in the class declaration
-- instead of rewriting its logic in the instance declaration.
--
-- 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 a (ts::[*]) :: *
	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' without 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 @a @ts
{-# INLINE body #-}

-- * Class 'HTTP_BodyStream'
class HTTP_BodyStream repr where
	type BodyStreamArg repr as (ts::[*]) framing :: *
	type BodyStreamConstraint repr as (ts::[*]) framing :: Constraint
	type BodyStreamConstraint repr as ts framing = ()
	bodyStream' ::
	 BodyStreamConstraint repr as ts framing =>
	 repr (BodyStreamArg repr as ts framing -> k) k

-- | Like 'bodyStream'' but with the type variables 'as', 'ts' and 'framing'
-- first instead or 'repr', so it can be passed using 'TypeApplications'
-- without adding a @@_@ for 'repr'.
bodyStream ::
 forall as ts framing k repr.
 HTTP_BodyStream repr =>
 BodyStreamConstraint repr as ts framing =>
 repr (BodyStreamArg repr as ts framing -> k) k
bodyStream = bodyStream' @repr @as @ts @framing
{-# INLINE bodyStream #-}

-- * 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 return (queryParams' n)
type QueryName   = BS.ByteString
type QueryValue  = BS.ByteString

-- | Like 'capture'' but with the type variable 'a' first instead or 'repr'
-- so it can be passed using 'TypeApplications' without adding a @@_@ for 'repr'.
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

-- | Like 'basicAuth'' but with the type variable 'a' first instead or 'repr'
-- so it can be passed using 'TypeApplications' without adding a @@_@ for 'repr'.
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

{- TODO: see if this is useful somewhere.
-- * 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   #-}

-- * Class 'HTTP_ResponseStream'
class HTTP_ResponseStream repr where
	type ResponseStreamConstraint repr as (ts::[*]) framing :: Constraint
	type ResponseStreamConstraint repr as ts framing = ()
	type ResponseStreamArgs repr as (ts::[*]) framing :: *
	type ResponseStream repr :: *
	responseStream ::
	 ResponseStreamConstraint repr as ts framing =>
	 HTTP.Method ->
	 repr (ResponseStreamArgs repr as ts framing)
	      (ResponseStream repr)

getStream,headStream,putStream,postStream,deleteStream,traceStream,connectStream,optionsStream,patchStream ::
 forall as ts framing repr.
 HTTP_ResponseStream repr =>
 ResponseStreamConstraint repr as ts framing =>
 repr (ResponseStreamArgs repr as ts framing)
      (ResponseStream repr)
getStream     = responseStream @repr @as @ts @framing HTTP.methodGet
headStream    = responseStream @repr @as @ts @framing HTTP.methodHead
putStream     = responseStream @repr @as @ts @framing HTTP.methodPut
postStream    = responseStream @repr @as @ts @framing HTTP.methodPost
deleteStream  = responseStream @repr @as @ts @framing HTTP.methodDelete
traceStream   = responseStream @repr @as @ts @framing HTTP.methodTrace
connectStream = responseStream @repr @as @ts @framing HTTP.methodConnect
optionsStream = responseStream @repr @as @ts @framing HTTP.methodOptions
patchStream   = responseStream @repr @as @ts @framing HTTP.methodPatch
{-# INLINE getStream     #-}
{-# INLINE headStream    #-}
{-# INLINE putStream     #-}
{-# INLINE postStream    #-}
{-# INLINE deleteStream  #-}
{-# INLINE traceStream   #-}
{-# INLINE connectStream #-}
{-# INLINE optionsStream #-}
{-# INLINE patchStream   #-}

-- * Framing
-- ** Type family 'FramingMonad'
type family FramingMonad  p :: * -> *
-- ** Type family 'FramingYield'
type family FramingYield  p :: *
-- ** Type family 'FramingReturn'
type family FramingReturn p :: *

-- ** Class 'FramingEncode'
class FramingEncode framing p where
	framingEncode ::
	 Proxy framing ->
	 {-mimeEncode-}(FramingYield p -> BSL.ByteString) ->
	 p -> IO (Either (FramingReturn p) (BSL.ByteString, p))

-- ** Class 'FramingDecode'
class FramingDecode framing p where
	framingDecode ::
	 FramingMonad p ~ m =>
	 Monad m =>
	 Proxy framing ->
	 {-mimeDecode-}(BSL.ByteString -> Either String (FramingYield p)) ->
	 m BS.ByteString -> p

-- ** Type 'NoFraming'
-- | A framing strategy that does not do any framing at all,
-- it just passes the input data.
-- Most of the time this will be used with binary data, such as files.
data NoFraming

-- ** Type 'NewlineFraming'
-- | A simple framing strategy that has no header,
-- and inserts a newline character after each frame.
-- WARNING: this assumes that it is used with a Content-Type
-- that encodes without newlines (e.g. JSON).
data NewlineFraming

-- ** Type 'NetstringFraming'
-- | The netstring framing strategy as defined by djb:
-- <http://cr.yp.to/proto/netstrings.txt>
--
-- Any string of 8-bit bytes may be encoded as @[len]":"[string]","@.  Here
-- @[string]@ is the string and @[len]@ is a nonempty sequence of ASCII digits
-- giving the length of @[string]@ in decimal. The ASCII digits are @<30>@ for
-- 0, @<31>@ for 1, and so on up through @<39>@ for 9. Extra zeros at the front
-- of @[len]@ are prohibited: @[len]@ begins with @<30>@ exactly when
-- @[string]@ is empty.
--
-- For example, the string @"hello world!"@ is encoded as
-- @<31 32 3a 68 65 6c 6c 6f 20 77 6f 72 6c 64 21 2c>@,
-- i.e., @"12:hello world!,"@.
-- The empty string is encoded as @"0:,"@.
data NetstringFraming