From 55fbec385f00063a392266f74f6d6e38248e3a3a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Mon, 18 Nov 2019 00:05:52 +0100
Subject: [PATCH] Rework forms to be a lot more declarative
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>
---
examples/Simple.hs | 79 ++++++++++---
hikaru.cabal | 9 +-
lib/Hikaru/Form.hs | 256 ++++++++++++++++++++++++-----------------
lib/Hikaru/Localize.hs | 10 +-
package.yaml | 1 +
stack.yaml | 5 +-
6 files changed, 235 insertions(+), 125 deletions(-)
diff --git a/examples/Simple.hs b/examples/Simple.hs
index d018faf..fe4e076 100644
--- a/examples/Simple.hs
+++ b/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,22 +103,23 @@ 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
+ -- 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
- <* offerText
+ -- Present a simple greeting page.
+ route $ getHelloR <$ get <* seg "hello" <*> arg
+ <* offerText
- -- Create an echoing JSON API.
- route $ postEchoR <$ post <* seg "api" <* seg "echo"
- <* offerJSON <* acceptJSON
+ -- Create an echoing JSON API.
+ route $ postEchoR <$ post <* seg "api" <* seg "echo"
+ <* offerJSON <* acceptJSON
-- Handlers ----------------------------------------------------------------
@@ -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
diff --git a/hikaru.cabal b/hikaru.cabal
index ca5fba8..4694605 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -1,8 +1,10 @@
--- 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
diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs
index 1ffddb2..bf36924 100644
--- a/lib/Hikaru/Form.hs
+++ b/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:
diff --git a/lib/Hikaru/Localize.hs b/lib/Hikaru/Localize.hs
index 1697f5d..d87caa4 100644
--- a/lib/Hikaru/Localize.hs
+++ b/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
-- |
diff --git a/package.yaml b/package.yaml
index e4e6ef6..91bfee6 100644
--- a/package.yaml
+++ b/package.yaml
@@ -23,6 +23,7 @@ extra-source-files: README.md
ghc-options: -Wall -Wcompat
default-extensions:
+ - ApplicativeDo
- BlockArguments
- DeriveGeneric
- FlexibleInstances
diff --git a/stack.yaml b/stack.yaml
index 2f5959d..b928ab3 100644
--- a/stack.yaml
+++ b/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: {}
--
GitLab