aboutsummaryrefslogtreecommitdiff
path: root/server/lib
diff options
context:
space:
mode:
Diffstat (limited to 'server/lib')
-rw-r--r--server/lib/Uplcg/Main/Server.hs46
-rw-r--r--server/lib/Uplcg/Views.hs11
2 files changed, 36 insertions, 21 deletions
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