diff --git a/demo/Main.hs b/demo/Main.hs
new file mode 100644
index 0000000000000000000000000000000000000000..4952029907bb9f59e2c1be33c0ba8f36c118b0b8
--- /dev/null
+++ b/demo/Main.hs
@@ -0,0 +1,66 @@
+{-|
+Module : Main
+Copyright : Jan Hamal Dvořák
+License : AGPL-3
+
+Maintainer : mordae@anilinux.org
+Stability : unstable
+Portability : non-portable (ghc)
+-}
+
+module Main ( main
+ )
+where
+ import BasePrelude
+
+ import Hikaru.Demo (makeDemo)
+
+
+ data Options
+ = Options
+ { optMainFunc :: Options -> IO ()
+ , optConf :: String
+ }
+
+
+ mainFunc :: Parser (Options -> IO ())
+ mainFunc = flag' mainVersion ( long "version"
+ <> short 'V'
+ <> help "Show version information"
+ <> hidden
+ )
+ <|> pure mainWebsite
+
+
+ options :: Parser Options
+ options = Options <$> mainFunc
+ <*> strOption ( long "config"
+ <> short 'C'
+ <> help "Configuration file to read"
+ <> value "byrocraft.cfg"
+ )
+
+
+ main :: IO ()
+ main = do
+ opts <- execParser $
+ info (helper *> options)
+ ( fullDesc
+ <> progDesc "Collaborative Administration Tool"
+ <> footer "Report bugs at <http://github.com/mordae/byrocraft/issues>."
+ )
+
+ optMainFunc opts opts
+
+
+ mainVersion :: Options -> IO ()
+ mainVersion _opts = do
+ prog <- getProgName
+ putStrLn $ prog <> " " <> packageVersion
+
+
+ mainWebsite :: Options -> IO ()
+ mainWebsite Options{optConf} = serve =<< load [ Required optConf ]
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/hikaru.cabal b/hikaru.cabal
index 13ef444d54fa11c85cd5fc7756fb74d2b7ee8834..0cd8be6348ecc4b043d2887b079c2c42c321e074 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: 789872e5159353725050ec2764d9951be0fbf0c39bb684307f281650bb6fd9a8
+-- hash: 29d0cf827300a88d2c302f25025d2f8d70bf6580c115003871c8397c80211d86
name: hikaru
version: 0.1.0.0
@@ -47,7 +47,7 @@ library
Paths_hikaru
hs-source-dirs:
lib
- default-extensions: BlockArguments DataKinds DefaultSignatures FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
+ default-extensions: BlockArguments DataKinds DefaultSignatures DeriveGeneric FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
ghc-options: -Wall -Wcompat
build-depends:
aeson >=1.4 && <1.5
@@ -70,3 +70,43 @@ library
, wai >=3.2 && <3.3
, wai-extra >=3.0 && <3.1
default-language: Haskell2010
+
+test-suite spec
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ other-modules:
+ Hikaru.Demo
+ Hikaru.DemoSpec
+ Hikaru.FormSpec
+ Hikaru.Test
+ Paths_hikaru
+ hs-source-dirs:
+ test
+ default-extensions: BlockArguments DataKinds DefaultSignatures DeriveGeneric FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
+ ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N
+ cpp-options: -DTEST
+ build-tool-depends:
+ hspec-discover:hspec-discover
+ build-depends:
+ aeson >=1.4 && <1.5
+ , base >=4.13 && <4.14
+ , base-prelude >=1.3 && <1.4
+ , binary >=0.8 && <0.9
+ , bytestring >=0.10 && <0.11
+ , case-insensitive >=1.2 && <1.3
+ , containers >=0.6 && <0.7
+ , cookie >=0.4 && <0.5
+ , cryptonite >=0.26 && <0.27
+ , hikaru
+ , hspec
+ , http-types >=0.12 && <0.13
+ , lucid >=2.9 && <2.10
+ , mtl >=2.2 && <2.3
+ , resourcet >=1.2 && <1.3
+ , string-conversions >=0.4 && <0.5
+ , text >=1.2 && <1.3
+ , text-icu >=0.7 && <0.8
+ , time >=1.9 && <1.10
+ , wai >=3.2 && <3.3
+ , wai-extra >=3.0 && <3.1
+ default-language: Haskell2010
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index 37791519339a6a2b19c4e6efb8f9d81c8ad6dc96..b1742c016c34afca09218ba453df6e774f4db2bd 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -855,7 +855,7 @@ where
-- |
-- Default @Content-Type@ to @text/html; charset=utf8@
- -- and set the response body to the provided byte string.
+ -- and set the response body to the rendering of provided HTML markup.
--
sendHTML :: (MonadAction m) => HtmlT m a -> m ()
sendHTML html = do
diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs
index d255e9fea1367f7f1810a479d0744f1f43997e2d..e1153f81d39c78bdd374ecebc6414fcb5787f454 100644
--- a/lib/Hikaru/Form.hs
+++ b/lib/Hikaru/Form.hs
@@ -7,589 +7,777 @@ Maintainer : mordae@anilinux.org
Stability : unstable
Portability : non-portable (ghc)
-This module provides applicative form handling.
+This module provides tools for building localized HTML forms
+with server-side validation.
+
+There are three important steps involved:
+
+1. A 'Form' needs to be defined first. For that you need to supply the
+ underlying data type as well as high-level description of the form
+ elements.
+
+2. It needs be fed some request data. You control what data by using
+ 'newForm', 'getForm' or 'postForm'.
+
+3. It needs to be rendered as HTML. This module will leave you with a
+ high-level form 'View', but you need to take care of the rendering
+ yourself.
+
-}
module Hikaru.Form
- ( MonadCsrf(..)
- , View(..)
- , FormNote(..)
- , NoteLevel(..)
- , Form
- , FieldT
- , newForm
+ (
+ -- * Using Forms
+ -- |
+ -- Running a form generally means turning the request data into an updated
+ -- form view and when validation succeeds also the resulting object.
+ --
+ newForm
, getForm
, postForm
- , hiddenField
- , hiddenField'
- , csrfTokenField
- , inputField
- , inputField'
- , textArea
- , textArea'
- , selectField
- , selectField'
- , selectFieldEnum
- , selectFieldEnum'
- , multiSelectField
- , multiSelectField'
- , opt
- , req
- , processValue
- , whenChecking
- , fieldShouldCheck
- , fieldValue
- , addNote
- , addAttribute
- , hasErrors
- )
-where
- import BasePrelude
+ , runForm
- import Control.Monad.Reader
- import Control.Monad.State
- import Data.Text (Text, strip)
- import Hikaru.Action
- import Hikaru.CSRF
- import Hikaru.Types
+ -- * Building Forms
+ -- |
+ -- Forms are constructed using a simple DSL described lower.
+ --
+ , Form
+ , FormT
+ -- ** Elements
+ , element
+ , hidden
- -- Form Types --------------------------------------------------------------
+ -- ** Controls
+ , ElementT
+ , ControlT
+ -- *** Input
+ , input
+ , input'
+ , placeholder
- data View l
- = FormFields
- { viewFields :: [View l]
- , viewNotes :: [FormNote l]
- }
- | HiddenField
- { viewName :: Text
- , viewValue :: Maybe Text
- , viewNotes :: [FormNote l]
- , viewAttrs :: [(Text, Dynamic)]
- }
- | InputField
- { viewName :: Text
- , viewLabel :: l
- , viewValue :: Maybe Text
- , viewNotes :: [FormNote l]
- , viewAttrs :: [(Text, Dynamic)]
- }
- | TextArea
- { viewName :: Text
- , viewLabel :: l
- , viewValue :: Maybe Text
- , viewNotes :: [FormNote l]
- , viewAttrs :: [(Text, Dynamic)]
- }
- | SelectField
- { viewName :: Text
- , viewLabel :: l
- , viewOptions :: [(Text, l, Bool)]
- , viewNotes :: [FormNote l]
- , viewAttrs :: [(Text, Dynamic)]
- , viewMulti :: Bool
- }
+ -- *** Select
+ , select
+ , options
+ , optionsFromValues
+ , optionsFromEnum
- instance Semigroup (View l) where
- FormFields [] [] <> view = view
- view <> FormFields [] [] = view
+ -- ** Validation
+ , validate
+ , check
+ , note
- FormFields fs1 ns1 <> FormFields fs2 ns2
- = FormFields (fs1 <> fs2) (ns1 <> ns2)
+ -- ** Rendering Hints
+ , hint
- FormFields fs ns <> view
- = FormFields (fs <> [view]) ns
+ -- ** Debugging
+ , dumpForm
+ , dumpControl
- view <> FormFields fs ns
- = FormFields ([view] <> fs) ns
+ -- * Rendering Forms
+ , View(..)
+ , Element(..)
+ , Control(..)
+ , Note(..)
+ , Field(..)
+ , FieldTag(..)
+ , Option(..)
+ , ToOption(..)
+ , Selectable(..)
+
+ -- ** Localization
+ , FormMessage(..)
+ , FromFormMessage(..)
+ )
+where
+ import BasePrelude hiding (Option, Control)
- v1 <> v2 = FormFields ([v1, v2]) []
+ import Control.Monad.Reader (ReaderT, runReaderT, ask)
+ import Control.Monad.State (StateT, runStateT, execStateT, modify, get)
+ import Control.Monad.Trans (MonadTrans, lift)
+ import Data.Text (Text, strip)
+ import Hikaru.Action
+ import Hikaru.Localize
+ import Hikaru.Types
- {-# INLINE (<>) #-}
- instance Monoid (View l) where
- mempty = FormFields [] []
- {-# INLINE mempty #-}
+ data Env o
+ = Env
+ { envPrefix :: Text
+ , envParams :: Maybe [(Text, Text)]
+ , envFiles :: Maybe [(Text, FilePath)]
+ , envValue :: Maybe o
+ , envValidate :: Bool
+ }
+ deriving (Show)
-- |
- -- TODO
+ -- Root of the generated form.
--
- data FormNote l
- = FormNote
- { noteLevel :: NoteLevel
- , noteLabel :: l
+ -- Can be used to render the form as HTML.
+ -- Roughly corresponds to the @\<form\>@ element.
+ --
+ data View l
+ = View
+ { viewElements :: [Element l]
+ , viewControls :: [Control l]
}
- deriving (Eq, Ord)
+ deriving (Show)
-- |
- -- TODO
+ -- Shortcut for a form that produces a value with the same type as was
+ -- the original object. This should be a rule for all the forms.
--
- data NoteLevel
- = NoteError
- | NoteNeutral
- | NoteSuccess
- deriving (Eq, Ord, Show)
-
- instance Semigroup NoteLevel where
- (<>) = min
- {-# INLINE (<>) #-}
-
- instance Monoid NoteLevel where
- mempty = NoteSuccess
- {-# INLINE mempty #-}
-
+ -- Example:
+ --
+ -- @
+ -- addItemForm :: ('MonadAction' m) => 'Form' Messages m AddItem
+ -- addItemForm = do
+ -- AddItem
+ -- \<$\> 'element' MsgItemName do
+ -- 'input'' "name" itemName
+ --
+ -- \<*\> 'element' MsgItemType do
+ -- 'select' "type" itemType do
+ -- 'optionsFromEnum' MsgItemType
+ -- @
+ --
+ type Form l m o = FormT l o m o
- newtype FormT l m a
+ -- |
+ -- Applicative functor for form construction.
+ --
+ newtype FormT l o m a
= FormT
- { unFormT :: ReaderT (Env l) (StateT (View l) m) a
+ { runFormT :: ReaderT (Env o) (StateT (View l) m) (Maybe a)
}
- deriving (MonadIO, Monad, Applicative, Functor)
- deriving instance (Monad m) => MonadReader (Env l) (FormT l m)
- deriving instance (Monad m) => MonadState (View l) (FormT l m)
+ instance (Monad m) => Functor (FormT l o m) where
+ fmap f FormT{..} = FormT do
+ x <- runFormT
+ return $ fmap f x
+ {-# INLINE fmap #-}
+
+ instance (Monad m) => Applicative (FormT l o m) where
+ pure x = FormT $ pure $ Just x
+ {-# INLINE pure #-}
+
+ l <*> r = FormT do
+ l' <- runFormT l
+ r' <- runFormT r
+ return $ l' <*> r'
+ {-# INLINE (<*>) #-}
- instance MonadTrans (FormT l) where
- lift = FormT . lift . lift
- {-# INLINE lift #-}
- instance (MonadCsrf m) => MonadCsrf (FormT l m)
+ -- |
+ -- 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.
+ --
+ data Element l
+ = Element
+ { elemLabel :: l
+ , elemControls :: [Control l]
+ }
+ deriving (Show)
- newtype Form l m a
- = Form
- { unForm :: FormT l m (Maybe a)
+ -- |
+ -- Element customization context.
+ --
+ newtype ElementT l o m a
+ = ElementT
+ { runElementT :: ReaderT (Env o) (StateT (Element l) m) (Maybe a)
}
- instance (Monad m) => Functor (Form l m) where
- fmap f Form{..} = Form do
- x <- unForm
+ instance (Monad m) => Functor (ElementT l o m) where
+ fmap f ElementT{..} = ElementT do
+ x <- runElementT
return $ fmap f x
{-# INLINE fmap #-}
- instance (Monad m) => Applicative (Form l m) where
- pure x = Form $ pure $ Just x
+ instance (Monad m) => Applicative (ElementT l o m) where
+ pure x = ElementT $ pure $ Just x
{-# INLINE pure #-}
- Form{unForm = unFormL} <*> Form{unForm = unFormR} = Form do
- l <- unFormL
- r <- unFormR
- return $ l <*> r
+ l <*> r = ElementT do
+ l' <- runElementT l
+ r' <- runElementT r
+ return $ l' <*> r'
{-# INLINE (<*>) #-}
- data Env l
- = Env
- { envPrefix :: [Text]
- , envParams :: [(Text, Text)]
- , envFiles :: [(Text, FilePath)]
- , envCheck :: Bool
+ -- |
+ -- Form controls extend fields with a name, notes and rendering hints.
+ --
+ data Control l
+ = Control
+ { ctrlName :: Text
+ , ctrlField :: Field l
+ , ctrlNotes :: [Note l]
+ , ctrlHints :: [Dynamic]
}
+ deriving (Show)
+
+
+ data ControlState l v m
+ = ControlState
+ { csName :: Text
+ , csField :: Field l
+ , csHints :: [Dynamic]
+ , csValidators :: [Maybe v -> m [Note l]]
+ , csValue :: Maybe v
+ }
+
+ instance (Show l, Show v) => Show (ControlState l v m) where
+ show ControlState{..} =
+ mconcat [ "ControlState {"
+ , "csName = " <> show csName
+ , ", csField = " <> show csField
+ , ", csHints = " <> show csHints
+ , ", csValidators = " <> show (length csValidators)
+ , ", csValue = " <> show csValue
+ , "}"
+ ]
- newtype FieldT l a m b
- = FieldT
- { unFieldT :: ReaderT Bool (StateT (View l, Maybe a) m) b
+ -- |
+ -- Control customization context.
+ --
+ -- Note that you can access the underlying 'Monad' using 'lift' here.
+ --
+ newtype ControlT (t :: FieldTag) l o v m a
+ = ControlT
+ { runControlT :: ReaderT (Env o) (StateT (ControlState l v m) m) a
}
deriving (MonadIO, Monad, Applicative, Functor)
- instance MonadTrans (FieldT l a) where
- lift = FieldT . lift . lift
+ instance MonadTrans (ControlT t l o v) where
+ lift = ControlT . lift . lift
{-# INLINE lift #-}
- instance (MonadCsrf m) => MonadCsrf (FieldT l a m)
+ instance (MonadAction m) => MonadAction (ControlT t l o v m) where
+ getActionEnv = ControlT $ lift $ lift $ getActionEnv
+ {-# INLINE getActionEnv #-}
-- |
- -- Build a fresh form without using any request data.
+ -- Short text with associated severity to be presented along the
+ -- form control. Used to indicate validation results.
--
- newForm :: (MonadAction m) => Text -> Form l m a -> m (View l)
- newForm name = flip execStateT view . flip runReaderT env . unFormT . unForm
- where
- view = FormFields [] []
- env = Env { envPrefix = [name]
- , envParams = []
- , envFiles = []
- , envCheck = False
- }
+ data Note l
+ = Note
+ { noteSeverity :: Severity
+ , noteMessage :: l
+ }
+ deriving (Show)
-- |
- -- Process the form using parameters in the query string.
+ -- Form field types.
--
- getForm :: (MonadAction m) => Text -> Form l m a -> m (View l, Maybe a)
- getForm name form = do
- params <- getParams
-
- let view = FormFields [] []
- env = Env { envPrefix = [name]
- , envParams = filter (("" /=) . strip . snd) params
- , envFiles = []
- , envCheck = True
- }
+ -- If you miss checkbox, radio or textarea, remember that you can
+ -- signal the way to render the field using a rendering 'hint'.
+ --
+ data Field l
+ = InputField
+ { fieldType :: Text
+ , fieldPlacehold :: Maybe l
+ , fieldValue :: Text
+ }
+ | SelectField
+ { fieldOptions :: [Option l]
+ }
+ deriving (Show)
- (value, view') <- runStateT (runReaderT (unFormT $ unForm form) env) view
- if hasErrors view'
- then return (view', Nothing)
- else return (view', value)
+ -- |
+ -- Tag used to specialize context for the individual control types.
+ --
+ data FieldTag
+ = InputFieldTag
+ | SelectFieldTag
+ deriving (Show, Eq)
-- |
- -- Process the form using parameters in the request body.
+ -- An option for 'select' to choose from.
--
- postForm :: (MonadAction m) => Text -> Form l m a -> m (View l, Maybe a)
- postForm name form = do
- fields <- getFields
- files <- getFiles
+ data Option l
+ = Option
+ { optionLabel :: l
+ , optionSelected :: Bool
+ , optionValue :: Text
+ }
+ deriving (Show)
- let view = FormFields [] []
- env = Env { envPrefix = [name]
- , envParams = filter (("" /=) . strip . snd) fields
- , envFiles = files
- , envCheck = True
- }
- (value, view') <- runStateT (runReaderT (unFormT $ unForm form) env) view
+ class ToOption l o where
+ toOption :: o -> Option l
- if hasErrors view'
- then return (view', Nothing)
- else return (view', value)
+ instance ToOption l (Option l) where
+ toOption = id
+ {-# INLINE toOption #-}
-- |
- -- TODO
+ -- A class with two overlapping instances used to smoothly handle
+ -- both single-select and multi-select controls.
--
- csrfTokenField :: (MonadCsrf m) => l -> Form l m Text
- csrfTokenField msg = Form do
- Env{envCheck} <- ask
+ class Selectable a where
+ selectValues :: [Text] -> Maybe a
+ selectOptions :: a -> [Option l] -> [Option l]
+
+ instance {-# OVERLAPPING #-} (Param a, Eq a) => Selectable a where
+ selectValues [p] = fromParam p
+ selectValues _ps = Nothing
- name' <- makeName "csrftoken"
- value <- fromMaybe "" <$> formParamMaybe name'
- valid <- isTokenValid value
- token <- generateToken
+ selectOptions p = map update
+ where
+ update opt@Option{..} = opt { optionSelected = match optionValue }
+ match x = case fromParam x of
+ Nothing -> False
+ Just x' -> p == x'
- let view = HiddenField { viewName = name'
- , viewValue = Just token
- , viewNotes = if envCheck && not valid
- then [FormNote NoteError msg]
- else []
- , viewAttrs = []
- }
+ instance {-# OVERLAPPING #-} (Param a, Eq a) => Selectable [a] where
+ selectValues = Just . mapMaybe fromParam
- modify (<> view)
- return $ Just token
+ selectOptions ps = map update
+ where
+ update opt@Option{..} = opt { optionSelected = match optionValue }
+ match x = case fromParam x of
+ Nothing -> False
+ Just x' -> x' `elem` ps
-- |
- -- TODO
+ -- Default localized messages related to form validation.
+ --
+ -- You might want to wrap this in your message catalog:
--
- hiddenField' :: (Monad m, Param a)
- => Text -> FieldT l a m b -> Form l m a
- hiddenField' name field = hiddenField name Nothing field
+ -- @
+ -- data Messages
+ -- = MsgForm 'FormMessage'
+ -- | ...
+ -- deriving (Show)
+ --
+ -- instance 'Localizable' Messages where
+ -- 'localize' lang (MsgForm msg) = 'localize' lang msg
+ -- ...
+ -- @
+ --
+ data FormMessage
+ = FormMsgFieldRequired
+ deriving (Show)
+
+ instance Localizable FormMessage where
+ -- English strings
+ localize "en" FormMsgFieldRequired = Just "This field is required."
+
+ -- No translation, caller should try a different locale.
+ localize _lang _msg = Nothing
-- |
- -- TODO
+ -- Class used to wrap the 'FormMessage' with your own message type.
--
- hiddenField :: (Monad m, Param a)
- => Text -> Maybe a -> FieldT l a m b -> Form l m a
- hiddenField name orig field = Form do
- name' <- makeName name
- value <- formParamMaybe name'
-
- let value' = value <|> orig
- view = HiddenField { viewName = name'
- , viewValue = toParam <$> value'
- , viewNotes = []
- , viewAttrs = []
- }
+ -- Just point to the constructor within your own message catalog:
+ --
+ -- @
+ -- instance 'FromFormMessage' Messages where
+ -- 'fromFormMessage' = MsgForm
+ -- @
+ --
+ class FromFormMessage l where
+ fromFormMessage :: FormMessage -> l
- (view', value'') <- runFieldT field value' view
- modify (<> view')
- return value''
+ -- Using Forms -------------------------------------------------------------
-- |
- -- TODO
+ -- Build a fresh form without using any request data.
--
- inputField' :: (Monad m, Param a)
- => Text -> l -> FieldT l a m b -> Form l m a
- inputField' name label field = inputField name label Nothing field
+ -- This function is used when the form is initially presented to the user.
+ -- It makes no sense to validate it, since the user have not entered any
+ -- input data or it has been seeded using a (most probably) valid object.
+ --
+ -- For example:
+ --
+ -- @
+ -- getEditItemR :: Natural -> Action ()
+ -- getEditItemR itemId = do
+ -- item <- getItem itemId
+ -- view <- 'newForm' "editItem" Nothing editItemForm
+ -- 'sendHTML' do
+ -- form_ [method_ "POST"] do
+ -- horizontalForm_ view
+ -- horizontalFormButtons_ do
+ -- submitButton_ do
+ -- 'lc_' MsgBtnSubmit
+ -- @
+ --
+ newForm :: (Monad m) => Text -> Maybe o -> Form l m o -> m (View l)
+ newForm name orig = flip execStateT view . flip runReaderT env . runFormT
+ where
+ view = View [] []
+ env = Env { envPrefix = name
+ , envParams = Nothing
+ , envFiles = Nothing
+ , envValue = orig
+ , envValidate = False
+ }
-- |
- -- TODO
+ -- Build the form using query string parameters.
--
- inputField :: (Monad m, Param a)
- => Text -> l -> Maybe a -> FieldT l a m b -> Form l m a
- inputField name label orig field = Form do
- name' <- makeName name
- value <- formParamMaybe name'
-
- let value' = value <|> orig
- view = InputField { viewName = name'
- , viewLabel = label
- , viewValue = toParam <$> value'
- , viewNotes = []
- , viewAttrs = []
- }
+ -- The values are validated and corresponding notes are generated.
+ -- In case of success the resulting object is generated as well.
+ --
+ -- See 'postForm' for an example as they are used the same way.
+ --
+ getForm :: (MonadAction m) => Text -> Form l m o -> m (Maybe o, View l)
+ getForm name FormT{..} = do
+ params <- getParams
- (view', value'') <- runFieldT field value' view
+ let view = View [] []
+ env = Env { envPrefix = name
+ , envParams = Just params
+ , envFiles = Nothing
+ , envValue = Nothing
+ , envValidate = True
+ }
- modify (<> view')
- return value''
+ runStateT (flip runReaderT env runFormT) view
-- |
- -- TODO
+ -- Build the form using files and files from the submitted form.
+ --
+ -- The values are validated and corresponding notes are generated.
+ -- In case of success the resulting object is generated as well.
+ --
+ -- For example:
+ --
+ -- @
+ -- postEditItemR :: Natural -> Action ()
+ -- postEditItemR itemId = do
+ -- (result, view) <- 'postForm' "editItem" Nothing editItemForm
--
- textArea' :: (Monad m, Param a)
- => Text -> l -> FieldT l a m b -> Form l m a
- textArea' name label field = textArea name label Nothing field
+ -- case result of
+ -- Nothing -> do
+ -- 'sendHTML' do
+ -- form_ [method_ "POST"] do
+ -- horizontalForm_ view
+ -- horizontalFormButtons_ do
+ -- submitButton_ do
+ -- 'lc_' MsgBtnSubmit
+ --
+ -- Just edit -> do
+ -- editItem edit
+ -- 'redirect' "/items/"
+ -- @
+ --
+ postForm :: (MonadAction m) => Text -> Form l m o -> m (Maybe o, View l)
+ postForm name FormT{..} = do
+ fields <- getFields
+ files <- getFiles
+
+ let view = View [] []
+ env = Env { envPrefix = name
+ , envParams = Just fields
+ , envFiles = Just files
+ , envValue = Nothing
+ , envValidate = True
+ }
+
+ runStateT (flip runReaderT env runFormT) view
-- |
- -- TODO
+ -- Build the form using only the supplied values.
+ --
+ -- The values are validated and corresponding notes are generated.
+ -- In case of success the resulting object is generated as well.
--
- textArea :: (Monad m, Param a)
- => Text -> l -> Maybe a -> FieldT l a m b -> Form l m a
- textArea name label orig field = Form do
- name' <- makeName name
- value <- formParamMaybe name'
+ -- This function is included for completeness only.
+ -- You should probably use either 'newForm', 'getForm' or 'postForm'.
+ --
+ runForm :: (Monad m)
+ => Text -> [(Text, Text)] -> [(Text, FilePath)] -> Form l m o
+ -> m (Maybe o, View l)
+ runForm name params files FormT{..} = do
+ let view = View [] []
+ env = Env { envPrefix = name
+ , envParams = Just params
+ , envFiles = Just files
+ , envValue = Nothing
+ , envValidate = True
+ }
- let value' = value <|> orig
- view = TextArea { viewName = name'
- , viewLabel = label
- , viewValue = toParam <$> value'
- , viewNotes = []
- , viewAttrs = []
- }
+ runStateT (flip runReaderT env runFormT) view
- (view', value'') <- runFieldT field value' view
- modify (<> view')
- return value''
+ -- Building Forms ----------------------------------------------------------
-- |
- -- TODO
+ -- Add a new form element with given label.
--
- selectField' :: (Monad m, Param a, Eq a)
- => Text -> l -> (a -> l) -> [a]
- -> FieldT l a m b -> Form l m a
- selectField' name label optlabel options field
- = selectField name label optlabel options Nothing field
+ -- Individual controls are specified using the 'ElementT' monad.
+ -- Normal elements can contain all control types.
+ --
+ element :: (Monad m) => l -> ElementT l o m a -> FormT l o m a
+ element label body = FormT do
+ env <- ask
+
+ (res, new) <- lift $ lift do
+ let base = Element label []
+ in flip runStateT base $ flip runReaderT env $ runElementT body
+
+ modify \view@View{..} ->
+ view { viewElements = viewElements <> [new] }
+
+ return res
-- |
+ -- Add a new hidden form control.
+ --
-- TODO
--
- selectField :: (Monad m, Param a, Eq a)
- => Text -> l -> (a -> l) -> [a] -> Maybe a
- -> FieldT l a m b -> Form l m a
- selectField name label optlabel options orig field = Form do
- name' <- makeName name
- value <- formParamMaybe name'
+ hidden :: (Monad m, FromFormMessage l, Param v)
+ => Text
+ -> (o -> v)
+ -> ControlT 'InputFieldTag l o v m a
+ -> FormT l o m v
+ hidden name getter body = FormT do
+ env@Env{..} <- ask
+ (val, text) <- getParamOrig name (getter <$> envValue)
- let value' = value <|> orig
- opts = [ (toParam x, optlabel x, Just x == value) | x <- options ]
- view = SelectField { viewName = name'
- , viewLabel = label
- , viewOptions = opts
- , viewNotes = []
- , viewAttrs = []
- , viewMulti = False
- }
+ new <- lift $ lift do
+ let field = InputField "hidden" Nothing text
+ state = ControlState name field [] [] val
+ in flip execStateT state $ flip runReaderT env $ runControlT body
- (view', value'') <- runFieldT field value' view
+ ctrl <- lift $ lift $ buildControl env new
- modify (<> view')
- return value''
+ modify \view@View{..} ->
+ view { viewControls = viewControls <> [ctrl] }
+
+ return $ csValue new
-- |
-- TODO
--
- selectFieldEnum' :: (Monad m, Param a, Eq a, Bounded a, Enum a)
- => Text -> l -> (a -> l) -> FieldT l a m b -> Form l m a
- selectFieldEnum' name label optlabel field
- = selectFieldEnum name label optlabel Nothing field
+ input :: (Monad m, FromFormMessage l, Param v)
+ => Text
+ -> (o -> v)
+ -> ControlT 'InputFieldTag l o v m a
+ -> ElementT l o m v
+ input name getter body = ElementT do
+ env@Env{..} <- ask
+ (val, text) <- getParamOrig name (getter <$> envValue)
+
+ new <- lift $ lift do
+ let field = InputField "text" Nothing text
+ state = ControlState name field [] [] val
+ in flip execStateT state $ flip runReaderT env $ runControlT body
+
+ ctrl <- lift $ lift $ buildControl env new
+
+ modify \elt@Element{..} ->
+ elt { elemControls = elemControls <> [ctrl] }
+
+ return $ csValue new
-- |
- -- Alternative to the 'selectField' for enumerable, bounded value types.
- --
- -- TODO: Example
+ -- TODO
--
- selectFieldEnum :: (Monad m, Param a, Eq a, Bounded a, Enum a)
- => Text -> l -> (a -> l) -> Maybe a
- -> FieldT l a m b -> Form l m a
- selectFieldEnum name label optlabel orig field
- = selectField name label optlabel [minBound..maxBound] orig field
+ input' :: (Monad m, FromFormMessage l, Param v)
+ => Text -> (o -> v) -> ElementT l o m v
+ input' name getter = input name getter $ return ()
-- |
-- TODO
--
- multiSelectField' :: (Monad m, Param a, Eq a)
- => Text -> l -> (a -> l) -> [a]
- -> FieldT l [a] m b -> Form l m [a]
- multiSelectField' name label optlabel options field
- = multiSelectField name label optlabel options Nothing field
+ placeholder :: (Monad m) => l -> ControlT 'InputFieldTag l o v m ()
+ placeholder ph = ControlT do
+ modify \s@ControlState{..} ->
+ s { csField = csField { fieldPlacehold = Just ph } }
-- |
-- TODO
--
- multiSelectField :: (Monad m, Param a, Eq a)
- => Text -> l -> (a -> l) -> [a] -> Maybe [a]
- -> FieldT l [a] m b -> Form l m [a]
- multiSelectField name label optlabel options orig field = Form do
- name' <- makeName name
- params <- formParams name'
+ select :: (Monad m, FromFormMessage l, Param v, Selectable v)
+ => Text
+ -> (o -> v)
+ -> ControlT 'SelectFieldTag l o v m a
+ -> ElementT l o m v
+ select name getter body = ElementT do
+ env@Env{..} <- ask
+ val <- getSelectParams name
- let found = nub $ params <> fromMaybe [] orig
- opts = [ (toParam x, optlabel x, x `elem` found) | x <- options ]
- view = SelectField { viewName = name'
- , viewLabel = label
- , viewOptions = opts
- , viewNotes = []
- , viewAttrs = []
- , viewMulti = False
- }
+ new <- lift $ lift do
+ let val' = val <|> (getter <$> envValue)
+ field = SelectField []
+ state = ControlState name field [] [] val'
+ in flip execStateT state $ flip runReaderT env $ runControlT body
- (view', found') <- runFieldT field (Just found) view
+ ctrl <- lift $ lift $ buildControl env new
- modify (<> view')
- return $ found'
+ modify \elt@Element{..} ->
+ elt { elemControls = elemControls <> [ctrl] }
+
+ return $ csValue new
-- |
- -- TODO
+ -- Configure 'select' options directly.
+ --
+ -- TODO: Add an example.
--
- opt :: (Monad m) => FieldT l a m ()
- opt = return ()
+ options :: (Monad m, Param v, Selectable v)
+ => [Option l] -> ControlT 'SelectFieldTag l o v m ()
+ options opts = ControlT do
+ modify \s@ControlState{..} ->
+ let opts' = case csValue of
+ Nothing -> opts
+ Just val -> selectOptions val opts
+ in s { csField = csField { fieldOptions = opts' } }
-- |
- -- TODO
+ -- Configure 'select' options using a list of values.
+ --
+ -- TODO: Add an example.
--
- req :: (Monad m) => l -> FieldT l a m ()
- req label = do
- whenChecking do
- value <- fieldValue
- case value of
- Nothing -> addNote $ FormNote NoteError label
- Just _v -> return ()
+ optionsFromValues :: (Monad m, Param v, Selectable v)
+ => (v -> l) -> [v] -> ControlT 'SelectFieldTag l o v m ()
+ optionsFromValues label vals = options [ Option (label x) False (toParam x)
+ | x <- vals
+ ]
-- |
- -- TODO
+ -- Configure 'select' options using enumeration.
+ --
+ -- TODO: Add an example.
--
- addNote :: (Monad m) => FormNote l -> FieldT l a m ()
- addNote note = FieldT do
- modify \(view, value) ->
- ( view { viewNotes = viewNotes view <> [note] }
- , value
- )
+ optionsFromEnum :: (Monad m, Param v, Selectable v, Bounded v, Enum v)
+ => (v -> l) -> ControlT 'SelectFieldTag l o v m ()
+ optionsFromEnum label = optionsFromValues label [minBound..maxBound]
-- |
-- TODO
--
- addAttribute :: (Monad m, Typeable v) => Text -> v -> FieldT l a m ()
- addAttribute name attr = FieldT do
- modify \(view, value) ->
- ( view { viewAttrs = viewAttrs view <> [(name, toDyn attr)] }
- , value
- )
+ validate :: (Monad m) => (Maybe v -> m [Note l]) -> ControlT t l o v m ()
+ validate fn = ControlT do
+ modify \s@ControlState{..} ->
+ s { csValidators = csValidators <> [fn] }
-- |
-- TODO
--
- processValue :: (Monad m) => (Maybe a -> Maybe a) -> FieldT l a m ()
- processValue process = FieldT do
- modify \(view, value) -> (view, process value)
+ check :: (Monad m) => (Maybe v -> [Note l]) -> ControlT t l o v m ()
+ check fn = validate (return . fn)
-- |
-- TODO
--
- whenChecking :: (Monad m) => FieldT l a m b -> FieldT l a m ()
- whenChecking checkField = do
- check <- fieldShouldCheck
-
- if check
- then checkField >> return ()
- else return ()
+ note :: (Monad m) => Severity -> l -> ControlT t l o v m ()
+ note sev msg = validate (\_ -> return [Note sev msg])
-- |
-- TODO
--
- fieldShouldCheck :: (Monad m) => FieldT l a m Bool
- fieldShouldCheck = FieldT ask
+ hint :: (Monad m, Typeable h) => h -> ControlT t l o v m ()
+ hint x = ControlT do
+ modify \s@ControlState{..} ->
+ s { csHints = csHints <> [toDyn x] }
- -- |
- -- TODO
- --
- fieldValue :: (Monad m) => FieldT l a m (Maybe a)
- fieldValue = FieldT (snd <$> get)
+ -- Debugging ---------------------------------------------------------------
- -- |
- -- Determine whether the view has any (possibly nested) errors.
- --
- hasErrors :: View l -> Bool
- hasErrors FormFields{..} = any isErrorNote viewNotes || any hasErrors viewFields
- hasErrors view = any isErrorNote (viewNotes view)
+ dumpForm :: (MonadIO m, Show l, Show o) => FormT l o m ()
+ dumpForm = FormT do
+ env <- ask
+
+ liftIO do
+ putStr "Form Dump:\n "
+ putStrLn (show env)
+
+ return $ Just ()
- -- Form Internals ---------------------------------------------------------
+ dumpControl :: (MonadIO m, Show l, Show o, Show v) => ControlT t l o v m ()
+ dumpControl = ControlT do
+ state <- get
+ liftIO do
+ putStr "Control Dump:\n "
+ putStrLn (show state)
- runFieldT :: (Monad m) => FieldT l a m b -> Maybe a -> View l
- -> FormT l m (View l, Maybe a)
- runFieldT field value view = do
- Env{envCheck} <- ask
- lift $ execStateT (runReaderT (unFieldT field) envCheck) (view, value)
+ -- Internal ----------------------------------------------------------------
- isErrorNote :: FormNote l -> Bool
- isErrorNote (FormNote NoteError _) = True
- isErrorNote _else = False
+ getParamOrig :: (Monad m, Param v)
+ => Text -> Maybe v -> ReaderT (Env o) m (Maybe v, Text)
+ getParamOrig name orig = do
+ Env{..} <- ask
- formParamMaybe :: (Monad m, Param a) => Text -> FormT l m (Maybe a)
- formParamMaybe name = do
- Env{envParams} <- ask
- return $ fromParam =<< lookup name envParams
+ case envParams of
+ Nothing -> return (orig, maybe "" toParam orig)
+ Just ps -> let param = strip <$> lookup (envPrefix <> "." <> name) ps
+ in return (fromParam =<< param, fromMaybe "" param)
- formFileMaybe :: (Monad m) => Text -> FormT l m (Maybe FilePath)
- formFileMaybe name = do
- Env{envFiles} <- ask
- return $ lookup name envFiles
+ getSelectParams :: (Monad m, Param v, Selectable v)
+ => Text -> ReaderT (Env o) m (Maybe v)
+ getSelectParams name = do
+ Env{..} <- ask
+ let name' = envPrefix <> "." <> name
+ return $ selectValues . lookupList name' =<< envParams
- formParams :: (Monad m, Param a) => Text -> FormT l m [a]
- formParams name = do
- Env{envParams} <- ask
- let match = (name ==) . fst
- conv = fromParam . snd
- in return $ mapMaybe conv $ filter match $ envParams
+ lookupList :: (Eq a) => a -> [(a, b)] -> [b]
+ lookupList name = map snd . filter ((name ==) . fst)
+
+
+ buildControl :: (Monad m, FromFormMessage l)
+ => Env o
+ -> ControlState l v m
+ -> m (Control l)
+ buildControl Env{..} ControlState{..} = do
+ vres <- case envValidate of
+ True -> sequence $ map ($ csValue) (required : csValidators)
+ False -> return []
+
+ return Control { ctrlName = envPrefix <> "." <> csName
+ , ctrlField = csField
+ , ctrlNotes = mconcat vres
+ , ctrlHints = csHints
+ }
- makeName :: (Monad m) => Text -> FormT l m Text
- makeName name = do
- Env{envPrefix} <- ask
- return $ mconcat $ intersperse "." $ reverse (name : envPrefix)
+ required :: (Monad m, FromFormMessage l) => Maybe v -> m [Note l]
+ required Nothing = return [Note Danger $ fromFormMessage FormMsgFieldRequired]
+ required _else = return []
-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/lib/Hikaru/Localize.hs b/lib/Hikaru/Localize.hs
index 8b6ba09d21172f2b62dc325c91fb964aeb0a6a0e..cc529266426c1e1004fd6e4a0faf3e1c41bc944f 100644
--- a/lib/Hikaru/Localize.hs
+++ b/lib/Hikaru/Localize.hs
@@ -16,33 +16,32 @@ First, you need to create a message catalog:
data SampleMessages
= MsgSuccess
| MsgFailure
+ deriving (Show)
-- Default HTML rendering of the messages.
instance 'ToHtml' SampleMessages where
'toHtmlRaw' = 'toHtml'
- 'toHtml' MsgSuccess = \"Success\"
- 'toHtml' MsgFailure = \"Failure\"
-- Language-specific rendering of those messages.
-instance Localized SampleMessages where
- -- Czech variants
- localize \"cs\" MsgSuccess = 'Just' \"Úspěch\"
- localize \"cs\" MsgFailure = 'Just' \"Selhání\"
+instance Localizable SampleMessages where
+ -- English variants
+ 'localize' \"en\" MsgSuccess = 'Just' \"Success\"
+ 'localize' \"en\" MsgFailure = 'Just' \"Failure\"
- -- English is the default
- localize \"en\" msg = 'Just' ('toHtml' msg)
+ -- Czech variants
+ 'localize' \"cs\" MsgSuccess = 'Just' \"Úspěch\"
+ 'localize' \"cs\" MsgFailure = 'Just' \"Selhání\"
-- Otherwise try the next locale
- localize _locale _msg = 'Nothing'
+ 'localize' _locale _msg = 'Nothing'
@
Next, create a preferred language list for every action:
@
'Hikaru.Dispatch.dispatch' runAction $ do
- 'Hikaru.Dispatch.wrapActions' ('selectLanguages' \"lang\" \"lang\" >>)
-
- 'Hikaru.Dispatch.route' ...
+ 'Hikaru.Dispatch.wrapAction' ('selectLanguages' \"lang\" \"lang\" >>) $ do
+ 'Hikaru.Dispatch.route' ...
@
Finally, you can use your catalog when rendering pages:
@@ -59,7 +58,8 @@ getSampleR flag = do
module Hikaru.Localize
( Locale
- , Localized(..)
+ , Localizable(..)
+ , lc
, lc_
, selectLanguages
)
@@ -84,35 +84,65 @@ where
-- |
-- Any message that can be rendered localized.
--
- class (ToHtml a) => Localized a where
+ class (Show l) => Localizable l where
-- |
-- Try to localize the message using given locale.
-- Return 'Nothing' if the locale is not supported.
--
- localize :: (Monad m) => Locale -> a -> Maybe (HtmlT m ())
- localize _lc = const Nothing
+ localize :: Locale -> l -> Maybe Text
+ localize _lang _msg = Nothing
{-# INLINE localize #-}
+ -- |
+ -- Same as 'localize', but for HTML.
+ -- Defaults to using the plain 'localize'.
+ --
+ localizeHtml :: (Monad m) => Locale -> l -> Maybe (HtmlT m ())
+ localizeHtml lang = fmap toHtml . localize lang
+ {-# INLINE localizeHtml #-}
+
-- |
-- Instance to make 'Text' usable for interoperability and
-- gradual localization.
--
- instance Localized Text where
- localize _lc = Just . toHtml
+ instance Localizable Text where
+ localize _lc = Just
+ {-# INLINE localize #-}
+
+
+ -- |
+ -- Instance to make 'Maybe' values simpler to render localized.
+ --
+ instance Localizable l => Localizable (Maybe l) where
+ localize lang (Just msg) = localize lang msg
+ localize _ Nothing = Just ""
{-# INLINE localize #-}
+ -- |
+ -- Localize given message to the language indicated by the
+ -- 'getLanguages' of the current action. Uses 'localize' internally.
+ --
+ lc :: (MonadAction m, Localizable l) => l -> m Text
+ lc msg = do
+ langs <- getLanguages
+
+ case mapMaybe (flip localize msg) langs of
+ [] -> return $ cs $ show msg
+ x:_ -> return x
+
+
-- |
-- Localize given message to the language indicated by the
-- 'getLanguages' of the current action.
--
- lc_ :: (MonadAction m, Localized a) => a -> HtmlT m ()
+ lc_ :: (MonadAction m, Localizable l) => l -> HtmlT m ()
lc_ msg = do
langs <- getLanguages
- case mapMaybe (flip localize msg) langs of
- [] -> toHtml msg
+ case mapMaybe (flip localizeHtml msg) langs of
+ [] -> toHtml $ show msg
x:_ -> x
diff --git a/lib/Hikaru/Types.hs b/lib/Hikaru/Types.hs
index 4d37016584d43ab2be60d4f4947019fc0ab3c225..115e11c7a9a285946924f4561f1a869666874e6f 100644
--- a/lib/Hikaru/Types.hs
+++ b/lib/Hikaru/Types.hs
@@ -22,8 +22,8 @@ where
import Data.ByteString (ByteString)
import Data.String.Conversions
import Data.Text (Text, pack, unpack)
- import Network.HTTP.Types.Status
import Network.HTTP.Types.Header
+ import Network.HTTP.Types.Status
import Network.Wai
import qualified Data.ByteString.Lazy
@@ -181,21 +181,24 @@ where
{-# INLINE toParam #-}
instance Param Text where
- fromParam = Just . id
+ fromParam "" = Nothing
+ fromParam sp = Just sp
{-# INLINE fromParam #-}
toParam = id
{-# INLINE toParam #-}
instance Param Data.Text.Lazy.Text where
- fromParam = Just . Data.Text.Lazy.fromStrict
+ fromParam "" = Nothing
+ fromParam sp = Just $ Data.Text.Lazy.fromStrict sp
{-# INLINE fromParam #-}
toParam = Data.Text.Lazy.toStrict
{-# INLINE toParam #-}
instance Param Data.ByteString.ByteString where
- fromParam = Just . Data.Text.Encoding.encodeUtf8
+ fromParam "" = Nothing
+ fromParam sp = Just $ Data.Text.Encoding.encodeUtf8 sp
{-# INLINE fromParam #-}
toParam = Data.Text.Encoding.decodeUtf8With
@@ -203,8 +206,9 @@ where
{-# INLINE toParam #-}
instance Param Data.ByteString.Lazy.ByteString where
- fromParam = Just . Data.ByteString.Lazy.fromStrict
- . Data.Text.Encoding.encodeUtf8
+ fromParam "" = Nothing
+ fromParam sp = Just $ Data.ByteString.Lazy.fromStrict
+ $ Data.Text.Encoding.encodeUtf8 sp
{-# INLINE fromParam #-}
toParam = Data.Text.Encoding.decodeUtf8With
diff --git a/package.yaml b/package.yaml
index b78b5ab9956088cb8553cc1b420e856d997408d3..6e2a8b8620c4270dbde003b48741d383cfd3b2a0 100644
--- a/package.yaml
+++ b/package.yaml
@@ -26,6 +26,7 @@ default-extensions:
- BlockArguments
- DataKinds
- DefaultSignatures
+ - DeriveGeneric
- FlexibleInstances
- GADTs
- GeneralizedNewtypeDeriving
@@ -78,4 +79,17 @@ library:
- Hikaru.Route
- Hikaru.Types
+tests:
+ spec:
+ main: Spec.hs
+ source-dirs: test
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ cpp-options: -DTEST
+
+ dependencies:
+ - hikaru
+ - hspec
+
+ build-tools: hspec-discover
+
# EOF
diff --git a/test/Hikaru/Demo.hs b/test/Hikaru/Demo.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f4b68a6bdd0b922af9c10bca5d4c99a57474dda2
--- /dev/null
+++ b/test/Hikaru/Demo.hs
@@ -0,0 +1,357 @@
+{-|
+Module : Hikaru.Demo
+Copyright : Jan Hamal Dvořák
+License : AGPL-3
+
+Maintainer : mordae@anilinux.org
+Stability : unstable
+Portability : non-portable (ghc)
+-}
+
+module Hikaru.Demo
+ ( makeDemo
+ )
+where
+ import BasePrelude hiding (for_, Option, Control)
+
+ import Control.Monad.Reader
+ import Data.Aeson ()
+ import Data.Text (Text)
+ import Hikaru
+ import Lucid
+ import Network.HTTP.Types.Header
+ import Network.HTTP.Types.Status
+ import Network.Wai
+
+
+ -- Action ------------------------------------------------------------------
+
+
+ -- |
+ -- Our custom action monad allows us to inspect request,
+ -- build response and consult the model at the same time.
+ --
+ newtype Action a
+ = Action
+ { unAction :: ReaderT DemoEnv IO a
+ }
+ deriving (Functor, Applicative, Monad, MonadIO)
+
+ instance MonadAction Action where
+ getActionEnv = Action (demoActionEnv <$> ask)
+
+ instance MonadModel Action where
+ getModelEnv = Action (demoModelEnv <$> ask)
+
+
+ data DemoEnv
+ = DemoEnv
+ { demoActionEnv :: ActionEnv
+ , demoModelEnv :: ModelEnv
+ }
+
+
+ -- Model -------------------------------------------------------------------
+
+
+ class (MonadIO m) => MonadModel m where
+ getModelEnv :: m ModelEnv
+
+
+ data ModelEnv
+ = ModelEnv
+ { modelCounter :: MVar Word
+ , modelCases :: MVar [Case]
+ }
+
+
+ makeModelEnv :: Word -> IO ModelEnv
+ makeModelEnv n = ModelEnv <$> newMVar n <*> newMVar []
+
+
+ countVisitor :: (MonadModel m) => m Word
+ countVisitor = do
+ counter <- modelCounter <$> getModelEnv
+ liftIO do
+ modifyMVar_ counter (return . succ)
+ readMVar counter
+
+
+ addCase :: (MonadModel m) => AddCase -> m Case
+ addCase AddCase{..} = do
+ nextId <- liftIO . readMVar . modelCounter =<< getModelEnv
+
+ let case' = Case { caseId = nextId
+ , caseName = acName
+ , caseRecNo = fromMaybe acName acRecNo
+ , caseMode = acMode
+ , caseActive = acActive
+ }
+
+ cases <- modelCases <$> getModelEnv
+
+ liftIO do
+ modifyMVar_ cases (return . (<> [case']))
+ return case'
+
+
+ -- Dispatching -------------------------------------------------------------
+
+
+ makeDemo :: IO Application
+ makeDemo = do
+ model <- makeModelEnv 0
+ return $ makeApplication model
+
+
+ runAction :: ModelEnv -> Action () -> Application
+ runAction me act = do
+ respond $ \ae -> do
+ runReaderT (unAction act) (DemoEnv ae me)
+
+
+ makeApplication :: ModelEnv -> Application
+ makeApplication me = do
+ dispatch (runAction me) do
+ -- Register nicer 404 error handler.
+ handler NotFound handleNotFound
+
+ -- Negotiate content for the root page.
+ route $ getRootHtmlR <$ get <* offerHTML
+ route $ getRootTextR <$ get <* offerText
+
+ -- Disable caching for all the following endpoints.
+ wrapAction (defaultHeader hCacheControl "no-store" >>) do
+ -- Present a simple greeting page.
+ route $ getHelloR <$ get <* seg "hello" <*> arg
+ <* offerText
+
+ -- Present an echoing JSON API.
+ route $ postEchoR <$ post <* seg "api" <* seg "echo"
+ <* offerJSON <* acceptJSON
+
+ -- Case handling.
+ route $ postCaseR <$ post <* seg "case" <* seg "" <* acceptForm
+ route $ getCasesR <$ get <* seg "case" <* seg "" <* offerJSON
+
+
+ -- Handlers ----------------------------------------------------------------
+
+
+ getRootHtmlR :: Action ()
+ getRootHtmlR = do
+ -- Update the counter.
+ n <- countVisitor
+
+ -- Present fancy HTML result.
+ sendHTML do
+ h1_ "Welcome!"
+ p_ $ "You are " >> toHtml (show n) >> ". visitor!"
+
+
+ getRootTextR :: Action ()
+ getRootTextR = do
+ -- Update the counter.
+ n <- countVisitor
+
+ -- Present a plain textual result.
+ sendString $ unlines [ "Welcome!"
+ , "You are " <> show n <> ". visitor!"
+ ]
+
+
+ postEchoR :: Action ()
+ postEchoR = sendJSON =<< getJSON
+
+
+ getHelloR :: Text -> Action ()
+ getHelloR name = sendText $ "Hello, " <> name <> "!"
+
+
+ handleNotFound :: RequestError -> Text -> Action ()
+ handleNotFound _exn msg = do
+ setStatus status404
+ sendHTML do
+ h1_ "404 Not Found"
+ p_ (toHtml msg)
+
+
+ postCaseR :: Action ()
+ postCaseR = do
+ (res, view) <- postForm "addCase" addCaseForm
+
+ case res of
+ Nothing -> do
+ setStatus status400
+ sendHTML do
+ simpleForm_ view
+
+ Just ac -> do
+ _case <- addCase ac
+ redirect "/case/"
+
+
+ getCasesR :: Action ()
+ getCasesR = do
+ cases <- liftIO . readMVar . modelCases =<< getModelEnv
+
+ sendHTML do
+ h1_ "Cases"
+
+ form_ [method_ "POST"] do
+ view <- newForm "addCase" Nothing addCaseForm
+ simpleForm_ view
+ button_ [type_ "submit"] "Submit"
+
+ table_ do
+ tr_ do
+ th_ "Id"
+ th_ "Name"
+ th_ "RecNo"
+ th_ "Mode"
+ th_ "Active"
+
+ for cases \Case{..} -> do
+ tr_ do
+ td_ $ toHtml $ show caseId
+ td_ $ toHtml $ caseName
+ td_ $ toHtml $ caseRecNo
+ td_ $ toHtml $ show caseMode
+ td_ $ toHtml $ show caseActive
+
+
+ -- Forms -------------------------------------------------------------------
+
+
+ simpleForm_ :: (MonadAction m, Localizable l) => View l -> HtmlT m ()
+ simpleForm_ View{..} = do
+ forM_ viewControls \ctrl@Control{..} -> do
+ viewControl_ ctrl
+ forM_ ctrlNotes \Note{..} -> do
+ p_ do
+ lc_ noteMessage
+
+ forM_ viewElements \Element{..} -> do
+ div_ do
+ div_ do
+ case elemControls of
+ Control{..}:_ -> label_ [for_ ctrlName] $ lc_ elemLabel
+ _otherwise -> label_ $ lc_ elemLabel
+
+ div_ do
+ forM_ elemControls \ctrl@Control{..} -> do
+ viewControl_ ctrl
+
+ forM_ elemControls \Control{..} -> do
+ forM_ ctrlNotes \Note{..} -> do
+ p_ do
+ lc_ noteMessage
+
+
+ viewControl_ :: (Localizable l, MonadAction m) => Control l -> HtmlT m ()
+ viewControl_ Control{..} = do
+ case ctrlField of
+ InputField{..} -> do
+ ph <- lc fieldPlacehold
+ input_ [ type_ fieldType
+ , name_ ctrlName
+ , placeholder_ ph
+ , value_ fieldValue
+ ]
+
+ SelectField{..} -> do
+ select_ [name_ ctrlName] do
+ mapM_ viewOption_ fieldOptions
+
+
+ viewOption_ :: (MonadAction m, Localizable l) => Option l -> HtmlT m ()
+ viewOption_ Option{..} = do
+ case optionSelected of
+ True -> do
+ option_ [selected_ "selected", value_ optionValue] do
+ lc_ optionLabel
+
+ False -> do
+ option_ [value_ optionValue] do
+ lc_ optionLabel
+
+
+ data Case
+ = Case
+ { caseId :: Word
+ , caseName :: Text
+ , caseRecNo :: Text
+ , caseMode :: AccessMode
+ , caseActive :: Bool
+ }
+ deriving (Show, Generic)
+
+
+ data AddCase
+ = AddCase
+ { acName :: Text
+ , acRecNo :: Maybe Text
+ , acMode :: AccessMode
+ , acActive :: Bool
+ }
+
+ data AccessMode
+ = ModePublic
+ | ModePrivate
+ deriving (Show, Eq)
+
+ instance Param AccessMode where
+ toParam ModePublic = "public"
+ toParam ModePrivate = "private"
+
+ fromParam "public" = Just ModePublic
+ fromParam "private" = Just ModePrivate
+ fromParam _else = Nothing
+
+
+ data RenderHint
+ = RenderCollapsed
+ | RenderExpanded
+ deriving (Eq, Show)
+
+
+ data Messages
+ = MsgCaseName
+ | MsgCaseMode
+ | MsgCaseEnabled
+ | MsgForm FormMessage
+ deriving (Show)
+
+ instance Localizable Messages where
+ localize "en" MsgCaseName = Just "Name"
+ localize "en" MsgCaseMode = Just "Mode"
+ localize "en" MsgCaseEnabled = Just "Enabled"
+
+ localize lang (MsgForm msg) = localize lang msg
+ localize _lang _msg = Nothing
+
+ instance FromFormMessage Messages where
+ fromFormMessage = MsgForm
+
+
+ addCaseForm :: (MonadAction m) => Form Messages m AddCase
+ addCaseForm = do
+ (\(x1, x2) x3 x4 -> AddCase x1 x2 x3 x4)
+ <$> element MsgCaseName do
+ (,)
+ <$> input "name" acName do
+ return ()
+
+ <*> input "recno" acRecNo do
+ return ()
+
+ <*> element MsgCaseMode do
+ select "mode" acMode do
+ return ()
+
+ <*> element MsgCaseEnabled do
+ select "active" acActive do
+ hint RenderExpanded
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/test/Hikaru/DemoSpec.hs b/test/Hikaru/DemoSpec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..35f0057bd4558e4627807e832d60785f4653bfef
--- /dev/null
+++ b/test/Hikaru/DemoSpec.hs
@@ -0,0 +1,76 @@
+{-|
+Module : Hikaru.DemoSpec
+Copyright : Jan Hamal Dvořák
+License : AGPL-3
+
+Maintainer : mordae@anilinux.org
+Stability : unstable
+Portability : non-portable (ghc)
+
+Smoke tests coverting a simple demo site.
+-}
+
+module Hikaru.DemoSpec
+ ( spec
+ )
+where
+ import BasePrelude
+
+ import Hikaru.Demo
+ import Hikaru.Test
+
+
+ spec :: Spec
+ spec = do
+ describe "GET /" do
+ context "by default" do
+ it "responds with 200 and text/html" do
+ runDemo do
+ resp <- get "/" []
+ assertStatus 200 resp
+ assertHeader hContentType "text/html; charset=utf8" resp
+ assertBodyContains "<h1>Welcome" resp
+ assertBodyContains " 1. " resp
+
+ context "when asked for text/plain" do
+ it "responds with 200 and text/plain" do
+ runDemo do
+ resp <- get "/" [(hAccept, "text/plain")]
+ assertStatus 200 resp
+ assertHeader hContentType "text/plain; charset=utf8" resp
+ assertBodyContains "Welcome" resp
+ assertBodyContains " 2. " resp
+
+ describe "GET /404" do
+ it "responds with 404" do
+ runDemo do
+ resp <- get "/404" []
+ assertStatus 404 resp
+ assertBodyContains "404" resp
+
+ describe "GET /hello/<arg>" do
+ it "greets caller" do
+ runDemo do
+ resp <- get "/hello/Tester" []
+ assertStatus 200 resp
+ assertHeader hContentType "text/plain; charset=utf8" resp
+ assertHeader hCacheControl "no-store" resp
+ assertBody "Hello, Tester!" resp
+
+ describe "POST /api/echo" do
+ it "echoes JSON payload" do
+ runDemo do
+ resp <- post "/api/echo" [(hContentType, "application/json")] "[1, 2]"
+ assertStatus 200 resp
+ assertBody "[1,2]" resp
+
+
+ demo :: Application
+ demo = unsafePerformIO makeDemo
+
+
+ runDemo :: Session a -> IO a
+ runDemo s = runSession s demo
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/test/Hikaru/FormSpec.hs b/test/Hikaru/FormSpec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a845d7c1e73727053c9e8350123bf6441dca8306
--- /dev/null
+++ b/test/Hikaru/FormSpec.hs
@@ -0,0 +1,31 @@
+{-|
+Module : Hikaru.FormSpec
+Copyright : Jan Hamal Dvořák
+License : AGPL-3
+
+Maintainer : mordae@anilinux.org
+Stability : unstable
+Portability : non-portable (ghc)
+-}
+
+module Hikaru.FormSpec
+ ( spec
+ )
+where
+ import BasePrelude
+
+ import Hikaru ()
+ import Hikaru.Test
+
+
+ -- Spec --------------------------------------------------------------------
+
+
+ spec :: Spec
+ spec = do
+ describe "form" do
+ it "has tests written" do
+ False
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/test/Hikaru/Test.hs b/test/Hikaru/Test.hs
new file mode 100644
index 0000000000000000000000000000000000000000..5941094b574eb80eb61632bc8878d540cf9130cb
--- /dev/null
+++ b/test/Hikaru/Test.hs
@@ -0,0 +1,55 @@
+{-|
+Module : Hikaru.Test
+Copyright : Jan Hamal Dvořák
+License : AGPL-3
+
+Maintainer : mordae@anilinux.org
+Stability : unstable
+Portability : non-portable (ghc)
+
+Common testing definitions.
+-}
+
+module Hikaru.Test
+ ( get
+ , post
+
+ , module Network.HTTP.Types
+ , module Network.Wai
+ , module Network.Wai.Internal
+ , module Network.Wai.Test
+ , module Test.Hspec
+ )
+where
+ import BasePrelude
+
+ import qualified Data.ByteString.Lazy as Lazy
+
+ import Data.ByteString (ByteString)
+ import Network.HTTP.Types
+ import Network.Wai
+ import Network.Wai.Internal
+ import Network.Wai.Test
+ import Test.Hspec
+
+
+ get :: ByteString -> RequestHeaders -> Session SResponse
+ get path headers =
+ let req = setPath defaultRequest path
+ in request $ req { requestMethod = methodGet
+ , requestHeaders = headers
+ }
+
+
+ post :: ByteString -> RequestHeaders -> ByteString -> Session SResponse
+ post path headers body = srequest sreq
+ where
+ req = setPath defaultRequest path
+ sreq = SRequest { simpleRequestBody = Lazy.fromStrict body
+ , simpleRequest = req { requestMethod = methodPost
+ , requestHeaders = headers
+ }
+ }
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..8f12fe38bace2b23f8ef24256b1f716ee844274a
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,14 @@
+{-|
+Module : Spec
+Copyright : Jan Hamal Dvořák
+License : AGPL-3
+
+Maintainer : mordae@anilinux.org
+Stability : unstable
+Portability : non-portable (ghc)
+-}
+
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+
+
+-- vim:set ft=haskell sw=2 ts=2 et: