{-# 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' -- | 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 #-}