aboutsummaryrefslogtreecommitdiff
path: root/server/lib/Uplcg
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/lib/Uplcg/BaseUrl.hs17
-rw-r--r--server/lib/Uplcg/Config.hs21
-rw-r--r--server/lib/Uplcg/Main/Server.hs56
-rw-r--r--server/lib/Uplcg/Views.hs29
4 files changed, 28 insertions, 95 deletions
diff --git a/server/lib/Uplcg/BaseUrl.hs b/server/lib/Uplcg/BaseUrl.hs
deleted file mode 100644
index f49d0d0..0000000
--- a/server/lib/Uplcg/BaseUrl.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Uplcg.BaseUrl
- ( BaseUrl (..)
- , parse
- , render
- ) where
-
-import qualified Data.Text as T
-
-newtype BaseUrl = BaseUrl [T.Text] deriving (Show)
-
-render :: BaseUrl -> T.Text
-render (BaseUrl []) = ""
-render (BaseUrl xs) = "/" <> T.intercalate "/" xs
-
-parse :: T.Text -> BaseUrl
-parse = BaseUrl . filter (not . T.null) . T.split (== '/')
diff --git a/server/lib/Uplcg/Config.hs b/server/lib/Uplcg/Config.hs
deleted file mode 100644
index 9197d97..0000000
--- a/server/lib/Uplcg/Config.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Uplcg.Config
- ( Config (..)
- , fromEnv
- ) where
-
-import qualified Data.Text as T
-import System.Environment (getEnv)
-import Uplcg.BaseUrl (BaseUrl)
-import qualified Uplcg.BaseUrl as BaseUrl
-
-data Config = Config
- { cHostname :: String
- , cPort :: Int
- , cBaseUrl :: BaseUrl
- } deriving (Show)
-
-fromEnv :: IO Config
-fromEnv = Config
- <$> getEnv "UPLCG_HOSTNAME"
- <*> (read <$> getEnv "UPLCG_PORT")
- <*> (BaseUrl.parse . T.pack <$> getEnv "UPLCG_BASE")
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
index 2f9a70f..1672d84 100644
--- a/server/lib/Uplcg/Main/Server.hs
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -21,14 +21,12 @@ import Data.Char (isAlphaNum)
import Data.Foldable (for_)
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HMS
-import qualified Data.List as L
-import Data.Maybe (fromMaybe, isNothing)
+import Data.Maybe (isNothing)
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 qualified Data.Text.Lazy.Encoding as TL
import Data.Traversable (for)
import qualified Data.Vector as V
import qualified Network.HTTP.Types.Status as HttpStatus
@@ -38,13 +36,10 @@ import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WaiWs
import qualified Network.Wai.Middleware.HttpAuth as HttpAuth
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
@@ -66,8 +61,7 @@ data Room = Room
}
data Server = Server
- { serverConfig :: Config
- , serverLogger :: FL.FastLogger
+ { serverLogger :: FL.FastLogger
, serverCookieSocket :: CookieSocket.Handle Player
, serverCards :: Cards
, serverRooms :: MVar (HMS.HashMap RoomId Room)
@@ -81,9 +75,9 @@ readCards = Cards
parseCards = V.fromList . filter (not . T.null) . map dropComment . T.lines
dropComment = T.strip . fst . T.break (== '#')
-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
+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
newRoom :: RoomId -> RoomPassword -> Cards -> StdGen -> STM Room
newRoom rid rpw cards gen = Room rid rpw
@@ -150,20 +144,17 @@ getPassword = do
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 "/" $ Scotty.redirect $ "/rooms"
Scotty.get "/rooms" $ do
views <- liftIO $ roomViews server
- Scotty.html . renderHtml $ Views.rooms (serverConfig server) views
+ Scotty.html . renderHtml $ Views.rooms views
Scotty.post "/rooms" $ do
rid <- getParam "id"
rpw <- getParam "password"
_ <- liftIO $ createRoom server rid rpw
Scotty.redirect $ TL.fromStrict $
- BaseUrl.render (Config.cBaseUrl $ serverConfig server) <>
"/rooms/" <> unRoomId rid <>
case rpw of
NoRoomPassword -> ""
@@ -179,12 +170,12 @@ scottyApp server = Scotty.scottyApp $ do
liftIO $ print mbGiven
case mbGiven of
Just given | given == actual ->
- Scotty.html . renderHtml $ Views.client (serverConfig server) ridt $ Just actual
+ Scotty.html . renderHtml $ Views.client ridt $ Just actual
_ -> do
Scotty.status HttpStatus.unauthorized401
Scotty.setHeader "WWW-Authenticate" "Basic realm=\"Provide password, user is ignored\", charset=\"UTF-8\""
NoRoomPassword ->
- Scotty.html . renderHtml $ Views.client (serverConfig server) ridt Nothing
+ Scotty.html . renderHtml $ Views.client ridt Nothing
Scotty.get "/assets/client.js" $ do
Scotty.setHeader "Content-Type" "application/JavaScript"
@@ -200,8 +191,8 @@ parsePendingConnection pending =
(pathPart, queryPart) = second (B.drop 1) $ BC.break (== '?') path
pwd = fmap T.decodeUtf8 .
lookup "password" $ HttpUri.parseSimpleQuery queryPart in
- case BaseUrl.parse (T.decodeUtf8 pathPart) of
- BaseUrl.BaseUrl ["rooms", txt, "events"] | Right r <- parseRoomId txt ->
+ case filter (not . T.null) . T.split (== '/') $ T.decodeUtf8 pathPart of
+ ["rooms", txt, "events"] | Right r <- parseRoomId txt ->
Just (r, maybe NoRoomPassword RoomPassword pwd)
_ -> Nothing
@@ -303,29 +294,16 @@ wsApp server pc = case parsePendingConnection pc of
serverLogger server $ "Could not decode client message: " <>
FL.toLogStr (show msg)
-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
- { Wai.pathInfo = path
- , Wai.rawPathInfo = fromMaybe (Wai.rawPathInfo req) .
- B.stripPrefix bs $ Wai.rawPathInfo req
- }
- where
- bs = T.encodeUtf8 $ BaseUrl.render base
-
main :: IO ()
main = do
- config <- Config.fromEnv
- let settings = Warp.setPort (Config.cPort config) .
- Warp.setHost (fromString $ Config.cHostname config) $
- Warp.defaultSettings
+ host <- fromString <$> getEnv "UPLCG_HOSTNAME"
+ port <- read <$> getEnv "UPLCG_PORT"
+ let settings = Warp.setPort port $ Warp.setHost host 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 config fl $ \server -> do
+ withServer fl $ \server -> do
sapp <- scottyApp server
- Warp.runSettings settings $ baseUrl (Config.cBaseUrl config) $
+ Warp.runSettings settings $
WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp
diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs
index fc7042b..d25a9ce 100644
--- a/server/lib/Uplcg/Views.hs
+++ b/server/lib/Uplcg/Views.hs
@@ -13,34 +13,30 @@ import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Types.URI as HttpUri
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
-import qualified Uplcg.BaseUrl as BaseUrl
-import Uplcg.Config
import Uplcg.Version (version)
data RoomView = RoomView Text Bool Int
-template :: Config -> Text -> H.Html -> H.Html
-template conf title body = H.docTypeHtml $ do
+template :: Text -> H.Html -> H.Html
+template title body = H.docTypeHtml $ do
H.head $ do
H.meta H.! A.charset "UTF-8"
H.link H.! A.rel "stylesheet" H.! A.type_ "text/css"
- H.! A.href (H.toValue $
- BaseUrl.render (cBaseUrl conf) <> "/assets/style.css")
+ H.! A.href "/assets/style.css"
H.title $ H.toHtml title
H.meta H.! A.name "viewport" H.! A.content "width=device-width"
H.body $ do
body
H.footer $ "Untitled PL Card Game version " <> H.toHtml version
-rooms :: Config -> [RoomView] -> H.Html
-rooms conf rids = template conf "Untitled PL Card Game" $
+rooms :: [RoomView] -> H.Html
+rooms rids = template "Untitled PL Card Game" $
H.div H.! A.class_ "rooms" $ do
H.h1 "Rooms"
if null rids
then H.p "No rooms online."
else H.ul $ for_ rids $ \(RoomView rid lock num) -> H.li $ do
- H.a H.! A.href (H.toValue $
- BaseUrl.render (cBaseUrl conf) <> "/rooms/" <> rid) $
+ H.a H.! A.href (H.toValue $ "/rooms/" <> rid) $
H.toHtml rid
when lock " 🔒"
" ("
@@ -49,8 +45,7 @@ rooms conf rids = template conf "Untitled PL Card Game" $
H.br
H.h1 "Create Room"
- H.form H.! A.method "POST" H.! A.action (H.toValue $
- BaseUrl.render (cBaseUrl conf) <> "/rooms") $ do
+ H.form H.! A.method "POST" H.! A.action "/rooms" $ do
H.label H.! A.for "name" $ "Room name: "
H.input H.! A.type_ "text" H.! A.name "id"
H.br
@@ -59,12 +54,11 @@ rooms conf rids = template conf "Untitled PL Card Game" $
H.br
H.input H.! A.type_ "submit" H.! A.value "Create room"
-client :: Config -> Text -> Maybe Text -> H.Html
-client conf roomId mbPassword = template conf "Untitled PL Card Game" $ do
+client :: Text -> Maybe Text -> H.Html
+client roomId mbPassword = template "Untitled PL Card Game" $ do
H.div H.! A.id "main" $ ""
H.script H.! A.type_ "text/JavaScript"
- H.! A.src (H.toValue $
- BaseUrl.render (cBaseUrl conf) <> "/assets/client.js") $ ""
+ H.! A.src "/assets/client.js" $ ""
H.script H.! A.type_ "text/JavaScript" $ H.unsafeLazyByteString entryPoint
where
t2b = BLB.byteString . T.encodeUtf8
@@ -77,8 +71,7 @@ client conf roomId mbPassword = template conf "Untitled PL Card Game" $ do
" protocol = 'wss:'" <>
" }" <>
" var url = protocol + '//' + document.location.host +" <>
- " '" <> t2b (BaseUrl.render $ cBaseUrl conf) <> "/rooms/" <>
- t2b roomId <> "/events" <>
+ " '/rooms/" <> t2b roomId <> "/events" <>
(case mbPassword of
Nothing -> ""
Just pwd -> BLB.byteString $ HttpUri.renderSimpleQuery True
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 18:28:49 +0000