{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
#if __GLASGOW_HASKELL__ >= 806
{-# LANGUAGE UndecidableInstances #-}
#endif
module Servant.Swagger.Internal where

import Control.Applicative ((<|>))
import Control.Lens
import Data.Aeson
import Data.Foldable (toList)
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Proxy
import Data.Singletons.Bool
import Data.Swagger hiding (Header)
import qualified Data.Swagger as Swagger
import Data.Swagger.Declare
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable
import GHC.Generics (D1, Meta (..), Rep)
import GHC.TypeLits
import Network.HTTP.Media (MediaType)
import Prelude.Compat
import Servant.API
import Servant.API.Description (FoldDescription, reflectDescription)
import Servant.API.Modifiers (FoldRequired)
import Prelude ()

import Servant.Swagger.Internal.TypeLevel.API

-- | Generate a Swagger specification for a servant API.
--
-- To generate Swagger specification, your data types need
-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.
--
-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@.
-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.
--
-- You can easily derive those instances via @Generic@.
-- For more information, refer to <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.
--
-- Example:
--
-- @
-- newtype Username = Username String deriving (Generic, ToText)
--
-- instance ToParamSchema Username
--
-- data User = User
--   { username :: Username
--   , fullname :: String
--   } deriving (Generic)
--
-- instance ToJSON User
-- instance ToSchema User
--
-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User
--
-- mySwagger :: Swagger
-- mySwagger = toSwagger (Proxy :: Proxy MyAPI)
-- @
class HasSwagger api where
  -- | Generate a Swagger specification for a servant API.
  toSwagger :: Proxy api -> Swagger

instance HasSwagger Raw where
  toSwagger _ = mempty & paths . at "/" ?~ mempty

instance HasSwagger EmptyAPI where
  toSwagger _ = mempty

-- | All operations of sub API.
-- This is similar to @'operationsOf'@ but ensures that operations
-- indeed belong to the API at compile time.
subOperations
  :: (HasSwagger sub, IsSubAPI sub api)
  => Proxy sub
  -- ^ Part of a servant API.
  -> Proxy api
  -- ^ The whole servant API.
  -> Traversal' Swagger Operation
subOperations sub _ = operationsOf (toSwagger sub)

-- | Make a singleton Swagger spec (with only one endpoint).
-- For endpoints with no content see 'mkEndpointNoContent'.
mkEndpoint
  :: forall a cs hs proxy method status
   . (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method, ToSchema a)
  => FilePath
  -- ^ Endpoint path.
  -> proxy (Verb method status cs (Headers hs a))
  -- ^ Method, content-types, headers and response.
  -> Swagger
mkEndpoint path proxy =
  mkEndpointWithSchemaRef (Just ref) path proxy
    & definitions .~ defs
  where
    (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty

-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.
mkEndpointNoContent
  :: forall nocontent cs hs proxy method status
   . (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
  => FilePath
  -- ^ Endpoint path.
  -> proxy (Verb method status cs (Headers hs nocontent))
  -- ^ Method, content-types, headers and response.
  -> Swagger
mkEndpointNoContent = mkEndpointWithSchemaRef Nothing

-- | Like @'mkEndpoint'@ but with explicit schema reference.
-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.
mkEndpointWithSchemaRef
  :: forall cs hs proxy method status a
   . (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
  => Maybe (Referenced Schema)
  -> FilePath
  -> proxy (Verb method status cs (Headers hs a))
  -> Swagger
mkEndpointWithSchemaRef mref path _ =
  mempty
    & paths . at path
      ?~ ( mempty
             & method
               ?~ ( mempty
                      & produces ?~ MimeList responseContentTypes
                      & at code
                        ?~ Inline
                          ( mempty
                              & schema .~ mref
                              & headers .~ responseHeaders
                          )
                  )
         )
  where
    method = swaggerMethod (Proxy :: Proxy method)
    code = fromIntegral (natVal (Proxy :: Proxy status))
    responseContentTypes = allContentType (Proxy :: Proxy cs)
    responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)

mkEndpointNoContentVerb
  :: forall proxy method
   . SwaggerMethod method
  => FilePath
  -- ^ Endpoint path.
  -> proxy (NoContentVerb method)
  -- ^ Method
  -> Swagger
mkEndpointNoContentVerb path _ =
  mempty
    & paths . at path
      ?~ ( mempty
             & method
               ?~ ( mempty
                      & at code ?~ Inline mempty
                  )
         )
  where
    method = swaggerMethod (Proxy :: Proxy method)
    code = 204 -- hardcoded in servant-server

-- | Add parameter to every operation in the spec.
addParam :: Param -> Swagger -> Swagger
addParam param = allOperations . parameters %~ (Inline param :)

-- | Add a tag to every operation in the spec.
addTag :: Text -> Swagger -> Swagger
addTag tag = allOperations . tags %~ ([tag] <>)

-- | Add accepted content types to every operation in the spec.
addConsumes :: [MediaType] -> Swagger -> Swagger
addConsumes cs = allOperations . consumes %~ (<> Just (MimeList cs))

-- | Format given text as inline code in Markdown.
markdownCode :: Text -> Text
markdownCode s = "`" <> s <> "`"

addDefaultResponse400 :: ParamName -> Swagger -> Swagger
addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (pure response400)
  where
    sname = markdownCode pname
    description400 = "Invalid " <> sname
    alter400 = description %~ (<> (" or " <> sname))
    response400 = mempty & description .~ description400

-- | Methods, available for Swagger.
class SwaggerMethod method where
  swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)

instance SwaggerMethod 'GET where swaggerMethod _ = get

instance SwaggerMethod 'PUT where swaggerMethod _ = put

instance SwaggerMethod 'POST where swaggerMethod _ = post

instance SwaggerMethod 'DELETE where swaggerMethod _ = delete

instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options

instance SwaggerMethod 'HEAD where swaggerMethod _ = head_

instance SwaggerMethod 'PATCH where swaggerMethod _ = patch

instance HasSwagger (UVerb method cs '[]) where
  toSwagger _ = mempty

-- | @since <TODO>
instance
  {-# OVERLAPPABLE #-}
  ( AllAccept cs
  , HasStatus a
  , HasSwagger (UVerb method cs as)
  , SwaggerMethod method
  , ToSchema a
  )
  => HasSwagger (UVerb method cs (a ': as))
  where
  toSwagger _ =
    toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))
      `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))

-- ATTENTION: do not remove this instance!
-- A similar instance above will always use the more general
-- polymorphic -- HasSwagger instance and will result in a type error
-- since 'NoContent' does not have a 'ToSchema' instance.
instance
  ( AllAccept cs
  , HasSwagger (UVerb method cs as)
  , KnownNat status
  , SwaggerMethod method
  )
  => HasSwagger (UVerb method cs (WithStatus status NoContent ': as))
  where
  toSwagger _ =
    toSwagger (Proxy :: Proxy (Verb method status cs NoContent))
      `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))

-- workaround for https://github.com/GetShopTV/swagger2/issues/218
-- We'd like to juse use (<>) but the instances are wrong
combinePathItem :: PathItem -> PathItem -> PathItem
combinePathItem s t =
  PathItem
    { _pathItemGet = _pathItemGet s <> _pathItemGet t
    , _pathItemPut = _pathItemPut s <> _pathItemPut t
    , _pathItemPost = _pathItemPost s <> _pathItemPost t
    , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t
    , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t
    , _pathItemHead = _pathItemHead s <> _pathItemHead t
    , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t
    , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
    }

combineSwagger :: Swagger -> Swagger -> Swagger
combineSwagger s t =
  Swagger
    { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t
    , _swaggerHost = _swaggerHost s <|> _swaggerHost t
    , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t
    , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t
    , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t
    , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t
    , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)
    , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t
    , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t
    , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t
    , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t
    , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t
    , _swaggerTags = _swaggerTags s <> _swaggerTags t
    , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t
    }

instance {-# OVERLAPPABLE #-} (AllAccept cs, KnownNat status, SwaggerMethod method, ToSchema a) => HasSwagger (Verb method status cs a) where
  toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))

-- | @since 1.1.7
instance (Accept ct, KnownNat status, SwaggerMethod method, ToSchema a) => HasSwagger (Stream method status fr ct a) where
  toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))

instance
  {-# OVERLAPPABLE #-}
  (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method, ToSchema a)
  => HasSwagger (Verb method status cs (Headers hs a))
  where
  toSwagger = mkEndpoint "/"

-- ATTENTION: do not remove this instance!
-- A similar instance above will always use the more general
-- polymorphic -- HasSwagger instance and will result in a type error
-- since 'NoContent' does not have a 'ToSchema' instance.
instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where
  toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))

instance
  (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
  => HasSwagger (Verb method status cs (Headers hs NoContent))
  where
  toSwagger = mkEndpointNoContent "/"

instance SwaggerMethod method => HasSwagger (NoContentVerb method) where
  toSwagger = mkEndpointNoContentVerb "/"

instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where
  toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)

-- | @'Vault'@ combinator does not change our specification at all.
instance HasSwagger sub => HasSwagger (Vault :> sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy sub)

-- | @'IsSecure'@ combinator does not change our specification at all.
instance HasSwagger sub => HasSwagger (IsSecure :> sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy sub)

-- | @'RemoteHost'@ combinator does not change our specification at all.
instance HasSwagger sub => HasSwagger (RemoteHost :> sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy sub)

-- | @'Fragment'@ combinator does not change our specification at all.
instance HasSwagger sub => HasSwagger (Fragment a :> sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy sub)

