Forms don't return any result as long as there are Danger notes

Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>

lib/Hikaru.hs

@@ -14,6 +14,7 @@ module Hikaru
   (
   -- * Exported Modules
     module Hikaru.Action
+  , module Hikaru.CSRF
   , module Hikaru.Dispatch
   , module Hikaru.Form
   , module Hikaru.Link
@@ -24,6 +25,7 @@ module Hikaru
   )
 where
   import Hikaru.Action
+  import Hikaru.CSRF
   import Hikaru.Dispatch
   import Hikaru.Form
   import Hikaru.Link

lib/Hikaru/Form.hs

@@ -47,6 +47,8 @@ module Hikaru.Form
   -- ** Elements
   , element
   , hidden
+  , hiddenValue
+  , token
 
   -- ** Controls
   , ElementT
@@ -68,6 +70,9 @@ module Hikaru.Form
   , check
   , note
 
+  -- ** Value Adjustment
+  , adjust
+
   -- ** Rendering Hints
   , hint
 
@@ -98,6 +103,7 @@ where
   import Control.Monad.Trans (MonadTrans, lift)
   import Data.Text (Text, strip)
   import Hikaru.Action
+  import Hikaru.CSRF
   import Hikaru.Localize
   import Hikaru.Types
 
@@ -175,8 +181,7 @@ where
   -- |
   -- A form element that normally corresponds to a single row.
   --
-  -- An element can be either visible or hidden and can have multiple
-  -- controls. Hidden elements can have only 'input' controls.
+  -- Elements can have multiple controls.
   --
   data Element l
     = Element
@@ -372,11 +377,13 @@ where
   --
   data FormMessage
     = FormMsgFieldRequired
+    | FormMsgTokenInvalid
     deriving (Show)
 
   instance Localizable FormMessage where
     -- English strings
     localize "en" FormMsgFieldRequired = Just "This field is required."
+    localize "en" FormMsgTokenInvalid  = Just "The form has expired. Try again."
 
     -- No translation, caller should try a different locale.
     localize _lang _msg = Nothing
@@ -453,7 +460,11 @@ where
                    , envValidate = True
                    }
 
