-- | Types that describe route info. We use it to derive OpenApi schema or clients.
module Mig.Core.Types.Info (
  RouteInfo (..),
  RouteInput (..),
  Describe (..),
  noDescription,
  getInputType,
  RouteOutput (..),
  IsRequired (..),
  OutputSchema,
  InputSchema,
  SchemaDefs (..),
  emptySchemaDefs,
  toSchemaDefs,
  addRouteInput,
  setOutputMedia,
  setMethod,
  emptyRouteInfo,
  describeInfoInputs,

  -- * api updates
  addBodyInfo,
  addHeaderInfo,
  addOptionalHeaderInfo,
  addQueryInfo,
  addQueryFlagInfo,
  addOptionalInfo,
  addCaptureInfo,

  -- * checks
  routeHasQuery,
  routeHasOptionalQuery,
  routeHasQueryFlag,
  routeHasCapture,
) where

import Data.List.Extra (firstJust)
import Data.Map.Strict qualified as Map
import Data.OpenApi (Definitions, Referenced, Schema, ToParamSchema (..), ToSchema (..), declareSchemaRef)
import Data.OpenApi.Declare (runDeclare)
import Data.Proxy
import Data.String
import Data.Text (Text)
import GHC.TypeLits
import Mig.Core.Class.MediaType
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status

-- | Information on route
data RouteInfo = RouteInfo
  { RouteInfo -> Maybe Method
method :: Maybe Method
  -- ^ http method
  , RouteInfo -> [Describe RouteInput]
inputs :: [Describe RouteInput]
  -- ^ route inputs
  , RouteInfo -> RouteOutput
output :: RouteOutput
  -- ^ route outputs
  , RouteInfo -> [Text]
tags :: [Text]
  -- ^ open-api tags
  , RouteInfo -> Text
description :: Text
  -- ^ open-api description
  , RouteInfo -> Text
summary :: Text
  -- ^ open-api summary
  }
  deriving (Int -> RouteInfo -> ShowS
[RouteInfo] -> ShowS
RouteInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RouteInfo] -> ShowS
$cshowList :: [RouteInfo] -> ShowS
show :: RouteInfo -> String
$cshow :: RouteInfo -> String
showsPrec :: Int -> RouteInfo -> ShowS
$cshowsPrec :: Int -> RouteInfo -> ShowS
Show, RouteInfo -> RouteInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouteInfo -> RouteInfo -> Bool
$c/= :: RouteInfo -> RouteInfo -> Bool
== :: RouteInfo -> RouteInfo -> Bool
$c== :: RouteInfo -> RouteInfo -> Bool
Eq)

newtype IsRequired = IsRequired Bool
  deriving newtype (Int -> IsRequired -> ShowS
[IsRequired] -> ShowS
IsRequired -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IsRequired] -> ShowS
$cshowList :: [IsRequired] -> ShowS
show :: IsRequired -> String
$cshow :: IsRequired -> String
showsPrec :: Int -> IsRequired -> ShowS
$cshowsPrec :: Int -> IsRequired -> ShowS
Show, IsRequired -> IsRequired -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsRequired -> IsRequired -> Bool
$c/= :: IsRequired -> IsRequired -> Bool
== :: IsRequired -> IsRequired -> Bool
$c== :: IsRequired -> IsRequired -> Bool
Eq)

-- | Values which have human-readable description.
data Describe a = Describe
  { forall a. Describe a -> Maybe Text
description :: Maybe Text
  , forall a. Describe a -> a
content :: a
  }
  deriving (Int -> Describe a -> ShowS
forall a. Show a => Int -> Describe a -> ShowS
forall a. Show a => [Describe a] -> ShowS
forall a. Show a => Describe a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Describe a] -> ShowS
$cshowList :: forall a. Show a => [Describe a] -> ShowS
show :: Describe a -> String
$cshow :: forall a. Show a => Describe a -> String
showsPrec :: Int -> Describe a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Describe a -> ShowS
Show, Describe a -> Describe a -> Bool
forall a. Eq a => Describe a -> Describe a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Describe a -> Describe a -> Bool
$c/= :: forall a. Eq a => Describe a -> Describe a -> Bool
== :: Describe a -> Describe a -> Bool
$c== :: forall a. Eq a => Describe a -> Describe a -> Bool
Eq)

