{-# 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