diff --git a/devforms.cabal b/devforms.cabal --- a/devforms.cabal +++ b/devforms.cabal @@ -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 diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -26,3 +26,4 @@ setUpperBoundInclusive 15 questionLikert "This form works well" questionTime "Select a time" + questionText "Any special requests?" diff --git a/src/DevForms.hs b/src/DevForms.hs --- a/src/DevForms.hs +++ b/src/DevForms.hs @@ -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 diff --git a/src/ParsedInteger.hs b/src/ParsedInteger.hs new file mode 100644 --- /dev/null +++ b/src/ParsedInteger.hs @@ -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 diff --git a/src/Question.hs b/src/Question.hs --- a/src/Question.hs +++ b/src/Question.hs @@ -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 diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -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" )