{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StrictData #-}
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 repr where
(<.>) :: repr a b -> repr b c -> repr a c; infixl 4 <.>
class Alt repr where
(<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
data (:!:) a b = a:!:b
infixl 3 :!:
class Pro repr where
dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
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
(</>) :: Cat repr => HTTP_Path repr => Segment -> repr a b -> repr a b
(</>) n = (segment n <.>); infixr 5 </>
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 repr where
header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
type HeaderValue = BS.ByteString
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
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
type BodyStreamConstraint repr as ts framing = ()
bodyStream' ::
BodyStreamConstraint repr as ts framing =>
repr (BodyStreamArg repr as ts framing -> k) k
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
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
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 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 #-}
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 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)
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 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 #-}
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