Rework forms to be a lot more declarative

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

examples/Simple.hs

@@ -14,19 +14,23 @@ Simple /= Easy /= Short. Happy reading.
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ApplicativeDo #-}
 
 module Simple (main)
 where
+  import Prelude
   import Control.Concurrent.MVar
   import Control.Monad.Reader
+  import Data.Maybe
   import Data.Text (Text)
+  import Hikaru
   import Lucid
   import Network.HTTP.Types.Header
   import Network.HTTP.Types.Status
   import Network.Wai
   import Network.Wai.Handler.Warp
   import Network.Wai.Middleware.RequestLogger
-  import Hikaru
 
 
   -- Action ------------------------------------------------------------------
@@ -99,14 +103,15 @@ where
       -- Plug in a cool logging middleware.
       middleware $ logStdoutDev
 
-      -- Enable 300s cache for the static endpoints.
-      wrapAction (defaultHeader hCacheControl "public, max-age=300" >>) $ do
       -- Negotiate content for the root page.
       route $ getRootHtmlR <$ get <* offerHTML
       route $ getRootTextR <$ get <* offerText
 
       -- Disable caching for all the following endpoints.
-      wrapActions (defaultHeader hCacheControl "no-store" >>)
+      wrapAction (defaultHeader hCacheControl "no-store" >>) $ do
+        -- Return search results and repeat the form.
+        route $ getSearchHtmlR <$ get <* seg "search"
+                               <* offerHTML
 
         -- Present a simple greeting page.
         route $ getHelloR <$ get <* seg "hello" <*> arg
@@ -130,6 +135,54 @@ where
       h1_ "Welcome!"
       p_ $ "You are " >> toHtml (show n) >> ". visitor!"
 
+      form_ [action_ "/search", method_ "GET"] $ do
+        view <- newForm "search" $ searchForm (Just "meaning of life")
+        formView_ view
+
+
+  getSearchHtmlR :: Action ()
+  getSearchHtmlR = do
+    sendHTML $ do
+      (maybeQuery, view) <- getForm "search" (searchForm Nothing)
+
+      h1_ "Search results"
+      form_ [method_ "GET"] $ do
+        formView_ view
+
+      case maybeQuery of
+        Nothing -> ""
+        Just q -> do
+          hr_ []
+          h2_ $ toHtml q
+          p_ "Sorry, no results found!"
+
+
+  searchForm :: (Monad m) => Maybe Text -> FormT Text m (Maybe Text)
+  searchForm q = do
+     q' <- inputField "q" "Query" q
+     _  <- button "search" "Search"
+     return q'
+
+
+  formView_ :: (MonadAction m, Localized l) => FormView l -> HtmlT m ()
+  formView_ view = do
+    forM_ (formElements view) $ \element ->
+      case element of
+        Button{..} -> do
+          button_ [ id_ elemName
+                  , name_ elemName
+                  ] $ lc_ elemLabel
+
+        InputField{..} -> do
+          label_ [ for_ elemName ] $ do
+            lc_ elemLabel
+            ":"
+
+          input_ [ id_ elemName
+                 , name_ elemName
+                 , value_ (fromMaybe "" elemValue)
+                 ]
+
 
   getRootTextR :: Action ()
   getRootTextR = do

hikaru.cabal

--- This file has been generated from package.yaml by hpack version 0.28.2.
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: ec8f75c55cd1cdb48ba2e77fa77a1586494297b85c9582601ebecf2c5e230fdb
+-- hash: b5ce075070487e21e8dc52b2afc5f1995311580f4978d92703fc77c3208c217c
 
 name:           hikaru
 version:        0.1.0.0
@@ -22,7 +24,6 @@ copyright:      Jan Hamal Dvořák
 license:        AGPL-3
 license-file:   LICENSE.md
 build-type:     Simple
-cabal-version:  >= 1.10
 extra-source-files:
     README.md
 
@@ -45,7 +46,7 @@ library
       Paths_hikaru
   hs-source-dirs:
       lib
-  default-extensions: BlockArguments DeriveGeneric FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving DataKinds
+  default-extensions: ApplicativeDo BlockArguments DeriveGeneric FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving DataKinds
   ghc-options: -Wall -Wcompat
   build-depends:
       aeson >=1.4 && <1.5