-- | @'HttpVersion'@ combinator does not change our specification at all.
instance HasSwagger sub => HasSwagger (HttpVersion :> sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy sub)

-- | @'WithNamedContext'@ combinator does not change our specification at all.
instance HasSwagger sub => HasSwagger (WithNamedContext x c sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy sub)

-- | @'WithResource'@ combinator does not change our specification at all.
instance HasSwagger sub => HasSwagger (WithResource res :> sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy sub)

instance (HasSwagger sub, KnownSymbol sym) => HasSwagger (sym :> sub) where
  toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
    where
      piece = symbolVal (Proxy :: Proxy sym)

instance (HasSwagger sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, ToParamSchema a, Typeable a) => HasSwagger (Capture' mods sym a :> sub) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy sub)
      & addParam param
      & prependPath capture
      & addDefaultResponse400 tname
    where
      symbol = symbolVal (Proxy :: Proxy sym)
      pname =
        if symbol == ""
          then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)
          else symbol
      tname = Text.pack pname
      transDesc "" = Nothing
      transDesc desc = Just (Text.pack desc)
      capture = "{" <> pname <> "}"
      param =
        mempty
          & name .~ tname
          & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
          & required ?~ True
          & schema
            .~ ParamOther
              ( mempty
                  & in_ .~ ParamPath
                  & paramSchema .~ toParamSchema (Proxy :: Proxy a)
              )

-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.
instance (HasSwagger sub, KnownSymbol sym, ToParamSchema a, Typeable a) => HasSwagger (CaptureAll sym a :> sub) where
  toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))

instance (HasSwagger api, KnownSymbol desc) => HasSwagger (Description desc :> api) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy api)
      & allOperations . description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)

instance (HasSwagger api, KnownSymbol desc) => HasSwagger (Summary desc :> api) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy api)
      & allOperations . summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)

instance (HasSwagger api, KnownSymbol operationId) => HasSwagger (OperationId operationId :> api) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy api)
      & allOperations . operationId %~ (Just (Text.pack (symbolVal (Proxy :: Proxy operationId))) <>)

instance (HasSwagger sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, SBoolI (FoldRequired mods), ToParamSchema a) => HasSwagger (QueryParam' mods sym a :> sub) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy sub)
      & addParam param
      & addDefaultResponse400 tname
    where
      tname = Text.pack (symbolVal (Proxy :: Proxy sym))
      transDesc "" = Nothing
      transDesc desc = Just (Text.pack desc)
      param =
        mempty
          & name .~ tname
          & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
          & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
          & schema .~ ParamOther sch
      sch =
        mempty
          & in_ .~ ParamQuery
          & paramSchema .~ toParamSchema (Proxy :: Proxy a)

instance (HasSwagger sub, KnownSymbol sym, ToParamSchema a) => HasSwagger (QueryParams sym a :> sub) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy sub)
      & addParam param
      & addDefaultResponse400 tname
    where
      tname = Text.pack (symbolVal (Proxy :: Proxy sym))
      param =
        mempty
          & name .~ tname
          & schema .~ ParamOther sch
      sch =
        mempty
          & in_ .~ ParamQuery
          & paramSchema .~ pschema

      pschemaItems = SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))
