@@ -12,7 +12,8 @@ import Data.Either (Either(..), either)
12
12
import Data.Maybe (Maybe (..))
13
13
import Data.Time.Duration (Milliseconds (..))
14
14
import Effect (Effect )
15
- import Effect.Aff (Aff , forkAff , attempt , runAff , killFiber )
15
+ import Effect.Aff (Aff , attempt , finally , forkAff , killFiber , runAff )
16
+ import Effect.Aff.Compat (EffectFnAff , fromEffectFnAff )
16
17
import Effect.Class (liftEffect )
17
18
import Effect.Class.Console as A
18
19
import Effect.Console (log , logShow )
@@ -21,6 +22,10 @@ import Foreign.Object as FO
21
22
22
23
foreign import logAny :: forall a . a -> Effect Unit
23
24
25
+ foreign import data Server :: Type
26
+ foreign import startServer :: EffectFnAff { server :: Server , port :: Int }
27
+ foreign import stopServer :: Server -> EffectFnAff Unit
28
+
24
29
logAny' :: forall a . a -> Aff Unit
25
30
logAny' = liftEffect <<< logAny
26
31
@@ -50,49 +55,53 @@ main = void $ runAff (either (\e -> logShow e *> throwException e) (const $ log
50
55
let ok200 = StatusCode 200
51
56
let notFound404 = StatusCode 404
52
57
53
- -- A complete URL is necessary for tests to work on Node.js
54
- let prefix = append " http://localhost:3838"
55
- let mirror = prefix " /mirror"
56
- let doesNotExist = prefix " /does-not-exist"
57
- let notJson = prefix " /not-json"
58
58
let retryPolicy = AX .defaultRetryPolicy { timeout = Just (Milliseconds 500.0 ), shouldRetryWithStatusCode = \_ -> true }
59
59
60
- A .log " GET /does-not-exist: should be 404 Not found after retries"
61
- (attempt $ AX .retry retryPolicy (AX .request ResponseFormat .ignore) $ AX .defaultRequest { url = doesNotExist }) >>= assertRight >>= \res -> do
62
- assertEq notFound404 res.status
63
-
64
- A .log " GET /mirror: should be 200 OK"
65
- (attempt $ AX .request ResponseFormat .ignore $ AX .defaultRequest { url = mirror }) >>= assertRight >>= \res -> do
66
- assertEq ok200 res.status
67
-
68
- A .log " GET /does-not-exist: should be 404 Not found"
69
- (attempt $ AX .request ResponseFormat .ignore $ AX .defaultRequest { url = doesNotExist }) >>= assertRight >>= \res -> do
70
- assertEq notFound404 res.status
71
-
72
- A .log " GET /not-json: invalid JSON with Foreign response should throw an error"
73
- void $ assertLeft =<< attempt (AX .get ResponseFormat .json doesNotExist)
74
-
75
- A .log " GET /not-json: invalid JSON with String response should be ok"
76
- (attempt $ AX .get ResponseFormat .string notJson) >>= assertRight >>= \res -> do
77
- assertEq ok200 res.status
78
-
79
- A .log " POST /mirror: should use the POST method"
80
- (attempt $ AX .post ResponseFormat .json mirror (RequestBody .string " test" )) >>= assertRight >>= \res -> do
81
- assertEq ok200 res.status
82
- assertEq (Just " POST" ) (J .toString =<< FO .lookup " method" =<< J .toObject res.response)
83
-
84
- A .log " PUT with a request body"
85
- let content = " the quick brown fox jumps over the lazy dog"
86
- (attempt $ AX .put ResponseFormat .json mirror (RequestBody .string content)) >>= assertRight >>= \res -> do
87
- assertEq ok200 res.status
88
- assertEq (Just " PUT" ) (J .toString =<< FO .lookup " method" =<< J .toObject res.response)
89
- assertEq (Just content) (J .toString =<< FO .lookup " body" =<< J .toObject res.response)
90
-
91
- A .log " Testing CORS, HTTPS"
92
- (attempt $ AX .get ResponseFormat .json " https://cors-test.appspot.com/test" ) >>= assertRight >>= \res -> do
93
- assertEq ok200 res.status
94
- -- assertEq (Just "test=test") (lookupHeader "Set-Cookie" res.headers)
95
-
96
- A .log " Testing cancellation"
97
- forkAff (AX .post_ mirror (RequestBody .string " do it now" )) >>= killFiber (error " Pull the cord!" )
98
- assertMsg " Should have been canceled" true
60
+ { server, port } ← fromEffectFnAff startServer
61
+ finally (fromEffectFnAff (stopServer server)) do
62
+ A .log (" Test server running on port " <> show port)
63
+
64
+ let prefix = append (" http://localhost:" <> show port)
65
+ let mirror = prefix " /mirror"
66
+ let doesNotExist = prefix " /does-not-exist"
67
+ let notJson = prefix " /not-json"
68
+
69
+ A .log " GET /does-not-exist: should be 404 Not found after retries"
70
+ (attempt $ AX .retry retryPolicy (AX .request ResponseFormat .ignore) $ AX .defaultRequest { url = doesNotExist }) >>= assertRight >>= \res -> do
71
+ assertEq notFound404 res.status
72
+
73
+ A .log " GET /mirror: should be 200 OK"
74
+ (attempt $ AX .request ResponseFormat .ignore $ AX .defaultRequest { url = mirror }) >>= assertRight >>= \res -> do
75
+ assertEq ok200 res.status
76
+
77
+ A .log " GET /does-not-exist: should be 404 Not found"
78
+ (attempt $ AX .request ResponseFormat .ignore $ AX .defaultRequest { url = doesNotExist }) >>= assertRight >>= \res -> do
79
+ assertEq notFound404 res.status
80
+
81
+ A .log " GET /not-json: invalid JSON with Foreign response should throw an error"
82
+ void $ assertLeft =<< attempt (AX .get ResponseFormat .json doesNotExist)
83
+
84
+ A .log " GET /not-json: invalid JSON with String response should be ok"
85
+ (attempt $ AX .get ResponseFormat .string notJson) >>= assertRight >>= \res -> do
86
+ assertEq ok200 res.status
87
+
88
+ A .log " POST /mirror: should use the POST method"
89
+ (attempt $ AX .post ResponseFormat .json mirror (RequestBody .string " test" )) >>= assertRight >>= \res -> do
90
+ assertEq ok200 res.status
91
+ assertEq (Just " POST" ) (J .toString =<< FO .lookup " method" =<< J .toObject res.response)
92
+
93
+ A .log " PUT with a request body"
94
+ let content = " the quick brown fox jumps over the lazy dog"
95
+ (attempt $ AX .put ResponseFormat .json mirror (RequestBody .string content)) >>= assertRight >>= \res -> do
96
+ assertEq ok200 res.status
97
+ assertEq (Just " PUT" ) (J .toString =<< FO .lookup " method" =<< J .toObject res.response)
98
+ assertEq (Just content) (J .toString =<< FO .lookup " body" =<< J .toObject res.response)
99
+
100
+ A .log " Testing CORS, HTTPS"
101
+ (attempt $ AX .get ResponseFormat .json " https://cors-test.appspot.com/test" ) >>= assertRight >>= \res -> do
102
+ assertEq ok200 res.status
103
+ -- assertEq (Just "test=test") (lookupHeader "Set-Cookie" res.headers)
104
+
105
+ A .log " Testing cancellation"
106
+ forkAff (AX .post_ mirror (RequestBody .string " do it now" )) >>= killFiber (error " Pull the cord!" )
107
+ assertMsg " Should have been canceled" true
0 commit comments