{-# 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
-- Copyright   : (c) Justin Le 2021
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- A package with "test suites" to help verify that your servant APIs are
-- valid at compile-time.  Currently the only property tested is that there
-- are no duplicated paths.  See README for more information on usage.

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

-- | Has a valid well-formed API Tree
class HasApiTree (api :: Type) where
    type ToApiTree api :: ApiTree

    -- | Useful runtime witness of the API tree; use to inspect it with
    -- 'reflectApiTree'.  This is not used in any part of the actual
    -- validation; is just an extra treat.
    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)

-- | A type-level version of 'Servant.API.Verbs.ReflectMethod'.
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

-- | To be used with 'validApiTree'.
type ValidApiTree api = TypeRep (ToApiTree api)

-- | The full validator.  To use:
--
-- @
-- serverApi :: Proxy ServerApi
-- serverApi = Proxy
--
-- validServerApi :: ValidApiTree ServerApi
-- validServerApi = validApiTree serverApi
-- @
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)

-- | Version of 'reflectApiTree' taking an explicit 'TypeRep'.
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

-- | Useful utility to view the routing structure of a tree; similar to
-- 'Servant.Server.layout'.
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))