#if MIN_VERSION_swagger2(2,4,0)
      pschema = mempty & type_ ?~ SwaggerArray & items ?~ pschemaItems
#else
      pschema = mempty & type_ .~ SwaggerArray & items ?~ pschemaItems
#endif

instance (HasSwagger sub, KnownSymbol sym) => HasSwagger (QueryFlag sym :> sub) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy sub)
      & addParam param
      & addDefaultResponse400 tname
    where
      tname = Text.pack (symbolVal (Proxy :: Proxy sym))
      param =
        mempty
          & name .~ tname
          & schema
            .~ ParamOther
              ( mempty
                  & in_ .~ ParamQuery
                  & allowEmptyValue ?~ True
                  & paramSchema
                    .~ ( toParamSchema (Proxy :: Proxy Bool)
                           & default_ ?~ toJSON False
                       )
              )

instance (HasSwagger sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, SBoolI (FoldRequired mods), ToParamSchema a) => HasSwagger (Header' mods sym a :> sub) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy sub)
      & addParam param
      & addDefaultResponse400 tname
    where
      tname = Text.pack (symbolVal (Proxy :: Proxy sym))
      transDesc "" = Nothing
      transDesc desc = Just (Text.pack desc)
      param =
        mempty
          & name .~ tname
          & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
          & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
          & schema
            .~ ParamOther
              ( mempty
                  & in_ .~ ParamHeader
                  & paramSchema .~ toParamSchema (Proxy :: Proxy a)
              )

instance (AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods), ToSchema a) => HasSwagger (ReqBody' mods cs a :> sub) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy sub)
      & addParam param
      & addConsumes (allContentType (Proxy :: Proxy cs))
      & addDefaultResponse400 tname
      & definitions %~ (<> defs)
    where
      tname = "body"
      transDesc "" = Nothing
      transDesc desc = Just (Text.pack desc)
      (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
      param =
        mempty
          & name .~ tname
          & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
          & required ?~ True
          & schema .~ ParamBody ref

-- | This instance is an approximation.
--
-- @since 1.1.7
instance (Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods), ToSchema a) => HasSwagger (StreamBody' mods fr ct a :> sub) where
  toSwagger _ =
    toSwagger (Proxy :: Proxy sub)
      & addParam param
      & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))
      & addDefaultResponse400 tname
      & definitions %~ (<> defs)
    where
      tname = "body"
      transDesc "" = Nothing
      transDesc desc = Just (Text.pack desc)
      (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
      param =
        mempty
          & name .~ tname
          & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
          & required ?~ True
          & schema .~ ParamBody ref

instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where
  toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))

-- =======================================================================
-- Below are the definitions that should be in Servant.API.ContentTypes
-- =======================================================================

class AllAccept cs where
  allContentType :: Proxy cs -> [MediaType]

instance AllAccept '[] where
  allContentType _ = []

instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
  allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)

class ToResponseHeader h where
  toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)

instance (KnownSymbol (FoldDescription mods), KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header' mods sym a) where
  toResponseHeader _ =
    ( hname
    , Swagger.Header (transDesc $ reflectDescription (Proxy :: Proxy mods)) hschema
    )
    where
      hname = Text.pack (symbolVal (Proxy :: Proxy sym))
      transDesc "" = Nothing
      transDesc desc = Just (Text.pack desc)
      hschema = toParamSchema (Proxy :: Proxy a)

class AllToResponseHeader hs where
  toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header

instance AllToResponseHeader '[] where
  toAllResponseHeaders _ = mempty

instance (AllToResponseHeader hs, ToResponseHeader h) => AllToResponseHeader (h ': hs) where
  toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
    where
      (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
      hdrs = toAllResponseHeaders (Proxy :: Proxy hs)

instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where
  toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)
