From bea39f31ff13e0cd039d024e2708c1405429abf9 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt
Date: Sun, 23 Aug 2020 12:30:59 +0200
Subject: Show errors on same page

---
 server/lib/Uplcg/Main/Server.hs | 46 ++++++++++++++++++++++++++---------------
 server/lib/Uplcg/Views.hs       | 11 ++++++----
 2 files changed, 36 insertions(+), 21 deletions(-)

(limited to 'server')

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
-- 
cgit v1.2.3