-- | no description provided
noDescription :: a -> Describe a
noDescription :: forall a. a -> Describe a
noDescription = forall a. Maybe Text -> a -> Describe a
Describe forall a. Maybe a
Nothing

{-| Appends descriptiton for the info
special name request-body is dedicated to request body input
nd raw-input is dedicated to raw input
-}
describeInfoInputs :: [(Text, Text)] -> RouteInfo -> RouteInfo
describeInfoInputs :: [(Text, Text)] -> RouteInfo -> RouteInfo
describeInfoInputs [(Text, Text)]
descs RouteInfo
routeInfo = RouteInfo
routeInfo{$sel:inputs:RouteInfo :: [Describe RouteInput]
inputs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Describe RouteInput -> Describe RouteInput
addDesc RouteInfo
routeInfo.inputs}
  where
    addDesc :: Describe RouteInput -> Describe RouteInput
addDesc Describe RouteInput
inp =
      forall a. Maybe Text -> a -> Describe a
Describe (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall {r}. HasField "content" r RouteInput => r -> Text
getInputName Describe RouteInput
inp) Map Text Text
descMap) Describe RouteInput
inp.content

    getInputName :: r -> Text
getInputName r
inp =
      case r
inp.content of
        ReqBodyInput MediaType
_ SchemaDefs
_ -> Text
"request-body"
        RouteInput
RawBodyInput -> Text
"raw-input"
        CaptureInput Text
captureName Schema
_ -> Text
captureName
        QueryInput IsRequired
_ Text
queryName Schema
_ -> Text
queryName
        QueryFlagInput Text
queryName -> Text
queryName
        HeaderInput IsRequired
_ Text
headerName Schema
_ -> Text
headerName

    descMap :: Map Text Text
descMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
descs

-- | Route inputs
data RouteInput
  = ReqBodyInput MediaType SchemaDefs
  | RawBodyInput
  | CaptureInput Text Schema
  | QueryInput IsRequired Text Schema
  | QueryFlagInput Text
  | HeaderInput IsRequired Text Schema
  deriving (Int -> RouteInput -> ShowS
[RouteInput] -> ShowS
RouteInput -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RouteInput] -> ShowS
$cshowList :: [RouteInput] -> ShowS
show :: RouteInput -> String
$cshow :: RouteInput -> String
showsPrec :: Int -> RouteInput -> ShowS
$cshowsPrec :: Int -> RouteInput -> ShowS
Show, RouteInput -> RouteInput -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouteInput -> RouteInput -> Bool
$c/= :: RouteInput -> RouteInput -> Bool
== :: RouteInput -> RouteInput -> Bool
$c== :: RouteInput -> RouteInput -> Bool
Eq)

-- | Get input media-type
getInputType :: RouteInfo -> Maybe MediaType
getInputType :: RouteInfo -> Maybe MediaType
getInputType RouteInfo
route = forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust (RouteInput -> Maybe MediaType
fromInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.content)) RouteInfo
route.inputs
  where
    fromInput :: RouteInput -> Maybe MediaType
fromInput = \case
      ReqBodyInput MediaType
ty SchemaDefs
_ -> forall a. a -> Maybe a
Just MediaType
ty
      RouteInput
_ -> forall a. Maybe a
Nothing

-- | Input schema
type InputSchema = SchemaDefs

-- | Route output
data RouteOutput = RouteOutput
  { RouteOutput -> Status
status :: Status
  -- ^ http status
  , RouteOutput -> MediaType
media :: MediaType
  -- ^ media type
  , RouteOutput -> SchemaDefs
schema :: OutputSchema
  -- ^ open-api schema
  }
  deriving (Int -> RouteOutput -> ShowS
[RouteOutput] -> ShowS
RouteOutput -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RouteOutput] -> ShowS
$cshowList :: [RouteOutput] -> ShowS
show :: RouteOutput -> String
$cshow :: RouteOutput -> String
showsPrec :: Int -> RouteOutput -> ShowS
$cshowsPrec :: Int -> RouteOutput -> ShowS
Show, RouteOutput -> RouteOutput -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouteOutput -> RouteOutput -> Bool
$c/= :: RouteOutput -> RouteOutput -> Bool
== :: RouteOutput -> RouteOutput -> Bool
$c== :: RouteOutput -> RouteOutput -> Bool
Eq)

-- | Output schema
type OutputSchema = SchemaDefs

-- | Schem definition with references to the used sub-values
data SchemaDefs = SchemaDefs
  { SchemaDefs -> Definitions Schema
defs :: Definitions Schema
  , SchemaDefs -> Maybe (Referenced Schema)
ref :: Maybe (Referenced Schema)
  }
  deriving (Int -> SchemaDefs -> ShowS
[SchemaDefs] -> ShowS
SchemaDefs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaDefs] -> ShowS
$cshowList :: [SchemaDefs] -> ShowS
show :: SchemaDefs -> String
$cshow :: SchemaDefs -> String
showsPrec :: Int -> SchemaDefs -> ShowS
$cshowsPrec :: Int -> SchemaDefs -> ShowS
Show, SchemaDefs -> SchemaDefs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemaDefs -> SchemaDefs -> Bool
$c/= :: SchemaDefs -> SchemaDefs -> Bool
== :: SchemaDefs -> SchemaDefs -> Bool
$c== :: SchemaDefs -> SchemaDefs -> Bool
Eq)

-- | Create schema definition
toSchemaDefs :: forall a. (ToSchema a) => SchemaDefs
toSchemaDefs :: forall a. ToSchema a => SchemaDefs
toSchemaDefs =
  Definitions Schema -> Maybe (Referenced Schema) -> SchemaDefs
SchemaDefs Definitions Schema
defs (forall a. a -> Maybe a
Just Referenced Schema
ref)
  where
    (Definitions Schema
defs, Referenced Schema
ref) = forall d a. Declare d a -> d -> (d, a)
runDeclare (forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (forall {k} (t :: k). Proxy t
Proxy @a)) forall a. Monoid a => a
mempty

-- | An empty schema definition
emptySchemaDefs :: SchemaDefs
emptySchemaDefs :: SchemaDefs
emptySchemaDefs = Definitions Schema -> Maybe (Referenced Schema) -> SchemaDefs
SchemaDefs forall a. Monoid a => a
mempty forall a. Maybe a
Nothing

-- | Add route input to route info list of inputs
addRouteInput :: RouteInput -> RouteInfo -> RouteInfo
addRouteInput :: RouteInput -> RouteInfo -> RouteInfo
addRouteInput RouteInput
inp = Describe RouteInput -> RouteInfo -> RouteInfo
addRouteInputWithDescriptiton (forall a. a -> Describe a
noDescription RouteInput
inp)

-- | Adds route input with description
addRouteInputWithDescriptiton :: Describe RouteInput -> RouteInfo -> RouteInfo
addRouteInputWithDescriptiton :: Describe RouteInput -> RouteInfo -> RouteInfo
addRouteInputWithDescriptiton Describe RouteInput
inp RouteInfo
routeInfo =
  RouteInfo
routeInfo{$sel:inputs:RouteInfo :: [Describe RouteInput]
inputs = Describe RouteInput
inp forall a. a -> [a] -> [a]
: RouteInfo
routeInfo.inputs}

{-| Default empty route info. We update it as we construct the route with type-safe DSL.
Almost all values are derived from type signatures
-}
emptyRouteInfo :: RouteInfo
emptyRouteInfo :: RouteInfo
emptyRouteInfo =
  Maybe Method
-> [Describe RouteInput]
-> RouteOutput
-> [Text]
-> Text
-> Text
-> RouteInfo
RouteInfo forall a. Maybe a
Nothing [] (Status -> MediaType -> SchemaDefs -> RouteOutput
RouteOutput Status
ok200 MediaType
"*/*" SchemaDefs
emptySchemaDefs) [] Text
"" Text
""

-- | Set http-method of the route
setMethod :: Method -> MediaType -> RouteInfo -> RouteInfo
setMethod :: Method -> MediaType -> RouteInfo -> RouteInfo
setMethod Method
method MediaType
mediaType RouteInfo
routeInfo =
  RouteInfo
routeInfo
    { $sel:method:RouteInfo :: Maybe Method
method = forall a. a -> Maybe a
Just Method
method
    , $sel:output:RouteInfo :: RouteOutput
output = Status -> MediaType -> SchemaDefs -> RouteOutput
RouteOutput RouteInfo
routeInfo.output.status MediaType
mediaType SchemaDefs
emptySchemaDefs
    }

-- | Set output meida-type for the route
setOutputMedia :: MediaType -> RouteInfo -> RouteInfo
setOutputMedia :: MediaType -> RouteInfo -> RouteInfo
setOutputMedia MediaType
mediaType RouteInfo
routeInfo =
  RouteInfo
routeInfo{$sel:output:RouteInfo :: RouteOutput
output = RouteOutput -> RouteOutput
setMedia RouteInfo
routeInfo.output}
  where
    setMedia :: RouteOutput -> RouteOutput
setMedia RouteOutput
outp = RouteOutput
outp{$sel:media:RouteOutput :: MediaType
media = MediaType
mediaType}

-- | Add parameter to the inputs of the route
addParamInfoBy :: forall sym a. (KnownSymbol sym, ToParamSchema a) => (Text -> Schema -> RouteInput) -> RouteInfo -> RouteInfo
addParamInfoBy :: forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
(Text -> Schema -> RouteInput) -> RouteInfo -> RouteInfo
addParamInfoBy Text -> Schema -> RouteInput
cons = RouteInput -> RouteInfo -> RouteInfo
addRouteInput (Text -> Schema -> RouteInput
cons (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToParamSchema a => Proxy a -> Schema
toParamSchema (forall {k} (t :: k). Proxy t
Proxy @a)))

-- | Adds required header info to API schema
addHeaderInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo
addHeaderInfo :: forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addHeaderInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
(Text -> Schema -> RouteInput) -> RouteInfo -> RouteInfo
addParamInfoBy @sym @a (IsRequired -> Text -> Schema -> RouteInput
HeaderInput (Bool -> IsRequired
IsRequired Bool
True))

-- | Adds optional header info to API schema
addOptionalHeaderInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo
addOptionalHeaderInfo :: forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addOptionalHeaderInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
(Text -> Schema -> RouteInput) -> RouteInfo -> RouteInfo
addParamInfoBy @sym @a (IsRequired -> Text -> Schema -> RouteInput
HeaderInput (Bool -> IsRequired
IsRequired Bool
False))

-- | Adds required query info to API schema
addQueryInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo
addQueryInfo :: forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addQueryInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
(Text -> Schema -> RouteInput) -> RouteInfo -> RouteInfo
addParamInfoBy @sym @a (IsRequired -> Text -> Schema -> RouteInput
QueryInput (Bool -> IsRequired
IsRequired Bool
True))

-- | Adds optional query info to API schema
addOptionalInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo
addOptionalInfo :: forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addOptionalInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
(Text -> Schema -> RouteInput) -> RouteInfo -> RouteInfo
addParamInfoBy @sym @a (IsRequired -> Text -> Schema -> RouteInput
QueryInput (Bool -> IsRequired
IsRequired Bool
False))

-- | Adds capture info to API schema
addCaptureInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo
addCaptureInfo :: forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addCaptureInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
(Text -> Schema -> RouteInput) -> RouteInfo -> RouteInfo
addParamInfoBy @sym @a Text -> Schema -> RouteInput
CaptureInput

