Add some basic form handling

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

hikaru.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: d0a7845c898c2997900f8e5819b6a1f36591929a82a17fca5fe8c37c2bfc64d7
+-- hash: 720e967156931e18bf7c6039511f03e0f2ad855252f62cab1c80a2d9d8322d9e
 
 name:           hikaru
 version:        0.1.0.0
@@ -35,6 +35,7 @@ library
       Web.Hikaru
       Web.Hikaru.Action
       Web.Hikaru.Dispatch
+      Web.Hikaru.Form
       Web.Hikaru.Link
       Web.Hikaru.Locale
       Web.Hikaru.Media

lib/Web/Hikaru.hs

@@ -15,6 +15,7 @@ module Web.Hikaru
   -- * Exported Modules
     module Web.Hikaru.Action
   , module Web.Hikaru.Dispatch
+  , module Web.Hikaru.Form
   , module Web.Hikaru.Link
   , module Web.Hikaru.Locale
   , module Web.Hikaru.Media
@@ -24,6 +25,7 @@ module Web.Hikaru
 where
   import Web.Hikaru.Action
   import Web.Hikaru.Dispatch
+  import Web.Hikaru.Form
   import Web.Hikaru.Link
   import Web.Hikaru.Locale
   import Web.Hikaru.Media

lib/Web/Hikaru/Form.hs

+{-|
+Module      :  Web.Hikaru.Form
+Copyright   :  Jan Hamal Dvořák
+License     :  AGPL-3
+
+Maintainer  :  mordae@anilinux.org
+Stability   :  unstable
+Portability :  non-portable (ghc)
+
+This module provides tools to simplify form building and parsing.
+-}
+
+module Web.Hikaru.Form
+  ( Form
+  , FormHandler
+  , handleForm
+
+  -- ** Inputs
+  , formInput
+  , formMultiple
+  , formOptions
+  , selectedOption
+  , selectedOptions
+  )
+where
+  import BasePrelude
+
+  import Data.ByteString.Builder (toLazyByteString)
+  import Data.Text (Text)
+  import Lucid
+  import Web.Hikaru.Action
+  import Web.Hikaru.Types
+
+
+  -- |
+  -- HTML form with a potentially parsed object.
+  --
+  type Form m a = HtmlT m (Maybe a)
+
+
+  -- |
+  -- Function that takes either a form to present to the user or
+  -- a fully parsed object to somehow handle.
+  --
+  type FormHandler m a = Either (HtmlT m ()) a -> m ()
+
+
+  -- |
+  -- Simplifies handling form submissions.
+  --
+  -- Example:
+  --
+  -- @
+  -- handleForm someForm \\case
+  --   Left incompleteForm -> do
+  --     sendHTML do
+  --       genericPage_ \"Nice Form\" $ do
+  --         incompleteForm
+  --
+  --   Right entry -> do
+  --     processEntry entry
+  --     redirect \"\/entries\/\"
+  -- @
+  --
+  handleForm :: (Monad m) => Form m a -> FormHandler m a -> m ()
+  handleForm form decide = do
+    (mb, mx) <- runHtmlT form
+
+    case mx of
+      -- A little hack to get both the HtmlT and its value and shield the
+      -- caller from 'Builder' and 'toHtmlRaw'.
+      Nothing -> decide $ Left (toHtmlRaw $ toLazyByteString $ mb mempty)
+      Just x  -> decide $ Right x
+
+
+  -- |
+  -- Read a single form @\<input\>@ field as both the original text and the
+  -- converted value.
+  --
+  -- Return 'Nothing' if the request was submitted using one of the HTTP
+  -- methods that do not support request bodies (such as @GET@ or @HEAD@).
+  --
+  formInput :: (MonadAction m, FromParam a) => Text -> m (Text, Maybe a)
+  formInput name = do
+    caseMethod ("", Nothing) do
+      text  <- fromMaybe "" <$> getFieldMaybe name
+      return (text, fromParam text)
+
+
+  -- |
+  -- Read multiple form @\<input\>@ fields as both the original texts and the
+  -- converted values.
+  --
+  -- Return empty list if the request was submitted using one of the HTTP
+  -- methods that do not support request bodies (such as @GET@ or @HEAD@).
+  --
+  formMultiple :: (MonadAction m, FromParam a) => Text -> m [(Text, a)]
+  formMultiple name = do
+    caseMethod [] do
+      getFieldList name
+      <&> mapMaybe \x -> case fromParam x of
+                           Nothing -> Nothing
+                           Just v  -> Just (x, v)
+
+
+  -- |
+  -- Read selected @\<option\>@ fields and return a list of all available
+  -- fields along with their selection status.
+  --
+  formOptions :: (MonadAction m, FromParam a, ToParam a, Eq a)
+              => Text -> [a] -> m [(Text, a, Bool)]
+  formOptions name options = do
+    found <- caseMethod [] (getFieldList name)
+    return $ flip map options \v -> (toParam v, v, v `elem` found)
+
+
+  -- |
+  -- Return the first selected value in the option list returned by
+  -- 'formOptions'.
+  --
+  selectedOption :: [(Text, a, Bool)] -> Maybe a
+  selectedOption = listToMaybe . selectedOptions
+
+
+  -- |
+  -- Return all selected values in the option list returned by
+  -- 'formOptions'.
+  --
+  selectedOptions :: [(Text, a, Bool)] -> [a]
+  selectedOptions = mapMaybe (\(_, v, s) -> if s then Just v else Nothing)
+
+
+  -- Helper Functions --------------------------------------------------------
+
+
+  -- |
+  -- Run action only for methods that come with bodies.
+  -- Otherwise return the default value.
+  --
+  caseMethod :: (MonadAction m) => a -> m a -> m a
+  caseMethod dfl action = do
+    method <- getMethod
+
+    case method of
+      "GET"     -> return dfl
+      "HEAD"    -> return dfl
+      "CONNECT" -> return dfl
+      "OPTIONS" -> return dfl
+      "TRACE"   -> return dfl
+      _else     -> action
+
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:

package.yaml

@@ -64,6 +64,7 @@ library:
     - Web.Hikaru
     - Web.Hikaru.Action
     - Web.Hikaru.Dispatch
+    - Web.Hikaru.Form
     - Web.Hikaru.Link
     - Web.Hikaru.Locale
     - Web.Hikaru.Media