diff options
Diffstat (limited to 'server/lib/Uplcg/Main')
| -rw-r--r-- | server/lib/Uplcg/Main/Server.hs | 82 |
1 files changed, 52 insertions, 30 deletions
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs index a2914ab..acf2931 100644 --- a/server/lib/Uplcg/Main/Server.hs +++ b/server/lib/Uplcg/Main/Server.hs @@ -9,7 +9,8 @@ import Control.Concurrent.STM (STM, TVar, atomically) import qualified Control.Concurrent.STM as STM import Control.Exception (bracket) import Control.Lens ((&), (.~), (^.)) -import Control.Monad (forever, when) +import Control.Monad (forever) +import Control.Monad.Trans (liftIO) import qualified Data.Aeson as Aeson import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -22,17 +23,24 @@ import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import Data.Traversable (for) import qualified Data.Vector as V 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.Log.FastLogger as FL import System.Random (StdGen, newStdGen) +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Uplcg.BaseUrl (BaseUrl) +import qualified Uplcg.BaseUrl as BaseUrl +import Uplcg.Config (Config) +import qualified Uplcg.Config as Config import qualified Uplcg.CookieSocket as CookieSocket import Uplcg.Game import Uplcg.Messages +import qualified Uplcg.Views as Views import qualified Web.Scotty as Scotty type RoomId = T.Text @@ -46,7 +54,8 @@ data Room = Room } data Server = Server - { serverLogger :: FL.FastLogger + { serverConfig :: Config + , serverLogger :: FL.FastLogger , serverCookieSocket :: CookieSocket.Handle Player , serverCards :: Cards , serverRooms :: MVar (HMS.HashMap RoomId Room) @@ -60,9 +69,9 @@ readCards = Cards parseCards = V.fromList . filter (not . T.null) . map dropComment . T.lines dropComment = T.strip . fst . T.break (== '#') -withServer :: FL.FastLogger -> (Server -> IO a) -> IO a -withServer fl f = CookieSocket.withHandle 5 $ \cs -> do - f =<< Server fl cs <$> readCards <*> MVar.newMVar HMS.empty +withServer :: Config -> FL.FastLogger -> (Server -> IO a) -> IO a +withServer conf fl f = CookieSocket.withHandle 5 $ \cs -> do + f =<< Server conf fl cs <$> readCards <*> MVar.newMVar HMS.empty newRoom :: RoomId -> Cards -> StdGen -> STM Room newRoom rid cards gen = Room rid @@ -71,17 +80,32 @@ newRoom rid cards gen = Room rid parseRoomId :: T.Text -> Either String T.Text parseRoomId txt - | T.all isAlphaNum txt && T.length txt >= 6 = Right txt + | T.all isAlphaNum txt && l >= 6 && l <= 32 = Right txt | otherwise = Left "Bad room name" + where + l = T.length txt + +roomViews :: Server -> IO [Views.RoomView] +roomViews server = do + rooms <- liftIO . MVar.readMVar $ serverRooms server + liftIO . for (HMS.toList rooms) $ \(rid, room) -> + fmap (Views.RoomView rid . HMS.size) . atomically . STM.readTVar $ + roomSinks room + +scottyApp :: Server -> IO Wai.Application +scottyApp server = Scotty.scottyApp $ do + Scotty.get "/" $ + Scotty.redirect $ TL.fromStrict $ + BaseUrl.render (Config.cBaseUrl $ serverConfig server) <> "/rooms" + + Scotty.get "/rooms" $ do + views <- liftIO $ roomViews server + Scotty.html . renderHtml $ Views.rooms (serverConfig server) views -scottyApp :: IO Wai.Application -scottyApp = Scotty.scottyApp $ do Scotty.get "/rooms/:id/" $ do - rid <- Scotty.param "id" - when (T.length rid < 6) $ - Scotty.raise "Room ID should be at least 6 characters" - Scotty.setHeader "Content-Type" "text/html" - Scotty.file "assets/client.html" + rid <- Scotty.param "id" >>= + either (Scotty.raise . TL.pack) pure . parseRoomId + Scotty.html . renderHtml $ Views.client (serverConfig server) rid Scotty.get "/assets/client.js" $ do Scotty.setHeader "Content-Type" "application/JavaScript" @@ -94,9 +118,10 @@ scottyApp = Scotty.scottyApp $ do routePendingConnection :: WS.PendingConnection -> Maybe RoomId routePendingConnection pending = let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in - case splitPath path of - ["rooms", txt, "events"] | Right r <- parseRoomId txt -> Just r - _ -> Nothing + case BaseUrl.parse path of + BaseUrl.BaseUrl ["rooms", txt, "events"] | Right r <- parseRoomId txt -> + Just r + _ -> Nothing getOrCreateRoom :: Server -> RoomId -> IO Room getOrCreateRoom server rid = MVar.modifyMVar (serverRooms server) $ \rooms -> @@ -183,11 +208,8 @@ wsApp server pc = case routePendingConnection pc of serverLogger server $ "Could not decode client message: " <> FL.toLogStr (show msg) -splitPath :: T.Text -> [T.Text] -splitPath = filter (not . T.null) . T.split (== '/') - -baseUrl :: [T.Text] -> Wai.Middleware -baseUrl prefix application = \req -> +baseUrl :: BaseUrl -> Wai.Middleware +baseUrl base@(BaseUrl.BaseUrl prefix) application = \req -> case L.stripPrefix prefix (Wai.pathInfo req) of Nothing -> application req Just path -> application req @@ -196,19 +218,19 @@ baseUrl prefix application = \req -> B.stripPrefix bs $ Wai.rawPathInfo req } where - bs = T.encodeUtf8 $ "/" <> T.intercalate "/" prefix + bs = T.encodeUtf8 $ BaseUrl.render base main :: IO () main = do - host <- fromString <$> getEnv "UPLCG_HOSTNAME" - port <- read <$> getEnv "UPLCG_PORT" - base <- splitPath . T.pack <$> getEnv "UPLCG_BASE" - let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings + config <- Config.fromEnv + let settings = Warp.setPort (Config.cPort config) . + Warp.setHost (fromString $ Config.cHostname config) $ + Warp.defaultSettings timeCache <- FL.newTimeCache FL.simpleTimeFormat FL.withTimedFastLogger timeCache (FL.LogStderr FL.defaultBufSize) $ \tfl -> let fl s = tfl (\time -> FL.toLogStr time <> " " <> s <> "\n") in - withServer fl $ \server -> do - sapp <- scottyApp - Warp.runSettings settings $ baseUrl base $ + withServer config fl $ \server -> do + sapp <- scottyApp server + Warp.runSettings settings $ baseUrl (Config.cBaseUrl config) $ WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp |