{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
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 repr where
(<.>) :: repr a b -> repr b c -> repr a c; infixr 4 <.>
default (<.>) ::
Trans repr =>
Cat (UnTrans repr) =>
repr a b -> repr b c -> repr a c
x <.> y = noTrans (unTrans x <.> unTrans y)
class Alt repr where
(<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixr 3 <!>
default (<!>) ::
Trans repr =>
Alt (UnTrans repr) =>
repr a k -> repr b k -> repr (a:!:b) k
x <!> y = noTrans (unTrans x <!> unTrans y)
data (:!:) a b = a:!:b
infixr 3 :!:
class Trans repr where
type UnTrans repr :: * -> * -> *
noTrans :: UnTrans repr a b -> repr a b
unTrans :: repr a b -> UnTrans repr a b
class Pro repr where
dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
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_Raw repr where
type RawConstraint repr :: Constraint
type RawArgs repr :: *
type Raw repr :: *
raw ::
RawConstraint repr =>
repr (RawArgs repr) (Raw repr)
type RawConstraint repr = RawConstraint (UnTrans repr)
type RawArgs repr = RawArgs (UnTrans repr)
type Raw repr = Raw (UnTrans repr)
default raw ::
Trans repr =>
HTTP_Raw (UnTrans repr) =>
RawConstraint (UnTrans repr) =>
RawArgs (UnTrans repr) ~ RawArgs repr =>
Raw (UnTrans repr) ~ Raw repr =>
repr (RawArgs repr) (Raw repr)
raw = noTrans raw
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
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
(</>) :: Cat repr => HTTP_Path repr => PathSegment -> repr a b -> repr a b
(</>) n = (segment n <.>); infixr 4 </>
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 repr where
header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
default header ::
Trans repr =>
HTTP_Header (UnTrans repr) =>
HTTP.HeaderName -> repr (HeaderValue -> k) k
header = noTrans . header
type HeaderValue = BS.ByteString
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
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)
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 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
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)
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 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)
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
queryParams ::
forall a k repr.
HTTP_Query repr =>
QueryConstraint repr a =>
QueryName -> repr ([a] -> k) k
queryParams = queryParams'
{-# INLINE queryParams #-}
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
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
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 #-}
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 repr where
version :: HTTP.HttpVersion -> repr k k
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)
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
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 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)
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 #-}
type family FramingMonad p :: * -> *
type family FramingYield p :: *
type family FramingReturn p :: *
class FramingEncode framing p where
framingEncode ::
Proxy framing ->
(FramingYield p -> BSL.ByteString) ->
p -> IO (Either (FramingReturn p) (BSL.ByteString, p))
class FramingDecode framing p where
framingDecode ::
FramingMonad p ~ m =>
Monad m =>
Proxy framing ->
(BSL.ByteString -> Either String (FramingYield p)) ->
m BS.ByteString -> p
data NoFraming
data NewlineFraming
data NetstringFraming