Lint.hs

{-# 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 (Eq, Ord)

instance Show Path where
  show (PPath s p)           = "\"" <> s <> "\" :> " <> show p
  show (PCapture s t p)      = "Capture \"" <> s <> "\" " <> show t <> " :> " <> show p
  show (PCaptureAll s t p)   = "CaptureAll \"" <> s <> "\" " <> show t <> " :> " <> show p
  show (PQueryParam s t p)   = "QueryParam \"" <> s <> "\" " <> show t <> " :> " <> show p
  show (PQueryParams s t p)  = "QueryParams \"" <> s <> "\" " <> show t <> " :> " <> show p
  show (PReqBody t p)        = "ReqBody _ _ " <> show t <> " :> " <> show p
  show (PVerb method code t) = "Verb '" <> Text.unpack (decodeUtf8 method) <> " " <> show code <> " " <> show 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 = paths @a <> paths @b

instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (Capture' _mods hint a :> b) where
  paths = PCapture (symbolVal (Proxy @hint)) (typeRep (Proxy @a))<$> paths @b

instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (CaptureAll hint a :> b) where
  paths = PCaptureAll (symbolVal (Proxy @hint)) (typeRep (Proxy @a)) <$> paths @b

instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (QueryParam hint a :> b) where
  paths = PQueryParam (symbolVal (Proxy @hint)) (typeRep (Proxy @a)) <$> paths @b

instance (Lintable b, KnownSymbol hint, Typeable a) => Lintable (QueryParams hint a :> b) where
  paths = PQueryParam (symbolVal (Proxy @hint)) (typeRep (Proxy @a)) <$> paths @b

instance (Lintable b, Typeable a) => Lintable (ReqBody' _mods _ms a :> b) where
  paths = PReqBody (typeRep (Proxy @a)) <$> paths @b

instance (KnownSymbol a, Lintable b) => Lintable (a :> b) where
  paths = PPath (symbolVal (Proxy @a)) <$> paths @b

instance {-# OVERLAPPABLE #-}
  ( ReflectMethod method
  ) => Lintable (NoContentVerb method) where
  paths = pure $ PVerb (reflectMethod (Proxy @method)) 204 (typeRep (Proxy @NoContent))

instance {-# OVERLAPPABLE #-}
  ( Typeable ret
  , ReflectMethod method
  , KnownNat code
  ) => Lintable (Verb method code _cs ret) where
  paths = pure $ PVerb (reflectMethod (Proxy @method)) (natVal (Proxy @code)) (typeRep (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 (Eq, Ord, Show, Generic)

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

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

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

checkForDuplicates :: Path -> Maybe Error
checkForDuplicates p =
  if length (nubOrd noStatic) /= length noStatic
  then Just $ Error [[ chunk "Duplicate found in route "
                     , bold $ chunk $ Text.pack (show p) <> ":"
                    ]]
  else Nothing
  where
  noStatic = filter (\case APath _ -> False; _ -> True) $ ambiguity p

-- | Pretty errors via @Text.Colour@
newtype Error = Error { toChunks :: [[Chunk]] }
  deriving newtype (Eq, Show, Semigroup, Monoid)

elem' :: [Ambiguity] -> [[Ambiguity]] -> Bool
elem' = any . (=!!=)

-- | 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' = case go psAll of [x,_] -> [x]; x -> x
  where
  psAll = paths @api
  go [] = []
  go (p:ps) =
    let ambiguities = [printAmbiguity psAll p | ambiguity p `elem'` (ambiguity <$> deleteFirst p psAll)]
        badReturns  = mapMaybe (badReturn psAll p) psAll
        duplicates  = checkForDuplicates p
    in ambiguities <> badReturns <> maybeToList duplicates <> go ps

-- | Pass your API type for lint errors thrown in IO
-- This is typically useful for testing
lintAPI :: forall api. Lintable api => IO ()
lintAPI = case lintAPI' @api of
    [] -> pure ()
    ls -> error $ Text.unpack $ renderChunksText With24BitColours . unlinesChunks $ unlinesChunks . toChunks <$> ls

-- | Pass your API type for lint via @putStrLn@ in stdout
printLintAPI :: forall api. Lintable api => IO ()
printLintAPI = case lintAPI' @api of
    [] -> pure ()
    ls -> putStrLn $ Text.unpack $ renderChunksText With24BitColours . unlinesChunks $ unlinesChunks . toChunks <$> ls

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

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

printAmbiguity :: [Path] -> Path -> Error
printAmbiguity ps p = Error $
    [ chunk "Ambiguous with "
    , bold $ chunk $ Text.pack (show p) <> ":"
    ] : (overlappingColor <$> ps)
  where
    overlappingColor p' = pure $
      if ambiguity p =!!= ambiguity p'
      then fore red $ chunk $ ("\t" <>) $ Text.pack $ show p' <> " 👈"
      else chunk $ ("\t" <>) $ Text.pack $ show p'

-- | Exported for testing only
unlinesChunks :: [[Chunk]] -> [Chunk]
unlinesChunks = concatMap (<> [chunk "\n"])