1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
-- |
-- Module: Server
-- Description: Test HTTP server for wai-cors
-- Copyright: © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>.
-- License: MIT
-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-- Stability: experimental
--
module Server
( main
) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Network.Socket (withSocketsDo)
import Network.Wai.Middleware.Cors
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as WAI
import qualified Network.Wai.Handler.Warp as WARP
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
import qualified Data.Text as T
main ∷ IO ()
main = withSocketsDo . WARP.run 8080 $ server
-- -------------------------------------------------------------------------- --
-- Server application
server ∷ WAI.Application
server = cors corsPolicy $ \request →
case WAI.pathInfo request of
"cors":_ → corsapp request
_ → testapp
where
testapp respond = respond $ WAI.responseFile HTTP.status200 [] "index.html" Nothing
corsapp = WS.websocketsOr WS.defaultConnectionOptions wsserver $ \_ respond →
respond $ WAI.responseLBS HTTP.status200 [] "Success"
-- -------------------------------------------------------------------------- --
-- CORS Policy
corsPolicy ∷ WAI.Request → Maybe CorsResourcePolicy
corsPolicy request = case WAI.pathInfo request of
"cors" : "non-simple":_ → Just nonSimplePolicy
"cors" : "simple":_ → Just simpleCorsResourcePolicy
_ → Nothing
-- -------------------------------------------------------------------------- --
-- Websockets Server
wsserver ∷ WS.ServerApp
wsserver pc = do
c ← WS.acceptRequest pc
forever (go c) `catch` \case
WS.CloseRequest _code _msg → WS.sendClose c ("closed" ∷ T.Text)
e → throwIO e
where
go c = do
msg ← WS.receiveDataMessage c
forkIO $ WS.sendDataMessage c msg
-- -------------------------------------------------------------------------- --
-- Non Simple Policy
-- | Perform the following tests the following with this policy:
--
-- * @Variy: Origin@ header is set on responses
-- * @X-cors-test@ header is accepted
-- * @X-cors-test@ header is exposed on response
-- * @Access-Control-Allow-Origin@ header is set on responses to the request host
-- * @DELETE@ requests are not allowed
-- * @PUT@ requests are allowed
-- * Requests that don't include an @Origin@ header result in 400 responses
-- (it's not clear how to test this with a browser client)
--
-- Note that Chrome sends @Origin: null@ when loaded from a "file://..." URL,
-- PhantomJS sends "file://".
--
nonSimplePolicy ∷ CorsResourcePolicy
nonSimplePolicy = CorsResourcePolicy
{ corsOrigins = Just (["http://localhost:8080", "null", "file://"], False)
, corsMethods = ["PUT"]
, corsRequestHeaders = ["X-cors-test"]
, corsExposedHeaders = Just ["X-cors-test", "Vary"]
, corsMaxAge = Nothing
, corsVaryOrigin = True
, corsRequireOrigin = True
, corsIgnoreFailures = False
}
|
