aboutsummaryrefslogtreecommitdiff
path: root/server/lib/Cafp/Main
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-08-03 17:26:45 +0200
committerJasper Van der Jeugt2020-08-03 17:26:45 +0200
commit7e646e1676e08331598ae2b9518f2b1b5f999ba2 (patch)
treef2d25239230cfb711fbd26828e5698b94b876988 /server/lib/Cafp/Main
parent9ce21e70492ca82c5554e3fa523108755fa721e8 (diff)
Make it deployable
Diffstat (limited to 'server/lib/Cafp/Main')
-rw-r--r--server/lib/Cafp/Main/Server.hs35
1 files changed, 29 insertions, 6 deletions
diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs
index 21cdb6f..9ded571 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -13,9 +13,13 @@ import Control.Exception (bracket)
import Control.Lens ((^.))
import Control.Monad (forever, when)
import qualified Data.Aeson as Aeson
+import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Foldable (for_)
import qualified Data.HashMap.Strict as HMS
+import qualified Data.List as L
+import Data.Maybe (fromMaybe)
+import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
@@ -24,6 +28,7 @@ import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WaiWs
import qualified Network.WebSockets as WS
+import System.Environment (getEnv)
import qualified System.IO as IO
import System.Random (StdGen, newStdGen)
import qualified Web.Scotty as Scotty
@@ -61,6 +66,7 @@ newRoom server gen = Room
<$> (STM.newTVar $ newGame (serverCards server) gen)
<*> STM.newTVar HMS.empty
+
scottyApp :: IO Wai.Application
scottyApp = Scotty.scottyApp $ do
Scotty.get "/rooms/:id/" $ do
@@ -81,9 +87,9 @@ scottyApp = Scotty.scottyApp $ do
routePendingConnection :: WS.PendingConnection -> Maybe RoomId
routePendingConnection pending =
let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in
- case T.split (== '/') path of
- [_, "rooms", roomId, "events"] -> Just roomId
- _ -> Nothing
+ case splitPath path of
+ ["rooms", roomId, "events"] -> Just roomId
+ _ -> Nothing
getOrCreateRoom :: Server -> RoomId -> IO Room
getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms ->
@@ -146,11 +152,28 @@ wsApp server pc = case routePendingConnection pc of
Nothing -> do
warning $ "Could not decode client message: " ++ show msg
+splitPath :: T.Text -> [T.Text]
+splitPath = filter (not . T.null) . T.split (== '/')
+
+baseUrl :: [T.Text] -> Wai.Middleware
+baseUrl prefix application = \req ->
+ case L.stripPrefix prefix (Wai.pathInfo req) of
+ Nothing -> application req
+ Just path -> application req
+ { Wai.pathInfo = path
+ , Wai.rawPathInfo = fromMaybe (Wai.rawPathInfo req) .
+ B.stripPrefix bs $ Wai.rawPathInfo req
+ }
+ where
+ bs = T.encodeUtf8 $ "/" <> T.intercalate "/" prefix
+
main :: IO ()
main = do
- let port = 3000
- settings = Warp.setPort port Warp.defaultSettings
+ host <- fromString <$> getEnv "CAFP_HOSTNAME"
+ port <- read <$> getEnv "CAFP_PORT"
+ base <- splitPath . T.pack <$> getEnv "CAFP_BASE"
+ let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings
server <- newServer
sapp <- scottyApp
- Warp.runSettings settings $
+ Warp.runSettings settings $ baseUrl base $
WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp