{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
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 qualified Data.Conduit.List as CL
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.POSIX (getPOSIXTime)
import GHC.Generics (Generic)
import Network.Wai.Handler.Warp (testWithApplication)
import Servant (serveDirectoryFileServer)
import Servant.API
( Capture
, Description
, Fragment
, Get
, Header
, JSON
, Post
, QueryFlag
, QueryParam
, QueryParams
, Raw
, ReqBody
, Summary
, type (:<|>) (..)
, type (:>)
)
import Servant.API.WebSocketConduit (WebSocketConduit)
import qualified Servant.Client.TypeScript as SCT (gen)
import Servant.Client.TypeScript (GenAll)
import Servant.Server (HasServer, Server, serve)
import System.Directory
( doesFileExist
, 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))
import Test.WebDriver
( Browser (chromeOptions)
, asyncJS
, chrome
, closeSession
, defaultConfig
, openPage
, runSession
, useBrowser
)
-- | TEST SETTINGS
showLineNumbers :: Bool
showLineNumbers = True
parRuns :: Int
parRuns = 5
isHeadless :: Bool
isHeadless = True
--
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
type WebSocketAPI :: Type
type WebSocketAPI
= "foo" :> "bar"
:> WebSocketConduit User User
type WebSocketSecureAPI :: Type
type WebSocketSecureAPI
= "foo" :> "bar"
:> Header "Dunno" String
:> WebSocketConduit User User
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "Printing" printSpec
describe "Round Trips" $ parallel roundTrips
printSpec :: Spec
printSpec = do
it "Should be a trusting type casting WebSocket" $ SCT.gen @WebSocketAPI `shouldBe` [i|const API = {
base: "",
"/foo/bar": ():
Promise<{ send : (input: User) => void
, receive : (cb: (output: User) => void) => void
, raw : WebSocket
}> => {
const pr = window.location.protocol === "http:" ? "ws:" : "wss:";
const ws = new WebSocket(`${pr}//${window.location.host}${API.base}/foo/bar`);
return Promise.resolve({
send: (input: User) => ws.send(JSON.stringify(input)),
receive: (cb: ((output: User) => void)) =>
ws.onmessage = (message: MessageEvent<string>) => cb(JSON.parse(message.data)),
raw: ws
});
}
};|]
it "Should allow for the WebSocket SEC header" $ SCT.gen @WebSocketSecureAPI `shouldBe` [i|const API = {
base: "",
"/foo/bar{Dunno}": (Dunno:string):
Promise<{ send : (input: User) => void
, receive : (cb: (output: User) => void) => void
, raw : WebSocket
}> => {
const pr = window.location.protocol === "http:" ? "ws:" : "wss:";
const ws = new WebSocket(`${pr}//${window.location.host}${API.base}/foo/bar`, [Dunno]);
return Promise.resolve({
send: (input: User) => ws.send(JSON.stringify(input)),
receive: (cb: ((output: User) => void)) =>
ws.onmessage = (message: MessageEvent<string>) => cb(JSON.parse(message.data)),
raw: ws
});
}
};|]
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": async (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": async (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}": async (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 Fragment" $ SCT.gen @FragmentAPI `shouldBe` [i|const API = {
base: "",
"/foo/bar\#fragment": async (): Promise<string> => {
const uri = `${API.base}/foo/bar`;
return fetch(uri, {
method: "POST"
}).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)": async (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}": async (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 WebSocket health" parRuns \((age,toJSBool -> isAdmin',encode -> names) :: (Int,Bool,[AlphaNumAscii])) ->
shouldRoundTrip @WebSocketAPI
(CL.map id)
( "/foo/bar"
, ""
, [i|
const msg = { names: #{names}, age: #{age}, isAdmin: #{isAdmin'} };
res.receive(msg_ => {
if(JSON.stringify(msg_.names) === JSON.stringify(msg.names)
&& msg_.age === msg.age
&& msg_.isAdmin === msg.isAdmin){
return #{resolveSuccess}
}
return resolve('msg did not echo, got this instead: ' + JSON.stringify(msg_));
})
res.raw.onopen = () => res.send(msg);
|])
pprop "Should round trip for Query" parRuns \((age,toJSBool -> isAdmin',encode -> names) :: (Int,Bool,[AlphaNumAscii])) ->
shouldRoundTrip @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'}){
return resolve('responded with ' + JSON.stringify(res) + "\\n" + JSON.stringify(#{names}));
}
return #{resolveSuccess};|])
pprop "Should round trip for Capture" parRuns \((age,name,toJSBool -> isAdmin') :: (Int,AlphaNumAscii,Bool)) ->
let names' = [encode name] in
shouldRoundTrip @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'}){
return resolve('responded with ' + JSON.stringify(res) + "\\n" + JSON.stringify(#{names'}));
}
return #{resolveSuccess};|])
pprop "Should round trip for Header" parRuns \((age,name,toJSBool -> isAdmin') :: (Int,AlphaNumAscii,Bool)) ->
let names = encode [name] in shouldRoundTrip @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'}){
return resolve('should respond with ' + JSON.stringify(res));
}
return #{resolveSuccess};|])
pprop "Should round trip for Fragment" parRuns \(frag :: AlphaNumAscii) -> shouldRoundTrip @FragmentAPI
(pure $ unAlphaNumAscii frag)
( "/foo/bar#fragment"
, mempty
, [i|
if(#{frag} !== res){
return resolve('should respond with ' + JSON.stringify(res));
}
return #{resolveSuccess};|])
pprop "Should round trip for Request Body" parRuns \User{..} ->
let isAdmin' = toJSBool isAdmin
names' = encode names
in shouldRoundTrip @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'}){
return resolve("User was not as expected");
}
return #{resolveSuccess};|])
it "Should round trip for Mixed" $ shouldRoundTrip @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 #{resolveSuccess};
}
return resolve("User was not as expected");
|])
srid :: String -> String
srid script = [i|<html>
<head>
<script src="/#{script <.> "js"}"></script>
</head>
<body></body>
</html>|]
resolveSuccess :: String
resolveSuccess = [i|resolve("success")|]
shouldRoundTrip :: forall (api :: Type).
( HasServer api '[]
, GenAll api
) => Server api -> (String, String, String) -> IO ()
shouldRoundTrip app (path, args, test)
= getTemporaryDirectory >>= \tmpDir ->
testWithApplication (pure $ serve (Proxy @(api :<|> Raw)) (app :<|> serveDirectoryFileServer tmpDir)) $ \port -> do
rand :: Int <- randomIO
now <- getPOSIXTime
let
tsFilePath, localhost, ts :: String
localhost = "http://127.0.0.1:" <> show port
tsFilePath = show now <> show (rand * 1000000) <.> "ts"
ts = [i|#{printTS $ GGT.gen @User}
#{SCT.gen @api}
window["test"] = resolve => {
API["#{path}"](#{args}).then(res => {
#{test}
});
};|]
death = do
removeFileIfExists $ tmpDir </> tsFilePath
removeFileIfExists $ tmpDir </> tsFilePath <.> "js"
removeFileIfExists $ tmpDir </> tsFilePath <.> "html"
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 (tmpDir </> tsFilePath) ts
writeFile (tmpDir </> tsFilePath <.> "html") (srid tsFilePath)
tscres <- readProcessWithExitCode "tsc"
[ tmpDir </> tsFilePath
, "--lib", "ES2021,DOM"
, "--module", "system"
, "--outFile", tmpDir </> tsFilePath <.> "js"
] ""
handleFailure tscres "TSC exited with" do
res <- runSession
(useBrowser chrome { chromeOptions = if isHeadless then
[ "--headless"
, "--disable-gpu"
] else [] } defaultConfig)
do
openPage $ localhost </> tsFilePath <.> "html"
res <- asyncJS [] [i|test(arguments[0])|]
closeSession
return res
case res of
Just "success" -> pure ()
Just x -> death >> error x
Nothing -> death >> error "TIMEOUT"
removeFileIfExists :: FilePath -> IO ()
removeFileIfExists fp = do
exists <- doesFileExist fp
when exists $ removeFile fp
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