{-# LANGUAGE RecordWildCards #-}
module Wire.API.VersionInfo
(
vinfoObjectSchema,
versionHeader,
VersionHeader,
From,
Until,
VersionedMonad (..),
)
where
import Data.ByteString.Char8 qualified as B8
import Data.CaseInsensitive qualified as CI
import Data.Metrics.Servant
import Data.Schema
import Data.Singletons
import GHC.TypeLits
import Imports
import Network.Wai qualified as Wai
import Servant
import Servant.Client.Core
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import Wire.API.Routes.ClientAlgebra
vinfoObjectSchema :: ValueSchema NamedSwaggerDoc v -> ObjectSchema SwaggerDoc [v]
vinfoObjectSchema :: forall v.
ValueSchema NamedSwaggerDoc v -> ObjectSchema SwaggerDoc [v]
vinfoObjectSchema ValueSchema NamedSwaggerDoc v
sch = Text
-> SchemaP SwaggerDoc Value Value [v] [v]
-> SchemaP SwaggerDoc Object [Pair] [v] [v]
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"supported" (ValueSchema NamedSwaggerDoc v
-> SchemaP SwaggerDoc Value Value [v] [v]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema NamedSwaggerDoc v
sch)
type = "X-Wire-API-Version"
versionHeader :: CI.CI ByteString
= ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> (String -> ByteString) -> String -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B8.pack (String -> CI ByteString) -> String -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Proxy VersionHeader -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @VersionHeader)
data Until v
data From v
instance
( SingI n,
Ord (Demote v),
Enum (Demote v),
SingKind v,
HasServer api ctx
) =>
HasServer (Until (n :: v) :> api) ctx
where
type ServerT (Until n :> api) m = ServerT api m
route :: forall env.
Proxy (Until n :> api)
-> Context ctx
-> Delayed env (Server (Until n :> api))
-> Router env
route Proxy (Until n :> api)
_ Context ctx
ctx Delayed env (Server (Until n :> api))
action =
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Context ctx
ctx (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
Delayed env (Server api)
Delayed env (Server (Until n :> api))
action Delayed env (Server api)
-> DelayedIO () -> Delayed env (Server api)
forall env b. Delayed env b -> DelayedIO () -> Delayed env b
`addVersionCheck` (Request -> DelayedIO ()) -> DelayedIO ()
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO ()
headerCheck
where
headerCheck :: Wai.Request -> DelayedIO ()
headerCheck :: Request -> DelayedIO ()
headerCheck Request
req = do
let v :: Demote v
v =
Int -> Demote v
forall a. Enum a => Int -> a
toEnum (Int -> Demote v) -> Int -> Demote v
forall a b. (a -> b) -> a -> b
$
Int -> (ByteString -> Int) -> Maybe ByteString -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Int
0
(Int -> Either Text Int -> Int
forall b a. b -> Either a b -> b
fromRight Int
0 (Either Text Int -> Int)
-> (ByteString -> Either Text Int) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Int
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader)
(CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
versionHeader (Request -> [(CI ByteString, ByteString)]
Wai.requestHeaders Request
req))
Bool -> DelayedIO () -> DelayedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Demote v
v Demote v -> Demote v -> Bool
forall a. Ord a => a -> a -> Bool
>= forall (a :: v). (SingKind v, SingI a) => Demote v
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @n) (DelayedIO () -> DelayedIO ()) -> DelayedIO () -> DelayedIO ()
forall a b. (a -> b) -> a -> b
$
ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err404
addVersionCheck :: Delayed env b -> DelayedIO () -> Delayed env b
addVersionCheck :: forall env b. Delayed env b -> DelayedIO () -> Delayed env b
addVersionCheck Delayed {DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
contentType -> DelayedIO body
capturesD :: env -> DelayedIO captures
methodD :: DelayedIO ()
authD :: DelayedIO auth
acceptD :: DelayedIO ()
contentD :: DelayedIO contentType
paramsD :: DelayedIO params
headersD :: DelayedIO headers
bodyD :: contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
capturesD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
contentD :: ()
paramsD :: ()
headersD :: ()
bodyD :: ()
serverD :: ()
..} DelayedIO ()
new =
Delayed
{ capturesD :: env -> DelayedIO captures
capturesD = \env
env -> env -> DelayedIO captures
capturesD env
env DelayedIO captures -> DelayedIO () -> DelayedIO captures
forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* DelayedIO ()
new,
DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
contentType -> DelayedIO body
methodD :: DelayedIO ()
authD :: DelayedIO auth
acceptD :: DelayedIO ()
contentD :: DelayedIO contentType
paramsD :: DelayedIO params
headersD :: DelayedIO headers
bodyD :: contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
methodD :: DelayedIO ()
authD :: DelayedIO auth
acceptD :: DelayedIO ()
contentD :: DelayedIO contentType
paramsD :: DelayedIO params
headersD :: DelayedIO headers
bodyD :: contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
..
}
hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (Until n :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (Until n :> api) m
-> ServerT (Until n :> api) n
hoistServerWithContext Proxy (Until n :> api)
_ Proxy ctx
ctx forall x. m x -> n x
f =
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy ctx
ctx m x -> n x
forall x. m x -> n x
f
class VersionedMonad v m where
guardVersion :: (v -> Bool) -> m ()
instance
( VersionedMonad (Demote v) m,
SingI n,
Ord (Demote v),
SingKind v,
HasClientAlgebra m api
) =>
HasClient m (Until (n :: v) :> api)
where
type Client m (Until n :> api) = Client m api
clientWithRoute :: Proxy m
-> Proxy (Until n :> api) -> Request -> Client m (Until n :> api)
clientWithRoute Proxy m
pm Proxy (Until n :> api)
_ Request
req = forall (m :: * -> *) api a.
HasClientAlgebra m api =>
m a -> (a -> Client m api) -> Client m api
bindClient @m @api
((Demote v -> Bool) -> m ()
forall v (m :: * -> *). VersionedMonad v m => (v -> Bool) -> m ()
guardVersion (\Demote v
v -> Demote v
v Demote v -> Demote v -> Bool
forall a. Ord a => a -> a -> Bool
< forall (a :: v). (SingKind v, SingI a) => Demote v
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @n))
((() -> Client m api) -> Client m api)
-> (() -> Client m api) -> Client m api
forall a b. (a -> b) -> a -> b
$ \()
_ ->
Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Request
req
hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (Until n :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (Until n :> api)
-> Client mon' (Until n :> api)
hoistClientMonad Proxy m
pm Proxy (Until n :> api)
_ forall x. mon x -> mon' x
f = Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) mon x -> mon' x
forall x. mon x -> mon' x
f
instance (RoutesToPaths api) => RoutesToPaths (Until v :> api) where
getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api
instance
( SingI n,
Ord (Demote v),
Enum (Demote v),
SingKind v,
HasServer api ctx
) =>
HasServer (From (n :: v) :> api) ctx
where
type ServerT (From n :> api) m = ServerT api m
route :: forall env.
Proxy (From n :> api)
-> Context ctx
-> Delayed env (Server (From n :> api))
-> Router env
route Proxy (From n :> api)
_ Context ctx
ctx Delayed env (Server (From n :> api))
action =
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall env.
Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Context ctx
ctx (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
(Server api -> () -> Server api)
-> Delayed env (Server api) -> Delayed env (() -> Server api)
forall a b. (a -> b) -> Delayed env a -> Delayed env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Server api -> () -> Server api
forall a b. a -> b -> a
const Delayed env (Server api)
Delayed env (Server (From n :> api))
action Delayed env (() -> Server api)
-> DelayedIO () -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addHeaderCheck` (Request -> DelayedIO ()) -> DelayedIO ()
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO ()
headerCheck
where
headerCheck :: Wai.Request -> DelayedIO ()
headerCheck :: Request -> DelayedIO ()
headerCheck Request
req = do
let v :: Demote v
v =
Int -> Demote v
forall a. Enum a => Int -> a
toEnum (Int -> Demote v) -> Int -> Demote v
forall a b. (a -> b) -> a -> b
$
Int -> (ByteString -> Int) -> Maybe ByteString -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Int
0
(Int -> Either Text Int -> Int
forall b a. b -> Either a b -> b
fromRight Int
0 (Either Text Int -> Int)
-> (ByteString -> Either Text Int) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Int
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader)
(CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
versionHeader (Request -> [(CI ByteString, ByteString)]
Wai.requestHeaders Request
req))
Bool -> DelayedIO () -> DelayedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Demote v
v Demote v -> Demote v -> Bool
forall a. Ord a => a -> a -> Bool
< forall (a :: v). (SingKind v, SingI a) => Demote v
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @n) (DelayedIO () -> DelayedIO ()) -> DelayedIO () -> DelayedIO ()
forall a b. (a -> b) -> a -> b
$
ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err404
hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (From n :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (From n :> api) m
-> ServerT (From n :> api) n
hoistServerWithContext Proxy (From n :> api)
_ Proxy ctx
ctx forall x. m x -> n x
f =
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy ctx
ctx m x -> n x
forall x. m x -> n x
f
instance
( VersionedMonad (Demote v) m,
SingI n,
Ord (Demote v),
SingKind v,
HasClientAlgebra m api
) =>
HasClient m (From (n :: v) :> api)
where
type Client m (From n :> api) = Client m api
clientWithRoute :: Proxy m
-> Proxy (From n :> api) -> Request -> Client m (From n :> api)
clientWithRoute Proxy m
pm Proxy (From n :> api)
_ Request
req = forall (m :: * -> *) api a.
HasClientAlgebra m api =>
m a -> (a -> Client m api) -> Client m api
bindClient @m @api
((Demote v -> Bool) -> m ()
forall v (m :: * -> *). VersionedMonad v m => (v -> Bool) -> m ()
guardVersion (\Demote v
v -> Demote v
v Demote v -> Demote v -> Bool
forall a. Ord a => a -> a -> Bool
>= forall (a :: v). (SingKind v, SingI a) => Demote v
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @n))
((() -> Client m api) -> Client m api)
-> (() -> Client m api) -> Client m api
forall a b. (a -> b) -> a -> b
$ \()
_ ->
Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Request
req
hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (From n :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (From n :> api)
-> Client mon' (From n :> api)
hoistClientMonad Proxy m
pm Proxy (From n :> api)
_ forall x. mon x -> mon' x
f = Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) mon x -> mon' x
forall x. mon x -> mon' x
f
instance (RoutesToPaths api) => RoutesToPaths (From v :> api) where
getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api