{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.Lint
  ( lintAPI
  , lintAPI'
  , printLintAPI
  , Error(..)
  , Path(..)
  , Lintable(..)
  , Ambiguity(..)
  , unlinesChunks
  ) where

import           Data.ByteString           (ByteString)
import           Data.Containers.ListUtils (nubOrd)
import           Data.Kind                 (Constraint, Type)
import           Data.Maybe                (mapMaybe, maybeToList)
import           Data.Proxy                (Proxy (Proxy))
import qualified Data.Text                 as Text (pack, unpack)
import           Data.Text.Encoding        (decodeUtf8)
import           Data.Typeable             (TypeRep, Typeable, typeRep)
import           GHC.Generics              (Generic)
import           GHC.TypeLits              (KnownNat, KnownSymbol, natVal,
                                            symbolVal)
import           Servant.API               (Capture', CaptureAll, NoContent,
                                            NoContentVerb, QueryParam,
                                            QueryParams, ReflectMethod (..),
                                            ReqBody', Verb, type (:<|>),
                                            type (:>))
import           Text.Colour               (Chunk, TerminalCapabilities (..),
                                            bold, renderChunksText)
import           Text.Colour.Chunk         (chunk, fore, red)

-- | A term level representation of the API
-- Its defined recursive to flatten the API to a list of routes instead of a tree
type Path :: Type
data Path
  = PPath String !Path
  | PCapture String TypeRep !Path
  | PCaptureAll String TypeRep !Path
  | PQueryParam String TypeRep !Path
  | PQueryParams String TypeRep !Path
  | PReqBody TypeRep !Path
  | PVerb ByteString Integer TypeRep
  deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
/= :: Path -> Path -> Bool
Eq, Eq Path
Eq Path =>
(Path -> Path -> Ordering)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Path)
-> (Path -> Path -> Path)
-> Ord Path
Path -> Path -> Bool
Path -> Path -> Ordering
Path -> Path -> Path
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
$ccompare :: Path -> Path -> Ordering
compare :: Path -> Path -> Ordering
$c< :: Path -> Path -> Bool
< :: Path -> Path -> Bool
$c<= :: Path -> Path -> Bool
<= :: Path -> Path -> Bool
$c> :: Path -> Path -> Bool
> :: Path -> Path -> Bool
$c>= :: Path -> Path -> Bool
>= :: Path -> Path -> Bool
$cmax :: Path -> Path -> Path
max :: Path -> Path -> Path
$cmin :: Path -> Path -> Path
min :: Path -> Path -> Path
Ord)

instance Show Path where
  show :: Path -> String
show (PPath String
s Path
p)           = String
"\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" :> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path -> String
forall a. Show a => a -> String
show Path
p
  show (PCapture String
s TypeRep
t Path
p)      = String
"Capture \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path -> String
forall a. Show a => a -> String
show Path
p
  show (PCaptureAll String
s TypeRep
t Path
p)   = String
"CaptureAll \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path -> String
forall a. Show a => a -> String
show Path
p
  show (PQueryParam String
s TypeRep
t Path
p)   = String
"QueryParam \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path -> String
forall a. Show a => a -> String
show Path
p
  show (PQueryParams String
s TypeRep
t Path
p)  = String
"QueryParams \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path -> String
forall a. Show a => a -> String
show Path
p
  show (PReqBody TypeRep
t Path
p)        = String
"ReqBody _ _ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path -> String
forall a. Show a => a -> String
show Path
p
  show (PVerb ByteString
method Integer
code TypeRep
t) = String
"Verb '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (ByteString -> Text
decodeUtf8 ByteString
method) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
code String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t

-- | The Lintable type class describes how to go from a Servant Combinator to a @Path@
-- This is essentially a function from `Type -> [Path]`
-- If you have custom Servant Combinators you may need to add an instance of Lintable for your Combinator, typically ignoring the custom Combinator.
type Lintable :: Type -> Constraint
class Lintable a where
  paths :: [Path]

instance (Lintable a, Lintable b) => Lintable (a :<|> b) where
  paths :: [Path]
paths = forall a. Lintable a => [Path]
paths @a [Path] -> [Path] -> [Path]
forall a. Semigroup a => a -> a -> a
<> forall a. Lintable a => [Path]
paths @b

instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (Capture' _mods hint a :> b) where
  paths :: [Path]
paths = String -> TypeRep -> Path -> Path
PCapture (Proxy hint -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @hint)) (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))(Path -> Path) -> [Path] -> [Path]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Lintable a => [Path]
paths @b

instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (CaptureAll hint a :> b) where
  paths :: [Path]
paths = String -> TypeRep -> Path -> Path
PCaptureAll (Proxy hint -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @hint)) (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) (Path -> Path) -> [Path] -> [Path]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Lintable a => [Path]
paths @b

instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (QueryParam hint a :> b) where
  paths :: [Path]
paths = String -> TypeRep -> Path -> Path
PQueryParam (Proxy hint -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @hint)) (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) (Path -> Path) -> [Path] -> [Path]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Lintable a => [Path]
paths @b

instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (QueryParams hint a :> b) where
  paths :: [Path]
paths = String -> TypeRep -> Path -> Path
PQueryParam (Proxy hint -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @hint)) (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) (Path -> Path) -> [Path] -> [Path]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Lintable a => [Path]
paths @b

instance (Lintable b, Typeable a) => Lintable (ReqBody' _mods _ms a :> b) where
  paths :: [Path]
paths = TypeRep -> Path -> Path
PReqBody (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) (Path -> Path) -> [Path] -> [Path]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Lintable a => [Path]
paths @b

instance (KnownSymbol a, Lintable b) => Lintable (a :> b) where
  paths :: [Path]
paths = String -> Path -> Path
PPath (Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @a)) (Path -> Path) -> [Path] -> [Path]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Lintable a => [Path]
paths @b

instance {-# OVERLAPPABLE #-}
  ( ReflectMethod method
  ) => Lintable (NoContentVerb method) where
  paths :: [Path]
paths = Path -> [Path]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path -> [Path]) -> Path -> [Path]
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer -> TypeRep -> Path
PVerb (Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (forall (t :: k1). Proxy t
forall {k} (t :: k). Proxy t
Proxy @method)) Integer
204 (Proxy NoContent -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @NoContent))

instance {-# OVERLAPPABLE #-}
  ( Typeable ret
  , ReflectMethod method
  , KnownNat code
  ) => Lintable (Verb method code _cs ret) where
  paths :: [Path]
paths = Path -> [Path]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path -> [Path]) -> Path -> [Path]
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer -> TypeRep -> Path
PVerb (Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (forall (t :: k1). Proxy t
forall {k} (t :: k). Proxy t
Proxy @method)) (Proxy code -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @code)) (Proxy ret -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ret))

