added convert function from CustomWebServer to Application (#7)

* added convert function from CustomWebServer to Application

* formatting

* formatting

* transformers lib removed

* formatting again

* changelog

.gitignore

@@ -18,3 +18,4 @@ cabal.sandbox.config
 .stack-work/
 cabal.project.local
 .HTF/
+*.iml

CHANGELOG.md

@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+## [0.1.1.5] - 2019-08-8
+### Added
+- Added `toApplication` function - convert function from CustomWebServer to Application.
+
 ## [0.1.1.4] - 2019-01-28
 ### Added
 - Implement `restartOnError`, add `pure` web monads.

src/Web/Template/Server.hs

@@ -5,29 +5,31 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 
 module Web.Template.Server
- ( restartOnError
- , restartOnError1
- , runWebServer
- , defaultHandleLog
- ) where
+ ( restartOnError
+ , restartOnError1
+ , runWebServer
+ , defaultHandleLog
+ , toApplication
+ ) where
 
 import Control.Concurrent (threadDelay)
 import Control.Exception (SomeException, catch)
 import Control.Monad (unless)
-import Control.Monad.RWS (evalRWST)
+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.Status (status401)
-import Network.Wai (Middleware)
+import Network.Wai (Application, Middleware)
 import Network.Wai.Handler.Warp (defaultSettings,
  exceptionResponseForDebug,
  setOnExceptionResponse, setPort)
 import Web.Cookie (parseCookiesText)
-import Web.Scotty.Trans (Options (..), defaultHandler,
- header, json, middleware, next,
- param, scottyOptsT, status)
-import Web.Template.Except (JsonWebError (..), handleEx)
+import Web.Scotty.Trans (Options (..), ScottyT,
+ defaultHandler, header, json,
+ middleware, next, param, scottyAppT,
+ scottyOptsT, status)
+import Web.Template.Except (Except, JsonWebError (..), handleEx)
 import Web.Template.Log (bcdlog)
 import Web.Template.Types
 
@@ -40,29 +42,38 @@ restartOnError :: IO () -> Int -> IO ()
 restartOnError f delayUs = f `catch` handle
  where
  handle :: SomeException -> IO ()
- handle e = do putStrLn $ "unexpected exception\n" ++ show e
- putStrLn $ "server will be restarted in " ++ show delayUs ++ "us"
- threadDelay delayUs
- restartOnError f delayUs
+ handle e = do
+ putStrLn $ "unexpected exception\n" ++ show e
+ putStrLn $ "server will be restarted in " ++ show delayUs ++ "us"
+ threadDelay delayUs
+ restartOnError f delayUs
 
 -- | For given port and server settings run the server.
 runWebServer :: (Monoid w, Show w) => Port -> CustomWebServer r w s -> IO ()
-runWebServer port CustomWebServer {..} =
- scottyOptsT (scottyOpts port) ((fst <$>) . (\rws -> evalRWST rws readerEnv stateEnv)) $ do
- mapM_ middleware middlewares
- defaultHandler handleEx
- mapM_ runRoute routes
+runWebServer port s = scottyOptsT (scottyOpts port) (evalCustomWebServer s) (toScottyT s)
+
+toApplication :: (Monoid w, Show w) => CustomWebServer r w s -> IO Application
+toApplication s = scottyAppT (evalCustomWebServer s) (toScottyT s)
+
+toScottyT :: Monoid w => CustomWebServer r w s -> ScottyT Except (Env r w s) ()
+toScottyT CustomWebServer {..} = do
+ mapM_ middleware middlewares
+ defaultHandler handleEx
+ mapM_ runRoute routes
+
+evalCustomWebServer :: Monad m => CustomWebServer r w s -> RWST r w s m b1 -> m b1
+evalCustomWebServer CustomWebServer {..} = (fst <$>) . (\rws -> evalRWST rws readerEnv stateEnv)
 
 defaultHandleLog :: Middleware
 defaultHandleLog = bcdlog
 
 runRoute :: Monoid w => Route r w s -> ScottyM r w s ()
-runRoute Route{..} = method (fromString $ "/:version" ++ path) (checkVersion version . auth $ process)
+runRoute Route {..} = method (fromString $ "/:version" ++ path) (checkVersion version . auth $ process)
 
 scottyOpts :: Port -> Options
 scottyOpts port = Options 1 warpSettings
- where warpSettings = setOnExceptionResponse exceptionResponseForDebug .
-   setPort port $ defaultSettings
+ where
+ warpSettings = setOnExceptionResponse exceptionResponseForDebug . setPort port $ defaultSettings
 
 auth :: Monoid w => Process r w s -> WebM r w s ()
 auth (Process p) = p
@@ -71,8 +82,9 @@ auth (AuthProcess p) = do
  let idMaybe = cookiesM >>= getIdFromCookies
  case idMaybe of
  Just id' -> p id'
- Nothing -> do status status401
- json . JsonWebError $ "Authorization failed"
+ Nothing -> do
+ status status401
+ json . JsonWebError $ "Authorization failed"
 
 checkVersion :: Monoid w => Int -> WebM r w s () -> WebM r w s ()
 checkVersion version route = do
@@ -82,4 +94,3 @@ checkVersion version route = do
 
 getIdFromCookies :: TL.Text -> Maybe UserId
 getIdFromCookies cookies = lookup "id" $ parseCookiesText $ encodeUtf8 $ toStrict cookies
-

web-template.cabal

@@ -1,5 +1,5 @@
 name: web-template
-version: 0.1.1.4
+version: 0.1.1.5
 synopsis: Web template
 description:
  Web template includes: