{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Servant.Validate
( HasApiTree(..), MethodString(..)
, validApiTree, ValidApiTree
, reflectApiTree, reflectApiTree_
, SApiTree(..), reflectSApiTree
) where
import Data.Kind
import Data.Map (Map)
import Data.Proxy
import Data.Set (Set)
import Data.Text (Text)
import Data.Type.Bool
import Data.Type.Equality
import GHC.TypeLits
import Servant.API
import Servant.Validate.Internal
import Type.Reflection
import Unsafe.Coerce
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
class HasApiTree (api :: Type) where
type ToApiTree api :: ApiTree
sApiTree :: SApiTree (ToApiTree api)
instance (KnownSymbol path, HasApiTree api) => HasApiTree ((path :: Symbol) :> api) where
type ToApiTree (path :> api) = 'Branch '[] '[ '(path, ToApiTree api) ]
sApiTree :: SApiTree (ToApiTree (path :> api))
sApiTree = Prod SSym '[]
-> Prod (Tup SSym SApiTree) '[ '(path, ToApiTree api)]
-> SApiTree ('Branch '[] '[ '(path, ToApiTree api)])
forall (ms :: [Symbol]) (ts :: [(Symbol, ApiTree)]).
Prod SSym ms
-> Prod (Tup SSym SApiTree) ts -> SApiTree ('Branch ms ts)
SBranch Prod SSym '[]
forall k (f :: k -> *). Prod f '[]
PNil (SSym path
-> SApiTree (ToApiTree api)
-> Tup SSym SApiTree '(path, ToApiTree api)
forall k k (f :: k -> *) (x :: k) (g :: k -> *) (y :: k).
f x -> g y -> Tup f g '(x, y)
Tup SSym path
forall (s :: Symbol). KnownSymbol s => SSym s
SSym (HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api) Tup SSym SApiTree '(path, ToApiTree api)
-> Prod (Tup SSym SApiTree) '[]
-> Prod (Tup SSym SApiTree) '[ '(path, ToApiTree api)]
forall a (f :: a -> *) (a :: a) (as :: [a]).
f a -> Prod f as -> Prod f (a : as)
:< Prod (Tup SSym SApiTree) '[]
forall k (f :: k -> *). Prod f '[]
PNil)
instance HasApiTree api => HasApiTree (Capture' mods sym a :> api) where
type ToApiTree (Capture' mods sym a :> api) =
'Branch '[] '[ '("<capture>", ToApiTree api) ]
sApiTree :: SApiTree (ToApiTree (Capture' mods sym a :> api))
sApiTree = Prod SSym '[]
-> Prod (Tup SSym SApiTree) '[ '("<capture>", ToApiTree api)]
-> SApiTree ('Branch '[] '[ '("<capture>", ToApiTree api)])
forall (ms :: [Symbol]) (ts :: [(Symbol, ApiTree)]).
Prod SSym ms
-> Prod (Tup SSym SApiTree) ts -> SApiTree ('Branch ms ts)
SBranch Prod SSym '[]
forall k (f :: k -> *). Prod f '[]
PNil (SSym "<capture>"
-> SApiTree (ToApiTree api)
-> Tup SSym SApiTree '("<capture>", ToApiTree api)
forall k k (f :: k -> *) (x :: k) (g :: k -> *) (y :: k).
f x -> g y -> Tup f g '(x, y)
Tup SSym "<capture>"
forall (s :: Symbol). KnownSymbol s => SSym s
SSym (HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api) Tup SSym SApiTree '("<capture>", ToApiTree api)
-> Prod (Tup SSym SApiTree) '[]
-> Prod (Tup SSym SApiTree) '[ '("<capture>", ToApiTree api)]
forall a (f :: a -> *) (a :: a) (as :: [a]).
f a -> Prod f as -> Prod f (a : as)
:< Prod (Tup SSym SApiTree) '[]
forall k (f :: k -> *). Prod f '[]
PNil)
instance HasApiTree api => HasApiTree (CaptureAll sym v :> api) where
type ToApiTree (CaptureAll sym v :> api) =
'Branch '[] '[ '("<capture>", ToApiTree api) ]
sApiTree :: SApiTree (ToApiTree (CaptureAll sym v :> api))
sApiTree = Prod SSym '[]
-> Prod (Tup SSym SApiTree) '[ '("<capture>", ToApiTree api)]
-> SApiTree ('Branch '[] '[ '("<capture>", ToApiTree api)])
forall (ms :: [Symbol]) (ts :: [(Symbol, ApiTree)]).
Prod SSym ms
-> Prod (Tup SSym SApiTree) ts -> SApiTree ('Branch ms ts)
SBranch Prod SSym '[]
forall k (f :: k -> *). Prod f '[]
PNil (SSym "<capture>"
-> SApiTree (ToApiTree api)
-> Tup SSym SApiTree '("<capture>", ToApiTree api)
forall k k (f :: k -> *) (x :: k) (g :: k -> *) (y :: k).
f x -> g y -> Tup f g '(x, y)
Tup SSym "<capture>"
forall (s :: Symbol). KnownSymbol s => SSym s
SSym (HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api) Tup SSym SApiTree '("<capture>", ToApiTree api)
-> Prod (Tup SSym SApiTree) '[]
-> Prod (Tup SSym SApiTree) '[ '("<capture>", ToApiTree api)]
forall a (f :: a -> *) (a :: a) (as :: [a]).
f a -> Prod f as -> Prod f (a : as)
:< Prod (Tup SSym SApiTree) '[]
forall k (f :: k -> *). Prod f '[]
PNil)
instance (HasApiTree a, HasApiTree b) => HasApiTree (a :<|> b) where
type ToApiTree (a :<|> b) = MergeTree '[] (ToApiTree a) (ToApiTree b)
sApiTree :: SApiTree (ToApiTree (a :<|> b))
sApiTree = SApiTree (ToApiTree a)
-> SApiTree (ToApiTree b)
-> SApiTree (MergeTree '[] (ToApiTree a) (ToApiTree b))
forall (base :: [Symbol]) (a :: ApiTree) (b :: ApiTree).
SApiTree a -> SApiTree b -> SApiTree (MergeTree base a b)
sMergeTree @'[] (HasApiTree a => SApiTree (ToApiTree a)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @a) (HasApiTree b => SApiTree (ToApiTree b)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @b)
class MethodString k where
type ToMethodString (x :: k) :: Symbol
instance MethodString StdMethod where
type ToMethodString 'PATCH = "PATCH"
type ToMethodString 'OPTIONS = "OPTIONS"
type ToMethodString 'CONNECT = "CONNECT"
type ToMethodString 'TRACE = "TRACE"
type ToMethodString 'DELETE = "DELETE"
type ToMethodString 'PUT = "PUT"
type ToMethodString 'HEAD = "HEAD"
type ToMethodString 'POST = "POST"
type ToMethodString 'GET = "GET"
instance MethodString Symbol where
type ToMethodString (m :: Symbol) = m
instance (MethodString k, KnownSymbol (ToMethodString m)) => HasApiTree (Verb (m :: k) s t a) where
type ToApiTree (Verb m s t a) = 'Branch '[ToMethodString m] '[]
sApiTree :: SApiTree (ToApiTree (Verb m s t a))
sApiTree = Prod SSym '[ToMethodString m]
-> Prod (Tup SSym SApiTree) '[]
-> SApiTree ('Branch '[ToMethodString m] '[])
forall (ms :: [Symbol]) (ts :: [(Symbol, ApiTree)]).
Prod SSym ms
-> Prod (Tup SSym SApiTree) ts -> SApiTree ('Branch ms ts)
SBranch (SSym (ToMethodString m)
forall (s :: Symbol). KnownSymbol s => SSym s
SSym SSym (ToMethodString m)
-> Prod SSym '[] -> Prod SSym '[ToMethodString m]
forall a (f :: a -> *) (a :: a) (as :: [a]).
f a -> Prod f as -> Prod f (a : as)
:< Prod SSym '[]
forall k (f :: k -> *). Prod f '[]
PNil) Prod (Tup SSym SApiTree) '[]
forall k (f :: k -> *). Prod f '[]
PNil
instance HasApiTree api => HasApiTree (Summary s :> api) where
type ToApiTree (Summary s :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (Summary s :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (Description s :> api) where
type ToApiTree (Description s :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (Description s :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (QueryFlag s :> api) where
type ToApiTree (QueryFlag s :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (QueryFlag s :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (QueryParams s a :> api) where
type ToApiTree (QueryParams s a :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (QueryParams s a :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (QueryParam' mods sym a :> api) where
type ToApiTree (QueryParam' mods sym a :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (QueryParam' mods sym a :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (Header' mods sym a :> api) where
type ToApiTree (Header' mods sym a :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (Header' mods sym a :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (HttpVersion :> api) where
type ToApiTree (HttpVersion :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (HttpVersion :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (Vault :> api) where
type ToApiTree (Vault :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (Vault :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (BasicAuth realm a :> api) where
type ToApiTree (BasicAuth realm a :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (BasicAuth realm a :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (AuthProtect tag :> api) where
type ToApiTree (AuthProtect tag :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (AuthProtect tag :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (IsSecure :> api) where
type ToApiTree (IsSecure :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (IsSecure :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (RemoteHost :> api) where
type ToApiTree (RemoteHost :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (RemoteHost :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (ReqBody' mods ct a :> api) where
type ToApiTree (ReqBody' mods ct a :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (ReqBody' mods ct a :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
instance HasApiTree api => HasApiTree (StreamBody' mods framing ct a :> api) where
type ToApiTree (StreamBody' mods framing ct a :> api) = ToApiTree api
sApiTree :: SApiTree (ToApiTree (StreamBody' mods framing ct a :> api))
sApiTree = HasApiTree api => SApiTree (ToApiTree api)
forall api. HasApiTree api => SApiTree (ToApiTree api)
sApiTree @api
type ValidApiTree api = TypeRep (ToApiTree api)
validApiTree :: forall api. (HasApiTree api, Typeable (ToApiTree api)) => Proxy api -> ValidApiTree api
validApiTree :: Proxy api -> ValidApiTree api
validApiTree Proxy api
_ = ValidApiTree api
forall k (a :: k). Typeable a => TypeRep a
typeRep
data ApiTreeMap = BranchesMap (Set Text) (Map Text ApiTreeMap)
deriving (Int -> ApiTreeMap -> ShowS
[ApiTreeMap] -> ShowS
ApiTreeMap -> String
(Int -> ApiTreeMap -> ShowS)
-> (ApiTreeMap -> String)
-> ([ApiTreeMap] -> ShowS)
-> Show ApiTreeMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiTreeMap] -> ShowS
$cshowList :: [ApiTreeMap] -> ShowS
show :: ApiTreeMap -> String
$cshow :: ApiTreeMap -> String
showsPrec :: Int -> ApiTreeMap -> ShowS
$cshowsPrec :: Int -> ApiTreeMap -> ShowS
Show, ApiTreeMap -> ApiTreeMap -> Bool
(ApiTreeMap -> ApiTreeMap -> Bool)
-> (ApiTreeMap -> ApiTreeMap -> Bool) -> Eq ApiTreeMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiTreeMap -> ApiTreeMap -> Bool
$c/= :: ApiTreeMap -> ApiTreeMap -> Bool
== :: ApiTreeMap -> ApiTreeMap -> Bool
$c== :: ApiTreeMap -> ApiTreeMap -> Bool
Eq, Eq ApiTreeMap
Eq ApiTreeMap
-> (ApiTreeMap -> ApiTreeMap -> Ordering)
-> (ApiTreeMap -> ApiTreeMap -> Bool)
-> (ApiTreeMap -> ApiTreeMap -> Bool)
-> (ApiTreeMap -> ApiTreeMap -> Bool)
-> (ApiTreeMap -> ApiTreeMap -> Bool)
-> (ApiTreeMap -> ApiTreeMap -> ApiTreeMap)
-> (ApiTreeMap -> ApiTreeMap -> ApiTreeMap)
-> Ord ApiTreeMap
ApiTreeMap -> ApiTreeMap -> Bool
ApiTreeMap -> ApiTreeMap -> Ordering
ApiTreeMap -> ApiTreeMap -> ApiTreeMap
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ApiTreeMap -> ApiTreeMap -> ApiTreeMap
$cmin :: ApiTreeMap -> ApiTreeMap -> ApiTreeMap
max :: ApiTreeMap -> ApiTreeMap -> ApiTreeMap
$cmax :: ApiTreeMap -> ApiTreeMap -> ApiTreeMap
>= :: ApiTreeMap -> ApiTreeMap -> Bool
$c>= :: ApiTreeMap -> ApiTreeMap -> Bool
> :: ApiTreeMap -> ApiTreeMap -> Bool
$c> :: ApiTreeMap -> ApiTreeMap -> Bool
<= :: ApiTreeMap -> ApiTreeMap -> Bool
$c<= :: ApiTreeMap -> ApiTreeMap -> Bool
< :: ApiTreeMap -> ApiTreeMap -> Bool
$c< :: ApiTreeMap -> ApiTreeMap -> Bool
compare :: ApiTreeMap -> ApiTreeMap -> Ordering
$ccompare :: ApiTreeMap -> ApiTreeMap -> Ordering
$cp1Ord :: Eq ApiTreeMap
Ord)
reflectApiTree_ :: TypeRep (apiTree :: ApiTree) -> ApiTreeMap
reflectApiTree_ :: TypeRep apiTree -> ApiTreeMap
reflectApiTree_ = SApiTree apiTree -> ApiTreeMap
forall (api :: ApiTree). SApiTree api -> ApiTreeMap
reflectSApiTree (SApiTree apiTree -> ApiTreeMap)
-> (TypeRep apiTree -> SApiTree apiTree)
-> TypeRep apiTree
-> ApiTreeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep apiTree -> SApiTree apiTree
forall (api :: ApiTree). TypeRep api -> SApiTree api
toSApiTree
reflectApiTree :: forall api. (HasApiTree api, Typeable (ToApiTree api)) => ApiTreeMap
reflectApiTree :: ApiTreeMap
reflectApiTree = TypeRep (ToApiTree api) -> ApiTreeMap
forall (apiTree :: ApiTree). TypeRep apiTree -> ApiTreeMap
reflectApiTree_ (Typeable (ToApiTree api) => TypeRep (ToApiTree api)
forall k (a :: k). Typeable a => TypeRep a
typeRep @(ToApiTree api))
reflectSApiTree :: SApiTree api -> ApiTreeMap
reflectSApiTree :: SApiTree api -> ApiTreeMap
reflectSApiTree (SBranch Prod SSym ms
ms Prod (Tup SSym SApiTree) ts
ts) = Set Text -> Map Text ApiTreeMap -> ApiTreeMap
BranchesMap
([Text] -> Set Text
forall a. Eq a => [a] -> Set a
S.fromAscList ((forall (a :: Symbol). SSym a -> Text) -> Prod SSym ms -> [Text]
forall k (as :: [k]) (f :: k -> *) r.
(forall (a :: k). f a -> r) -> Prod f as -> [r]
reflectProd forall (a :: Symbol). SSym a -> Text
reflectSSym Prod SSym ms
ms))
([(Text, ApiTreeMap)] -> Map Text ApiTreeMap
forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList ((forall (a :: (Symbol, ApiTree)).
Tup SSym SApiTree a -> (Text, ApiTreeMap))
-> Prod (Tup SSym SApiTree) ts -> [(Text, ApiTreeMap)]
forall k (as :: [k]) (f :: k -> *) r.
(forall (a :: k). f a -> r) -> Prod f as -> [r]
reflectProd ((forall (a :: Symbol). SSym a -> Text)
-> (forall (api :: ApiTree). SApiTree api -> ApiTreeMap)
-> Tup SSym SApiTree a
-> (Text, ApiTreeMap)
forall j k (xy :: (j, k)) (f :: j -> *) (g :: k -> *) a b.
(forall (x :: j). f x -> a)
-> (forall (y :: k). g y -> b) -> Tup f g xy -> (a, b)
reflectTup forall (a :: Symbol). SSym a -> Text
reflectSSym forall (api :: ApiTree). SApiTree api -> ApiTreeMap
reflectSApiTree) Prod (Tup SSym SApiTree) ts
ts))