-    runStateT (flip runReaderT env runFormT) view
+    (res, view') <- runStateT (flip runReaderT env runFormT) view
+
+    if validates view'
+       then return (res, view')
+       else return (Nothing, view')
 
 
   -- |
@@ -496,7 +507,11 @@ where
                    , envValidate = True
                    }
 
-    runStateT (flip runReaderT env runFormT) view
+    (res, view') <- runStateT (flip runReaderT env runFormT) view
+
+    if validates view'
+       then return (res, view')
+       else return (Nothing, view')
 
 
   -- |
@@ -520,7 +535,11 @@ where
                    , envValidate = True
                    }
 
-    runStateT (flip runReaderT env runFormT) view
+    (res, view') <- runStateT (flip runReaderT env runFormT) view
+
+    if validates view'
+       then return (res, view')
+       else return (Nothing, view')
 
 
   -- Building Forms ----------------------------------------------------------
@@ -549,7 +568,7 @@ where
   -- |
   -- Add a new hidden form control.
   --
-  -- TODO
+  -- TODO: Add an example.
   --
   hidden :: (Monad m, FromFormMessage l, Param v)
          => Text
@@ -558,7 +577,35 @@ where
          -> FormT l o m v
   hidden name getter body = FormT do
     env@Env{..} <- ask
-    (val, text) <- getParamOrig name (getter <$> envValue)
+    (val, text) <- getParamOrig name (return $ getter <$> envValue)
+
+    new <- lift $ lift do
+      let field = InputField "hidden" Nothing text
+          state = ControlState name field [] [] val
+       in flip execStateT state $ flip runReaderT env $ runControlT body
+
+    ctrl <- lift $ lift $ buildControl env new
+
+    modify \view@View{..} ->
+      view { viewControls = viewControls <> [ctrl] }
+
+    return $ csValue new
+
+
+  -- |
+  -- Add a new hidden form control with a value completely uncoupled
+  -- from the form object. Useful for anti-CSRF tokens and similar.
+  --
+  -- TODO: Add an example
+  --
+  hiddenValue :: (Monad m, FromFormMessage l, Param v)
+              => Text
+              -> m (Maybe v)
+              -> ControlT 'InputFieldTag l o v m a
+              -> FormT l o m v
+  hiddenValue name generate body = FormT do
+    env@Env{..} <- ask
+    (val, text) <- getParamOrig name generate
 
     new <- lift $ lift do
       let field = InputField "hidden" Nothing text
@@ -573,6 +620,26 @@ where
     return $ csValue new
 
 
+  -- |
+  -- A hidden input holding an anti-CSRF token.
+  --
+  -- TODO: Add an example.
+  --
+  token :: (MonadCsrf m, FromFormMessage l) => Text -> FormT l o m Text
+  token name =
+    hiddenValue name (Just <$> generateToken) do
+      validate \case
+        Nothing -> do
+          return [Note Danger (fromFormMessage FormMsgTokenInvalid)]
+
+        Just tok -> do
+          valid <- isTokenValid tok
+          return
+            if valid
+               then []
+               else [Note Danger (fromFormMessage FormMsgTokenInvalid)]
+
+
   -- |
   -- TODO
   --
@@ -583,7 +650,7 @@ where
         -> ElementT l o m v
   input name getter body = ElementT do
     env@Env{..} <- ask
-    (val, text) <- getParamOrig name (getter <$> envValue)
+    (val, text) <- getParamOrig name (return $ getter <$> envValue)
 
     new <- lift $ lift do
       let field = InputField "text" Nothing text
@@ -710,6 +777,22 @@ where
       s { csHints = csHints <> [toDyn x] }
 
 
+  -- |
+  -- Adjust control value.
+  --
+  adjust :: (Monad m, Param v)
+         => (Maybe v -> m (Maybe v))
+         -> ControlT 'InputFieldTag l o v m ()
+  adjust fn = ControlT do
+    ControlState{csValue} <- get
+    value' <- lift $ lift $ fn csValue
+
+    modify \s@ControlState{csField} ->
+      s { csValue = value'
+        , csField = csField { fieldValue = maybe "" toParam value' }
+        }
+
+
   -- Debugging ---------------------------------------------------------------
 
 
@@ -736,14 +819,18 @@ where
   -- Internal ----------------------------------------------------------------
 
 
-  getParamOrig :: (Monad m, Param v)
-               => Text -> Maybe v -> ReaderT (Env o) m (Maybe v, Text)
-  getParamOrig name orig = do
+  getParamOrig :: (Monad m, Monad (n m), MonadTrans n, Param v)
+               => Text -> m (Maybe v) -> ReaderT (Env o) (n m) (Maybe v, Text)
+  getParamOrig name generate = do
     Env{..} <- ask
 
     case envParams of
-      Nothing -> return (orig, maybe "" toParam orig)
-      Just ps -> let param = strip <$> lookup (envPrefix <> "." <> name) ps
+      Nothing -> do
+        orig <- lift $ lift $ generate
+        return (orig, maybe "" toParam orig)
+
+      Just ps -> do
+        let param = strip <$> lookup (envPrefix <> "__" <> name) ps
          in return (fromParam =<< param, fromMaybe "" param)
 
 
@@ -751,7 +838,7 @@ where
                   => Text -> ReaderT (Env o) m (Maybe v)
   getSelectParams name = do
     Env{..} <- ask
-    let name' = envPrefix <> "." <> name
+    let name' = envPrefix <> "__" <> name
     return $ selectValues . lookupList name' =<< envParams
 
 
@@ -768,7 +855,7 @@ where
               True  -> sequence $ map ($ csValue) (required : csValidators)
               False -> return []
 
-    return Control { ctrlName       = envPrefix <> "." <> csName
+    return Control { ctrlName       = envPrefix <> "__" <> csName
                    , ctrlField      = csField
                    , ctrlNotes      = mconcat vres
                    , ctrlHints      = csHints
@@ -780,4 +867,15 @@ where
   required _else   = return []
 
 
+  -- |
+  -- Returns True only if no view notes are of the 'Danger' severity.
+  --
+  validates :: View l -> Bool
+  validates View{..} = all elemOk viewElements && all ctrlOk viewControls
+    where
+      elemOk Element{..} = all ctrlOk elemControls
+      ctrlOk Control{..} = all noteOk ctrlNotes
+      noteOk Note{..} = noteSeverity /= Danger
+
+
 -- vim:set ft=haskell sw=2 ts=2 et: