version 0.1.1.8: added middleware with header CORS (#11)

.gitignore

@@ -19,3 +19,4 @@ cabal.sandbox.config
 cabal.project.local
 .HTF/
 *.iml
+*.swp

CHANGELOG.md

@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+## [0.1.1.8] - 2019-09-20
+### Added
+- Middleware which adds CORS header to every response.
+
 ## [0.1.1.7] - 2019-09-18
 ### Changed
 - `throwJson` type is more polymorphic to match `throwIO` and similar.

app/Main.hs

@@ -9,19 +9,23 @@ import Text.Printf (printf)
 import Web.Scotty.Trans (get, text)
 import Web.Template (CustomWebServer (..), MonadWebError,
  Process (..), ProcessRW, Route (..),
- defaultHandleLog, restartOnError1,
- runWebServer, throwJson500)
+ defaultHandleLog, defaultHeaderCORS,
+ restartOnError1, runWebServer, throwJson500)
 
 main :: IO ()
 main = restartOnError1 $ runWebServer 5000 myWebServer
  where
- rEnv = 0
- wEnv = ["Start server"]
- myWebServer = CustomWebServer rEnv wEnv () [defaultHandleLog] [ Route get 1 "/ping" pingR
- , Route get 2 "/ping" pingR2
- , Route get 1 "/pong" pongR
- , Route get 1 "/throw" throwR
- ]
+ rEnv = 0
+ wEnv = ["Start server"]
+ myMiddlewares = [ defaultHandleLog -- add this to use default logger
+ , defaultHeaderCORS -- add header CORS to response
+ ]
+ myRoutes = [ Route get 1 "/ping" pingR
+ , Route get 2 "/ping" pingR2
+ , Route get 1 "/pong" pongR
+ , Route get 1 "/throw" throwR
+ ]
+ myWebServer = CustomWebServer rEnv wEnv () myMiddlewares myRoutes
 
 pingR :: ProcessRW Int [Text]
 pingR = Process $ do

src/Web/Template/Server.hs

@@ -9,6 +9,7 @@ module Web.Template.Server
  , restartOnError1
  , runWebServer
  , defaultHandleLog
+ , defaultHeaderCORS
  , toApplication
  ) where
 
@@ -19,8 +20,10 @@ import Control.Monad.RWS (RWST, evalRWST)
 import Data.String (fromString)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Text.Lazy as TL (Text, toStrict)
+import Network.HTTP.Types.Header (Header)
 import Network.HTTP.Types.Status (status401)
-import Network.Wai (Application, Middleware)
+import Network.Wai (Application, Middleware,
+ mapResponseHeaders, modifyResponse)
 import Network.Wai.Handler.Warp (defaultSettings,
  exceptionResponseForDebug,
  setOnExceptionResponse, setPort)
@@ -67,6 +70,14 @@ evalCustomWebServer CustomWebServer {..} = (fst <$>) . (\rws -> evalRWST rws rea
 defaultHandleLog :: Middleware
 defaultHandleLog = bcdlog
 
+defaultHeaderCORS :: Middleware
+defaultHeaderCORS = modifyResponse (mapResponseHeaders addHeaderCORS)
+ where
+ addHeaderCORS :: [Header] -> [Header]
+ addHeaderCORS headers = case lookup "Access-Control-Allow-Origin" headers of
+ Just _ -> headers
+ Nothing -> ("Access-Control-Allow-Origin", "*") : headers
+
 runRoute :: Monoid w => Route r w s -> ScottyM r w s ()
 runRoute Route {..} = method (fromString $ "/:version" ++ path) (checkVersion version . auth $ process)
 

web-template.cabal

@@ -1,5 +1,5 @@
 name: web-template
-version: 0.1.1.7
+version: 0.1.1.8
 synopsis: Web template
 description:
  Web template includes: