servant-aeson-generics-typescript (empty) → 0.0.0.1
raw patch · 6 files changed
+837/−0 lines, 6 filesdep +QuickCheckdep +aesondep +aeson-generics-typescript
Dependencies added: QuickCheck, aeson, aeson-generics-typescript, async, base, bytestring, containers, directory, filepath, hspec, hspec-wai, http-types, jose-jwt, process, random, servant, servant-auth, servant-server, split, string-interpolate, text, time, warp
Files
- LICENSE +11/−0
- README.md +53/−0
- servant-aeson-generics-typescript.cabal +115/−0
- src/Servant/Client/TypeScript.hs +327/−0
- test/Main.hs +2/−0
- test/Servant/Client/TypeScriptSpec.hs +329/−0
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2023 Platonic.Systems++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,53 @@+# Servant Aeson Generics TypeScript++This project leveratges aeson-generics-typescript to generate type safe API bindings in TypeScript for a given Servant API.+Included here are tests that round trip by compling the TypeScript with tsc, running the client in nodejs, and checking that request response round trips with the Servant server.++```haskell+data Foo = ...+ deriving stock (Generic)+ deriving anyclass (ToJSON, FromJSON, TypeScriptDefinition)++type API = "foo" :> Get '[JSON] Foo+```++Is all it takes to have a TypeScript Definition, and TypeScript client. Now you can obtain the TypeScript client as a string like so.++```haskell+client :: String+client = gen @API+```++## Example++You can see many examples in the tests. One provided here for documentation purposes:++```haskell+data Foo = Foo { thang :: String, otherThang :: Int }+ deriving stock (Generic)+ deriving anyclass (ToJSON, FromJSON, TypeScriptDefinition)++type API = "foo" :> Capture "bar" Int :> Post '[JSON] Foo++client = tsClient @'[Foo] @API+```++will generate++```typescript+// Defined in Servant.Client.TypeScriptSpec of main+interface Foo {+ // readonly tag: "Foo";+ readonly thang: string;+ readonly otherThang: number;+}+const API = {+ base: "",+ "/foo/:bar": (bar:number): Promise<Foo> => {+ const uri = `${API.base}/foo/${bar}`;+ return fetch(uri, {+ method: "POST"+ }).then(res => res.json());+ }+};+```
+ servant-aeson-generics-typescript.cabal view
@@ -0,0 +1,115 @@+cabal-version: 3.0+name: servant-aeson-generics-typescript+version: 0.0.0.1+synopsis: Generates a TypeScript client for Servant APIs+description:+ This project leveratges aeson-generics-typescript to generate type safe API bindings in TypeScript for a given Servant API.+ Included here are tests that round trip by compling the TypeScript with tsc, running the client in nodejs, and checking that request response round trips with the Servant server.++category: Web+author: Platonic.Systems+maintainer: info@Platonic.Systems+copyright: 2023+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-source-files: README.md++source-repository head+ type: git+ location:+ https://gitlab.com/platonic/servant-aeson-generics-typescript.git++common shared+ default-language: GHC2021+ default-extensions:+ AllowAmbiguousTypes+ ApplicativeDo+ BlockArguments+ CPP+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ ExtendedDefaultRules+ FunctionalDependencies+ GADTs+ ImpredicativeTypes+ LambdaCase+ LinearTypes+ MultiWayIf+ OverloadedLabels+ OverloadedStrings+ PartialTypeSignatures+ PatternSynonyms+ QuantifiedConstraints+ RecordWildCards+ RoleAnnotations+ TypeFamilies+ TypeFamilyDependencies+ UndecidableInstances+ ViewPatterns++library+ import: shared+ hs-source-dirs: src+ exposed-modules: Servant.Client.TypeScript+ hs-source-dirs: src+ ghc-options:+ -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude+ -Wno-missing-local-signatures -Wno-missing-import-lists+ -Wno-missing-export-lists -Wno-missing-safe-haskell-mode+ -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe++ build-depends:+ , aeson+ , aeson-generics-typescript+ , base+ , containers+ , http-types+ , jose-jwt+ , servant+ , string-interpolate+ , text++executable tests+ import: shared+ main-is: Main.hs+ hs-source-dirs: test src+ ghc-options:+ -Wall -Wcompat -fwarn-redundant-constraints+ -fwarn-incomplete-uni-patterns -fwarn-tabs+ -fwarn-incomplete-record-updates -fwarn-identities -threaded+ -fno-warn-missing-home-modules -rtsopts -freduction-depth=1000+ -with-rtsopts=-N +RTS -H2G -A32M -RTS++ build-depends:+ , aeson >=2.1.2 && <2.2+ , aeson-generics-typescript >=0.0.0 && <0.1+ , async >=2.2.4 && <2.3+ , base >=4.17.2 && <4.18+ , bytestring >=0.11.5 && <0.12+ , containers >=0.6.7 && <0.7+ , directory >=1.3.7 && <1.4+ , filepath >=1.4.2 && <1.5+ , hspec >=2.11.7 && <2.12+ , hspec-wai >=0.11.1 && <0.12+ , http-types >=0.12.3 && <0.13+ , jose-jwt >=0.9.6 && <0.10+ , process >=1.6.17 && <1.7+ , QuickCheck >=2.14.3 && <2.15+ , random >=1.2.1 && <1.3+ , servant >=0.20.1 && <0.21+ , servant-auth >=0.4.1 && <0.5+ , servant-server >=0.20 && <0.21+ , split >=0.2.4 && <0.3+ , string-interpolate >=0.3.2 && <0.4+ , text >=2.0.2 && <2.1+ , time >=1.12.2 && <1.13+ , warp >=3.3.30 && <3.4++ other-modules:+ Servant.Client.TypeScript+ Servant.Client.TypeScriptSpec
+ src/Servant/Client/TypeScript.hs view
@@ -0,0 +1,327 @@+{-# 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"
+ test/Main.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main where
+ test/Servant/Client/TypeScriptSpec.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Servant.Client.TypeScriptSpec+ ( main+ , spec+ ) where++import Control.Concurrent.Async (mapConcurrently_)+import Control.Monad (when)+import Data.Aeson (FromJSON, ToJSON, encode)+import Data.Aeson.Generics.TypeScript+ ( FieldTypeName+ , TypeScriptDefinition+ , printTS+ )+import qualified Data.Aeson.Generics.TypeScript as GGT (gen)+import Data.Char (isAscii, isDigit, isLetter, toLower)+import Data.Kind (Type)+import Data.List.Split (splitOn)+import Data.Proxy (Proxy (Proxy))+import Data.String (IsString)+import Data.String.Interpolate (i)+import Data.Time.Clock (getCurrentTime)+import GHC.Generics (Generic)+import Network.Wai.Handler.Warp (testWithApplication)+import Servant.API+ ( Capture+ , Description+ , Fragment+ , Get+ , Header+ , JSON+ , Post+ , QueryFlag+ , QueryParam+ , QueryParams+ , ReqBody+ , Summary+ , type (:>)+ )+import qualified Servant.Client.TypeScript as SCT (gen)+import Servant.Client.TypeScript (GenAll)+import Servant.Server (Application, serve)+import System.Directory (getTemporaryDirectory, removeFile)+import System.Exit (ExitCode (ExitFailure))+import System.FilePath ((<.>), (</>))+import System.Process (readProcessWithExitCode)+import System.Random (randomIO)+import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe)+import Test.QuickCheck (generate, resize, suchThat)+import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))++showLineNumbers :: Bool+showLineNumbers = True++parRuns :: Int+parRuns = 5++type User :: Type+data User = User+ { names :: [AlphaNumAscii]+ , age :: Int+ , isAdmin :: Bool+ }+ deriving stock (Eq, Generic, Ord, Show)+ deriving anyclass (FromJSON, ToJSON, TypeScriptDefinition)++newtype AlphaNumAscii = AlphaNumAscii { unAlphaNumAscii :: String }+ deriving newtype (Eq, FieldTypeName, FromJSON, IsString, Ord, Show, ToJSON)++instance Arbitrary AlphaNumAscii where+ arbitrary = AlphaNumAscii <$> arbitrary `suchThat` all (\x -> (isDigit x || isLetter x) && isAscii x)++instance Arbitrary User where+ arbitrary = User <$> arbitrary <*> arbitrary <*> arbitrary++type CaptureAPI :: Type+type CaptureAPI+ = Description "This is the description of this route" :>+ "foo" :> "bar"+ :> Capture "Frog Splat" Int+ :> Capture "wat" String+ :> "Zap"+ :> Capture "zazzy" Bool+ :> Get '[JSON] User++type QueryAPI :: Type+type QueryAPI+ = Summary "This is the summary of this route"+ :> "foo" :> "bar"+ :> QueryParam "Frog Splat" Int+ :> QueryParam "wat" Bool+ :> "Zap"+ :> QueryParams "zazzy" String+ :> Post '[JSON] User++type HeaderAPI :: Type+type HeaderAPI+ = "foo" :> "bar"+ :> Header "Frog-Splat" Int+ :> Header "wat" String+ :> "Zap"+ :> Header "zazzy" Bool+ :> Post '[JSON] User++type BodyAPI :: Type+type BodyAPI+ = "foo" :> "bar"+ :> ReqBody '[JSON] User+ :> Post '[JSON] User++type FragmentAPI :: Type+type FragmentAPI+ = "foo" :> "bar"+ :> Fragment String+ :> Post '[JSON] String++type MixedCaptureQueryAPI :: Type+type MixedCaptureQueryAPI+ = "foo" :> "bar"+ :> Capture "Frog Splat" Int+ :> QueryParam "wat" String+ :> Header "bip" String+ :> Header "wip" Int+ :> "Zap"+ :> QueryFlag "rump"+ :> Capture "zazzy" Bool+ :> QueryParam "hu hu" String+ :> Get '[JSON] User++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Printing" printSpec+ describe "Round Trips" $ parallel roundTrips++printSpec :: Spec+printSpec = do+ it "Should interpolate variables into the url for Capture" $+ let open = '/' : "*"; close = '*' : "/"+ in SCT.gen @CaptureAPI `shouldBe` [i|const API = {+ base: "",+ #{open}+ * This is the description of this route+ #{close}+ "/foo/bar/:Frog%20Splat/:wat/Zap/:zazzy": (Frog_Splat:number,wat:string,zazzy:boolean): Promise<User> => {+ const uri = `${API.base}/foo/bar/${Frog_Splat}/${wat}/Zap/${zazzy}`;+ return fetch(uri, {+ method: "GET"+ }).then(res => res.json());+ }+};|]++ it "Should interpolate variables into the url for Query" $ SCT.gen @QueryAPI `shouldBe` [i|const API = {+ base: "",+ // This is the summary of this route+ "/foo/bar/Zap?Frog%20Splat&wat&zazzy": (Frog_Splat:number,wat:boolean,zazzy:Array<string>): Promise<User> => {+ const uri = `${API.base}/foo/bar/Zap?Frog%20Splat=${Frog_Splat}&wat=${wat}&${zazzy.reduceRight((acc,x) => "zazzy=" + x + (acc ? "&" + acc : ""), "")}`;+ return fetch(uri, {+ method: "POST"+ }).then(res => res.json());+ }+};|]++ it "Should interpolate variables into the url for Header" $ SCT.gen @HeaderAPI `shouldBe` [i|const API = {+ base: "",+ "/foo/bar/Zap{Frog-Splat,wat,zazzy}": (Frog_Splat:number,wat:string,zazzy:boolean): Promise<User> => {+ const uri = `${API.base}/foo/bar/Zap`;+ return fetch(uri, {+ method: "POST",+ headers: {+ "Frog-Splat": "" + Frog_Splat,+ "wat": wat,+ "zazzy": "" + zazzy+ }+ }).then(res => res.json());+ }+};|]++ it "Should interpolate variables into the url for Request Body" $ SCT.gen @BodyAPI `shouldBe` [i|const API = {+ base: "",+ "/foo/bar(User)": (User:User): Promise<User> => {+ const uri = `${API.base}/foo/bar`;+ return fetch(uri, {+ method: "POST",+ headers: {+ 'Content-Type': 'application/json'+ },+ body: JSON.stringify(User)+ }).then(res => res.json());+ }+};|]++ it "Should interpolate variables into the url for Mixed" $ SCT.gen @MixedCaptureQueryAPI `shouldBe` [i|const API = {+ base: "",+ "/foo/bar/:Frog%20Splat/Zap/:zazzy?wat&rump&hu%20hu{bip,wip}": (Frog_Splat:number,wat:string,bip:string,wip:number,rump:boolean,zazzy:boolean,hu_hu:string): Promise<User> => {+ const uri = `${API.base}/foo/bar/${Frog_Splat}/Zap/${zazzy}?wat=${wat}&rump=${rump}&hu%20hu=${hu_hu}`;+ return fetch(uri, {+ method: "GET",+ headers: {+ "bip": bip,+ "wip": "" + wip+ }+ }).then(res => res.json());+ }+};|]++toJSBool :: Bool -> String+toJSBool = fmap toLower . show++echoMaybe :: Applicative m => Maybe a -> m a+echoMaybe = \case+ Just b -> pure b+ _ -> error "Bool was not parsed from the frontend"++pprop :: forall a. Arbitrary a => String -> Int -> (a -> IO ()) -> Spec+pprop m runs p = it m $ do+ randos <- generate (sequence [ resize n (arbitrary @a) | n <- [1..runs] ])+ mapConcurrently_ p randos++roundTrips :: Spec+roundTrips = do+ pprop "Should round trip for Query" parRuns \((age,toJSBool -> isAdmin',encode -> names) :: (Int,Bool,[AlphaNumAscii])) ->+ shouldRoundTrip @QueryAPI+ (serve (Proxy @QueryAPI) (\ns g a -> User (AlphaNumAscii <$> a) <$> echoMaybe ns <*> echoMaybe g))+ ( "/foo/bar/Zap?Frog%20Splat&wat&zazzy"+ , [i|#{age},#{isAdmin'},#{names}|]+ , [i|+ if(JSON.stringify(res.names) !== JSON.stringify(#{names}) || res.age !== #{age} || res.isAdmin !== #{isAdmin'}){+ throw new Error('responded with ' + JSON.stringify(res) + "\\n" + JSON.stringify(#{names}))+ }+ return res|])++ pprop "Should round trip for Capture" parRuns \((age,name,toJSBool -> isAdmin') :: (Int,AlphaNumAscii,Bool)) ->+ let names' = [encode name] in+ shouldRoundTrip @CaptureAPI+ (serve (Proxy @CaptureAPI) (\ns a g -> pure $ User (pure $ AlphaNumAscii a) ns g))+ ( "/foo/bar/:Frog%20Splat/:wat/Zap/:zazzy"+ , [i|#{age},`#{name}`,#{isAdmin'}|]+ , [i|+ if(JSON.stringify(res.names) !== JSON.stringify(#{names'}) || res.age !== #{age} || res.isAdmin !== #{isAdmin'}){+ throw new Error('responded with ' + JSON.stringify(res) + "\\n" + JSON.stringify(#{names'}))+ }+ return res|])++ pprop "Should round trip for Header" parRuns \((age,name,toJSBool -> isAdmin') :: (Int,AlphaNumAscii,Bool)) ->+ let names = encode [name] in shouldRoundTrip @HeaderAPI+ (serve (Proxy @HeaderAPI) (\ns a g -> User <$> (pure . AlphaNumAscii <$> echoMaybe a) <*> echoMaybe ns <*> echoMaybe g))+ ( "/foo/bar/Zap{Frog-Splat,wat,zazzy}"+ , [i|#{age},#{name},#{isAdmin'}|]+ , [i|+ if(JSON.stringify(res.names) !== `#{names}` || res.age !== #{age} || res.isAdmin !== #{isAdmin'}){+ throw new Error('should respond with ' + JSON.stringify(res))+ }+ return res|])++ pprop "Should round trip for Request Body" parRuns \User{..} ->+ let isAdmin' = toJSBool isAdmin+ names' = encode names+ in shouldRoundTrip @BodyAPI+ (serve (Proxy @BodyAPI) pure)+ ( "/foo/bar(User)"+ , [i|{names:#{names},age:#{age},isAdmin:#{isAdmin'}}|]+ , [i|+ if(JSON.stringify(res.names) !== `#{names'}` || res.age !== #{age} || res.isAdmin !== #{isAdmin'}){+ throw new Error('should respond with true')+ }+ return res|])++ it "Should round trip for Mixed" $ shouldRoundTrip @MixedCaptureQueryAPI+ (serve (Proxy @MixedCaptureQueryAPI) (\_ _ _ _ _ _ _ -> pure $ User ["jack"] 22 True))+ ( "/foo/bar/:Frog%20Splat/Zap/:zazzy?wat&rump&hu%20hu{bip,wip}"+ , "3,'wazzy','zammy',4,false,true,'grim'"+ , [i|+ if(res.names[0] === "jack" && res.age === 22 && res.isAdmin){+ return res;+ }+ throw new Error('should respond with true')|])+++shouldRoundTrip :: forall (api :: Type). GenAll api => Application -> (String, String, String) -> IO ()+shouldRoundTrip app (path, args, test) = testWithApplication (pure app) $ \port -> do+ tmpDir :: FilePath <- getTemporaryDirectory+ rand :: Int <- randomIO+ now <- getCurrentTime++ let+ base, filePath, fetchAPI, typeDecl, ts :: String+ base = "http://127.0.0.1:" <> show port+ filePath = tmpDir </> show now <> show (rand * 1000000) <.> "ts"+ fetchAPI = SCT.gen @api+ typeDecl = printTS $ GGT.gen @User+ ts = [i|#{typeDecl}+#{fetchAPI}+API.base = "#{base}";+API["#{path}"](#{args}).then(res => {+ #{test}+});|] :: String+ death = do+ removeFile filePath+ removeFile $ filePath <.> "js"++ handleFailure :: forall a. (ExitCode, String, String) -> String -> IO a -> IO a+ handleFailure res mes continue = case res of+ (ExitFailure ef, out, err) -> do+ death+ putStrLn "━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"+ putStrLn $ addLineNumbers ts+ putStrLn "┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈"+ putStrLn out+ when (not (null err)) $ putStrLn err+ putStrLn "━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"+ error $ mes <> " " <> show ef+ _ -> continue++ writeFile filePath ts+ tscres <- readProcessWithExitCode "tsc" [filePath, "--outFile", filePath <.> "js" ] ""+ handleFailure tscres "TSC exited with" do+ nodeRes <- readProcessWithExitCode "node" [filePath <.> "js"] ""+ handleFailure nodeRes "Node exited with" death++addLineNumbers :: String -> String+addLineNumbers ts =+ if showLineNumbers then foldMap (\(x,ln) ->+ let lnf = show (ln :: Int) in "\n " <> lnf <> replicate (4 - length lnf) ' ' <> "| " <> x) $ zip (splitOn "\n" ts) [1..]+ else ts