devforms 0.1.0.3 → 0.1.1.0
raw patch · 6 files changed
+54/−28 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ DevForms: questionText :: Text -> FormBuilder ()
Files
- devforms.cabal +4/−1
- examples/Example.hs +1/−0
- src/DevForms.hs +4/−1
- src/ParsedInteger.hs +22/−0
- src/Question.hs +19/−24
- src/Server.hs +4/−2
devforms.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: devforms-version: 0.1.0.3+version: 0.1.1.0 synopsis: A builder DSL for HTML survey forms with built-in server and storage description: devforms is a Haskell library for building HTML survey forms using a@@ -32,9 +32,12 @@ other-modules: Server , Form , Question+ , ParsedInteger -- other-extensions: default-extensions: OverloadedStrings+ ghc-options:+ -Werror=incomplete-patterns build-depends: base >= 4.18 && < 5 , relude >= 1.2 && < 1.3 , mtl >= 2.2 && < 2.4
examples/Example.hs view
@@ -26,3 +26,4 @@ setUpperBoundInclusive 15 questionLikert "This form works well" questionTime "Select a time"+ questionText "Any special requests?"
src/DevForms.hs view
@@ -24,7 +24,7 @@ setUpperBoundInclusive 10 @ -}-module DevForms (ServerBuilder, FormBuilder, QuestionBuilder, devFormServer, form, questionCheckbox, questionLikert, questionChoice, questionDate, questionTime, questionInteger, setLowerBoundInclusive, setUpperBoundInclusive) where+module DevForms (ServerBuilder, FormBuilder, QuestionBuilder, devFormServer, form, questionCheckbox, questionLikert, questionChoice, questionDate, questionTime, questionInteger, setLowerBoundInclusive, setUpperBoundInclusive, questionText) where import Control.Monad.Writer import Form (Form (..), FormBuilder)@@ -126,3 +126,6 @@ -- | Set the maximum allowed value (inclusive) for a 'questionInteger'. setUpperBoundInclusive :: Integer -> QuestionBuilder () setUpperBoundInclusive bound = tell $ Endo $ \questionOptions -> questionOptions{upperBoundInclusive = Just bound}++questionText :: Text -> FormBuilder ()+questionText = addQuestion . QuestionText
+ src/ParsedInteger.hs view
@@ -0,0 +1,22 @@+module ParsedInteger (ParsedInteger, parseWithBounds, parsedToInteger)+where++newtype ParsedInteger = ParsedInteger Integer++parseWithBounds :: Maybe Integer -> Maybe Integer -> Integer -> Either Text ParsedInteger+parseWithBounds (Just lowerBoundInclusive) (Just upperBoundInclusive) n =+ if lowerBoundInclusive <= n && upperBoundInclusive >= n+ then pure $ ParsedInteger n+ else Left "Integer is outside bounds"+parseWithBounds (Just lowerBoundInclusive) Nothing n =+ if lowerBoundInclusive <= n+ then pure $ ParsedInteger n+ else Left "Integer is out of bounds"+parseWithBounds Nothing (Just upperBoundInclusive) n =+ if upperBoundInclusive >= n+ then pure $ ParsedInteger n+ else Left "Integer is out of bounds"+parseWithBounds Nothing Nothing n = Right $ ParsedInteger n++parsedToInteger :: ParsedInteger -> Integer+parsedToInteger (ParsedInteger n) = n
src/Question.hs view
@@ -8,9 +8,10 @@ import Data.String.Interpolate import Data.Text qualified as Text import Lucid+import ParsedInteger import Relude.Extra.Map as Map -data Question = QuestionCheckbox Text | QuestionLikert Text | QuestionChoice Text [Text] | QuestionDate Text | QuestionInteger Text QuestionOptions | QuestionTime Text deriving (Show)+data Question = QuestionCheckbox Text | QuestionLikert Text | QuestionChoice Text [Text] | QuestionDate Text | QuestionInteger Text QuestionOptions | QuestionTime Text | QuestionText Text deriving (Show) -- | A builder monad for configuring question options (e.g. bounds for integer questions). type QuestionBuilder = Writer (Endo QuestionOptions)@@ -44,13 +45,12 @@ input_ [type_ "date", name_ questionText, required_ ""] QuestionInteger questionText (QuestionOptions{lowerBoundInclusive, upperBoundInclusive}) -> do let validationScriptParts =- [ ( [__i|+ [ [__i| on input set my.value to my.value.replace('/[^0-9-]/g', '') end |]- )- , ( runJust+ , runJust "" lowerBoundInclusive ( \lb ->@@ -60,8 +60,7 @@ end |] )- )- , ( runJust+ , runJust "" upperBoundInclusive ( \ub ->@@ -78,7 +77,6 @@ end |] )- ) ] let validationScript = Text.intercalate "\n" validationScriptParts @@ -113,6 +111,9 @@ QuestionTime questionText -> do h3_ $ toHtml questionText input_ [type_ "time", name_ questionText, required_ ""]+ QuestionText questionText -> do+ h3_ $ toHtml questionText+ textarea_ [name_ questionText, required_ ""] "" parseAnswers :: [Question] -> Map Text Text -> Either Text [(JSON.Key, JSON.Value)] parseAnswers questions params = mapM (`parseAnswer` params) questions@@ -122,14 +123,11 @@ QuestionCheckbox questionText -> let value = JSON.Bool $ isJust $ Map.lookup questionText params in Right (Key.fromText questionText, value)- QuestionInteger questionText opts ->- case Map.lookup questionText params of- Nothing -> Left $ "Missing required field: " <> questionText- Just raw -> case readMaybe (toString raw) :: Maybe Integer of- Nothing -> Left $ "Invalid integer for: " <> questionText- Just n -> do- validateBounds questionText n opts- Right (Key.fromText questionText, JSON.toJSON n)+ QuestionInteger questionText QuestionOptions{lowerBoundInclusive, upperBoundInclusive} -> do+ answerRaw <- maybeToRight ("Missing required field: " <> questionText) $ Map.lookup questionText params+ n <- maybeToRight ("Invalid integer for: " <> questionText) (readMaybe (toString answerRaw) :: Maybe Integer)+ boundsCheckedInt <- parseWithBounds lowerBoundInclusive upperBoundInclusive n+ pure (Key.fromText questionText, JSON.toJSON (parsedToInteger boundsCheckedInt)) QuestionChoice questionText choices -> case Map.lookup questionText params of Nothing -> Left $ "Missing required field: " <> questionText@@ -162,15 +160,12 @@ Just raw | isValidTime raw -> Right (Key.fromText questionText, JSON.toJSON raw) | otherwise -> Left $ "Invalid time format for: " <> questionText <> ". Expected HH:MM"--validateBounds :: Text -> Integer -> QuestionOptions -> Either Text ()-validateBounds questionText n QuestionOptions{lowerBoundInclusive, upperBoundInclusive} = do- case lowerBoundInclusive of- Just lb | n < lb -> Left $ questionText <> ": value " <> show n <> " is below minimum " <> show lb- _ -> Right ()- case upperBoundInclusive of- Just ub | n > ub -> Left $ questionText <> ": value " <> show n <> " is above maximum " <> show ub- _ -> Right ()+ QuestionText questionText ->+ case lookup questionText params of+ Nothing -> Left $ "Missing required field: " <> questionText+ Just raw+ | Text.null (Text.strip raw) -> Left $ "Missing required field: " <> questionText+ | otherwise -> Right (Key.fromText questionText, JSON.toJSON raw) isValidDate :: Text -> Bool isValidDate t = case Text.splitOn "-" t of
src/Server.hs view
@@ -18,7 +18,7 @@ import System.FilePath (takeExtension) import Web.Scotty qualified as Scotty -data Server = Server {forms :: [Form]} deriving (Show)+newtype Server = Server {forms :: [Form]} deriving (Show) -- | A builder monad for configuring the devforms server. Use 'form' to add forms. type ServerBuilder = Writer (Endo Server)@@ -49,7 +49,9 @@ Scotty.status status400 Scotty.text $ toLazy err Right answerPairs -> do- let encoded = JSON.encode $ JSON.object answerPairs+ answerTime <- liftIO getCurrentTime+ let answerPairsWithTime = ("_submissiondatetime", JSON.toJSON answerTime) : answerPairs+ let encoded = JSON.encode $ JSON.object answerPairsWithTime appendFileLBS ("answers-" <> toString formId <> ".jsonl") ("\n" <> encoded) Scotty.html $ renderText $ p_ "Form submitted" )