1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.View.Form 3 ( FormHtml 4 , field 5 , inputText 6 , inputTextarea 7 , inputPassword 8 , inputCheckbox 9 , inputSelect 10 , inputEnum 11 , inputDate 12 , inputFile 13 , inputHidden 14 , csrfForm 15 , htmlForm 16 ) where 17 18 import Control.Applicative ((<|>)) 19 import Control.Monad (when) 20 import Control.Monad.Reader (reader) 21 import Control.Monad.Trans.Class (lift) 22 import Control.Monad.Trans.Control (liftWith) 23 import qualified Data.ByteString as BS 24 import qualified Data.ByteString.Char8 as BSC 25 import Data.Foldable (fold) 26 import qualified Data.Text as T 27 import Data.Time.Format (formatTime, defaultTimeLocale) 28 import qualified Text.Blaze.Internal as M 29 import qualified Text.Blaze.Html5 as H 30 import qualified Text.Blaze.Html5.Attributes as HA 31 32 import Databrary.Ops 33 import Databrary.Has (view) 34 import Databrary.Model.Enum 35 import Databrary.Model.Time 36 import Databrary.Model.Token 37 import Databrary.Model.Identity 38 import Databrary.Action 39 import Databrary.HTTP.Form 40 import Databrary.HTTP.Form.Errors 41 import Databrary.HTTP.Form.View 42 import Databrary.View.Html 43 import Databrary.View.Template 44 45 import {-# SOURCE #-} Databrary.Controller.Angular 46 47 type FormHtmlM f = FormViewT f M.MarkupM 48 type FormHtml f = FormHtmlM f () 49 50 pathId :: FormHtmlM f H.AttributeValue 51 pathId = reader (byteStringValue . formPathBS) 52 53 value :: FormHtmlM f (Maybe BS.ByteString) 54 value = do 55 val <- reader formDatum 56 return $ case val of 57 FormDatumNone -> Nothing 58 FormDatumJSON _ -> Nothing -- that's weird 59 FormDatumBS b -> (BS.null b) `unlessUse` b 60 FormDatumFlag -> Nothing 61 62 errorList :: [FormErrorMessage] -> H.Html 63 errorList [] = mempty 64 errorList err = 65 H.ul H.! HA.class_ "error-list" $ mapM_ 66 ((H.li H.! HA.class_ "error") . H.toHtml) err 67 68 errorLists :: [(FormPath, FormErrorMessage)] -> H.Html 69 errorLists [] = mempty 70 errorLists err = 71 H.dl H.! HA.class_ "error-list" $ mapM_ (\(p,e) -> do 72 H.dt $ H.toHtml (formPathText p) 73 H.dd H.! HA.class_ "error" $ H.toHtml e) err 74 75 _label :: H.AttributeValue -> H.Html -> H.Html 76 _label ref = H.label 77 H.! HA.for ref 78 79 type Field = H.AttributeValue -> Maybe BS.ByteString -> H.Html 80 81 field :: T.Text -> Field -> FormHtml f 82 field k sub = k .:> do 83 ref <- pathId 84 err <- formViewErrors 85 val <- value 86 lift $ H.label $ do 87 H.toHtml k 88 sub ref val 89 errorList err 90 H.br 91 92 inputText :: H.ToValue a => Maybe a -> Field 93 inputText val ref dat = H.input 94 H.! HA.type_ "text" 95 H.! HA.id ref 96 H.! HA.name ref 97 !? (HA.value <$> (fmap byteStringValue dat <|> fmap H.toValue val)) 98 99 inputTextarea :: H.ToMarkup a => Maybe a -> Field 100 inputTextarea val ref dat = H.textarea 101 H.! HA.id ref 102 H.! HA.name ref 103 $ fold $ fmap byteStringHtml dat <|> fmap H.toHtml val 104 105 inputPassword :: Field 106 inputPassword ref _ = H.input 107 H.! HA.type_ "password" 108 H.! HA.id ref 109 H.! HA.name ref 110 111 inputCheckbox :: Bool -> Field 112 inputCheckbox val ref dat = H.input 113 H.! HA.type_ "checkbox" 114 H.! HA.id ref 115 H.! HA.name ref 116 H.!? (maybe val (const True) dat, HA.checked "checked") 117 118 inputSelect :: H.ToMarkup b => Maybe BS.ByteString -> [(BS.ByteString, b)] -> Field 119 inputSelect val choices ref dat = H.select 120 H.! HA.id ref 121 H.! HA.name ref 122 $ mapM_ (\(v, c) -> H.option 123 H.! HA.value (byteStringValue v) 124 H.!? (any (v ==) (dat <|> val), HA.selected "selected") 125 $ H.toHtml c) choices 126 127 inputEnum :: forall a . DBEnum a => Bool -> Maybe a -> Field 128 inputEnum req val = 129 inputSelect (bshow <$> val) $ (if req then id else (("", "") :)) $ map (\(x, v) -> (bshow (x :: a), v)) pgEnumValues 130 where bshow = BSC.pack . show . fromEnum 131 132 inputDate :: Maybe Date -> Field 133 inputDate val ref dat = H.input 134 H.! HA.type_ "date" 135 H.! HA.id ref 136 H.! HA.name ref 137 !? (HA.value <$> (fmap byteStringValue dat <|> fmap (H.toValue . formatTime defaultTimeLocale "%F") val)) 138 139 inputFile :: Field 140 inputFile ref _ = H.input 141 H.! HA.type_ "file" 142 H.! HA.id ref 143 H.! HA.name ref 144 145 inputHidden :: H.ToValue a => a -> Field 146 inputHidden val ref dat = H.input 147 H.! HA.type_ "hidden" 148 H.! HA.id ref 149 H.! HA.name ref 150 H.! HA.value (maybe (H.toValue val) byteStringValue dat) 151 152 csrfForm :: RequestContext -> FormHtml f 153 csrfForm = 154 lift . extractFromIdentifiedSessOrDefault mempty (\s -> inputHidden (byteStringValue $ sessionVerf s) "csverf" Nothing) . view 155 156 htmlForm :: T.Text -> ActionRoute a -> a -> FormHtml f -> (JSOpt -> H.Html) -> RequestContext -> FormHtml f 157 htmlForm title act arg form body req = liftWith $ \run -> do 158 htmlTemplate req (Just title) $ \js -> do 159 actionForm act arg js $ do 160 (_, err) <- run $ when (actionMethod act arg /= GET) (csrfForm req) >> form 161 errorLists $ allFormErrors err 162 H.input 163 H.! HA.type_ "submit" 164 body js