diff options
| -rw-r--r-- | client/style.css | 5 | ||||
| -rw-r--r-- | server/lib/Uplcg/Main/Server.hs | 46 | ||||
| -rw-r--r-- | server/lib/Uplcg/Views.hs | 11 |
3 files changed, 41 insertions, 21 deletions
diff --git a/client/style.css b/client/style.css index 81513be..c4161a7 100644 --- a/client/style.css +++ b/client/style.css @@ -125,6 +125,11 @@ button, input { text-align: left; } +.error { + color: #d00; + font-weight: bold; +} + footer { font-size: 12px; margin: 60px auto 60px auto; diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs index 4a3829b..c0849fd 100644 --- a/server/lib/Uplcg/Main/Server.hs +++ b/server/lib/Uplcg/Main/Server.hs @@ -29,6 +29,7 @@ import qualified Data.Text.Lazy as TL import Data.Traversable (for) import qualified Network.HTTP.Types.Status as HttpStatus import qualified Network.HTTP.Types.URI as HttpUri +import qualified Network.HTTP.Types.Method as HttpMethod import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs @@ -79,9 +80,9 @@ newRoom rid rpw cards gen = Room rid rpw parseRoomId :: T.Text -> Either String RoomId parseRoomId txt - | 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" + | not (T.all isAlphaNum txt) = Left "please use alphanum characters only" + | l < 1 = Left "minimum length of 1" + | l > 32 = Left "maximum length of 32" | otherwise = Right $ RoomId txt where l = T.length txt @@ -139,22 +140,33 @@ scottyApp :: Server -> IO Wai.Application scottyApp server = Scotty.scottyApp $ do Scotty.get "/" $ Scotty.redirect $ "/rooms" - Scotty.get "/rooms" $ do + Scotty.matchAny "/rooms" $ do views <- liftIO $ roomViews server let decks = HMS.keys $ serverCards server - Scotty.html . renderHtml $ Views.rooms views decks - - Scotty.post "/rooms" $ do - rid <- getParam "id" - rpw <- getParam "password" - cards <- getParam "deck" - _ <- liftIO $ createRoom server rid rpw cards - Scotty.redirect $ TL.fromStrict $ - "/rooms/" <> unRoomId rid <> - case rpw of - NoRoomPassword -> "" - RoomPassword pwd -> T.decodeUtf8 $ HttpUri.renderQuery True - [("password", Just $ T.encodeUtf8 pwd)] + + method <- Wai.requestMethod <$> Scotty.request + mbCreatedRoom <- if method == HttpMethod.methodPost + then flip Scotty.rescue (pure . Just . Left) $ do + rid <- getParam "id" + rpw <- getParam "password" + cards <- getParam "deck" + liftIO $ Just . Right <$> createRoom server rid rpw cards + else do + pure Nothing + + case mbCreatedRoom of + Nothing -> do + Scotty.html . renderHtml $ Views.rooms views decks Nothing + Just (Left err) -> do + Scotty.status HttpStatus.badRequest400 + Scotty.html . renderHtml . Views.rooms views decks . + Just $ TL.unpack err + Just (Right r) -> Scotty.redirect $ TL.fromStrict $ + "/rooms/" <> unRoomId (roomId r) <> + case roomPassword r of + NoRoomPassword -> "" + RoomPassword pwd -> T.decodeUtf8 $ HttpUri.renderQuery True + [("password", Just $ T.encodeUtf8 pwd)] Scotty.get "/rooms/:id" $ do rid@(RoomId ridt) <- getParam "id" diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs index c3ef1cc..b5f733c 100644 --- a/server/lib/Uplcg/Views.hs +++ b/server/lib/Uplcg/Views.hs @@ -34,8 +34,8 @@ template title body = H.docTypeHtml $ do " version " H.toHtml version -rooms :: [RoomView] -> [Deck] -> H.Html -rooms rids decks = template "Untitled PL Card Game" $ +rooms :: [RoomView] -> [Deck] -> Maybe String -> H.Html +rooms rids decks mbError = template "Untitled PL Card Game" $ H.div H.! A.class_ "rooms" $ do H.h1 "Rooms" if null rids @@ -50,14 +50,17 @@ rooms rids decks = template "Untitled PL Card Game" $ H.br H.h1 "Create Room" + case mbError of + Nothing -> mempty + Just err -> H.p H.! A.class_ "error" $ H.toHtml err H.form H.! A.method "POST" H.! A.action "/rooms" $ do - H.label H.! A.for "name" $ "Room name: " + H.label H.! A.for "name" $ "Room identifier (alphanumeric only): " 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.label H.! A.for "deck" $ "Cards: " + H.label H.! A.for "deck" $ "Card set to use: " H.select H.! A.name "deck" $ for_ decks $ \deck -> H.option H.! A.value (H.toValue deck) $ H.toHtml deck H.br |