Add a form to add teams

count-von-count/src/CountVonCount/Web.hs

@@ -3,16 +3,17 @@ module CountVonCount.Web
     ( listen
     ) where
 
-import Control.Applicative ((<$>), (<*>), (<|>))
+import Control.Applicative (pure, (<$>), (<*>), (<|>))
 import Control.Monad (forM, unless)
 import Control.Monad.Reader (ReaderT, ask, runReaderT)
 import Control.Monad.Trans (liftIO)
+import Data.Char (isAlphaNum, isLower)
 import Data.List (sort)
 
 import Data.Text (Text)
 import Text.Blaze (Html)
 import Data.Time (getCurrentTime)
-import Text.Digestive (Form, stringRead, text, (.:))
+import Text.Digestive (Form, check, checkM, stringRead, text, (.:))
 import Text.Digestive.Snap (runForm)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
@@ -88,16 +89,40 @@ laps = do
 
     Snap.blaze $ Views.laps laps'
 
-assign :: Web ()
-assign = do
+teamForm :: Form Html Web Team
+teamForm = Team
+    <$> "id"    .: uniqueId (validId (notNull (text Nothing)))
+    <*> "name"  .: notNull (text Nothing)
+    <*> "laps"  .: pure 0
+    <*> "baton" .: pure Nothing
+  where
+    validId = check "Should be in lowercase and alphanumeric" $
+        T.all $ \c -> isAlphaNum c && isLower c
+    uniqueId = checkM "Should be unique" $ \id' -> do
+        teams <- map snd <$> runPersistence getAll
+        return $ not $ any ((== id') . teamId) teams
+    notNull = check "Can't be empty" $ not . T.null
+
+teamNew :: Web ()
+teamNew = do
+    (view, result) <- runForm "team" teamForm
+    case result of
+        Just team -> do
+            _ <- liftIO $ runPersistence $ add team
+            Snap.redirect "/management"
+        _         ->
+            Snap.blaze $ Views.teamNew view
+
+teamAssign :: Web ()
+teamAssign = do
     Just mac <- fmap T.decodeUtf8 <$> Snap.getParam "baton"
     counter  <- webCounter <$> ask
     batons   <- configBatons . webConfig <$> ask
 
     unless (T.null mac) $ do
         let Just baton = findBaton mac batons
         Just teamRef <- refFromParam "id"
-        liftIO $ assignBaton counter batons baton  teamRef
+        liftIO $ assignBaton counter batons baton teamRef
 
     Snap.redirect "/management"
 
@@ -109,8 +134,8 @@ bonusForm = BonusForm
     <$> "laps"   .: stringRead "Can't read number of laps" Nothing
     <*> "reason" .: text Nothing
 
-bonus :: Web ()
-bonus = do
+teamBonus :: Web ()
+teamBonus = do
     Just teamRef   <- refFromParam "id"
     (view, result) <- runForm "bonus" bonusForm
     case result of
@@ -120,10 +145,10 @@ bonus = do
             Snap.redirect "/management"
         _ -> do
             team <- runPersistence $ get teamRef
-            Snap.blaze $ Views.bonus teamRef team view
+            Snap.blaze $ Views.teamBonus teamRef team view
 
-reset :: Web ()
-reset = do
+teamReset :: Web ()
+teamReset = do
     Just teamRef <- refFromParam "id"
     counter      <- webCounter <$> ask
     logger       <- webLog <$> ask
@@ -147,9 +172,10 @@ site = Snap.route
     , ("/monitor/feed",        monitorFeed)
     , ("/management",          management)
     , ("/laps",                laps)
-    , ("/team/:id/assign",     assign)
-    , ("/team/:id/bonus",      bonus)
-    , ("/team/:id/reset",      reset)
+    , ("/team/new",            teamNew)
+    , ("/team/:id/assign",     teamAssign)
+    , ("/team/:id/bonus",      teamBonus)
+    , ("/team/:id/reset",      teamReset)
     ] <|> Snap.serveDirectory "static"
 
 listen :: Config -> Log -> WS.PubSub WS.Hybi00 -> Counter -> IO ()

count-von-count/src/CountVonCount/Web/Views.hs

@@ -5,7 +5,8 @@ module CountVonCount.Web.Views
     , monitor
     , management
     , laps
-    , bonus
+    , teamNew
+    , teamBonus
 
       -- * Partials
     , counterState
@@ -100,6 +101,8 @@ management teams batons = template "Teams" $ block "management" $ do
 
             postForm resetUri $
                 H.input ! A.type_ "submit" ! A.value "Reset counter"
+
+    linkTo "/team/new" "Add new team"
   where
     macValue = H.toValue . batonMac
 
@@ -116,8 +119,23 @@ laps laps' = template "Laps" $ block "laps" $ do
             H.td $ H.toHtml $ lapReason lap
             H.td $ H.toHtml $ lapCount lap
 
-bonus :: Ref Team -> Team -> D.View Html -> Html
-bonus ref team view = template "Add bonus" $ block "bonus" $ do
+teamNew :: D.View Html -> Html
+teamNew view = template "Add team" $ do
+    H.h1 "Add team"
+    D.form view "/team/new" $ do
+
+        D.label     "id" view "Id: " >> H.br
+        D.inputText "id" view        >> H.br
+        D.errorList "id" view
+
+        D.label     "name" view "Name: " >> H.br
+        D.inputText "name" view          >> H.br
+        D.errorList "name" view
+
+        D.inputSubmit "Add team"
+
+teamBonus :: Ref Team -> Team -> D.View Html -> Html
+teamBonus ref team view = template "Add bonus" $ block "bonus" $ do
     let bonusUri  = "/team/" ++ refToString ref ++ "/bonus"  -- TODO: cleanup
 
     H.h1 "Add bonus"

count-von-count/static/css/screen.css

@@ -64,6 +64,12 @@ span.soft {
     color: #777;
 }
 
+ul.digestive-functors-error-list {
+    color: red;
+    list-style-type: none;
+    padding-left: 0px;
+}
+
 /*******************************************************************************
 * Monitor                                                                      *
 *******************************************************************************/