2022-05-22 11:47:58 +00:00
|
|
|
module Test.HTTPurple.ServerSpec where
|
2017-05-25 19:12:29 +00:00
|
|
|
|
2017-07-18 05:31:46 +00:00
|
|
|
import Prelude
|
2022-05-04 21:02:29 +00:00
|
|
|
|
2021-11-19 06:16:35 +00:00
|
|
|
import Control.Monad.Except (throwError)
|
2022-05-05 15:51:43 +00:00
|
|
|
import Data.Either (Either(..))
|
|
|
|
import Data.Generic.Rep (class Generic)
|
2021-11-19 06:16:35 +00:00
|
|
|
import Data.Maybe (Maybe(Nothing))
|
2018-02-09 05:46:45 +00:00
|
|
|
import Data.Options ((:=))
|
2022-05-04 21:02:29 +00:00
|
|
|
import Effect.Class (liftEffect)
|
|
|
|
import Effect.Exception (error)
|
2021-11-19 06:16:35 +00:00
|
|
|
import Foreign.Object (empty)
|
2022-05-22 11:47:58 +00:00
|
|
|
import HTTPurple.Request (Request)
|
|
|
|
import HTTPurple.Response (ResponseM, notFound, ok)
|
2022-05-22 16:36:08 +00:00
|
|
|
import HTTPurple.Server (serve)
|
|
|
|
import HTTPurple.Server as Server
|
2021-11-19 06:16:35 +00:00
|
|
|
import Node.Encoding (Encoding(UTF8))
|
|
|
|
import Node.FS.Sync (readTextFile)
|
2022-05-22 16:54:11 +00:00
|
|
|
import Node.HTTP.Secure (cert, certString, key, keyString)
|
2022-05-05 15:51:43 +00:00
|
|
|
import Routing.Duplex (RouteDuplex')
|
|
|
|
import Routing.Duplex as RD
|
|
|
|
import Routing.Duplex.Generic as G
|
|
|
|
import Routing.Duplex.Generic as RG
|
2022-05-22 16:54:11 +00:00
|
|
|
import Test.HTTPurple.TestHelpers (Test, get, get', getStatus, (?=))
|
2021-11-19 06:16:35 +00:00
|
|
|
import Test.Spec (describe, it)
|
|
|
|
import Test.Spec.Assertions (expectError)
|
2017-05-25 19:12:29 +00:00
|
|
|
|
2022-05-05 15:51:43 +00:00
|
|
|
data Route = Test
|
|
|
|
|
|
|
|
derive instance Generic Route _
|
|
|
|
|
|
|
|
route :: RouteDuplex' Route
|
|
|
|
route = RD.root $ G.sum
|
|
|
|
{ "Test": RD.path "test" RG.noArgs
|
|
|
|
}
|
|
|
|
|
|
|
|
mockRouter :: Request Route -> ResponseM
|
2022-05-22 11:30:14 +00:00
|
|
|
mockRouter { route: Test } = ok $ RD.print route Test
|
2017-07-10 10:17:13 +00:00
|
|
|
|
2021-11-19 06:16:35 +00:00
|
|
|
serveSpec :: Test
|
2021-03-22 19:02:36 +00:00
|
|
|
serveSpec =
|
2021-11-19 06:16:35 +00:00
|
|
|
describe "serve" do
|
|
|
|
it "boots a server on the given port" do
|
2022-05-22 16:36:08 +00:00
|
|
|
close <- liftEffect $ serve { port: 8080 } { route, router: mockRouter }
|
2021-11-19 06:16:35 +00:00
|
|
|
out <- get 8080 empty "/test"
|
|
|
|
liftEffect $ close $ pure unit
|
2021-03-22 19:02:36 +00:00
|
|
|
out ?= "/test"
|
2021-11-19 06:16:35 +00:00
|
|
|
it "responds with a 500 upon unhandled exceptions" do
|
|
|
|
let router _ = throwError $ error "fail!"
|
2022-05-22 16:36:08 +00:00
|
|
|
close <- liftEffect $ serve { port: 8080 } { route, router }
|
2022-05-22 11:30:14 +00:00
|
|
|
status <- getStatus 8080 empty "/test"
|
2021-11-19 06:16:35 +00:00
|
|
|
liftEffect $ close $ pure unit
|
2021-03-22 19:02:36 +00:00
|
|
|
status ?= 500
|
2018-10-09 17:37:23 +00:00
|
|
|
|
2021-11-19 06:16:35 +00:00
|
|
|
serve'Spec :: Test
|
2021-03-22 19:02:36 +00:00
|
|
|
serve'Spec =
|
2021-11-19 06:16:35 +00:00
|
|
|
describe "serve'" do
|
|
|
|
it "boots a server with the given options" do
|
2021-03-22 19:02:36 +00:00
|
|
|
close <-
|
2021-11-19 06:16:35 +00:00
|
|
|
liftEffect
|
2022-05-22 16:36:08 +00:00
|
|
|
$ serve { hostname: "localhost", port: 8080 } { route, router: mockRouter }
|
2021-11-19 06:16:35 +00:00
|
|
|
out <- get 8080 empty "/test"
|
|
|
|
liftEffect $ close $ pure unit
|
2021-03-22 19:02:36 +00:00
|
|
|
out ?= "/test"
|
2018-02-09 05:46:45 +00:00
|
|
|
|
2021-11-19 06:16:35 +00:00
|
|
|
serveSecureSpec :: Test
|
2021-03-22 19:02:36 +00:00
|
|
|
serveSecureSpec =
|
2021-11-19 06:16:35 +00:00
|
|
|
describe "serveSecure" do
|
|
|
|
describe "with valid key and cert files" do
|
|
|
|
it "boots a server on the given port" do
|
2021-03-22 19:02:36 +00:00
|
|
|
close <-
|
2021-11-19 06:16:35 +00:00
|
|
|
liftEffect
|
2022-05-22 16:36:08 +00:00
|
|
|
$ serve { port: 8080, certFile: "./test/Mocks/Certificate.cer", keyFile: "./test/Mocks/Key.key" } { route, router: mockRouter }
|
2021-11-19 06:16:35 +00:00
|
|
|
out <- get' 8080 empty "/test"
|
|
|
|
liftEffect $ close $ pure unit
|
2021-03-22 19:02:36 +00:00
|
|
|
out ?= "/test"
|
2021-11-19 06:16:35 +00:00
|
|
|
describe "with invalid key and cert files" do
|
|
|
|
it "throws" do
|
|
|
|
expectError $ liftEffect
|
2022-05-22 16:36:08 +00:00
|
|
|
$ serve { port: 8080, certFile: "", keyFile: "" } { route, router: mockRouter }
|
2017-07-23 19:17:02 +00:00
|
|
|
|
2021-11-19 06:16:35 +00:00
|
|
|
serveSecure'Spec :: Test
|
2021-03-22 19:02:36 +00:00
|
|
|
serveSecure'Spec =
|
2021-11-19 06:16:35 +00:00
|
|
|
describe "serveSecure'" do
|
|
|
|
describe "with valid key and cert files" do
|
|
|
|
it "boots a server on the given port" do
|
|
|
|
let
|
2022-05-22 16:36:08 +00:00
|
|
|
options = { hostname: "localhost", port: 8080, certFile: "./test/Mocks/Certificate.cer", keyFile: "./test/Mocks/Key.key" }
|
2021-03-22 19:02:36 +00:00
|
|
|
close <-
|
2021-11-19 06:16:35 +00:00
|
|
|
liftEffect
|
2022-05-22 16:36:08 +00:00
|
|
|
$ serve options { route, router: mockRouter }
|
2021-11-19 06:16:35 +00:00
|
|
|
out <- get' 8080 empty "/test"
|
|
|
|
liftEffect $ close $ pure unit
|
2021-03-22 19:02:36 +00:00
|
|
|
out ?= "/test"
|
2018-02-09 05:46:45 +00:00
|
|
|
|
2021-11-19 06:16:35 +00:00
|
|
|
serverSpec :: Test
|
2021-03-22 19:02:36 +00:00
|
|
|
serverSpec =
|
2021-11-19 06:16:35 +00:00
|
|
|
describe "Server" do
|
2021-03-22 19:02:36 +00:00
|
|
|
serveSpec
|
|
|
|
serve'Spec
|
|
|
|
serveSecureSpec
|
|
|
|
serveSecure'Spec
|