{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-missing-methods #-}
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
( ErrorMessage (Text)
, KnownSymbol
, Symbol
, TypeError
, 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 (:>)
, (:<|>)
)
import Servant.API.WebSocketConduit (WebSocketConduit)
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
| WSInput
deriving stock (Eq, Show)
-- | What kind of API documentation are we using for this route?
type DocType :: Type
data DocType
= Summary'
| Description'
deriving stock (Show)
-- | An input chunk of the URI
type URIBit :: Type
data URIBit = PathBit String
| ArgBit InputMethod String String
| DocBit DocType String
deriving stock (Show)
-- | 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 (TypeError ('Text "💠 EmptyAPI's cannot be Fletched as they do not make a request")) => Fletch EmptyAPI where
instance (TypeError ('Text "💠 EmptyAPI's cannot be GenAll as they do not make a request")) => GenAll EmptyAPI where
instance (FieldTypeName i, FieldTypeName o) => Fletch (WebSocketConduit i o) where
argBits = [ArgBit WSInput "WebSocketInput" . fs_wrapped . fieldTypeName $ Proxy @i]
returnType = ("connect", fs_wrapped . fieldTypeName $ Proxy @o)
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
uriKey :: forall api. Fletch api => String
uriKey = mconcat
[ "/"
, intercalate "/" $ marge @api \case
PathBit s -> Just s
ArgBit Capture doc _ -> mappend ":" <$> urlEncode' doc
_ -> Nothing
, let queries = marge @api \case
ArgBit Query doc _ -> urlEncode' doc
ArgBit Querys doc _ -> urlEncode' doc
_ -> Nothing
in if null queries then mempty else '?' : intercalate "&" queries
, let req = marge @api \case
ArgBit Body doc _ -> Just doc
_ -> Nothing
in if null req then mempty else "(" <> mconcat req <> ")"
, let hs = marge @api \case
ArgBit Header_ doc _ -> Just doc
_ -> Nothing
in if null hs then mempty else "{" <> intercalate "," hs <> "}"
, let frag = marge @api \case
ArgBit Fragment _ _ -> Just ()
_ -> Nothing
in if null frag then mempty else "#fragment"
]
docs :: forall api. Fletch api => String
docs = mconcat $ marge @api \case
DocBit Summary' s -> Just $ '/' : '/' : ' ' : s <> "\n "
DocBit Description' d -> Just [i|/*
* #{d}
*/
|]
_ -> Nothing
urlEncode' :: String -> Maybe String
urlEncode' = hush . fmap unpack . decodeUtf8' . urlEncode True . fromString
genWebSocket :: forall api. Fletch api => String
genWebSocket = [i|#{docs @api}"#{uriKey @api}": (#{functionArgs @api}):
Promise<{ send : (input: #{wsInput}) => void
, receive : (cb: (output: #{wsOutput}) => void) => void
, raw : WebSocket
}> => {
const pr = window.location.protocol === "http:" ? "ws:" : "wss:";
const ws = new WebSocket(`${pr}//${window.location.host}${API.base}#{pathWithCaptureArgs @api}#{queryParams @api}`#{headersWS @api});
return Promise.resolve({
send: (input: #{wsInput}) => ws.send(JSON.stringify(input)),
receive: (cb: ((output: #{wsOutput}) => void)) =>
ws.onmessage = (message: MessageEvent<string>) => cb(JSON.parse(message.data)),
raw: ws
});
}|]
where
wsInput = case filter (\case
ArgBit WSInput _ _ -> True
_ -> False) $ argBits @api of
[ArgBit WSInput _ x] -> x
x -> error $ "Bad argits: " <> show x <> " This is a hack to transfer the input of the WebSocket to the function here."
(_, wsOutput) = returnType @api
genHTTP :: forall api. Fletch api => String
genHTTP = [i|#{docs @api}"#{uriKey @api}": async (#{functionArgs @api}): Promise<#{res}> => {
const uri = `${API.base}#{pathWithCaptureArgs @api}#{queryParams @api}`;
return fetch(uri, {
method: "#{method}"#{headers @api}#{reqBody @api}
}).then(res => res.json());
}|]
where (method, res) = returnType @api
queryParams :: forall api. Fletch api => String
queryParams = (\x -> if null x then x else "?" <> x) . intercalate "&" $ marge @api \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 :: forall api. Fletch api => String
pathWithCaptureArgs = mappend "/" . intercalate "/" $ marge @api \case
PathBit s -> Just s
ArgBit Capture doc _ -> Just $ "${" <> encodeJSVar doc <> "}"
_ -> Nothing
headers :: forall api. Fletch api => String
headers = let
hs = intercalate ",\n " $ marge @api \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}
}|]
headersWS :: forall api. Fletch api => String
headersWS = let
hs = intercalate ", " $ marge @api \case
ArgBit Header_ doc "string" -> Just $ encodeJSVar doc
ArgBit Header_ doc _ -> Just $ "\"\" + " <> encodeJSVar doc
_ -> Nothing
in if null hs then ("" :: String) else [i|, [#{hs}]|]
reqBody :: forall api. Fletch api => String
reqBody = case
marge @api \case
ArgBit Body doc _ -> Just $ encodeJSVar doc
_ -> Nothing
of [doc] -> [i|,
body: JSON.stringify(#{doc})|]
_ -> ("" :: String)
functionArgs :: forall api. Fletch api => String
functionArgs = intercalate "," $ marge @api \case
ArgBit y doc x
-- Fragments are not captured by a servant server, useful with Link
| y /= Fragment
-- WSInput is used to in .send, and not required as initial arguments
&& y /= WSInput -> Just $ encodeJSVar doc <> ":" <> x
_ -> Nothing
marge :: forall api b. Fletch api => (URIBit -> Maybe b) -> [b]
marge = flip mapMaybe $ argBits @api
-- | 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
-- | Handle left association of routes (IE parens on the left)
instance {-# OVERLAPS #-} (GenAll (route :<|> subrest), GenAll rest) => GenAll ((route :<|> subrest) :<|> rest) where
genAll = genAll @(route :<|> subrest) <> ",\n" <> genAll @rest
-- | Handle right association of routes (IE parens on the left)
instance (Fletch route, GenAll rest) => GenAll (route :<|> rest) where
genAll = genAll @route <> ",\n" <> genAll @rest
-- | Handle right association of routes (IE parens on the left)
instance {-# OVERLAPPABLE #-} Fletch route => GenAll route where
genAll =
case fst $ returnType @route of
-- POS sentinel value until I think of something better
"connect" -> genWebSocket @route
_ -> genHTTP @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"