100 lines
3.6 KiB
Haskell
100 lines
3.6 KiB
Haskell
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Servant.Client.JsSpec where
|
|
|
|
import Servant.API
|
|
import Servant.Server
|
|
import Network.Wai.Handler.Warp as Warp
|
|
import qualified Data.ByteString as B
|
|
import Data.ByteString(ByteString)
|
|
import Test.Hspec
|
|
import Data.Proxy
|
|
import Control.Monad.Trans
|
|
import Data.Aeson
|
|
import Data.Word
|
|
import GHC.Generics
|
|
import qualified Language.Javascript.JSaddle.WebKitGTK as WK
|
|
import qualified Language.Javascript.JSaddle.Monad as JSaddle
|
|
import Language.Javascript.JSaddle.Monad(JSM)
|
|
import Control.Concurrent
|
|
import Servant.Client.Js
|
|
import qualified JSDOM
|
|
import qualified JSDOM.Window as Window
|
|
import qualified Network.Wai as Wai
|
|
import Network.Wai.Middleware.AddHeaders
|
|
import qualified Network.HTTP.Types as Http
|
|
import Data.String
|
|
import System.IO
|
|
|
|
type TestApi = ReqBody '[OctetStream] ByteString :> Post '[JSON] TestResponse
|
|
testApi :: Proxy TestApi
|
|
testApi = Proxy
|
|
|
|
data TestResponse = TestResponse { byteList :: [Word8] }
|
|
deriving (Generic, ToJSON, FromJSON, Show, Eq)
|
|
|
|
testServer :: Server TestApi
|
|
testServer x = do
|
|
pure . TestResponse . B.unpack $ x
|
|
|
|
testClient :: Client ClientM TestApi
|
|
testClient = client testApi
|
|
|
|
-- WARNING: approximation!
|
|
jsaddleFinally :: JSM b -> JSM a -> JSM a
|
|
jsaddleFinally handler m = JSaddle.bracket (pure ()) (const handler) (const m)
|
|
-- jsaddleFinally handler m = JSaddle.catch (m <* handler) (\e -> handler >> throw (e :: SomeException))
|
|
|
|
close :: JSM ()
|
|
close = do
|
|
mw <- JSDOM.currentWindow
|
|
case mw of
|
|
Just w -> do
|
|
liftIO $ putStrLn "Closing window..."
|
|
Window.close w
|
|
Nothing -> liftIO $ putStrLn "Can't close the window!"
|
|
|
|
logRequest :: Wai.Middleware
|
|
logRequest app request respond = do
|
|
putStrLn "Request"
|
|
print request
|
|
app request (\response -> do
|
|
putStrLn "Response Headers"
|
|
print `mapM_` (Wai.responseHeaders response)
|
|
respond response)
|
|
|
|
corsHeaders :: (IsString s1, IsString s2) => [(s1, s2)]
|
|
corsHeaders = [ ("Access-Control-Allow-Origin", "null")
|
|
, ("Access-Control-Allow-Methods", "POST")
|
|
, ("Access-Control-Allow-Headers", "content-type")
|
|
]
|
|
|
|
addCors :: Wai.Middleware
|
|
addCors app request respond =
|
|
if Wai.requestMethod request == "OPTIONS"
|
|
then respond $ Wai.responseLBS Http.status200 corsHeaders ""
|
|
else addHeaders corsHeaders app request respond
|
|
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
describe "Servant.Client.Js" $ do
|
|
it "Receive a properly encoded response" $ do
|
|
Warp.testWithApplication (pure $ logRequest $ addCors $ serve testApi testServer) $ \portNr -> do
|
|
let clientEnv = mkClientEnv BaseUrl { baseUrlScheme = Http
|
|
, baseUrlHost = "localhost"
|
|
, baseUrlPort = fromIntegral portNr
|
|
, baseUrlPath = "/"
|
|
}
|
|
|
|
WK.run $ JSaddle.liftJSM $ jsaddleFinally close $ do
|
|
liftIO $ threadDelay $ 1000 * 1000
|
|
-- a mix of valid utf-8 and non-utf8 bytes
|
|
let bytes = [0x01, 0xff, 0x02, 0xfe, 0x03, 0xfd, 0x00, 0x64, 0xc3, 0xbb, 0x68, 0xc3]
|
|
response <- flip runClientM clientEnv $ do
|
|
testClient (B.pack bytes)
|
|
liftIO $ response `shouldBe` Right (TestResponse bytes)
|