Explicitly create password-protected rooms

5 files changed, 203 insertions, 81 deletions

diff --git a/client/src/Client.elm b/client/src/Client.elm
index 6e987e7..439acea 100644
--- a/client/src/Client.elm
+++ b/client/src/Client.elm
@@ -118,6 +118,7 @@ view model = case model of
                         , Html.Events.onInput ChangeMyName
                         ]
                         []
+                    , Html.br [] []
                     , Html.button
                         [ Html.Attributes.type_ "submit"
                         , Html.Attributes.disabled <|
@@ -153,6 +154,7 @@ viewTable game = case game.view.table of
                 " from your hand"
             ]
         , blackCard [] game.cards c <| selectedWhiteCards game
+        , Html.br [] []
         , Html.button
             [ Html.Attributes.disabled <|
                 List.length my > 0 ||
@@ -163,7 +165,8 @@ viewTable game = case game.view.table of
             [Html.text "Propose"]
         ] ++
         ifAdmin game.view
-            [ Html.button
+            [ Html.br [] []
+            , Html.button
                 [Html.Events.onClick AdminSkipProposals]
                 [Html.text "Skip remaining players"]
             ]
@@ -180,7 +183,8 @@ viewTable game = case game.view.table of
                         , Html.Attributes.class "votable"
                         ] in
             blackCard attrs game.cards black proposal) proposals ++
-        [ Html.button
+        [ Html.br [] []
+        , Html.button
             [ Html.Attributes.disabled <|
                 (case myVote of
                      Just _ -> True
@@ -192,7 +196,8 @@ viewTable game = case game.view.table of
             [Html.text "Vote"]
         ] ++
         ifAdmin game.view
-            [ Html.button
+            [ Html.br [] []
+            , Html.button
                 [Html.Events.onClick AdminSkipVotes]
                 [Html.text "Skip remaining players"]
             ]
@@ -214,7 +219,8 @@ viewTable game = case game.view.table of
                 ])
             results ++
         ifAdmin game.view
-            [ Html.button
+            [ Html.br [] []
+            , Html.button
                 [Html.Events.onClick AdminConfirmTally]
                 [Html.text "Next round"]
             ]
diff --git a/client/style.css b/client/style.css
index 3da29f8..2dd12cb 100644
--- a/client/style.css
+++ b/client/style.css
@@ -54,7 +54,6 @@ table {
 }
 
 button, input {
-  display: block;
   margin: 12px auto 12px auto;
 }
 
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