{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Servant.Client.TypeScript
  ( -- * Generator functions
    gen
  , tsClient
    -- * Type Classes
  , Fletch (..)
  , GenAll
    -- * AST data types
  , DocType (..)
  , InputMethod (..)
  , URIBit (..)
  ) where

import           Data.Aeson (ToJSON (toJSON))
import qualified Data.Aeson as Aeson
import           Data.Aeson.Generics.TypeScript
  ( FieldSpec (..)
  , FieldTypeName (fieldTypeName)
  , TypeScriptDefinition
  , concretely
  , fieldTypeName
  , fs_wrapped
  )
import qualified Data.Aeson.Generics.TypeScript as TS
import           Data.Containers.ListUtils (nubOrd)
import           Data.Kind (Constraint, Type)
import           Data.List (intercalate, sort)
import qualified Data.Map as Map
import           Data.Maybe (mapMaybe)
import           Data.String (fromString)
import           Data.String.Interpolate (i)
import           Data.Text (Text, pack, unpack)
import           Data.Text.Encoding (decodeUtf8')
import           Data.Typeable (Proxy (..))
import           GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import           Jose.Jwt (Jwt)
import           Network.HTTP.Types (Method, urlEncode)
import           Servant.API as Servant
  ( AuthProtect
  , Capture'
  , CaptureAll
  , Description
  , EmptyAPI
  , Fragment
  , HList (HCons)
  , Header'
  , Headers (Headers)
  , JSON
  , NoContent
  , QueryFlag
  , QueryParam'
  , QueryParams
  , ReflectMethod (reflectMethod)
  , ReqBody'
  , ResponseHeader (..)
  , Summary
  , Verb
  , type (:>)
  , (:<|>)
  )

hush :: Either a b -> Maybe b
hush :: forall a b. Either a b -> Maybe b
hush (Right b
x) = b -> Maybe b
forall a. a -> Maybe a
Just b
x
hush Either a b
_         = Maybe b
forall a. Maybe a
Nothing

-- | What is the means of input for this @URIBit@?
type InputMethod :: Type
data InputMethod
  = Capture
  | Query
  | Querys
  | Header_
  | Body
  | Fragment

-- | What kind of API documentation are we using for this route?
type DocType :: Type
data DocType
  = Summary'
  | Description'

-- | An input chunk of the URI
type URIBit :: Type
data URIBit = PathBit String
            | ArgBit InputMethod String String
            | DocBit DocType String

-- | Type class that iterates over the servant type and seperates out inputs and outputs
type Fletch :: Type -> Constraint
class Fletch route where
  argBits :: [URIBit]
  returnType :: (Method, String)

instance (KnownSymbol s, Fletch xs) => Fletch (Summary s :> xs) where
  argBits :: [URIBit]
argBits = DocType -> String -> URIBit
DocBit DocType
Summary' (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s -> String) -> Proxy s -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (KnownSymbol s, Fletch xs) => Fletch (Description s :> xs) where
  argBits :: [URIBit]
argBits = DocType -> String -> URIBit
DocBit DocType
Description' (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s -> String) -> Proxy s -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance Fletch EmptyAPI where
  argBits :: [URIBit]
argBits = []
  returnType :: (Method, String)
returnType = String -> (Method, String)
forall a. HasCallStack => String -> a
error String
"EmptyAPI's cannot return a value"

instance (Fletch xs, KnownSymbol s) => Fletch ((s :: Symbol) :> xs) where
  argBits :: [URIBit]
argBits = String -> URIBit
PathBit (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s)) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (Fletch xs, KnownSymbol s) => Fletch (AuthProtect s :> xs) where
  argBits :: [URIBit]
argBits = forall route. Fletch route => [URIBit]
argBits @(Header' '[JSON] s Jwt :> xs)
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @(Header' '[JSON] s Jwt :> xs)

instance (FieldTypeName x, ReflectMethod method) => Fletch (Verb method 200 (JSON ': _ms) x) where
  argBits :: [URIBit]
argBits = []
  returnType :: (Method, String)
returnType = (Proxy method -> Method
forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod (Proxy method -> Method) -> Proxy method -> Method
forall a b. (a -> b) -> a -> b
$ forall (t :: k1). Proxy t
forall {k} (t :: k). Proxy t
Proxy @method, FieldSpec -> String
fs_wrapped (FieldSpec -> String) -> FieldSpec -> String
forall a b. (a -> b) -> a -> b
$ Proxy x -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @x))

instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (Capture' _ys doc arg :> xs) where
  argBits :: [URIBit]
argBits = InputMethod -> String -> String -> URIBit
ArgBit InputMethod
Capture (Proxy doc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @doc)) (FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (Proxy arg -> FieldSpec) -> Proxy arg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy arg -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy arg -> String) -> Proxy arg -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @arg) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (CaptureAll doc arg :> xs) where
  argBits :: [URIBit]
argBits = InputMethod -> String -> String -> URIBit
ArgBit InputMethod
Capture (Proxy doc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @doc)) (FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (Proxy arg -> FieldSpec) -> Proxy arg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy arg -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy arg -> String) -> Proxy arg -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @arg) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (QueryParam' _ys doc arg :> xs) where
  argBits :: [URIBit]
argBits = InputMethod -> String -> String -> URIBit
ArgBit InputMethod
Query (Proxy doc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @doc)) (FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (Proxy arg -> FieldSpec) -> Proxy arg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy arg -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy arg -> String) -> Proxy arg -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @arg) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (QueryParams doc arg :> xs) where
  argBits :: [URIBit]