-- | Adds query flag to API schema
addQueryFlagInfo :: forall sym. (KnownSymbol sym) => RouteInfo -> RouteInfo
addQueryFlagInfo :: forall (sym :: Symbol). KnownSymbol sym => RouteInfo -> RouteInfo
addQueryFlagInfo = RouteInput -> RouteInfo -> RouteInfo
addRouteInput (Text -> RouteInput
QueryFlagInput (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym))

-- | Adds request body to API schema
addBodyInfo :: forall ty a. (ToMediaType ty, ToSchema a) => RouteInfo -> RouteInfo
addBodyInfo :: forall {k} (ty :: k) a.
(ToMediaType ty, ToSchema a) =>
RouteInfo -> RouteInfo
addBodyInfo = RouteInput -> RouteInfo -> RouteInfo
addRouteInput (MediaType -> SchemaDefs -> RouteInput
ReqBodyInput (forall {k} (a :: k). ToMediaType a => MediaType
toMediaType @ty) (forall a. ToSchema a => SchemaDefs
toSchemaDefs @a))

---------------------------------------------
-- checks

-- | Check that route has query with given name
routeHasQuery :: Text -> RouteInfo -> Bool
routeHasQuery :: Text -> RouteInfo -> Bool
routeHasQuery Text
expectedName = (RouteInput -> Bool) -> RouteInfo -> Bool
routeHasInput RouteInput -> Bool
isQuery
  where
    isQuery :: RouteInput -> Bool
isQuery = \case
      QueryInput (IsRequired Bool
True) Text
name Schema
_ -> Text
expectedName forall a. Eq a => a -> a -> Bool
== Text
name
      RouteInput
_ -> Bool
False

-- | Check that route has query with given name
routeHasOptionalQuery :: Text -> RouteInfo -> Bool
routeHasOptionalQuery :: Text -> RouteInfo -> Bool
routeHasOptionalQuery Text
expectedName = (RouteInput -> Bool) -> RouteInfo -> Bool
routeHasInput RouteInput -> Bool
isOptionalQuery
  where
    isOptionalQuery :: RouteInput -> Bool
isOptionalQuery = \case
      QueryInput (IsRequired Bool
False) Text
name Schema
_ -> Text
expectedName forall a. Eq a => a -> a -> Bool
== Text
name
      RouteInput
_ -> Bool
False

-- | Check that route has query with given name
routeHasQueryFlag :: Text -> RouteInfo -> Bool
routeHasQueryFlag :: Text -> RouteInfo -> Bool
routeHasQueryFlag Text
expectedName = (RouteInput -> Bool) -> RouteInfo -> Bool
routeHasInput RouteInput -> Bool
isQueryFlag
  where
    isQueryFlag :: RouteInput -> Bool
isQueryFlag = \case
      QueryFlagInput Text
name -> Text
expectedName forall a. Eq a => a -> a -> Bool
== Text
name
      RouteInput
_ -> Bool
False

-- | Check that route has query with given name
routeHasCapture :: Text -> RouteInfo -> Bool
routeHasCapture :: Text -> RouteInfo -> Bool
routeHasCapture Text
expectedName = (RouteInput -> Bool) -> RouteInfo -> Bool
routeHasInput RouteInput -> Bool
isCapture
  where
    isCapture :: RouteInput -> Bool
isCapture = \case
      CaptureInput Text
name Schema
_ -> Text
expectedName forall a. Eq a => a -> a -> Bool
== Text
name
      RouteInput
_ -> Bool
False

-- | Check that route has certain input
routeHasInput :: (RouteInput -> Bool) -> RouteInfo -> Bool
routeHasInput :: (RouteInput -> Bool) -> RouteInfo -> Bool
routeHasInput RouteInput -> Bool
check RouteInfo
info = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (RouteInput -> Bool
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.content)) RouteInfo
info.inputs

---------------------------------------------
-- utils

getName :: forall sym a. (KnownSymbol sym, IsString a) => a
getName :: forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName = forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @sym))