{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-} -- for type instance defaults
-- | 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.Function ((.))
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 <.>
	-- Trans defaults
	default (<.>) ::
	 Trans repr =>
	 Cat (UnTrans repr) =>
	 repr a b -> repr b c -> repr a c
	x <.> y = noTrans (unTrans x <.> unTrans y)
	-- (.>)  :: 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 <!>
	-- Trans defaults
	default (<!>) ::
	 Trans repr =>
	 Alt (UnTrans repr) =>
	 repr a k -> repr b k -> repr (a:!:b) k
	x <!> y = noTrans (unTrans x <!> unTrans y)
	-- 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 'Trans'
-- | A 'Trans'formation from one representation @('UnTrans t')@ to another one: 't'.
--
-- * 'noTrans' lifts to the identity 'Trans'formation
--   (the one which does nothing wrt. the 'UnTrans'formed @(repr)@esentation).
-- * 'unTrans' unlifts a 'Trans'formed value to its underlying @(repr)@esentation.
--
-- At its @class@ definition,
-- a combinator should be defined with a default value using 'noTrans'.
-- And at its @instance@ definition,
-- a combinator can be overwritten to apply a specific 'Trans'formation for 't'.
class Trans t where
	-- | The @(repr)@esentation that 't' 'Trans'forms.
	type UnTrans t :: * -> * -> *
	-- | Lift the underlying @(repr)@esentation to 't'.
	-- Useful to define a combinator that does nothing in a 'Trans'formation.
	noTrans :: UnTrans t a b -> t a b
	-- | Unlift a @(repr)@esentation. Useful when a 'Trans'formation
	-- combinator needs to access the 'UnTrans'formed @(repr)@esentation,
	-- or at the end to get the underlying 'UnTrans'formed @(repr)@esentation
	-- from the inferred 't' value (eg. in 'server').
	unTrans :: t a b -> UnTrans t a b

-- * 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
	-- Trans defaults
	default dimap ::
	 Trans repr =>
	 Pro (UnTrans repr) =>
	 (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
	dimap a2b b2a = noTrans . dimap a2b b2a . unTrans

-- * Class 'HTTP_Path'
class HTTP_Path repr where
	type PathConstraint repr a :: Constraint
	segment :: PathSegment -> repr k k
	capture' :: PathConstraint repr a => Name -> repr (a -> k) k
	captureAll :: repr ([PathSegment] -> k) k
	-- Trans defaults
	type PathConstraint repr a = PathConstraint (UnTrans repr) a
	default segment ::
	 Trans repr =>
	 HTTP_Path (UnTrans repr) =>
	 PathSegment -> repr k k
	default capture' ::
	 Trans repr =>
	 HTTP_Path (UnTrans repr) =>
	 PathConstraint (UnTrans repr) a =>
	 Name -> repr (a -> k) k
	default captureAll ::
	 Trans repr =>
	 HTTP_Path (UnTrans repr) =>
	 repr ([PathSegment] -> k) k
	segment    = noTrans . segment
	capture'   = noTrans . capture'
	captureAll = noTrans captureAll

-- | Convenient wrapper of 'segment'.
(</>) :: Cat repr => HTTP_Path repr => PathSegment -> 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 PathSegment = Text
type Path = [PathSegment]
type Name = String

-- * Class 'HTTP_Header'
class HTTP_Header repr where
	header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
	-- Trans defaults
	default header ::
	 Trans repr =>
	 HTTP_Header (UnTrans repr) =>
	 HTTP.HeaderName -> repr (HeaderValue -> k) k
	header = noTrans . header

type HeaderValue = BS.ByteString

-- * Class 'HTTP_Body'
class HTTP_Body repr where
	type BodyArg repr a (ts::[*]) :: *
	type BodyConstraint repr a (ts::[*]) :: Constraint
	body' ::
	 BodyConstraint repr a ts =>
	 repr (BodyArg repr a ts -> k) k
	-- Trans defaults
	type BodyArg repr a ts = BodyArg (UnTrans repr) a ts
	type BodyConstraint repr a ts = BodyConstraint (UnTrans repr) a ts
	default body' ::
	 forall a (ts::[*]) k.
	 Trans repr =>
	 HTTP_Body (UnTrans repr) =>
	 BodyConstraint (UnTrans repr) a ts =>
	 BodyArg repr a ts ~ BodyArg (UnTrans repr) a ts =>
	 repr (BodyArg repr a ts -> k) k
	body' = noTrans (body' @_ @a @ts)

