{-# 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 (Right x) = Just x
hush _ = 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 = DocBit Summary' (symbolVal $ Proxy @s) : argBits @xs
returnType = returnType @xs
instance (KnownSymbol s, Fletch xs) => Fletch (Description s :> xs) where
argBits = DocBit Description' (symbolVal $ Proxy @s) : argBits @xs
returnType = returnType @xs
instance Fletch EmptyAPI where
argBits = []
returnType = error "EmptyAPI's cannot return a value"
instance (Fletch xs, KnownSymbol s) => Fletch ((s :: Symbol) :> xs) where
argBits = PathBit (symbolVal (Proxy @s)) : argBits @xs
returnType = returnType @xs
instance (Fletch xs, KnownSymbol s) => Fletch (AuthProtect s :> xs) where
argBits = argBits @(Header' '[JSON] s Jwt :> xs)
returnType = returnType @(Header' '[JSON] s Jwt :> xs)
instance (FieldTypeName x, ReflectMethod method) => Fletch (Verb method 200 (JSON ': _ms) x) where
argBits = []
returnType = (reflectMethod $ Proxy @method, fs_wrapped $ fieldTypeName (Proxy @x))
instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (Capture' _ys doc arg :> xs) where
argBits = ArgBit Capture (symbolVal (Proxy @doc)) (fs_wrapped . fieldTypeName $ Proxy @arg) : argBits @xs
returnType = returnType @xs
instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (CaptureAll doc arg :> xs) where
argBits = ArgBit Capture (symbolVal (Proxy @doc)) (fs_wrapped . fieldTypeName $ Proxy @arg) : argBits @xs
returnType = returnType @xs
instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (QueryParam' _ys doc arg :> xs) where
argBits = ArgBit Query (symbolVal (Proxy @doc)) (fs_wrapped . fieldTypeName $ Proxy @arg) : argBits @xs
returnType = returnType @xs
instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (QueryParams doc arg :> xs) where
argBits = ArgBit Querys (symbolVal (Proxy @doc)) (fs_wrapped . fieldTypeName $ Proxy @[arg]) : argBits @xs
returnType = returnType @xs
instance (Fletch xs, KnownSymbol doc) => Fletch (QueryFlag doc :> xs) where
argBits = ArgBit Query (symbolVal (Proxy @doc)) (fs_wrapped . fieldTypeName $ Proxy @Bool) : argBits @xs
returnType = returnType @xs
instance (Fletch xs, KnownSymbol doc, FieldTypeName arg) => Fletch (Header' _ys doc arg :> xs) where
argBits = ArgBit Header_ (symbolVal (Proxy @doc)) (fs_wrapped . fieldTypeName $ Proxy @arg) : argBits @xs
returnType = returnType @xs
instance (Fletch xs, FieldTypeName x) => Fletch (ReqBody' _ys '[JSON] x :> xs) where
argBits = ArgBit Body (encodeJSVar name) name : argBits @xs
where name = fs_wrapped . fieldTypeName $ Proxy @x
returnType = returnType @xs
instance (Fletch xs, FieldTypeName x) => Fletch (Fragment x :> xs) where
argBits = ArgBit Fragment (encodeJSVar name) name : argBits @xs
where name = fs_wrapped . fieldTypeName $ Proxy @x
returnType = returnType @xs
encodeJSVar :: String -> String
encodeJSVar = fmap \case
' ' -> '_'
'-' -> '_'
x -> x
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 = argBits @api
urlEncode' = hush . fmap unpack . decodeUtf8' . urlEncode True . fromString
docs = mconcat $ marge \case
DocBit Summary' s -> Just $ '/' : '/' : ' ' : s <> "\n "
DocBit Description' d -> Just [i|/*
* #{d}
*/
|]
_ -> Nothing
uriKey = let
pathWithCapture = intercalate "/" $ marge \case
PathBit s -> Just s
ArgBit Capture doc _ -> mappend ":" <$> urlEncode' doc
_ -> Nothing
pathQueryParams = if null queries then mempty else '?' : intercalate "&" queries
where
queries = marge \case
ArgBit Query doc _ -> urlEncode' doc
ArgBit Querys doc _ -> urlEncode' doc
_ -> Nothing
pathHeaders = if null hs then mempty else "{" <> intercalate "," hs <> "}"
where
hs = marge \case
ArgBit Header_ doc _ -> Just doc
_ -> Nothing
pathReqBody = if null req then mempty else "(" <> mconcat req <> ")"
where
req = marge \case
ArgBit Body doc _ -> Just doc
_ -> Nothing
in "/" <> pathWithCapture <> pathQueryParams <> pathReqBody <> pathHeaders
queryParams = (\x -> if null x then x else "?" <> x) . intercalate "&" $ marge \case
ArgBit Query doc _ -> (<> "=${" <> fromString (encodeJSVar doc) <> "}") <$> urlEncode' doc
ArgBit Querys doc _ -> do
doc' <- urlEncode' doc
let var = encodeJSVar doc
return [i|${#{var}.reduceRight((acc,x) => "#{doc'}=" + x + (acc ? "&" + acc : ""), "")}|]
_ -> Nothing
pathWithCaptureArgs = mappend "/" . intercalate "/" $ marge \case
PathBit s -> Just s
ArgBit Capture doc _ -> Just $ "${" <> encodeJSVar doc <> "}"
_ -> Nothing
headers = let
hs = intercalate ",\n " $ marge \case
ArgBit Header_ doc "string" -> Just $ "\"" <> doc <> "\": " <> encodeJSVar doc
ArgBit Header_ doc _ -> Just $ "\"" <> doc <> "\": \"\" + " <> encodeJSVar doc
ArgBit Body _ _ -> Just "'Content-Type': 'application/json'"
_ -> Nothing
in if null hs then ("" :: String) else [i|,
headers: {
#{hs}
}|]
reqBody = case
marge \case
ArgBit Body doc _ -> Just $ encodeJSVar doc
_ -> Nothing
of [doc] -> [i|,
body: JSON.stringify(#{doc})|]
_ -> ("" :: String)
functionArgs = intercalate "," $ marge \case
ArgBit _ doc x -> Just $ encodeJSVar doc <> ":" <> x
_ -> Nothing
(method, res) = returnType @api
marge :: forall b. (URIBit -> Maybe b) -> [b]
marge = flip mapMaybe args
-- | Obtain the String for the client a la carte without type definitions
gen :: forall (api :: Type).
( GenAll api
) => String
gen = [i|const API = {
base: "",
#{generations}
};|] where generations = 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 = genOne @route <> ",\n" <> genAll @rest
instance {-# OVERLAPPABLE #-} Fletch route => GenAll route where
genAll = genOne @route
type TypeDecls :: [Type] -> Constraint
class TypeDecls xs where typeDecls :: [TS.TSType]
instance (TypeDecls xs, TypeScriptDefinition x) => TypeDecls (x ': xs) where
typeDecls = TS.gen @x : typeDecls @xs
instance TypeDecls '[] where
typeDecls = []
-- | Generate complete TypeScript client for a given api
tsClient :: forall xs api. (TypeDecls xs, GenAll api) => String
tsClient = intercalate "\n" (fmap TS.printTS . sort . nubOrd $ typeDecls @xs)
<> "\n" <> 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 (HCons (Servant.Header a) xs) = Map.singleton (pack . symbolVal $ Proxy @s) (toJSON a) <> fromHList xs
fromHList (HCons MissingHeader xs) = fromHList xs
fromHList (HCons (UndecodableHeader _) xs) = fromHList xs
instance FromHList '[] where
fromHList = mempty
instance (Aeson.ToJSON x, FromHList xs) => Aeson.ToJSON (Headers xs x) where
toJSON (Headers x xs) = Aeson.object
[ "content" Aeson..= x
, "headers" Aeson..= fromHList xs
]
instance (FieldTypeName x, FieldTypeName hs) => FieldTypeName (Headers hs x) where
fieldTypeName _ =
let
x = fieldTypeName (Proxy @x)
hs = fieldTypeName (Proxy @hs)
obj x_ hs_ = [i|{
contents: #{x_},
headers: #{hs_}
}|]
in FieldSpec (fs_type x <> fs_type hs) (fs_wrapped x `obj` fs_wrapped hs) (fs_unwrapped x `obj` fs_unwrapped hs)
instance FieldTypeName '[] where
fieldTypeName _ = concretely ""
instance (FieldTypeName hs, FieldTypeName x) => FieldTypeName (Header' ts doc x ': hs) where
fieldTypeName _ =
let xhs = fieldTypeName $ Proxy @hs
xfs = fieldTypeName $ Proxy @x
comma z = if null z then "" else ",\n" <> z
in FieldSpec (fs_type xhs <> fs_type xfs)
(fs_wrapped xfs <> comma (fs_wrapped xhs))
(fs_unwrapped xfs <> comma (fs_unwrapped xhs))
instance FieldTypeName NoContent where
fieldTypeName _ = concretely "null"
instance FieldTypeName Jwt where
fieldTypeName _ = concretely "string"