From 7fd01907dc68631465f274cf0d4d58896f5fd03a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 17 Aug 2020 22:02:39 +0200 Subject: Explicitly create password-protected rooms --- server/lib/Uplcg/Main/Server.hs | 237 ++++++++++++++++++++++++++++------------ server/lib/Uplcg/Views.hs | 30 ++++- server/uplcg.cabal | 2 + 3 files changed, 193 insertions(+), 76 deletions(-) (limited to 'server') 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);" <> diff --git a/server/uplcg.cabal b/server/uplcg.cabal index c97d358..d8d375d 100644 --- a/server/uplcg.cabal +++ b/server/uplcg.cabal @@ -36,6 +36,7 @@ Library elm-bridge >= 0.5 && < 0.6, fast-logger >= 3.0 && < 3.1, hashable >= 1.3 && < 1.4, + http-types >= 0.12 && < 0.13, lens >= 4.18 && < 4.19, mtl >= 2.2 && < 2.3, process >= 1.6 && < 1.7, @@ -52,6 +53,7 @@ Library vector-instances >= 3.4 && < 3.5, vector-shuffling >= 1.1 && < 1.2, wai >= 3.2 && < 3.3, + wai-extra >= 3.0 && < 3.1, wai-websockets >= 3.0 && < 3.1, warp >= 3.3 && < 3.4, websockets >= 0.12 && < 0.13 -- cgit v1.2.3