argBits = InputMethod -> String -> String -> URIBit
ArgBit InputMethod
Querys (Proxy doc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @doc)) (FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (Proxy [arg] -> FieldSpec) -> Proxy [arg] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy [arg] -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy [arg] -> String) -> Proxy [arg] -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @[arg]) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (Fletch xs, KnownSymbol doc) => Fletch (QueryFlag doc :> xs) where
  argBits :: [URIBit]
argBits = InputMethod -> String -> String -> URIBit
ArgBit InputMethod
Query (Proxy doc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @doc)) (FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (Proxy Bool -> FieldSpec) -> Proxy Bool -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy Bool -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy Bool -> String) -> Proxy Bool -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Bool) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (Header' _ys doc arg :> xs) where
  argBits :: [URIBit]
argBits = InputMethod -> String -> String -> URIBit
ArgBit InputMethod
Header_ (Proxy doc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @doc)) (FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (Proxy arg -> FieldSpec) -> Proxy arg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy arg -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy arg -> String) -> Proxy arg -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @arg) URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (Fletch xs, FieldTypeName x) => Fletch (ReqBody' _ys '[JSON] x :> xs) where
  argBits :: [URIBit]
argBits = InputMethod -> String -> String -> URIBit
ArgBit InputMethod
Body (String -> String
encodeJSVar String
name) String
name URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
    where name :: String
name = FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (Proxy x -> FieldSpec) -> Proxy x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy x -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy x -> String) -> Proxy x -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @x
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

instance (Fletch xs, FieldTypeName x) => Fletch (Fragment x :> xs) where
  argBits :: [URIBit]
argBits = InputMethod -> String -> String -> URIBit
ArgBit InputMethod
Fragment (String -> String
encodeJSVar String
name) String
name URIBit -> [URIBit] -> [URIBit]
forall a. a -> [a] -> [a]
: forall route. Fletch route => [URIBit]
argBits @xs
    where name :: String
name = FieldSpec -> String
fs_wrapped (FieldSpec -> String)
-> (Proxy x -> FieldSpec) -> Proxy x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy x -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy x -> String) -> Proxy x -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @x
  returnType :: (Method, String)
returnType = forall route. Fletch route => (Method, String)
returnType @xs

encodeJSVar :: String -> String
encodeJSVar :: String -> String
encodeJSVar = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
  Char
' ' -> Char
'_'
  Char
'-' -> Char
'_'
  Char
x -> Char
x

genOne :: forall api. Fletch api => String
genOne :: forall api. Fletch api => String
genOne = [i|#{docs}"#{uriKey}": (#{functionArgs}): Promise<#{res}> => {
    const uri = `${API.base}#{pathWithCaptureArgs}#{queryParams}`;
    return fetch(uri, {
      method: "#{method}"#{headers}#{reqBody}
    }).then(res => res.json());
  }|]
  where
    args :: [URIBit]
args = forall route. Fletch route => [URIBit]
argBits @api

    urlEncode' :: String -> Maybe String
urlEncode' = Either UnicodeException String -> Maybe String
forall a b. Either a b -> Maybe b
hush (Either UnicodeException String -> Maybe String)
-> (String -> Either UnicodeException String)
-> String
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String)
-> Either UnicodeException Text -> Either UnicodeException String
forall a b.
(a -> b) -> Either UnicodeException a -> Either UnicodeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
unpack (Either UnicodeException Text -> Either UnicodeException String)
-> (String -> Either UnicodeException Text)
-> String
-> Either UnicodeException String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Either UnicodeException Text
decodeUtf8' (Method -> Either UnicodeException Text)
-> (String -> Method) -> String -> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Method -> Method
urlEncode Bool
True (Method -> Method) -> (String -> Method) -> String -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Method
forall a. IsString a => String -> a
fromString

    docs :: String
docs = [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
      DocBit DocType
Summary' String
s -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n  "
      DocBit DocType
Description' String
d -> String -> Maybe String
forall a. a -> Maybe a
Just [i|/*
   * #{d}
   */
  |]
      URIBit
_ -> Maybe String
forall a. Maybe a
Nothing

    uriKey :: String
uriKey = let

        pathWithCapture :: String
pathWithCapture = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
          PathBit String
s -> String -> Maybe String
forall a. a -> Maybe a
Just String
s
          ArgBit InputMethod
Capture String
doc String
_ -> String -> String -> String
forall a. Monoid a => a -> a -> a
mappend String
":" (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String
urlEncode' String
doc
          URIBit
_ -> Maybe String
forall a. Maybe a
Nothing

        pathQueryParams :: String
pathQueryParams = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
queries then String
forall a. Monoid a => a
mempty else Char
'?' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"&" [String]
queries
          where
          queries :: [String]
queries = (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
            ArgBit InputMethod
Query String
doc String
_ -> String -> Maybe String
urlEncode' String
doc
            ArgBit InputMethod
Querys String
doc String
_ -> String -> Maybe String
urlEncode' String
doc
            URIBit
_ -> Maybe String
forall a. Maybe a
Nothing

        pathHeaders :: String
pathHeaders = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
hs then String
forall a. Monoid a => a
mempty else String
"{" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
hs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}"
          where
          hs :: [String]
hs = (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
            ArgBit InputMethod
Header_ String
doc String
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
doc
            URIBit
_ -> Maybe String
forall a. Maybe a
Nothing

        pathReqBody :: String
pathReqBody = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
req then String
forall a. Monoid a => a
mempty else String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String]
req String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
          where
          req :: [String]
req = (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
            ArgBit InputMethod
Body String
doc String
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
doc
            URIBit
_ -> Maybe String
forall a. Maybe a
Nothing

      in String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pathWithCapture String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pathQueryParams String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pathReqBody String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pathHeaders

    queryParams :: String
queryParams = (\String
x -> if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x then String
x else String
"?" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x) (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"&" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
      ArgBit InputMethod
Query String
doc String
_ -> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"=${" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. IsString a => String -> a
fromString (String -> String
encodeJSVar String
doc) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}") (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String
urlEncode' String
doc
      ArgBit InputMethod
Querys String
doc String
_ -> do
        String
doc' <- String -> Maybe String
urlEncode' String
doc
        let var :: String
var = String -> String
encodeJSVar String
doc
        String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
return [i|${#{var}.reduceRight((acc,x) => "#{doc'}=" + x + (acc ? "&" + acc : ""), "")}|]
      URIBit
_ -> Maybe String
forall a. Maybe a
Nothing

    pathWithCaptureArgs :: String
pathWithCaptureArgs = String -> String -> String
forall a. Monoid a => a -> a -> a
mappend String
"/" (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
      PathBit String
s -> String -> Maybe String
forall a. a -> Maybe a
Just String
s
      ArgBit InputMethod
Capture String
doc String
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"${" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
encodeJSVar String
doc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}"
      URIBit
_ -> Maybe String
forall a. Maybe a
Nothing

    headers :: String
headers = let
      hs :: String
hs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
",\n        " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
        ArgBit InputMethod
Header_ String
doc String
"string" -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
doc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
encodeJSVar String
doc
        ArgBit InputMethod
Header_ String
doc String
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
doc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\": \"\" + " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
encodeJSVar String
doc
        ArgBit InputMethod
Body String
_ String
_ -> String -> Maybe String
forall a. a -> Maybe a
Just String
"'Content-Type': 'application/json'"
        URIBit
_ -> Maybe String
forall a. Maybe a
Nothing
      in if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hs then (String
"" :: String) else [i|,
      headers: {
        #{hs}
      }|]

    reqBody :: String
reqBody = case
      (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
        ArgBit InputMethod
Body String
doc String
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
encodeJSVar String
doc
        URIBit
_ -> Maybe String
forall a. Maybe a
Nothing
      of [String
doc] -> [i|,
      body: JSON.stringify(#{doc})|]
         [String]
_ -> (String
"" :: String)

    functionArgs :: String
functionArgs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (URIBit -> Maybe String) -> [String]
forall b. (URIBit -> Maybe b) -> [b]
marge \case
      ArgBit InputMethod
_ String
doc String
x -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
encodeJSVar String
doc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x
      URIBit
_ -> Maybe String
forall a. Maybe a
Nothing

    (Method
method, String
res) = forall route. Fletch route => (Method, String)
returnType @api

    marge :: forall b. (URIBit -> Maybe b) -> [b]
    marge :: forall b. (URIBit -> Maybe b) -> [b]
marge = ((URIBit -> Maybe b) -> [URIBit] -> [b])
-> [URIBit] -> (URIBit -> Maybe b) -> [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (URIBit -> Maybe b) -> [URIBit] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [URIBit]
args

-- | Obtain the String for the client a la carte without type definitions
gen :: forall (api :: Type).
  ( GenAll api
  ) => String
gen :: forall api. GenAll api => String
gen = [i|const API = {
  base: "",
  #{generations}
};|] where generations :: String
generations = forall api. GenAll api => String
genAll @api

-- | The type class for iterating over the API type
type GenAll :: Type -> Constraint
class GenAll a where
  genAll :: String

instance (Fletch route, GenAll rest) => GenAll (route :<|> rest) where
  genAll :: String
genAll = forall api. Fletch api => String
genOne @route String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
",\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> forall api. GenAll api => String
genAll @rest

instance {-# OVERLAPPABLE #-} Fletch route => GenAll route where
  genAll :: String
genAll = forall api. Fletch api => String
genOne @route

type TypeDecls :: [Type] -> Constraint
class TypeDecls xs where typeDecls :: [TS.TSType]
instance (TypeDecls xs, TypeScriptDefinition x) => TypeDecls (x ': xs) where
  typeDecls :: [TSType]
typeDecls = forall a. TypeScriptDefinition a => TSType
TS.gen @x TSType -> [TSType] -> [TSType]
forall a. a -> [a] -> [a]
: forall (xs :: [*]). TypeDecls xs => [TSType]
typeDecls @xs
instance TypeDecls '[] where
  typeDecls :: [TSType]
typeDecls = []

-- | Generate complete TypeScript client for a given api
tsClient :: forall xs api. (TypeDecls xs, GenAll api) => String
tsClient :: forall (xs :: [*]) api. (TypeDecls xs, GenAll api) => String
tsClient = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((TSType -> String) -> [TSType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TSType -> String
TS.printTS ([TSType] -> [String])
-> ([TSType] -> [TSType]) -> [TSType] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TSType] -> [TSType]
forall a. Ord a => [a] -> [a]
sort ([TSType] -> [TSType])
-> ([TSType] -> [TSType]) -> [TSType] -> [TSType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TSType] -> [TSType]
forall a. Ord a => [a] -> [a]
nubOrd ([TSType] -> [String]) -> [TSType] -> [String]
forall a b. (a -> b) -> a -> b
$ forall (xs :: [*]). TypeDecls xs => [TSType]
typeDecls @xs)
  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> forall api. GenAll api => String
gen @api

type FromHList :: [Type] -> Constraint
class FromHList hs where
  fromHList :: HList hs -> Map.Map Text Aeson.Value

instance (KnownSymbol s, ToJSON h, FromHList hs) => FromHList (Header' ls s h ': hs) where
  fromHList :: HList (Header' ls s h : hs) -> Map Text Value
fromHList (HCons (Servant.Header x
a) HList xs
xs) = Text -> Value -> Map Text Value
forall k a. k -> a -> Map k a
Map.singleton (String -> Text
pack (String -> Text) -> (Proxy s -> String) -> Proxy s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s -> Text) -> Proxy s -> Text
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s) (x -> Value
forall a. ToJSON a => a -> Value
toJSON x
a) Map Text Value -> Map Text Value -> Map Text Value
forall a. Semigroup a => a -> a -> a
<> HList xs -> Map Text Value
forall (hs :: [*]). FromHList hs => HList hs -> Map Text Value
fromHList HList xs
xs
  fromHList (HCons ResponseHeader h x
MissingHeader HList xs
xs) = HList xs -> Map Text Value
forall (hs :: [*]). FromHList hs => HList hs -> Map Text Value
fromHList HList xs
xs
  fromHList (HCons (UndecodableHeader Method
_) HList xs
xs) = HList xs -> Map Text Value
forall (hs :: [*]). FromHList hs => HList hs -> Map Text Value
fromHList HList xs
xs

instance FromHList '[] where
  fromHList :: HList '[] -> Map Text Value
fromHList = HList '[] -> Map Text Value
forall a. Monoid a => a
mempty

instance (Aeson.ToJSON x, FromHList xs) => Aeson.ToJSON (Headers xs x) where
  toJSON :: Headers xs x -> Value
toJSON (Headers x
x HList xs
xs) = [Pair] -> Value
Aeson.object
    [ Key
"content" Key -> x -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= x
x
    , Key
"headers" Key -> Map Text Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
Aeson..= HList xs -> Map Text Value
forall (hs :: [*]). FromHList hs => HList hs -> Map Text Value
fromHList HList xs
xs
    ]

instance (FieldTypeName x, FieldTypeName hs) => FieldTypeName (Headers hs x) where
  fieldTypeName :: Proxy (Headers hs x) -> FieldSpec
fieldTypeName Proxy (Headers hs x)
_ =
    let
      x :: FieldSpec
x = Proxy x -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @x)
      hs :: FieldSpec
hs = Proxy hs -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @hs)
      obj :: p -> p -> dst
obj p
x_ p
hs_ = [i|{
  contents: #{x_},
  headers: #{hs_}
}|]
    in FieldType -> String -> String -> FieldSpec
FieldSpec (FieldSpec -> FieldType
fs_type FieldSpec
x FieldType -> FieldType -> FieldType
forall a. Semigroup a => a -> a -> a
<> FieldSpec -> FieldType
fs_type FieldSpec
hs) (FieldSpec -> String
fs_wrapped FieldSpec
x String -> String -> String
forall {dst} {p} {p}.
(Interpolatable (IsCustomSink dst) p dst,
 Interpolatable (IsCustomSink dst) p dst) =>
p -> p -> dst
`obj` FieldSpec -> String
fs_wrapped FieldSpec
hs) (FieldSpec -> String
fs_unwrapped FieldSpec
x String -> String -> String
forall {dst} {p} {p}.
(Interpolatable (IsCustomSink dst) p dst,
 Interpolatable (IsCustomSink dst) p dst) =>
p -> p -> dst
`obj` FieldSpec -> String
fs_unwrapped FieldSpec
hs)

instance FieldTypeName '[] where
  fieldTypeName :: Proxy '[] -> FieldSpec
fieldTypeName Proxy '[]
_ = String -> FieldSpec
concretely String
""

instance (FieldTypeName hs, FieldTypeName x) => FieldTypeName (Header' ts doc x ': hs) where
  fieldTypeName :: Proxy (Header' ts doc x : hs) -> FieldSpec
fieldTypeName Proxy (Header' ts doc x : hs)
_ =
    let xhs :: FieldSpec
xhs = Proxy hs -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy hs -> FieldSpec) -> Proxy hs -> FieldSpec
forall a b. (a -> b) -> a -> b
$ forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @hs
        xfs :: FieldSpec
xfs = Proxy x -> FieldSpec
forall a (a1 :: a). FieldTypeName a1 => Proxy a1 -> FieldSpec
fieldTypeName (Proxy x -> FieldSpec) -> Proxy x -> FieldSpec
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @x
        comma :: t a -> t a
comma t a
z = if t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
z then t a
"" else t a
",\n" t a -> t a -> t a
forall a. Semigroup a => a -> a -> a
<> t a
z
     in FieldType -> String -> String -> FieldSpec
FieldSpec (FieldSpec -> FieldType
fs_type FieldSpec
xhs FieldType -> FieldType -> FieldType
forall a. Semigroup a => a -> a -> a
<> FieldSpec -> FieldType
fs_type FieldSpec
xfs)
                  (FieldSpec -> String
fs_wrapped FieldSpec
xfs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall {t :: * -> *} {a}.
(Foldable t, IsString (t a), Semigroup (t a)) =>
t a -> t a
comma (FieldSpec -> String
fs_wrapped FieldSpec
xhs))
                  (FieldSpec -> String
fs_unwrapped FieldSpec
xfs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall {t :: * -> *} {a}.
(Foldable t, IsString (t a), Semigroup (t a)) =>
t a -> t a
comma (FieldSpec -> String
fs_unwrapped FieldSpec
xhs))

instance FieldTypeName NoContent where
  fieldTypeName :: Proxy NoContent -> FieldSpec
fieldTypeName Proxy NoContent
_ = String -> FieldSpec
concretely String
"null"

instance FieldTypeName Jwt where
  fieldTypeName :: Proxy Jwt -> FieldSpec
fieldTypeName Proxy Jwt
_ = String -> FieldSpec
concretely String
"string"