-- | This is a striped down version of the @Path@ focusing on removing details that ambiguate routes
type Ambiguity :: Type
data Ambiguity
  = ACapture
  | ACaptureAll
  | AQueryParam String
  | APath String
  | AReqBody
  | AVerb ByteString Integer
  deriving (Ambiguity -> Ambiguity -> Bool
(Ambiguity -> Ambiguity -> Bool)
-> (Ambiguity -> Ambiguity -> Bool) -> Eq Ambiguity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ambiguity -> Ambiguity -> Bool
== :: Ambiguity -> Ambiguity -> Bool
$c/= :: Ambiguity -> Ambiguity -> Bool
/= :: Ambiguity -> Ambiguity -> Bool
Eq, Eq Ambiguity
Eq Ambiguity =>
(Ambiguity -> Ambiguity -> Ordering)
-> (Ambiguity -> Ambiguity -> Bool)
-> (Ambiguity -> Ambiguity -> Bool)
-> (Ambiguity -> Ambiguity -> Bool)
-> (Ambiguity -> Ambiguity -> Bool)
-> (Ambiguity -> Ambiguity -> Ambiguity)
-> (Ambiguity -> Ambiguity -> Ambiguity)
-> Ord Ambiguity
Ambiguity -> Ambiguity -> Bool
Ambiguity -> Ambiguity -> Ordering
Ambiguity -> Ambiguity -> Ambiguity
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
$ccompare :: Ambiguity -> Ambiguity -> Ordering
compare :: Ambiguity -> Ambiguity -> Ordering
$c< :: Ambiguity -> Ambiguity -> Bool
< :: Ambiguity -> Ambiguity -> Bool
$c<= :: Ambiguity -> Ambiguity -> Bool
<= :: Ambiguity -> Ambiguity -> Bool
$c> :: Ambiguity -> Ambiguity -> Bool
> :: Ambiguity -> Ambiguity -> Bool
$c>= :: Ambiguity -> Ambiguity -> Bool
>= :: Ambiguity -> Ambiguity -> Bool
$cmax :: Ambiguity -> Ambiguity -> Ambiguity
max :: Ambiguity -> Ambiguity -> Ambiguity
$cmin :: Ambiguity -> Ambiguity -> Ambiguity
min :: Ambiguity -> Ambiguity -> Ambiguity
Ord, Int -> Ambiguity -> ShowS
[Ambiguity] -> ShowS
Ambiguity -> String
(Int -> Ambiguity -> ShowS)
-> (Ambiguity -> String)
-> ([Ambiguity] -> ShowS)
-> Show Ambiguity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ambiguity -> ShowS
showsPrec :: Int -> Ambiguity -> ShowS
$cshow :: Ambiguity -> String
show :: Ambiguity -> String
$cshowList :: [Ambiguity] -> ShowS
showList :: [Ambiguity] -> ShowS
Show, (forall x. Ambiguity -> Rep Ambiguity x)
-> (forall x. Rep Ambiguity x -> Ambiguity) -> Generic Ambiguity
forall x. Rep Ambiguity x -> Ambiguity
forall x. Ambiguity -> Rep Ambiguity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Ambiguity -> Rep Ambiguity x
from :: forall x. Ambiguity -> Rep Ambiguity x
$cto :: forall x. Rep Ambiguity x -> Ambiguity
to :: forall x. Rep Ambiguity x -> Ambiguity
Generic)

-- | Non lawful Eq check
(=!=) :: Ambiguity -> Ambiguity -> Bool
Ambiguity
ACapture =!= :: Ambiguity -> Ambiguity -> Bool
=!= Ambiguity
_                   = Bool
True
Ambiguity
_ =!= Ambiguity
ACapture                   = Bool
True
Ambiguity
AReqBody =!= Ambiguity
AReqBody            = Bool
True
APath String
s =!= APath String
s'             = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'
AVerb ByteString
m Integer
c =!= AVerb ByteString
m' Integer
c'        = ByteString
m ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
m' Bool -> Bool -> Bool
&& Integer
c Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
c'
AQueryParam String
s =!= AQueryParam String
s' = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'
Ambiguity
_ =!= Ambiguity
_                          = Bool
False

-- | Non lawful Eq check
(=!!=) :: [Ambiguity] -> [Ambiguity] -> Bool
a :: [Ambiguity]
a@(Ambiguity
ACaptureAll : [Ambiguity]
_) =!!= :: [Ambiguity] -> [Ambiguity] -> Bool
=!!= b :: [Ambiguity]
b@(Ambiguity
_:[Ambiguity]
_) = [Ambiguity] -> Ambiguity
forall a. HasCallStack => [a] -> a
last [Ambiguity]
a Ambiguity -> Ambiguity -> Bool
=!= [Ambiguity] -> Ambiguity
forall a. HasCallStack => [a] -> a
last [Ambiguity]
b
a :: [Ambiguity]
a@(Ambiguity
_:[Ambiguity]
_) =!!= b :: [Ambiguity]
b@(Ambiguity
ACaptureAll:[Ambiguity]
_)   = [Ambiguity] -> Ambiguity
forall a. HasCallStack => [a] -> a
last [Ambiguity]
a Ambiguity -> Ambiguity -> Bool
=!= [Ambiguity] -> Ambiguity
forall a. HasCallStack => [a] -> a
last [Ambiguity]
b
(Ambiguity
a:[Ambiguity]
as) =!!= (Ambiguity
b:[Ambiguity]
bs)               = Ambiguity
a Ambiguity -> Ambiguity -> Bool
=!= Ambiguity
b Bool -> Bool -> Bool
&& [Ambiguity]
as [Ambiguity] -> [Ambiguity] -> Bool
=!!= [Ambiguity]
bs
[] =!!= []                       = Bool
True
[Ambiguity]
_ =!!= [Ambiguity]
_                         = Bool
False

ambiguity :: Path -> [Ambiguity]
ambiguity :: Path -> [Ambiguity]
ambiguity = \case
  PPath String
s Path
p -> String -> Ambiguity
APath String
s Ambiguity -> [Ambiguity] -> [Ambiguity]
forall a. a -> [a] -> [a]
: Path -> [Ambiguity]
ambiguity Path
p
  PCapture String
_ TypeRep
_ Path
p -> Ambiguity
ACapture Ambiguity -> [Ambiguity] -> [Ambiguity]
forall a. a -> [a] -> [a]
: Path -> [Ambiguity]
ambiguity Path
p
  PCaptureAll String
_ TypeRep
_ Path
p -> Ambiguity
ACaptureAll Ambiguity -> [Ambiguity] -> [Ambiguity]
forall a. a -> [a] -> [a]
: Path -> [Ambiguity]
ambiguity Path
p
  PReqBody TypeRep
_ Path
p -> Ambiguity
AReqBody Ambiguity -> [Ambiguity] -> [Ambiguity]
forall a. a -> [a] -> [a]
: Path -> [Ambiguity]
ambiguity Path
p
  PQueryParam String
s TypeRep
_ Path
p -> String -> Ambiguity
AQueryParam String
s Ambiguity -> [Ambiguity] -> [Ambiguity]
forall a. a -> [a] -> [a]
: Path -> [Ambiguity]
ambiguity Path
p
  PQueryParams String
s TypeRep
_ Path
p -> String -> Ambiguity
AQueryParam String
s Ambiguity -> [Ambiguity] -> [Ambiguity]
forall a. a -> [a] -> [a]
: Path -> [Ambiguity]
ambiguity Path
p
  PVerb ByteString
method Integer
code TypeRep
_ty -> [ByteString -> Integer -> Ambiguity
AVerb ByteString
method Integer
code]

checkForDuplicates :: Path -> Maybe Error
checkForDuplicates :: Path -> Maybe Error
checkForDuplicates Path
p =
  if [Ambiguity] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Ambiguity] -> [Ambiguity]
forall a. Ord a => [a] -> [a]
nubOrd [Ambiguity]
noStatic) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Ambiguity] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ambiguity]
noStatic
  then Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ [[Chunk]] -> Error
