{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.API.Routes
(
Routes
, unRoutes
, pattern Routes
, Route
, defRoute
, HasRoutes (..)
, printRoutes
)
where
import Data.Aeson
import qualified Data.Aeson.Key as AK (fromText)
import qualified Data.Aeson.Types as A (Pair)
import Data.Bifunctor (bimap)
import Data.Foldable (foldl', traverse_)
import qualified Data.Map as Map
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as T
import Data.Typeable
import GHC.TypeLits (KnownSymbol, Symbol)
import Lens.Micro
import Network.HTTP.Types.Method (Method)
import Servant.API
import Servant.API.Modifiers (RequiredArgument)
import "this" Servant.API.Routes.Body
import "this" Servant.API.Routes.Header
import "this" Servant.API.Routes.Internal.Body
import "this" Servant.API.Routes.Param
import "this" Servant.API.Routes.Path
import "this" Servant.API.Routes.Route
import "this" Servant.API.Routes.Utils
newtype Routes = UnsafeRoutes
{ Routes -> Map Path (Map Method Route)
unRoutes :: Map.Map Path (Map.Map Method Route)
}
deriving (Int -> Routes -> ShowS
[Routes] -> ShowS
Routes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Routes] -> ShowS
$cshowList :: [Routes] -> ShowS
show :: Routes -> String
$cshow :: Routes -> String
showsPrec :: Int -> Routes -> ShowS
$cshowsPrec :: Int -> Routes -> ShowS
Show, Routes -> Routes -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Routes -> Routes -> Bool
$c/= :: Routes -> Routes -> Bool
== :: Routes -> Routes -> Bool
$c== :: Routes -> Routes -> Bool
Eq)
makeRoutes :: [Route] -> Routes
makeRoutes :: [Route] -> Routes
makeRoutes = Map Path (Map Method Route) -> Routes
UnsafeRoutes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Path (Map Method Route) -> Route -> Map Path (Map Method Route)
insert forall a. Monoid a => a
mempty
where
insert :: Map Path (Map Method Route) -> Route -> Map Path (Map Method Route)
insert Map Path (Map Method Route)
acc Route
r = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) Path
path Map Method Route
subMap Map Path (Map Method Route)
acc
where
path :: Path
path = Route
r forall s a. s -> Getting a s a -> a
^. Lens' Route Path
routePath
method :: Method
method = Route
r forall s a. s -> Getting a s a -> a
^. Lens' Route Method
routeMethod
subMap :: Map Method Route
subMap = forall k a. k -> a -> Map k a
Map.singleton Method
method Route
r
unmakeRoutes :: Routes -> [Route]
unmakeRoutes :: Routes -> [Route]
unmakeRoutes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. Routes -> Map Path (Map Method Route)
unRoutes
pattern Routes :: [Route] -> Routes
pattern $bRoutes :: [Route] -> Routes
$mRoutes :: forall {r}. Routes -> ([Route] -> r) -> ((# #) -> r) -> r
Routes rs <- (unmakeRoutes -> rs)
where
Routes = [Route] -> Routes
makeRoutes
{-# COMPLETE Routes #-}
instance ToJSON Routes where
toJSON :: Routes -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path, Map Method Route) -> Pair
mkPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.assocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Routes -> Map Path (Map Method Route)
unRoutes
where
mkPair :: (Path, Map.Map Method Route) -> A.Pair
mkPair :: (Path, Map Method Route) -> Pair
mkPair = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Text -> Key
AK.fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Text
renderPath) Map Method Route -> Value
subMapToJSON
subMapToJSON :: Map.Map Method Route -> Value
subMapToJSON :: Map Method Route -> Value
subMapToJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {kv} {v}. (KeyValue kv, ToJSON v) => (Method, v) -> kv
mkSubPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.assocs
mkSubPair :: (Method, v) -> kv
mkSubPair (Method
method, v
r) =
let key :: Key
key = Text -> Key
AK.fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Text
TE.decodeUtf8 forall a b. (a -> b) -> a -> b
$ Method
method
in Key
key forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
r
class HasRoutes api where
getRoutes :: [Route]
printRoutes :: forall api. HasRoutes api => IO ()
printRoutes :: forall api. HasRoutes api => IO ()
printRoutes = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Route -> IO ()
printRoute forall a b. (a -> b) -> a -> b
$ forall api. HasRoutes api => [Route]
getRoutes @api
where
printRoute :: Route -> IO ()
printRoute = Text -> IO ()
T.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Route -> Text
showRoute
instance HasRoutes EmptyAPI where
getRoutes :: [Route]
getRoutes = forall a. Monoid a => a
mempty
instance
ReflectMethod (method :: StdMethod) =>
HasRoutes (NoContentVerb method)
where
getRoutes :: [Route]
getRoutes = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Method -> Route
defRoute Method
method
where
method :: Method
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
instance
{-# OVERLAPPABLE #-}
(ReflectMethod (method :: StdMethod), Typeable a) =>
HasRoutes (Verb method status ctypes a)
where
getRoutes :: [Route]
getRoutes =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Method -> Route
defRoute Method
method
forall a b. a -> (a -> b) -> b
& Lens' Route Body
routeResponseType forall s t a b. ASetter s t a b -> b -> s -> t
.~ Body
response
where
method :: Method
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
response :: Body
response = forall a. Typeable a => Body
oneType @a
instance
{-# OVERLAPPING #-}
( ReflectMethod (method :: StdMethod)
, GetHeaderReps hs
, Typeable a
) =>
HasRoutes (Verb method status ctypes (Headers hs a))
where
getRoutes :: [Route]
getRoutes =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Method -> Route
defRoute Method
method
forall a b. a -> (a -> b) -> b
& Lens' Route [HeaderRep]
routeResponseHeaders forall s t a b. ASetter s t a b -> b -> s -> t
.~ [HeaderRep]
headers
forall a b. a -> (a -> b) -> b
& Lens' Route Body
routeResponseType forall s t a b. ASetter s t a b -> b -> s -> t
.~ Body
response
where
method :: Method
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
headers :: [HeaderRep]
headers = forall (hs :: [*]). GetHeaderReps hs => [HeaderRep]
getHeaderReps @hs
response :: Body
response = forall a. Typeable a => Body
oneType @a
#if MIN_VERSION_servant(0,18,1)
instance
{-# OVERLAPPING #-}
(ReflectMethod (method :: StdMethod)) =>
HasRoutes (UVerb method ctypes '[])
where
getRoutes :: [Route]
getRoutes = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Method -> Route
defRoute Method
method
where
method :: Method
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
instance
{-# OVERLAPPING #-}
(ReflectMethod (method :: StdMethod), Typeable a) =>
HasRoutes (UVerb method ctypes '[a])
where
getRoutes :: [Route]
getRoutes =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Method -> Route
defRoute Method
method
forall a b. a -> (a -> b) -> b
& Lens' Route Body
routeResponseType forall s t a b. ASetter s t a b -> b -> s -> t
.~ Body
response
where
method :: Method
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
response :: Body
response = forall a. Typeable a => Body
oneType @a
instance
(ReflectMethod (method :: StdMethod), AllTypeable as, Unique as) =>
HasRoutes (UVerb method ctypes as)
where
getRoutes :: [Route]
getRoutes =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Method -> Route
defRoute Method
method
forall a b. a -> (a -> b) -> b
& Lens' Route Body
routeResponseType forall s t a b. ASetter s t a b -> b -> s -> t
.~ Body
response
where
method :: Method
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
response :: Body
response = forall (as :: [*]). AllTypeable as => Body
oneOf @as
#endif
instance (HasRoutes l, HasRoutes r) => HasRoutes (l :<|> r) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @l forall a. Semigroup a => a -> a -> a
<> forall api. HasRoutes api => [Route]
getRoutes @r
instance (KnownSymbol path, HasRoutes api) => HasRoutes (path :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route Path
routePath forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Path -> Path
prependPathPart Text
path
where
path :: Text
path = forall (name :: Symbol). KnownSymbol name => Text
knownSymbolT @path
instance
(Typeable a, HasRoutes api) =>
HasRoutes (Capture' mods capture a :> api)
where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route Path
routePath forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Path -> Path
prependPathPart Text
capture
where
capture :: Text
capture = Text
"<" forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => Text
showTypeRep @a forall a. Semigroup a => a -> a -> a
<> Text
">"
instance
(Typeable [a], HasRoutes api) =>
HasRoutes (CaptureAll capture a :> api)
where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route Path
routePath forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Path -> Path
prependPathPart Text
capture
where
capture :: Text
capture = Text
"<" forall a. Semigroup a => a -> a -> a
<> forall a. Typeable a => Text
showTypeRep @[a] forall a. Semigroup a => a -> a -> a
<> Text
">"
instance
(KnownSymbol sym, Typeable (RequiredArgument mods a), HasRoutes api) =>
HasRoutes (QueryParam' mods sym a :> api)
where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route [Param]
routeParams forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Param
param forall a. a -> [a] -> [a]
:)
where
param :: Param
param = forall (s :: Symbol) a. (KnownSymbol s, Typeable a) => Param
singleParam @sym @(RequiredArgument mods a)
instance
(KnownSymbol sym, Typeable a, HasRoutes api) =>
HasRoutes (QueryParams sym a :> api)
where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route [Param]
routeParams forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Param
param forall a. a -> [a] -> [a]
:)
where
param :: Param
param = forall (s :: Symbol) a. (KnownSymbol s, Typeable a) => Param
arrayElemParam @sym @a
#if MIN_VERSION_servant(0,19,0)
instance (HasRoutes (ToServantApi routes)) => HasRoutes (NamedRoutes routes) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @(ToServantApi routes)
#endif
instance (KnownSymbol sym, HasRoutes api) => HasRoutes (QueryFlag sym :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route [Param]
routeParams forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Param
param forall a. a -> [a] -> [a]
:)
where
param :: Param
param = forall (s :: Symbol). KnownSymbol s => Param
flagParam @sym
instance (HasRoutes api, Typeable a) => HasRoutes (ReqBody' mods list a :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route Body
routeRequestBody forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Body
reqBody
where
reqBody :: Body
reqBody = forall a. Typeable a => Body
oneType @a
instance (HasRoutes api) => HasRoutes (Vault :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api
instance (HasRoutes api) => HasRoutes (HttpVersion :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api
instance (HasRoutes api, KnownSymbol realm) => HasRoutes (BasicAuth realm usr :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route [Text]
routeAuths forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Text
auth forall a. a -> [a] -> [a]
:)
where
auth :: Text
auth = Text
"Basic " forall a. Semigroup a => a -> a -> a
<> forall (name :: Symbol). KnownSymbol name => Text
knownSymbolT @realm
instance (HasRoutes api) => HasRoutes (Description sym :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api
instance (HasRoutes api) => HasRoutes (Summary sym :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api
instance
(HasRoutes api, KnownSymbol tag) =>
HasRoutes (AuthProtect (tag :: Symbol) :> api)
where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route [Text]
routeAuths forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Text
auth forall a. a -> [a] -> [a]
:)
where
auth :: Text
auth = forall (name :: Symbol). KnownSymbol name => Text
knownSymbolT @tag
instance
(HasRoutes api, KnownSymbol sym, Typeable (RequiredArgument mods a)) =>
HasRoutes (Header' mods sym a :> api)
where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route [HeaderRep]
routeRequestHeaders forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (HeaderRep
header forall a. a -> [a] -> [a]
:)
where
header :: HeaderRep
header = forall (sym :: Symbol) a.
(KnownSymbol sym, Typeable a) =>
HeaderRep
mkHeaderRep @sym @(RequiredArgument mods a)
instance (HasRoutes api) => HasRoutes (Fragment v :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api
instance (HasRoutes api) => HasRoutes (IsSecure :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api
instance (HasRoutes api) => HasRoutes (RemoteHost :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api
instance (HasRoutes api, Typeable a) => HasRoutes (StreamBody' mods framing ct a :> api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Lens' Route Body
routeRequestBody forall s t a b. ASetter s t a b -> b -> s -> t
.~ Body
reqBody
where
reqBody :: Body
reqBody = forall a. Typeable a => Body
oneType @a
instance (HasRoutes api) => HasRoutes (WithNamedContext name subContext api) where
getRoutes :: [Route]
getRoutes = forall api. HasRoutes api => [Route]
getRoutes @api
instance
(ReflectMethod (method :: StdMethod), Typeable a) =>
HasRoutes (Stream method status framing ctype a)
where
getRoutes :: [Route]
getRoutes =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Method -> Route
defRoute Method
method
forall a b. a -> (a -> b) -> b
& Lens' Route Body
routeResponseType forall s t a b. ASetter s t a b -> b -> s -> t
.~ Body
response
where
method :: Method
method = forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
response :: Body
response = forall a. Typeable a => Body
oneType @a