lib/Hikaru/Form.hs

@@ -6,149 +6,197 @@ License     :  AGPL-3
 Maintainer  :  mordae@anilinux.org
 Stability   :  unstable
 Portability :  non-portable (ghc)
-
-This module provides tools to simplify form building and parsing.
 -}
 
 module Hikaru.Form
-  ( Form
-  , FormHandler
-  , handleForm
-
-  -- ** Inputs
-  , formInput
-  , formMultiple
-  , formOptions
-  , selectedOption
-  , selectedOptions
+  ( FormData
+  , FormView(..)
+  , FormElement(..)
+  , FormNote(..)
+  , FormT
+  , newForm
+  , getForm
+  , postForm
+  , button
+  , inputField
   )
 where
-  import BasePrelude
+  import BasePrelude hiding (length)
 
-  import Data.ByteString.Builder (toLazyByteString)
   import Data.Text (Text)
-  import Lucid
   import Hikaru.Action
   import Hikaru.Types
+  import Control.Monad.State
+  import Control.Monad.Reader
+
+
+  type FormData = ([(Text, Text)], [(Text, FileInfo FilePath)])
+
+
+  data FormView l
+    = FormView
+      { formElements   :: [FormElement l]
+      , formNotes      :: [FormNote l]
+      }
+
+  emptyFormView :: FormView l
+  emptyFormView = FormView { formElements = []
+                           , formNotes    = []
+                           }
+
+
+  data FormElement l
+    = Button
+      { elemName       :: Text
+      , elemLabel      :: l
+      }
+    | InputField
+      { elemName       :: Text
+      , elemLabel      :: l
+      , elemValue      :: Maybe Text
+      , elemNotes      :: [FormNote l]
+      }
+
+
+  data FormNote l
+    = NoteError
+      { noteLabel      :: l
+      }
+    | NoteNeutral
+      { noteLabel      :: l
+      }
+    | NoteSuccess
+      { noteLabel      :: l
+      }
+    deriving (Eq, Ord)
+
+
+  newtype FormT l m a
+    = FormT
+      { unFormT        :: ReaderT Env (StateT (FormView l) m) a
+      }
+    deriving (Functor, Applicative, Monad)
+
+
+  data Env
+    = Env
+      { envPrefix      :: [Text]
+      , envParams      :: [(Text, Text)]
+      , envFiles       :: [(Text, FileInfo FilePath)]
+      , envRunChecks   :: Bool
+      }
+
+  emptyEnv :: Env
+  emptyEnv = Env { envPrefix    = []
+                 , envParams    = []
+                 , envFiles     = []
+                 , envRunChecks = False
+                 }
 
 
   -- |
-  -- HTML form with a potentially parsed object.
+  -- Build an unchecked form.
   --
-  type Form m a = HtmlT m (Maybe a)
+  newForm :: (MonadAction m) => Text -> FormT l m a -> m (FormView l)
+  newForm name form = do
+    let env = emptyEnv { envPrefix = [name] }
+    (_, view) <- runForm env form
+    return view
 
 
   -- |
-  -- Function that takes either a form to present to the user or
-  -- a fully parsed object to somehow handle.
+  -- Build & process a checked form with parameters in the query string.
   --
-  type FormHandler m a = Either (HtmlT m ()) a -> m ()
+  getForm :: (MonadAction m) => Text -> FormT l m a -> m (a, FormView l)
+  getForm name form = do
+    params <- getParams
+
+    let env = emptyEnv { envPrefix    = [name]
+                       , envParams    = params
+                       , envRunChecks = True
+                       }
+
+    runForm env form
 
 
   -- |
-  -- 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\/\"
-  -- @
+  -- Build & process a checked form with parameters in the form fields.
   --
-  handleForm :: (Monad m) => Form m a -> FormHandler m a -> m ()
-  handleForm form decide = do
-    (mb, mx) <- runHtmlT form
+  postForm :: (MonadAction m) => Text -> FormT l m a -> m (a, FormView l)
+  postForm name form = do
+    fields <- getFields
+    files  <- getFiles
 
-    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
+    let env = emptyEnv { envPrefix    = [name]
+                       , envParams    = fields
+                       , envFiles     = files
+                       , envRunChecks = True
+                       }
+
+    runForm env form
 
 
   -- |
-  -- 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@).
+  -- Unwrap the transformer stack and run the form.
   --