Error [[ Text -> Chunk
chunk Text
"Duplicate found in route "
                     , Chunk -> Chunk
bold (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (Path -> String
forall a. Show a => a -> String
show Path
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
                    ]]
  else Maybe Error
forall a. Maybe a
Nothing
  where
  noStatic :: [Ambiguity]
noStatic = (Ambiguity -> Bool) -> [Ambiguity] -> [Ambiguity]
forall a. (a -> Bool) -> [a] -> [a]
filter (\case APath String
_ -> Bool
False; Ambiguity
_ -> Bool
True) ([Ambiguity] -> [Ambiguity]) -> [Ambiguity] -> [Ambiguity]
forall a b. (a -> b) -> a -> b
$ Path -> [Ambiguity]
ambiguity Path
p

-- | Pretty errors via @Text.Colour@
newtype Error = Error { Error -> [[Chunk]]
toChunks :: [[Chunk]] }
  deriving newtype (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show, NonEmpty Error -> Error
Error -> Error -> Error
(Error -> Error -> Error)
-> (NonEmpty Error -> Error)
-> (forall b. Integral b => b -> Error -> Error)
-> Semigroup Error
forall b. Integral b => b -> Error -> Error
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Error -> Error -> Error
<> :: Error -> Error -> Error
$csconcat :: NonEmpty Error -> Error
sconcat :: NonEmpty Error -> Error
$cstimes :: forall b. Integral b => b -> Error -> Error
stimes :: forall b. Integral b => b -> Error -> Error
Semigroup, Semigroup Error
Error
Semigroup Error =>
Error
-> (Error -> Error -> Error) -> ([Error] -> Error) -> Monoid Error
[Error] -> Error
Error -> Error -> Error
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Error
mempty :: Error
$cmappend :: Error -> Error -> Error
mappend :: Error -> Error -> Error
$cmconcat :: [Error] -> Error
mconcat :: [Error] -> Error
Monoid)

elem' :: [Ambiguity] -> [[Ambiguity]] -> Bool
elem' :: [Ambiguity] -> [[Ambiguity]] -> Bool
elem' = ([Ambiguity] -> Bool) -> [[Ambiguity]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (([Ambiguity] -> Bool) -> [[Ambiguity]] -> Bool)
-> ([Ambiguity] -> [Ambiguity] -> Bool)
-> [Ambiguity]
-> [[Ambiguity]]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ambiguity] -> [Ambiguity] -> Bool
(=!!=)

-- | Pass your API type for lint errors as Chunks
-- Chunks are colored terminal bits from @Text.Colour@ for making
-- pretty errors.
lintAPI' :: forall api. Lintable api => [Error]
lintAPI' :: forall api. Lintable api => [Error]
lintAPI' = case [Path] -> [Error]
go [Path]
psAll of [Error
x,Error
_] -> [Error
x]; [Error]
x -> [Error]
x
  where
  psAll :: [Path]
psAll = forall a. Lintable a => [Path]
paths @api
  go :: [Path] -> [Error]
go [] = []
  go (Path
p:[Path]
ps) =
    let ambiguities :: [Error]
ambiguities = [[Path] -> Path -> Error
printAmbiguity [Path]
psAll Path
p | Path -> [Ambiguity]
ambiguity Path
p [Ambiguity] -> [[Ambiguity]] -> Bool
`elem'` (Path -> [Ambiguity]
ambiguity (Path -> [Ambiguity]) -> [Path] -> [[Ambiguity]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> [Path] -> [Path]
forall t. Eq t => t -> [t] -> [t]
deleteFirst Path
p [Path]
psAll)]
        badReturns :: [Error]
badReturns  = (Path -> Maybe Error) -> [Path] -> [Error]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Path] -> Path -> Path -> Maybe Error
badReturn [Path]
psAll Path
p) [Path]
psAll
        duplicates :: Maybe Error
duplicates  = Path -> Maybe Error
checkForDuplicates Path
p
    in [Error]
ambiguities [Error] -> [Error] -> [Error]
forall a. Semigroup a => a -> a -> a
<> [Error]
badReturns [Error] -> [Error] -> [Error]
forall a. Semigroup a => a -> a -> a
<> Maybe Error -> [Error]
forall a. Maybe a -> [a]
maybeToList Maybe Error
duplicates [Error] -> [Error] -> [Error]
forall a. Semigroup a => a -> a -> a
<> [Path] -> [Error]
go [Path]
ps

-- | Pass your API type for lint errors thrown in IO
-- This is typically useful for testing
lintAPI :: forall api. Lintable api => IO ()
lintAPI :: forall api. Lintable api => IO ()
lintAPI = case forall api. Lintable api => [Error]
lintAPI' @api of
    [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Error]