-- | 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
	bodyStream' ::
	 BodyStreamConstraint repr as ts framing =>
	 repr (BodyStreamArg repr as ts framing -> k) k
	-- Trans defaults
	type BodyStreamArg repr as ts framing = BodyStreamArg (UnTrans repr) as ts framing
	type BodyStreamConstraint repr as ts framing = BodyStreamConstraint (UnTrans repr) as ts framing
	default bodyStream' ::
	 forall as ts framing k.
	 Trans repr =>
	 HTTP_BodyStream (UnTrans repr) =>
	 BodyStreamConstraint (UnTrans repr) as ts framing =>
	 BodyStreamArg repr as ts framing ~ BodyStreamArg (UnTrans repr) as ts framing =>
	 repr (BodyStreamArg repr as ts framing -> k) k
	bodyStream' = noTrans (bodyStream' @_ @as @ts @framing)

-- | 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
	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)
	-- Trans defaults
	type QueryConstraint repr a = QueryConstraint (UnTrans repr) a
	default queryParams' ::
	 Trans repr =>
	 HTTP_Query (UnTrans repr) =>
	 QueryConstraint (UnTrans repr) a =>
	 QueryName -> repr ([a] -> k) k
	queryParams' = noTrans . queryParams'
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 BasicAuthArgs repr a k :: *
	basicAuth' ::
	 BasicAuthConstraint repr a =>
	 BasicAuthRealm -> repr (BasicAuthArgs repr a k) k
	-- Trans defaults
	type BasicAuthConstraint repr a = BasicAuthConstraint (UnTrans repr) a
	type BasicAuthArgs repr a k = BasicAuthArgs (UnTrans repr) a k
	default basicAuth' ::
	 forall a k.
	 Trans repr =>
	 HTTP_BasicAuth (UnTrans repr) =>
	 BasicAuthConstraint (UnTrans repr) a =>
	 BasicAuthArgs repr a k ~ BasicAuthArgs (UnTrans repr) a k =>
	 BasicAuthRealm -> repr (BasicAuthArgs repr a k) k
	basicAuth' = noTrans . basicAuth' @_ @a

-- | 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 ResponseArgs repr a (ts::[*]) :: *
	type Response repr :: *
	response ::
	 ResponseConstraint repr a ts =>
	 HTTP.Method ->
	 repr (ResponseArgs repr a ts)
	      (Response repr)
	-- Trans defaults
	type ResponseConstraint repr a ts = ResponseConstraint (UnTrans repr) a ts
	type ResponseArgs repr a ts = ResponseArgs (UnTrans repr) a ts
	type Response repr = Response (UnTrans repr)
	default response ::
	 forall a ts.
	 Trans repr =>
	 HTTP_Response (UnTrans repr) =>
	 ResponseConstraint (UnTrans repr) a ts =>
	 ResponseArgs repr a ts ~ ResponseArgs (UnTrans repr) a ts =>
	 Response repr ~ Response (UnTrans repr) =>
	 HTTP.Method ->
	 repr (ResponseArgs repr a ts)
	      (Response repr)
	response = noTrans . response @_ @a @ts

-- | 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 ResponseStreamArgs repr as (ts::[*]) framing :: *
	type ResponseStream repr :: *
	responseStream ::
	 ResponseStreamConstraint repr as ts framing =>
	 HTTP.Method ->
	 repr (ResponseStreamArgs repr as ts framing)
	      (ResponseStream repr)
	-- Trans defaults
	type ResponseStreamConstraint repr as ts framing = ResponseStreamConstraint (UnTrans repr) as ts framing
	type ResponseStreamArgs repr as ts framing = ResponseStreamArgs (UnTrans repr) as ts framing
	type ResponseStream repr = ResponseStream (UnTrans repr)
	default responseStream ::
	 forall as ts framing.
	 Trans repr =>
	 HTTP_ResponseStream (UnTrans repr) =>
	 ResponseStreamConstraint (UnTrans repr) as ts framing =>
	 ResponseStreamArgs repr as ts framing ~ ResponseStreamArgs (UnTrans repr) as ts framing =>
	 ResponseStream repr ~ ResponseStream (UnTrans repr) =>
	 HTTP.Method ->
	 repr (ResponseStreamArgs repr as ts framing)
	      (ResponseStream repr)
	responseStream = noTrans . responseStream @_ @as @ts @framing

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