-  formInput :: (MonadAction m, FromParam a) => Text -> m (Text, Maybe a)
-  formInput name = do
-    caseMethod ("", Nothing) do
-      text  <- fromMaybe "" <$> getFieldMaybe name
-      return (text, fromParam text)
+  runForm :: (MonadAction m) => Env -> FormT l m a -> m (a, FormView l)
+  runForm env form = runStateT (runReaderT (unFormT form) env) emptyFormView
 
 
-  -- |
-  -- 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)
+  button :: (Monad m) => Text -> l -> FormT l m Bool
+  button name label = do
+    value    <- formParamMaybe name
+    fullName <- makeName name
 
+    appendElement $ Button { elemName  = fullName
+                           , elemLabel = label
+                           }
 
-  -- |
-  -- 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)
+    case value of
+      Nothing -> return False
+      Just () -> return True
 
 
-  -- |
-  -- Return the first selected value in the option list returned by
-  -- 'formOptions'.
-  --
-  selectedOption :: [(Text, a, Bool)] -> Maybe a
-  selectedOption = listToMaybe . selectedOptions
+  inputField :: (Monad m, ToParam a, FromParam a)
+             => Text -> l -> Maybe a -> FormT l m (Maybe a)
+  inputField name label value = do
+    fullName <- makeName name
+    value'   <- formParamMaybe fullName
 
+    appendElement $ InputField { elemName  = fullName
+                               , elemLabel = label
+                               , elemValue = value' <|> fmap toParam value
+                               , elemNotes = []
+                               }
 
-  -- |
-  -- 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)
+    formParamMaybe fullName
 
 
-  -- Helper Functions --------------------------------------------------------
+  -- Form Internals ---------------------------------------------------------
 
 
-  -- |
-  -- 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
+  appendElement :: (Monad m) => FormElement l -> FormT l m ()
+  appendElement element = FormT do
+    view@FormView{formElements} <- get
+    put $ view { formElements = formElements <> [element] }
+
+
+  formParamMaybe :: (Monad m, FromParam a) => Text -> FormT l m (Maybe a)
+  formParamMaybe name = FormT do
+    Env{envParams} <- ask
+    return $ fromParam =<< lookup name envParams
+
+
+  formFileMaybe :: (Monad m) => Text -> FormT l m (Maybe (FileInfo FilePath))
+  formFileMaybe name = FormT do
+    Env{envFiles} <- ask
+    return $ lookup name envFiles
+
 
+  makeName :: (Monad m) => Text -> FormT l m Text
+  makeName name = FormT do
+    Env{envPrefix} <- ask
+    return $ mconcat $ intersperse "." $ reverse (name : envPrefix)
 
 
 -- vim:set ft=haskell sw=2 ts=2 et:

lib/Hikaru/Localize.hs

@@ -90,7 +90,15 @@ where
     -- Return 'Nothing' if the locale is not supported.
     --
     localize :: (Monad m) => Locale -> a -> Maybe (HtmlT m ())
-    localize _lc _msg = Nothing
+    localize _lc = const Nothing
+
+
+  -- |
+  -- Instance to make 'Text' usable for interoperability and
+  -- gradual localization.
+  --
+  instance Localized Text where
+    localize _lc = Just . toHtml
 
 
   -- |

package.yaml

@@ -23,6 +23,7 @@ extra-source-files: README.md
 
 ghc-options: -Wall -Wcompat
 default-extensions:
+  - ApplicativeDo
   - BlockArguments
   - DeriveGeneric
   - FlexibleInstances

stack.yaml

@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-13.20
+resolver: lts-14.14
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -41,8 +41,7 @@ packages:
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
 # extra-deps: []
-extra-deps:
-  - category-printf-0.1.1.0
+#extra-deps:
 
 # Override default flag values for local packages and extra-deps
 # flags: {}