aboutsummaryrefslogtreecommitdiff
path: root/server/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--server/lib/Uplcg/Main/Server.hs237
-rw-r--r--server/lib/Uplcg/Views.hs30
2 files changed, 191 insertions, 76 deletions
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
index acf2931..2f9a70f 100644
--- a/server/lib/Uplcg/Main/Server.hs
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -1,56 +1,68 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
module Uplcg.Main.Server
( main
) where
-import Control.Concurrent.MVar (MVar)
-import qualified Control.Concurrent.MVar as MVar
-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)
-import Control.Monad.Trans (liftIO)
-import qualified Data.Aeson as Aeson
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as BL
-import Data.Char (isAlphaNum)
-import Data.Foldable (for_)
-import qualified Data.HashMap.Strict as HMS
-import qualified Data.List as L
-import Data.Maybe (fromMaybe, 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 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 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 Control.Concurrent.MVar (MVar)
+import qualified Control.Concurrent.MVar as MVar
+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)
+import Control.Monad.Trans (liftIO)
+import qualified Data.Aeson as Aeson
+import Data.Bifunctor (first, second)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+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.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
+import qualified Network.HTTP.Types.URI as HttpUri
+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.Wai.Middleware.HttpAuth as HttpAuth
+import qualified Network.WebSockets as WS
+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
+import qualified Uplcg.Views as Views
+import qualified Web.Scotty as Scotty
-type RoomId = T.Text
+newtype RoomId = RoomId {unRoomId :: T.Text}
+ deriving (Eq, Hashable, FL.ToLogStr)
+
+data RoomPassword = NoRoomPassword | RoomPassword T.Text deriving (Eq)
type Sink = BL.ByteString -> IO ()
data Room = Room
- { roomId :: RoomId
- , roomGame :: TVar Game
- , roomSinks :: TVar (HMS.HashMap PlayerId Sink)
+ { roomId :: !RoomId
+ , roomPassword :: !RoomPassword
+ , roomGame :: !(TVar Game)
+ , roomSinks :: !(TVar (HMS.HashMap PlayerId Sink))
}
data Server = Server
@@ -73,24 +85,68 @@ 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
+newRoom :: RoomId -> RoomPassword -> Cards -> StdGen -> STM Room
+newRoom rid rpw cards gen = Room rid rpw
<$> STM.newTVar (newGame cards gen)
<*> STM.newTVar HMS.empty
-parseRoomId :: T.Text -> Either String T.Text
+parseRoomId :: T.Text -> Either String RoomId
parseRoomId txt
- | T.all isAlphaNum txt && l >= 6 && l <= 32 = Right txt
- | otherwise = Left "Bad room name"
+ | not (T.all isAlphaNum txt) = Left "RoomId: alphanum characters only"
+ | l < 6 = Left "RoomId: minimum length of 6"
+ | l > 32 = Left "RoomId: maximum length of 32"
+ | otherwise = Right $ RoomId txt
where
l = T.length txt
+parseRoomPassword :: T.Text -> Either String RoomPassword
+parseRoomPassword txt
+ | T.null (T.strip txt) = Right NoRoomPassword
+ | T.length txt > 32 = Left "Password too long"
+ | otherwise = Right $ RoomPassword txt
+
+instance Scotty.Parsable RoomId where
+ parseParam = first TL.pack . parseRoomId . TL.toStrict
+
+instance Scotty.Parsable RoomPassword where
+ parseParam = first TL.pack . parseRoomPassword . TL.toStrict
+
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
+ liftIO . for (HMS.toList rooms) $ \(RoomId rid, room) -> do
+ sinks <- atomically . STM.readTVar $ roomSinks room
+ pure $ Views.RoomView rid
+ (roomPassword room /= NoRoomPassword) (HMS.size sinks)
+
+getParam :: Scotty.Parsable a => TL.Text -> Scotty.ActionM a
+getParam key =
+ lookupParam key >>=
+ maybe (Scotty.raise $ "Param " <> key <> " is missing") pure
+
+lookupParam :: Scotty.Parsable a => TL.Text -> Scotty.ActionM (Maybe a)
+lookupParam key = do
+ params <- Scotty.params
+ case lookup key params of
+ Nothing -> pure Nothing
+ Just value -> case Scotty.parseParam value of
+ Left err -> Scotty.raise $ "Error parsing " <> key <> ": " <> err
+ Right x -> pure $ Just x
+
+getPassword :: Scotty.ActionM (Maybe T.Text)
+getPassword = do
+ mbPassword <- lookupParam "password"
+ case mbPassword of
+ Just pwd -> pure $ Just pwd
+ Nothing -> do
+ mbAuthorization <- Scotty.header "Authorization"
+ pure $ case mbAuthorization of
+ Just authorization | Just pwd <- basic authorization ->
+ Just pwd
+ _ -> Nothing
+ where
+ basic = fmap (T.decodeUtf8 . snd) . HttpAuth.extractBasicAuth .
+ T.encodeUtf8 . TL.toStrict
scottyApp :: Server -> IO Wai.Application
scottyApp server = Scotty.scottyApp $ do
@@ -102,10 +158,33 @@ scottyApp server = Scotty.scottyApp $ do
views <- liftIO $ roomViews server
Scotty.html . renderHtml $ Views.rooms (serverConfig server) views
- Scotty.get "/rooms/:id/" $ do
- rid <- Scotty.param "id" >>=
- either (Scotty.raise . TL.pack) pure . parseRoomId
- Scotty.html . renderHtml $ Views.client (serverConfig server) rid
+ 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 -> ""
+ RoomPassword pwd -> T.decodeUtf8 $ HttpUri.renderQuery True
+ [("password", Just $ T.encodeUtf8 pwd)]
+
+ Scotty.get "/rooms/:id" $ do
+ rid@(RoomId ridt) <- getParam "id"
+ room <- liftIO $ getRoom server rid
+ case roomPassword room of
+ RoomPassword actual -> do
+ mbGiven <- getPassword
+ liftIO $ print mbGiven
+ case mbGiven of
+ Just given | given == actual ->
+ Scotty.html . renderHtml $ Views.client (serverConfig server) 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.get "/assets/client.js" $ do
Scotty.setHeader "Content-Type" "application/JavaScript"
@@ -115,24 +194,36 @@ scottyApp server = Scotty.scottyApp $ do
Scotty.setHeader "Content-Type" "text/css"
Scotty.file "assets/style.css"
-routePendingConnection :: WS.PendingConnection -> Maybe RoomId
-routePendingConnection pending =
- let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in
- case BaseUrl.parse path of
+parsePendingConnection :: WS.PendingConnection -> Maybe (RoomId, RoomPassword)
+parsePendingConnection pending =
+ let path = WS.requestPath $ WS.pendingRequest 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 ->
- Just r
+ Just (r, maybe NoRoomPassword RoomPassword pwd)
_ -> Nothing
-getOrCreateRoom :: Server -> RoomId -> IO Room
-getOrCreateRoom server rid = MVar.modifyMVar (serverRooms server) $ \rooms ->
+createRoom :: Server -> RoomId -> RoomPassword -> IO Room
+createRoom server rid rpw = MVar.modifyMVar (serverRooms server) $ \rooms ->
case HMS.lookup rid rooms of
- Just room -> pure (rooms, room)
- Nothing -> do
+ Just _ -> fail "Room already exists"
+ Nothing -> do
gen <- newStdGen
- serverLogger server $ "[" <> FL.toLogStr rid <> "] Created room"
- room <- atomically $ newRoom rid (serverCards server) gen
+ serverLogger server $ "[" <> FL.toLogStr rid <> "] Created " <>
+ (if rpw == NoRoomPassword then "" else "password-protected ") <>
+ "room"
+ room <- atomically $ newRoom rid rpw (serverCards server) gen
pure (HMS.insert rid room rooms, room)
+getRoom :: Server -> RoomId -> IO Room
+getRoom server rid = do
+ rooms <- MVar.readMVar (serverRooms server)
+ case HMS.lookup rid rooms of
+ Just room -> pure room
+ Nothing -> fail $ "Unknown room: " <> T.unpack (unRoomId rid)
+
deleteRoom :: Server -> RoomId -> IO ()
deleteRoom server rid = do
serverLogger server $ "[" <> FL.toLogStr rid <> "] Deleting room"
@@ -164,12 +255,16 @@ syncRoom server room = do
sink . Aeson.encode $ SyncGameView view
wsApp :: Server -> WS.ServerApp
-wsApp server pc = case routePendingConnection pc of
+wsApp server pc = case parsePendingConnection pc of
Nothing -> WS.rejectRequest pc "Invalid URL"
- Just rid -> do
- room <- getOrCreateRoom server rid
+ Just (rid@(RoomId ridt), givenPassword) -> do
+ room <- getRoom server rid
+ case roomPassword room of
+ actual@(RoomPassword _) | actual /= givenPassword ->
+ fail "Unauthorized"
+ _ -> pure ()
(conn, secret, mbRecovered) <-
- CookieSocket.acceptRequest (serverCookieSocket server) rid pc
+ CookieSocket.acceptRequest (serverCookieSocket server) ridt pc
let sink = WS.sendTextData conn
WS.withPingThread conn 30 (pure ()) $ bracket
(do
@@ -189,7 +284,7 @@ wsApp server pc = case routePendingConnection pc of
(serverCookieSocket server) secret
syncRoom server room)
(\playerId -> do
- sink . Aeson.encode $ Welcome rid
+ sink . Aeson.encode $ Welcome ridt
syncRoom server room
cards <- fmap (^. gameCards) . atomically . STM.readTVar $
roomGame room
@@ -200,7 +295,7 @@ wsApp server pc = case routePendingConnection pc of
msg <- WS.receiveData conn
case Aeson.decode msg of
Just cm -> do
- room <- getOrCreateRoom server rid -- TODO: only get?
+ room <- getRoom server rid
atomically . STM.modifyTVar' (roomGame room) $
processClientMessage playerId cm
syncRoom server room
diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs
index 348a92d..fc7042b 100644
--- a/server/lib/Uplcg/Views.hs
+++ b/server/lib/Uplcg/Views.hs
@@ -5,17 +5,19 @@ module Uplcg.Views
, client
) where
+import Control.Monad (when)
import qualified Data.ByteString.Lazy.Builder as BLB
import Data.Foldable (for_)
import Data.Text (Text)
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 Int
+data RoomView = RoomView Text Bool Int
template :: Config -> Text -> H.Html -> H.Html
template conf title body = H.docTypeHtml $ do
@@ -36,16 +38,29 @@ rooms conf rids = template conf "Untitled PL Card Game" $
H.h1 "Rooms"
if null rids
then H.p "No rooms online."
- else H.ul $ for_ rids $ \(RoomView rid num) -> H.li $ do
+ 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.toHtml rid
+ when lock " 🔒"
" ("
H.toHtml num
")"
-client :: Config -> Text -> H.Html
-client conf roomId = template conf "Untitled PL Card Game" $ do
+ H.br
+ H.h1 "Create Room"
+ H.form H.! A.method "POST" H.! A.action (H.toValue $
+ BaseUrl.render (cBaseUrl conf) <> "/rooms") $ do
+ H.label H.! A.for "name" $ "Room name: "
+ H.input H.! A.type_ "text" H.! A.name "id"
+ H.br
+ H.label H.! A.for "name" $ "Password (optional): "
+ H.input H.! A.type_ "text" H.! A.name "password"
+ 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
H.div H.! A.id "main" $ ""
H.script H.! A.type_ "text/JavaScript"
H.! A.src (H.toValue $
@@ -63,7 +78,12 @@ client conf roomId = template conf "Untitled PL Card Game" $ do
" }" <>
" var url = protocol + '//' + document.location.host +" <>
" '" <> t2b (BaseUrl.render $ cBaseUrl conf) <> "/rooms/" <>
- t2b roomId <> "/events';" <>
+ t2b roomId <> "/events" <>
+ (case mbPassword of
+ Nothing -> ""
+ Just pwd -> BLB.byteString $ HttpUri.renderSimpleQuery True
+ [("password", T.encodeUtf8 pwd)]) <>
+ "';" <>
" var socket = new WebSocket(url);" <>
" var socketSend = function(message) {" <>
" socket.send(message);" <>
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 04:38:25 +0000