diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for servant-typescript + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,59 @@ +# Welcome to `servant-typescript` [![Hackage](https://img.shields.io/hackage/v/servant-typescript.svg)](https://hackage.haskell.org/package/servant-typescript) ![servant-typescript](https://github.com/codedownio/servant-typescript/workflows/servant-typescript/badge.svg) + + +This library generates TypeScript client libraries for Servant. + +First, make sure you have [TypeScript](https://hackage.haskell.org/package/aeson-typescript) instances defined for all of the types used in the API. + +```haskell +data User = User { + name :: String + , age :: Int + , email :: String + } deriving (Eq, Show) +deriveJSONAndTypeScript A.defaultOptions ''User +``` + +If you need to generate lots of boilerplate instances, the functions in `aeson-typescript`'s [Recursive](https://hackage.haskell.org/package/aeson-typescript-0.4.0.0/docs/Data-Aeson-TypeScript-Recursive.html) module can be your friend. +I've used [recursivelyDeriveMissingTypeScriptInstancesFor](https://hackage.haskell.org/package/aeson-typescript-0.4.0.0/docs/Data-Aeson-TypeScript-Recursive.html#v:recursivelyDeriveMissingTypeScriptInstancesFor) to derive instances for the Kubernetes API. + +Next, you'll need some Servant API: + +```haskell +type UserAPI = "users" :> Get '[JSON] [User] + :<|> "albert" :> Get '[JSON] User + :<|> "isaac" :> Get '[JSON] User +``` + +Generating the library is as simple as this: + +```haskell +main = writeTypeScriptLibrary (Proxy :: Proxy UserAPI) "/my/destination/folder/" +``` +## Caveats + +* This library doesn't yet support generating generic TypeScript functions to match generic TypeScript instances. You can hack around this by writing your own `getFunctions` and hardcoding them manually for the necessary types. + +## Supporting additional combinators + +If you use unusual Servant combinators in your API, you may need to define additional `HasForeign` instances to explain how to convert them to TypeScript. For example, when I work with the [servant-websockets](https://hackage.haskell.org/package/servant-websockets) package, I add instances like the following. + +The same applies to custom `AuthProtect` combinators from [Servant.API.Experimental.Auth](https://hackage.haskell.org/package/servant-0.19/docs/Servant-API-Experimental-Auth.html), etc. + +```haskell +instance HasForeign LangTS Text WebSocket where + type Foreign Text WebSocket = Text + foreignFor _lang _pf _ _req = "void" + +instance HasForeign LangTS Text WebSocketPending where + type Foreign Text WebSocketPending = Text + foreignFor _lang _pf _ _req = "void" + +instance HasForeign LangTSDecls [TSDeclaration] WebSocketPending where + type Foreign [TSDeclaration] WebSocketPending = [TSDeclaration] + foreignFor _lang _pf _ _req = [] + +instance HasForeign LangTSDecls [TSDeclaration] WebSocket where + type Foreign [TSDeclaration] WebSocket = [TSDeclaration] + foreignFor _lang _pf _ _req = [] +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Data.Aeson as A +import Data.Aeson.TH as A hiding (Options) +import Data.Aeson.TypeScript.TH +import Data.Proxy +import Servant.API +import Servant.TypeScript + + +data User = User { + name :: String + , age :: Int + , email :: String + } deriving (Eq, Show) +deriveJSONAndTypeScript A.defaultOptions ''User + +type UserAPI = "users" :> Get '[JSON] [User] + :<|> "albert" :> Get '[JSON] User + :<|> "isaac" :> Get '[JSON] User + +main = writeTypeScriptLibrary (Proxy @UserAPI) "/tmp/test" diff --git a/servant-typescript.cabal b/servant-typescript.cabal new file mode 100644 --- /dev/null +++ b/servant-typescript.cabal @@ -0,0 +1,135 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: servant-typescript +version: 0.1.0.0 +synopsis: TypeScript client generation for Servant +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/github.com/codedownio#readme +bug-reports: https://github.com/github.com/codedownio/issues +author: Tom McLaughlin +maintainer: tom@codedown.io +copyright: 2022 Tom McLaughlin +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/github.com/codedownio + subdir: servant-typescript + +library + exposed-modules: + Servant.TypeScript + Servant.TypeScript.GetFunctions + other-modules: + Servant.TypeScript.Types + Servant.TypeScript.Util + Paths_servant_typescript + hs-source-dirs: + src + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + LambdaCase + MultiWayIf + ViewPatterns + build-depends: + aeson + , aeson-typescript + , base >=4.7 && <5 + , containers + , directory + , filepath + , lens + , mtl + , servant + , servant-foreign + , string-interpolate + , text + default-language: Haskell2010 + +executable servant-typescript-exe + main-is: Main.hs + other-modules: + Paths_servant_typescript + hs-source-dirs: + app + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + LambdaCase + MultiWayIf + ViewPatterns + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aeson-typescript + , base >=4.7 && <5 + , containers + , directory + , filepath + , lens + , mtl + , servant + , servant-foreign + , servant-typescript + , string-interpolate + , text + default-language: Haskell2010 + +test-suite servant-typescript-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_servant_typescript + hs-source-dirs: + test + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + LambdaCase + MultiWayIf + ViewPatterns + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aeson-typescript + , base >=4.7 && <5 + , containers + , directory + , filepath + , lens + , mtl + , servant + , servant-foreign + , servant-typescript + , string-interpolate + , text + default-language: Haskell2010 diff --git a/src/Servant/TypeScript.hs b/src/Servant/TypeScript.hs new file mode 100644 --- /dev/null +++ b/src/Servant/TypeScript.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ConstraintKinds #-} + +{-| +Module: Servant.TypeScript.Types +Copyright: (c) 2022 Tom McLaughlin +License: BSD3 +Stability: experimental +Portability: portable + +This library generates TypeScript client libraries for Servant. + +First, make sure you have 'TypeScript' instances defined for all of the types used in the API. + +@ +data User = User { + name :: String + , age :: Int + , email :: String + } deriving (Eq, Show) +deriveJSONAndTypeScript A.defaultOptions ''User +@ + +If you need to generate lots of boilerplate instances, the functions in @aeson-typescript@'s 'Data.Aeson.TypeScript.Recursive' module can be your friend. +I've used 'Data.Aeson.TypeScript.Recursive.recursivelyDeriveMissingTypeScriptInstancesFor' to derive instances for the Kubernetes API. + +Next, you'll need some Servant API: + +@ +type UserAPI = "users" :> Get '[JSON] [User] + :\<|\> "albert" :> Get '[JSON] User + :\<|\> "isaac" :> Get '[JSON] User +@ + +Generating the library is as simple as this: + +@ +main = writeTypeScriptLibrary (Proxy :: Proxy UserAPI) "\/my\/destination\/folder\/" +@ + +-} + + +module Servant.TypeScript ( + writeTypeScriptLibrary + , writeTypeScriptLibrary' + + -- * Options + , ServantTypeScriptOptions + , defaultServantTypeScriptOptions + , extraTypes + , getFileKey + , getFunctionName + , getFunctions + + -- * Misc + , MainConstraints + ) where + +import Control.Lens +import Control.Monad.Reader +import Data.Aeson.TypeScript.TH +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import Data.Proxy +import qualified Data.Set as S +import Data.String.Interpolate +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Servant.Foreign +import Servant.TypeScript.Types +import Servant.TypeScript.Util +import System.Directory +import System.FilePath + + +type MainConstraints api = ( + HasForeign LangTSDecls [TSDeclaration] api + , GenerateList [TSDeclaration] (Foreign [TSDeclaration] api) + , HasForeign LangTS T.Text api + , GenerateList T.Text (Foreign T.Text api) + ) + +-- | Write the TypeScript client library for the given API to the given folder using default options. +writeTypeScriptLibrary :: MainConstraints api => Proxy api -> FilePath -> IO () +writeTypeScriptLibrary = writeTypeScriptLibrary' defaultServantTypeScriptOptions + +-- | Write the TypeScript client library for the given API to the given folder. +writeTypeScriptLibrary' :: forall api. MainConstraints api => ServantTypeScriptOptions -> Proxy api -> FilePath -> IO () +writeTypeScriptLibrary' opts _ rootDir = flip runReaderT opts $ do + writeClientTypes (Proxy @api) "/tmp/test" + writeClientLibraries (Proxy @api) "/tmp/test" + +writeClientTypes :: forall api. ( + HasForeign LangTSDecls [TSDeclaration] api + , GenerateList [TSDeclaration] (Foreign [TSDeclaration] api) + ) => Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO () +writeClientTypes _ folder = do + -- Types from API + let decls = S.toList $ S.fromList $ getAllTypesFromReqs (getReqsWithDecls (Proxy :: Proxy api)) + + -- Extra types not mentioned in the API (used in websocket protocols) + extra <- asks extraTypes + let decls' = mconcat [getTypeScriptDeclarations x | TSType x <- extra] + + liftIO $ writeFile (folder "client.d.ts") (formatTSDeclarations (L.nub (decls <> decls'))) + +writeClientLibraries :: forall api. ( + HasForeign LangTS T.Text api + , GenerateList T.Text (Foreign T.Text api) + ) => Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO () +writeClientLibraries _ folder = do + -- Write the functions + let allEndpoints = getEndpoints (Proxy :: Proxy api) + ServantTypeScriptOptions {..} <- ask + let groupedMap = groupBy getFileKey allEndpoints + forM_ (M.toList groupedMap) $ \(fileKey, reqs) -> do + let (dir, _) = splitFileName fileKey + liftIO $ createDirectoryIfMissing True (folder dir) + + let path' = folder fileKey + let functionNames = fmap getFunctionName reqs + when (L.length functionNames /= S.size (S.fromList functionNames)) $ do + let duplicates = L.foldl' (flip (M.alter (\case Nothing -> Just (1 :: Integer); Just x -> Just (x + 1)))) mempty functionNames + error [i|Duplicate function names found when trying to generate '#{path'}': #{M.filter (>= 2) duplicates}|] + + liftIO $ T.writeFile path' (getFunctions getFunctionName reqs) + where + groupBy :: Ord k => (v -> k) -> [v] -> M.Map k [v] + groupBy key as = M.fromListWith (++) as' + where as' = map ((,) <$> key <*> (:[])) as + +getReqsWithDecls :: (HasForeign LangTSDecls [TSDeclaration] api, GenerateList [TSDeclaration] (Foreign [TSDeclaration] api)) + => Proxy api -> [Req [TSDeclaration]] +getReqsWithDecls = listFromAPI (Proxy :: Proxy LangTSDecls) (Proxy :: Proxy [TSDeclaration]) + +getAllTypesFromReqs :: forall a. (Eq a, Ord a) => [Req [a]] -> [a] +getAllTypesFromReqs reqs = S.toList $ S.fromList vals + where vals :: [a] = mconcat $ mconcat [catMaybes [req ^. reqReturnType, req ^. reqBody] + <> getTypesFromUrl (req ^. reqUrl) + <> concatMap getTypesFromHeaderArg (req ^. reqHeaders) + | req <- reqs] + getTypesFromUrl (Url path' queryArgs _) = concatMap getTypesFromSegment path' <> concatMap getTypesFromQueryArg queryArgs + getTypesFromSegment (Segment (Static {})) = [] + getTypesFromSegment (Segment (Cap arg)) = [arg ^. argType] + + getTypesFromQueryArg queryArg = [queryArg ^. (queryArgName . argType)] + + getTypesFromHeaderArg ha = [ha ^. (headerArg . argType)] + +getEndpoints :: (HasForeign LangTS T.Text api, GenerateList T.Text (Foreign T.Text api)) => Proxy api -> [Req T.Text] +getEndpoints = listFromAPI (Proxy :: Proxy LangTS) (Proxy :: Proxy T.Text) diff --git a/src/Servant/TypeScript/GetFunctions.hs b/src/Servant/TypeScript/GetFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Servant/TypeScript/GetFunctions.hs @@ -0,0 +1,90 @@ + +module Servant.TypeScript.GetFunctions ( + getFunctions + ) where + +import Control.Lens +import Data.Maybe +import Data.String.Interpolate +import Data.Text (Text) +import qualified Data.Text as T +import Servant.Foreign.Internal as FI + + +-- | Default implementation of @getFunctions@. +getFunctions :: (Req Text -> Text) -> [Req Text] -> Text +getFunctions getFunctionName reqs = + [i|import queryString from "query-string";\n\n|] + <> T.intercalate "\n" (fmap (reqToFunction getFunctionName) reqs) + +reqToFunction :: (Req Text -> Text) -> Req Text -> Text +reqToFunction getFunctionName req = [i| +export function #{getFunctionName req}#{getGenericBrackets req}(#{getFunctionArgs req}): Promise<#{getReturnType req}> { + let options: RequestInit = { + credentials: "same-origin" as RequestCredentials, + method: "#{req ^. reqMethod}", + headers: {"Content-Type": "application/json;charset=utf-8"} + }; + #{case (req ^. reqBody) of Nothing -> ("" :: Text); Just _ -> "\n options.body = JSON.stringify(body);\n" } + let params = {#{T.intercalate ", " (getQueryParamNames req)}}; + return (fetchFn || window.fetch)(`#{getPath req}` + "?" + queryString.stringify(params), options).then((response) => { + return new Promise((resolve, reject) => { + if (response.status !== 200) { + return response.text().then((text) => reject({text, status: response.status})); + } else { + #{if hasReturn req + then ("return response.json().then((json) => resolve(json));" :: Text) + else "resolve();"} + } + }); + }); +}|] + +hasReturn :: Req Text -> Bool +hasReturn req = case req ^. reqReturnType of + Nothing -> False + Just "void" -> False + Just _ -> True + +getQueryParamNames :: Req Text -> [Text] +getQueryParamNames req = [x ^. (queryArgName . argName . _PathSegment) + | x <- req ^. (reqUrl . queryStr)] + +getFunctionArgs :: Req Text -> Text +getFunctionArgs req = T.intercalate ", " $ catMaybes $ + maybeBodyArg + : fmap formatCaptureArg (req ^. (reqUrl . path)) + <> fmap (Just . formatQueryArg) (req ^. (reqUrl . queryStr)) + <> [Just [i|fetchFn?: (input: RequestInfo, init?: RequestInit) => Promise|]] + + where + maybeBodyArg = case req ^. reqBody of + Nothing -> Nothing + Just x -> Just [i|body: #{x}|] + +formatCaptureArg :: Segment Text -> Maybe Text +formatCaptureArg (Segment (Static {})) = Nothing +formatCaptureArg (Segment (Cap arg)) = Just [i|#{arg ^. (argName . _PathSegment)}: #{arg ^. argType}|] + +formatQueryArg :: QueryArg Text -> Text +formatQueryArg arg = case arg ^. queryArgType of + Normal -> [i|#{name}?: #{typ}|] + Flag -> [i|#{name}?: boolean|] + FI.List -> [i|#{name}?: [#{typ}]|] + where + qaName = arg ^. queryArgName + name = qaName ^. (argName . _PathSegment) + typ = qaName ^. argType + +getReturnType :: Req Text -> Text +getReturnType req = fromMaybe "void" (req ^. reqReturnType) + +getGenericBrackets :: Req Text -> Text +getGenericBrackets _req = "" + +getPath :: Req Text -> Text +getPath req = "/" <> T.intercalate "/" (fmap formatPathSegment (req ^. (reqUrl . path))) + where + formatPathSegment :: Segment Text -> Text + formatPathSegment (Segment (Static (PathSegment t))) = t + formatPathSegment (Segment (Cap ((^. argName) -> (PathSegment t)))) = [i|${#{t}}|] diff --git a/src/Servant/TypeScript/Types.hs b/src/Servant/TypeScript/Types.hs new file mode 100644 --- /dev/null +++ b/src/Servant/TypeScript/Types.hs @@ -0,0 +1,74 @@ + +module Servant.TypeScript.Types where + +import Control.Lens +import Data.Aeson.TypeScript.Recursive +import Data.Aeson.TypeScript.TH +import Data.String.Interpolate +import qualified Data.Text as T +import Servant.Foreign.Internal as FI +import qualified Servant.TypeScript.GetFunctions as GetFunctions +import Servant.TypeScript.Util + + +-- | Foreign type for getting TS types +data LangTS +instance (TypeScript a) => HasForeignType LangTS T.Text a where + typeFor _proxyLang _proxyFtype proxyA = T.pack $ getTypeScriptType proxyA + +-- | Foreign type for getting TS declarations +data LangTSDecls +instance (TypeScript a) => HasForeignType LangTSDecls [TSDeclaration] a where + typeFor _proxyLang _proxyFtype proxyA = getTypeScriptDeclarationsRecursively proxyA + +data ServantTypeScriptOptions = ServantTypeScriptOptions { + -- | Extra TypeScript types to include in the @d.ts@ file. + -- + -- Useful if you want to expose types that don't appear in your API, for whatever reason. + extraTypes :: [TSType] + + -- | Determine to which output file the client function for the given request is mapped. + -- + -- Useful to break up larger APIs into separate files based on criteria like route prefixes. + -- + -- It's fine if the file key contains sub-directories; they will be created as needed. + -- + -- A good approach is to split on @case req ^. (reqFuncName . _FunctionName) of ...@. + -- + -- Default implementation is @const "client.ts"@. + , getFileKey :: Req T.Text -> FilePath + + -- | Mangle a given request into a corresponding client function name. + -- By default, just prepends the HTTP method to the camel-cased route. + , getFunctionName :: Req T.Text -> T.Text + + -- | Given a list of requests, output a complete TypeScript module with the (exported) client functions, + -- ready to be consumed by your TypeScript app. + -- + -- For example, you can import dependencies at the top + -- to use in your functions. The default version relies on the NPM "query-string" package to construct + -- URLs. It uses the built-in @window.fetch@ by default, but allows you to pass your own @fetch@ function + -- instead (useful for server-side rendering etc.). The default client functions return @Promise@s with + -- the given return value, and on failure they reject the promise with a value of interface + -- @{ status: number; text: string; }@. + -- + -- If you want to write your own 'getFunctions', check out the 'Servant.TypeScript.GetFunctions' module for + -- inspiration. + -- + -- The first argument passed to 'getFunctions' is the 'getFunctionName' function. + , getFunctions :: (Req T.Text -> T.Text) -> [Req T.Text] -> T.Text + } + +-- | Reasonable default options. +defaultServantTypeScriptOptions :: ServantTypeScriptOptions +defaultServantTypeScriptOptions = ServantTypeScriptOptions { + extraTypes = [] + + , getFileKey = const "client.ts" + + , getFunctionName = \req -> case req ^. (reqFuncName . _FunctionName) of + (method:xs) -> toCamelList $ fmap snakeToCamel (method:xs) + _ -> error [i|Case not handled in getFunctionName: '#{req}'|] + + , getFunctions = GetFunctions.getFunctions + } diff --git a/src/Servant/TypeScript/Util.hs b/src/Servant/TypeScript/Util.hs new file mode 100644 --- /dev/null +++ b/src/Servant/TypeScript/Util.hs @@ -0,0 +1,19 @@ + +module Servant.TypeScript.Util where + +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T + + +snakeToCamel :: Text -> Text +snakeToCamel t = toCamelList $ T.splitOn "_" t + +toCamelList :: [Text] -> Text +toCamelList [] = "" +toCamelList [x] = T.toLower x +toCamelList (x:xs) = mconcat (T.toLower x : fmap capitalize xs) + +capitalize :: Text -> Text +capitalize t | T.length t == 1 = T.toUpper t +capitalize t = toUpper (T.head t) `T.cons` T.tail t diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"