ls -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TerminalCapabilities -> [Chunk] -> Text
forall (f :: * -> *).
Foldable f =>
TerminalCapabilities -> f Chunk -> Text
renderChunksText TerminalCapabilities
With24BitColours ([Chunk] -> Text) -> ([[Chunk]] -> [Chunk]) -> [[Chunk]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Chunk]] -> [Chunk]
unlinesChunks ([[Chunk]] -> Text) -> [[Chunk]] -> Text
forall a b. (a -> b) -> a -> b
$ [[Chunk]] -> [Chunk]
unlinesChunks ([[Chunk]] -> [Chunk]) -> (Error -> [[Chunk]]) -> Error -> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> [[Chunk]]
toChunks (Error -> [Chunk]) -> [Error] -> [[Chunk]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Error]
ls

-- | Pass your API type for lint via @putStrLn@ in stdout
printLintAPI :: forall api. Lintable api => IO ()
printLintAPI :: forall api. Lintable api => IO ()
printLintAPI = case forall api. Lintable api => [Error]
lintAPI' @api of
    [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Error]
ls -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TerminalCapabilities -> [Chunk] -> Text
forall (f :: * -> *).
Foldable f =>
TerminalCapabilities -> f Chunk -> Text
renderChunksText TerminalCapabilities
With24BitColours ([Chunk] -> Text) -> ([[Chunk]] -> [Chunk]) -> [[Chunk]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Chunk]] -> [Chunk]
unlinesChunks ([[Chunk]] -> Text) -> [[Chunk]] -> Text
forall a b. (a -> b) -> a -> b
$ [[Chunk]] -> [Chunk]
unlinesChunks ([[Chunk]] -> [Chunk]) -> (Error -> [[Chunk]]) -> Error -> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> [[Chunk]]
toChunks (Error -> [Chunk]) -> [Error] -> [[Chunk]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Error]
ls

deleteFirst :: Eq t => t -> [t] -> [t]
deleteFirst :: forall t. Eq t => t -> [t] -> [t]
deleteFirst t
_ [] = []
deleteFirst t
a (t
b:[t]
bc) | t
a t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
b    = [t]
bc
                     | Bool
otherwise = t
b t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t]
forall t. Eq t => t -> [t] -> [t]
deleteFirst t
a [t]
bc

badReturn :: [Path] -> Path -> Path -> Maybe Error
badReturn :: [Path] -> Path -> Path -> Maybe Error
badReturn [Path]
psAll Path
c = \case
  PPath String
_ Path
p -> [Path] -> Path -> Path -> Maybe Error
badReturn [Path]
psAll Path
c Path
p
  PCapture String
_ TypeRep
_ Path
p -> [Path] -> Path -> Path -> Maybe Error
badReturn [Path]
psAll Path
c Path
p
  PCaptureAll String
_ TypeRep
_ Path
p -> [Path] -> Path -> Path -> Maybe Error
badReturn [Path]
psAll Path
c Path
p
  PQueryParam String
_ TypeRep
_ Path
p -> [Path] -> Path -> Path -> Maybe Error
badReturn [Path]
psAll Path
c Path
p
  PVerb ByteString
_method Integer
500 TypeRep
_ty -> Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ [[Chunk]] -> Error
Error ([[Chunk]] -> Error) -> [[Chunk]] -> Error
forall a b. (a -> b) -> a -> b
$
     [ Text -> Chunk
chunk Text
"Bad verb, you should never intentionally return 500 as part of your API:"
     ] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: (Path -> [Chunk]
badReturnColor (Path -> [Chunk]) -> [Path] -> [[Chunk]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path]
psAll)
  PVerb ByteString
