module Servant.Util.Common.Common
( ApplicationLS
, ApplicationRS
, ApiHasArgClass (..)
, ApiHasArg
, inRouteServer
, symbolValT
, NameLabel (..)
) where
import Universum
import qualified Data.Text.Buildable as B
import Fmt (pretty)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Servant.API (Capture, QueryFlag, QueryParam', ReqBody, (:>))
import Servant.API.Modifiers (RequiredArgument)
import Servant.Server (Handler (..), HasServer (..), Server)
import qualified Servant.Server.Internal as SI
type family ApplicationLS x where
ApplicationLS (a b) = a
type family ApplicationRS x where
ApplicationRS (a b) = b
class ApiHasArgClass api where
type ApiArg api :: Type
type ApiArg api = ApplicationRS api
apiArgName
:: Proxy api -> String
default apiArgName
:: forall n someApiType a. (KnownSymbol n, api ~ someApiType n a)
=> Proxy api -> String
apiArgName Proxy api
_ =
Builder -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
forall p. Buildable p => p -> Builder
B.build (Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy n -> String) -> Proxy n -> String
forall a b. (a -> b) -> a -> b
$ Proxy n
forall k (t :: k). Proxy t
Proxy @n) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"' field"
class ServerT (subApi :> res) m ~ (ApiArg subApi -> ServerT res m)
=> ApiHasArgInvariant subApi res m
instance ServerT (subApi :> res) m ~ (ApiArg subApi -> ServerT res m)
=> ApiHasArgInvariant subApi res m
type ApiHasArg subApi res =
( ApiHasArgClass subApi
, ApiHasArgInvariant subApi res Handler
)
instance KnownSymbol s => ApiHasArgClass (Capture s a)
instance KnownSymbol s => ApiHasArgClass (QueryParam' mods s a) where
type ApiArg (QueryParam' mods s a) = RequiredArgument mods a
instance KnownSymbol s => ApiHasArgClass (QueryFlag s) where
type ApiArg (QueryFlag s) = Bool
apiArgName :: Proxy (QueryFlag s) -> String
apiArgName Proxy (QueryFlag s)
_ =
Builder -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
forall p. Buildable p => p -> Builder
B.build (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"' flag"
instance ApiHasArgClass (ReqBody ct a) where
apiArgName :: Proxy (ReqBody ct a) -> String
apiArgName Proxy (ReqBody ct a)
_ = String
"request body"
inRouteServer
:: forall api api' ctx env.
(Proxy api -> SI.Context ctx -> SI.Delayed env (Server api) -> SI.Router env)
-> (Server api' -> Server api)
-> (Proxy api' -> SI.Context ctx -> SI.Delayed env (Server api') -> SI.Router env)
inRouteServer :: (Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
routing Server api' -> Server api
f = \Proxy api'
_ Context ctx
ctx Delayed env (Server api')
delayed -> Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
routing Proxy api
forall k (t :: k). Proxy t
Proxy Context ctx
ctx ((Server api' -> Server api)
-> Delayed env (Server api') -> Delayed env (Server api)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Server api' -> Server api
f Delayed env (Server api')
delayed)
symbolValT :: forall s. KnownSymbol s => Text
symbolValT :: Text
symbolValT = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s)
data NameLabel (name :: Symbol) = NameLabel
instance (n1 ~ n2) => IsLabel n1 (NameLabel n2) where
fromLabel :: NameLabel n2
fromLabel = NameLabel n2
forall (name :: Symbol). NameLabel name
NameLabel