/
CORS.purs
128 lines (111 loc) · 3.9 KB
/
CORS.purs
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
module Bucketchain.CORS
( AllowOrigins(..)
, AllowCredentials
, MaxAge
, AllowMethods
, AllowHeaders(..)
, ExposeHeaders
, Options
, defaultOptions
, withCORS
) where
import Prelude
import Bucketchain.Header.Vary (addVary)
import Bucketchain.Http (Http, requestHeaders, requestMethod, setHeader, setStatusCode)
import Bucketchain.Middleware (Middleware)
import Control.Monad.Reader (ask)
import Data.Array (length)
import Data.Either (Either(..))
import Data.Foldable (elem)
import Data.HTTP.Method (Method(..), fromString)
import Data.Int (ceil)
import Data.Maybe (Maybe(..))
import Data.String (joinWith)
import Data.Time.Duration (Seconds(..))
import Effect (Effect)
import Effect.Class (liftEffect)
import Foreign.Object (lookup)
-- | The type of `Access-Control-Allow-Origin`.
data AllowOrigins
= AnyOrigin
| Origins (Array String)
-- | The type of `Access-Control-Allow-Credentials`.
type AllowCredentials = Boolean
-- | The type of `Access-Control-Max-Age`.
type MaxAge = Seconds
-- | The type of `Access-Control-Allow-Methods`.
type AllowMethods = Array Method
-- | The type of `Access-Control-Allow-Headers`.
data AllowHeaders
= AnyHeader
| Headers (Array String)
-- | The type of `Access-Control-Expose-Headers`.
type ExposeHeaders = Array String
-- | The type of CORS options.
type Options =
{ origins :: AllowOrigins
, credentials :: AllowCredentials
, maxAge :: MaxAge
, methods :: AllowMethods
, allowHeaders :: AllowHeaders
, exposeHeaders :: ExposeHeaders
}
-- | Default options.
-- |
-- | - origins: `AnyOrigin`
-- | - credentials: `false`
-- | - maxAge: `1728000`
-- | - methods: `[ GET, HEAD, PUT, POST, DELETE, PATCH ]`
-- | - allowHeaders: `AnyHeader`
-- | - exposeHeaders: `[]`
defaultOptions :: Options
defaultOptions =
{ origins: AnyOrigin
, credentials: false
, maxAge: Seconds 1728000.0
, methods: [ GET, HEAD, PUT, POST, DELETE, PATCH ]
, allowHeaders: AnyHeader
, exposeHeaders: []
}
-- | The CORS middleware.
withCORS :: Options -> Middleware
withCORS opts next = do
http <- ask
liftEffect $ addVary http "Origin"
case lookup "origin" $ requestHeaders http of
Nothing -> next
Just origin -> do
liftEffect $ setAllowOrigin http opts.origins origin
liftEffect $ setAllowCredentials http opts.credentials
case fromString (requestMethod http) of
Left OPTIONS -> liftEffect do
setMaxAge http opts.maxAge
setAllowMethods http opts.methods
setAllowHeaders http opts.allowHeaders
setStatusCode http 204
pure Nothing
_ -> do
liftEffect $ setExposeHeaders http opts.exposeHeaders
next
setAllowOrigin :: Http -> AllowOrigins -> String -> Effect Unit
setAllowOrigin http AnyOrigin _ = setHeader http "Access-Control-Allow-Origin" "*"
setAllowOrigin http (Origins origins) reqOrigin =
when (elem reqOrigin origins) $ setHeader http "Access-Control-Allow-Origin" reqOrigin
setAllowCredentials :: Http -> AllowCredentials -> Effect Unit
setAllowCredentials http true = setHeader http "Access-Control-Allow-Credentials" "true"
setAllowCredentials _ _ = pure unit
setMaxAge :: Http -> MaxAge -> Effect Unit
setMaxAge http (Seconds sec) = setHeader http "Access-Control-Max-Age" $ show (ceil sec)
setAllowMethods :: Http -> AllowMethods -> Effect Unit
setAllowMethods http methods =
setHeader http "Access-Control-Allow-Methods" $ joinWith ", " $ show <$> methods
setAllowHeaders :: Http -> AllowHeaders -> Effect Unit
setAllowHeaders http AnyHeader =
case lookup "access-control-request-headers" $ requestHeaders http of
Nothing -> pure unit
Just x -> setHeader http "Access-Control-Allow-Headers" x
setAllowHeaders http (Headers xs) =
setHeader http "Access-Control-Allow-Headers" $ joinWith ", " xs
setExposeHeaders :: Http -> ExposeHeaders -> Effect Unit
setExposeHeaders http xs =
when (length xs > 0) $ setHeader http "Access-Control-Expose-Headers" $ joinWith ", " xs