_method Integer
code TypeRep
ty | Integer
code Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
204 Bool -> Bool -> Bool
&& TypeRep
ty TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy NoContent -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @NoContent) -> Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ [[Chunk]] -> Error
Error ([[Chunk]] -> Error) -> [[Chunk]] -> Error
forall a b. (a -> b) -> a -> b
$
     [ Text -> Chunk
chunk Text
"Bad verb, NoContent must use HTTP Status Code 204, not "
     , Chunk -> Chunk
bold (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
code String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":"
     ] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: (Path -> [Chunk]
badReturnColor (Path -> [Chunk]) -> [Path] -> [[Chunk]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path]
psAll)
  PReqBody TypeRep
_ (PVerb ByteString
"GET" Integer
_ TypeRep
_) -> Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ [[Chunk]] -> Error
Error ([[Chunk]] -> Error) -> [[Chunk]] -> Error
forall a b. (a -> b) -> a -> b
$
     [ Text -> Chunk
chunk Text
"Bad verb, do not use ReqBody in a GET request, Http 1.1 says its meaningless"
     ] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: (Path -> [Chunk]
badReturnColor (Path -> [Chunk]) -> [Path] -> [[Chunk]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path]
psAll)
  PReqBody TypeRep
_ (PVerb {}) -> Maybe Error
forall a. Maybe a
Nothing
  PReqBody TypeRep
_ Path
_ -> Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ [[Chunk]] -> Error
Error ([[Chunk]] -> Error) -> [[Chunk]] -> Error
forall a b. (a -> b) -> a -> b
$
     [ Text -> Chunk
chunk Text
"ReqBody must be the last combinator before the Verb"
     ] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: (Path -> [Chunk]
badReturnColor (Path -> [Chunk]) -> [Path] -> [[Chunk]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path]
psAll)
  Path
_ -> Maybe Error
forall a. Maybe a
Nothing
  where
    badReturnColor :: Path -> [Chunk]
    badReturnColor :: Path -> [Chunk]
badReturnColor Path
p' = Chunk -> [Chunk]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Chunk -> [Chunk]) -> Chunk -> [Chunk]
forall a b. (a -> b) -> a -> b
$
      if Path
c Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
== Path
p'
      then Colour -> Chunk -> Chunk
fore Colour
red (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ (Text
"\t" <>) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path -> String
forall a. Show a => a -> String
show Path
p' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" 👈"
      else Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ (Text
"\t" <>) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path -> String
forall a. Show a => a -> String
show Path
p'

printAmbiguity :: [Path] -> Path -> Error
printAmbiguity :: [Path] -> Path -> Error
printAmbiguity [Path]
ps Path
p = [[Chunk]] -> Error
Error ([[Chunk]] -> Error) -> [[Chunk]] -> Error
forall a b. (a -> b) -> a -> b
$
    [ Text -> Chunk
chunk Text
"Ambiguous with "
    , Chunk -> Chunk
bold (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (Path -> String
forall a. Show a => a -> String
show Path
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
    ] [Chunk] -> [[Chunk]] -> [[Chunk]]
forall a. a -> [a] -> [a]
: (Path -> [Chunk]
overlappingColor (Path -> [Chunk]) -> [Path] -> [[Chunk]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path]
ps)
  where
    overlappingColor :: Path -> [Chunk]
overlappingColor Path
p' = Chunk -> [Chunk]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Chunk -> [Chunk]) -> Chunk -> [Chunk]
forall a b. (a -> b) -> a -> b
$
      if Path -> [Ambiguity]
ambiguity Path
p [Ambiguity] -> [Ambiguity] -> Bool
=!!= Path -> [Ambiguity]
ambiguity Path
p'
      then Colour -> Chunk -> Chunk
fore Colour
red (Chunk -> Chunk) -> Chunk -> Chunk
forall a b. (a -> b) -> a -> b
$ Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ (Text
"\t" <>) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path -> String
forall a. Show a => a -> String
show Path
p' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" 👈"
      else Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ (Text
"\t" <>) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path -> String
forall a. Show a => a -> String
show Path
p'

-- | Exported for testing only
unlinesChunks :: [[Chunk]] -> [Chunk]
unlinesChunks :: [[Chunk]] -> [Chunk]
unlinesChunks = ([Chunk] -> [Chunk]) -> [[Chunk]] -> [Chunk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Chunk] -> [Chunk] -> [Chunk]
forall a. Semigroup a => a -> a -> a
<> [Text -> Chunk
chunk Text
"\n"])