127 lines
2.6 KiB
Haskell
127 lines
2.6 KiB
Haskell
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module WebServer (runWebServer) where
|
|
|
|
import ClassyPrelude hiding (decodeUtf8)
|
|
import Control.Monad.Except
|
|
import Network.HTTP.Types
|
|
import Network.Wai
|
|
import Network.Wai.Handler.Warp (run)
|
|
import RoomDataHandler (roomDataHandler)
|
|
import Types.AppTypes
|
|
( Env (..),
|
|
HasConnectedClientState (..),
|
|
)
|
|
import Types.RoomsState
|
|
( HasRoomsState (getRoomsState),
|
|
roomStateDiffers,
|
|
updateRoomState,
|
|
)
|
|
import Types.WebEnv
|
|
|
|
newtype ExceptTApp e a = E {unExceptTApp :: IO (Either e a)}
|
|
deriving
|
|
( Functor,
|
|
Applicative,
|
|
Monad,
|
|
MonadIO,
|
|
MonadError e
|
|
)
|
|
via ExceptT e IO
|
|
|
|
newtype WebApp env a = WebApp {unWebApp :: env -> IO (Either ResponseReceived a)}
|
|
deriving
|
|
( Functor,
|
|
Applicative,
|
|
Monad,
|
|
MonadReader env,
|
|
MonadIO,
|
|
MonadError ResponseReceived
|
|
)
|
|
via ReaderT env (ExceptTApp ResponseReceived)
|
|
|
|
getRequestPath ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
MonadReader env m
|
|
) =>
|
|
m [Text]
|
|
getRequestPath = do
|
|
request <- getRequest <$> ask
|
|
return $ pathInfo request
|
|
|
|
app ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
HasConnectedClientState env,
|
|
MonadReader env m,
|
|
HasRoomsState env,
|
|
MonadError ResponseReceived m
|
|
) =>
|
|
m ResponseReceived
|
|
app = requestPathHandler
|
|
|
|
requestPathHandler ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
HasConnectedClientState env,
|
|
MonadReader env m,
|
|
HasRoomsState env,
|
|
MonadError ResponseReceived m
|
|
) =>
|
|
m ResponseReceived
|
|
requestPathHandler = do
|
|
getRequestPath >>= \case
|
|
["roomdata"] -> roomDataHandler
|
|
_ -> notFound
|
|
|
|
notFound ::
|
|
( MonadIO m,
|
|
HasWebEnv env,
|
|
MonadReader env m,
|
|
MonadError ResponseReceived m
|
|
) =>
|
|
m ResponseReceived
|
|
notFound = do
|
|
respond' <- getRespond <$> ask
|
|
response <-
|
|
liftIO $
|
|
respond' $
|
|
responseLBS
|
|
status404
|
|
[("Content-Type", "text/plain")]
|
|
"404 - Not Found"
|
|
throwError response
|
|
|
|
runWebApp ::
|
|
( MonadIO m,
|
|
MonadReader Env m
|
|
) =>
|
|
m Application
|
|
runWebApp = do
|
|
env <- ask
|
|
return
|
|
( \req res -> do
|
|
let webEnv = WebEnv {appEnv = env, request = req, respond = res}
|
|
eitherResult <- unWebApp app webEnv
|
|
case eitherResult of
|
|
Left result -> do
|
|
liftIO $ putStrLn "Some error occured"
|
|
return result
|
|
Right result -> do
|
|
return result
|
|
)
|
|
|
|
runWebServer ::
|
|
( MonadIO m,
|
|
MonadReader Env m
|
|
) =>
|
|
m ()
|
|
runWebServer = do
|
|
putStrLn "http://localhost:8081/"
|
|
runWebApp >>= liftIO . run 8081
|
|
return ()
|