{-# 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)
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
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))
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)
(=!=) :: 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
(=!!=) :: [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
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
(=!!=)
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
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
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'
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"])