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.2.0 +version: 0.2.0.1 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 @@ -53,6 +53,8 @@ , string-interpolate >= 0.3 && < 0.4 , file-embed >= 0.0.15 && < 0.1 , containers >= 0.6 && < 0.9 + , regex-base >= 0.94 && < 0.95 + , regex-tdfa >= 1.3 && < 1.4 hs-source-dirs: src default-language: GHC2021 mixins: base hiding (Prelude) diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -13,17 +13,18 @@ , "Camel" , "Duck" ] - questionDate "On which day would you like to meet your favourite animal?" + questionDateWith "On which day would you like to meet your favourite animal?" $ setOptional questionTime "On which time would you like to have the meeting?" - questionInteger "How many siblings do you have?" $ do + questionIntegerWith "How many siblings do you have?" $ do setLowerBoundInclusive 0 form "Another simple form" "otherform" $ do questionCheckbox "Do you want to check this box?" questionChoice "Select one of the following:" ["A", "B", "C"] questionDate "Select a date" - questionInteger "Enter a natural number" $ do + questionIntegerWith "Enter a natural number" $ do setUpperBoundInclusive 15 questionLikert "This form works well" questionTime "Select a time" - questionFreeText "Any special requests?" + questionFreeTextWith "Any special requests?" $ setOptional + questionRegexText "Enter five uppercase letters" "[A-Z]{5}" diff --git a/src/DevForms.hs b/src/DevForms.hs --- a/src/DevForms.hs +++ b/src/DevForms.hs @@ -9,6 +9,12 @@ builder DSL. Forms are served via a built-in web server (Scotty), and submissions are stored as JSONL files. +Each question type comes in two variants: + +* A plain version (e.g. 'questionLikert') that uses default options. +* A @With@ version (e.g. 'questionLikertWith') that accepts a builder block + for configuring options like 'setOptional' or bounds. + === Example @ @@ -18,17 +24,51 @@ questionLikert "I enjoy seeing animals" questionChoice "Favourite animal" ["Alpaca", "Bumblebee", "Camel", "Duck"] - questionDate "When would you like to visit the zoo?" - questionInteger "How many tickets?" $ do + questionDateWith "When would you like to visit the zoo?" $ setOptional + questionIntegerWith "How many tickets?" $ do setLowerBoundInclusive 1 setUpperBoundInclusive 10 @ -} -module DevForms (ServerBuilder, FormBuilder, QuestionBuilder, devFormServer, form, questionCheckbox, questionLikert, questionChoice, questionDate, questionTime, questionInteger, setLowerBoundInclusive, setUpperBoundInclusive, questionFreeText) where +module DevForms ( + ServerBuilder, + FormBuilder, + QuestionBuilder, + IntegerQuestionBuilder, + HasOptional (..), + HasBounds (..), + devFormServer, + form, + questionCheckbox, + questionCheckboxWith, + questionLikert, + questionLikertWith, + questionChoice, + questionChoiceWith, + questionDate, + questionDateWith, + questionTime, + questionTimeWith, + questionInteger, + questionIntegerWith, + questionFreeText, + questionFreeTextWith, + questionRegexText, + questionRegexTextWith, +) where import Control.Monad.Writer import Form (Form (..), FormBuilder) -import Question (Question (..), QuestionBuilder, QuestionOptions (..), QuestionType (..)) +import Question ( + HasBounds (..), + HasOptional (..), + IntegerQuestionBuilder, + Question (..), + QuestionBuilder, + QuestionType (..), + runIntegerQuestionBuilder, + runQuestionBuilder, + ) import Server (Server (..), ServerBuilder, runServer) {- | Start the devforms web server on the given port. @@ -43,10 +83,6 @@ devFormServer :: Int -> ServerBuilder () -> IO () devFormServer = runServer --- devFormServer serverBuilder = do --- let forms = appEndo (execWriter serverBuilder) $ Server{forms = []} --- print $ forms - {- | Define a survey form. The first argument is the human-readable title displayed at the top of the @@ -67,65 +103,155 @@ addQuestion question = tell $ Endo $ \f@Form{questions} -> f{questions = questions <> [question]} -{- | Add a yes\/no checkbox question. Renders as a single checkbox that the -respondent can tick or leave unticked. +{- | Add a yes\/no checkbox question with default options. Renders as a single +checkbox that the respondent can tick or leave unticked. -} questionCheckbox :: Text -> FormBuilder () -questionCheckbox questionText = - addQuestion $ Question questionText QuestionCheckbox +questionCheckbox label = questionCheckboxWith label (pure ()) -{- | Add a Likert-scale question. Renders as a 5-point agreement scale -(Strongly disagree … Strongly agree) plus a \"Cannot say\" option. +{- | Add a yes\/no checkbox question with custom options. Renders as a single +checkbox that the respondent can tick or leave unticked. + +The second argument is a 'QuestionBuilder' block where you can configure +shared options such as 'setOptional'. -} +questionCheckboxWith :: Text -> QuestionBuilder () -> FormBuilder () +questionCheckboxWith questionText builder = + addQuestion $ Question questionText QuestionCheckbox (runQuestionBuilder builder) + +{- | Add a Likert-scale question with default options. Renders as a 5-point +agreement scale (Strongly disagree … Strongly agree) plus a \"Cannot say\" +option. +-} questionLikert :: Text -> FormBuilder () -questionLikert questionText = addQuestion $ Question questionText QuestionLikert +questionLikert label = questionLikertWith label (pure ()) -{- | Add a multiple-choice question. Renders as a group of radio buttons — the -respondent must select exactly one of the provided options. +{- | Add a Likert-scale question with custom options. Renders as a 5-point +agreement scale (Strongly disagree … Strongly agree) plus a \"Cannot say\" +option. +The second argument is a 'QuestionBuilder' block where you can configure +shared options such as 'setOptional'. +-} +questionLikertWith :: Text -> QuestionBuilder () -> FormBuilder () +questionLikertWith questionText builder = + addQuestion $ Question questionText QuestionLikert (runQuestionBuilder builder) + +{- | Add a multiple-choice question with default options. Renders as a group of +radio buttons — the respondent must select exactly one of the provided +options. + The first argument is the question label; the second is the list of choices. -} questionChoice :: Text -> [Text] -> FormBuilder () -questionChoice title qOptions = - addQuestion $ Question title (QuestionChoice qOptions) +questionChoice label options = questionChoiceWith label options (pure ()) -{- | Add a date-picker question. Renders as an HTML date input and stores the -answer in @YYYY-MM-DD@ format. +{- | Add a multiple-choice question with custom options. Renders as a group of +radio buttons — the respondent must select exactly one of the provided +options. + +The first argument is the question label; the second is the list of choices. +The third argument is a 'QuestionBuilder' block where you can configure +shared options such as 'setOptional'. -} +questionChoiceWith :: Text -> [Text] -> QuestionBuilder () -> FormBuilder () +questionChoiceWith title qOptions builder = + addQuestion $ Question title (QuestionChoice qOptions) (runQuestionBuilder builder) + +{- | Add a date-picker question with default options. Renders as an HTML date +input and stores the answer in @YYYY-MM-DD@ format. +-} questionDate :: Text -> FormBuilder () -questionDate questionText = addQuestion $ Question questionText QuestionDate +questionDate label = questionDateWith label (pure ()) -{- | Add a time-picker question. Renders as an HTML time input and stores the -answer in @HH:MM@ format. +{- | Add a date-picker question with custom options. Renders as an HTML date +input and stores the answer in @YYYY-MM-DD@ format. + +The second argument is a 'QuestionBuilder' block where you can configure +shared options such as 'setOptional'. -} +questionDateWith :: Text -> QuestionBuilder () -> FormBuilder () +questionDateWith questionText builder = + addQuestion $ Question questionText QuestionDate (runQuestionBuilder builder) + +{- | Add a time-picker question with default options. Renders as an HTML time +input and stores the answer in @HH:MM@ format. +-} questionTime :: Text -> FormBuilder () -questionTime questionText = addQuestion $ Question questionText QuestionTime +questionTime label = questionTimeWith label (pure ()) -{- | Add an integer input question. The second argument is a 'QuestionBuilder' -block where you can optionally configure bounds using -'setLowerBoundInclusive' and 'setUpperBoundInclusive'. Bounds are enforced -both client-side (via HTML attributes) and server-side on submission. +{- | Add a time-picker question with custom options. Renders as an HTML time +input and stores the answer in @HH:MM@ format. +The second argument is a 'QuestionBuilder' block where you can configure +shared options such as 'setOptional'. +-} +questionTimeWith :: Text -> QuestionBuilder () -> FormBuilder () +questionTimeWith questionText builder = + addQuestion $ Question questionText QuestionTime (runQuestionBuilder builder) + +-- | Add an integer input question with default options (no bounds). +questionInteger :: Text -> FormBuilder () +questionInteger label = questionIntegerWith label (pure ()) + +{- | Add an integer input question with custom options. The second argument is +an 'IntegerQuestionBuilder' block where you can configure bounds using +'setLowerBoundInclusive' and 'setUpperBoundInclusive', as well as shared +options like 'setOptional'. Bounds are enforced both client-side (via HTML +attributes) and server-side on submission. + === Example @ -questionInteger "How many pets do you have?" $ do +questionIntegerWith "How many pets do you have?" $ do setLowerBoundInclusive 0 setUpperBoundInclusive 50 + setOptional @ -} -questionInteger :: Text -> QuestionBuilder () -> FormBuilder () -questionInteger title questionBuilder = do - let questionOptions = appEndo (execWriter questionBuilder) $ QuestionOptions{lowerBoundInclusive = Nothing, upperBoundInclusive = Nothing} - addQuestion $ Question title (QuestionInteger questionOptions) +questionIntegerWith :: Text -> IntegerQuestionBuilder () -> FormBuilder () +questionIntegerWith title builder = + addQuestion $ Question title QuestionInteger (runIntegerQuestionBuilder builder) --- | Set the minimum allowed value (inclusive) for a 'questionInteger'. -setLowerBoundInclusive :: Integer -> QuestionBuilder () -setLowerBoundInclusive bound = tell $ Endo $ \questionOptions -> questionOptions{lowerBoundInclusive = Just bound} +{- | Add a free-text textarea question with default options. The respondent can +enter arbitrary text. +-} +questionFreeText :: Text -> FormBuilder () +questionFreeText label = questionFreeTextWith label (pure ()) --- | Set the maximum allowed value (inclusive) for a 'questionInteger'. -setUpperBoundInclusive :: Integer -> QuestionBuilder () -setUpperBoundInclusive bound = tell $ Endo $ \questionOptions -> questionOptions{upperBoundInclusive = Just bound} +{- | Add a free-text textarea question with custom options. The respondent can +enter arbitrary text. -questionFreeText :: Text -> FormBuilder () -questionFreeText questionText = addQuestion $ Question questionText QuestionFreeText +The second argument is a 'QuestionBuilder' block where you can configure +shared options such as 'setOptional'. +-} +questionFreeTextWith :: Text -> QuestionBuilder () -> FormBuilder () +questionFreeTextWith questionText builder = + addQuestion $ Question questionText QuestionFreeText (runQuestionBuilder builder) + +{- | Add a regex-validated text input question with default options. The +respondent's answer must match the given POSIX extended regex pattern. + +The first argument is the question label; the second is the regex pattern. +-} +questionRegexText :: Text -> Text -> FormBuilder () +questionRegexText label regexPattern = questionRegexTextWith label regexPattern (pure ()) + +{- | Add a regex-validated text input question with custom options. The +respondent's answer must match the given POSIX extended regex pattern. The +pattern is also set as the HTML @pattern@ attribute for client-side +validation. + +The first argument is the question label; the second is the regex pattern. +The third argument is a 'QuestionBuilder' block where you can configure +shared options such as 'setOptional'. + +=== Example + +@ +questionRegexTextWith "SemVer number" "^v\\d+.\\d+.\\d+$" $ setOptional +@ +-} +questionRegexTextWith :: Text -> Text -> QuestionBuilder () -> FormBuilder () +questionRegexTextWith questionText regexPattern builder = + addQuestion $ Question questionText (QuestionRegexText regexPattern) (runQuestionBuilder builder) diff --git a/src/ParsedInteger.hs b/src/ParsedInteger.hs --- a/src/ParsedInteger.hs +++ b/src/ParsedInteger.hs @@ -1,21 +1,23 @@ -module ParsedInteger (ParsedInteger, parseWithBounds, parsedToInteger) +module ParsedInteger (ParsedInteger, parseWithBounds, parsedToInteger, IntegerBoundError (..)) where newtype ParsedInteger = ParsedInteger Integer -parseWithBounds :: Maybe Integer -> Maybe Integer -> Integer -> Either Text ParsedInteger +data IntegerBoundError = IntegerOutOfBounds deriving (Show) + +parseWithBounds :: Maybe Integer -> Maybe Integer -> Integer -> Either IntegerBoundError ParsedInteger parseWithBounds (Just lowerBoundInclusive) (Just upperBoundInclusive) n = if lowerBoundInclusive <= n && upperBoundInclusive >= n then pure $ ParsedInteger n - else Left "Integer is outside bounds" + else Left IntegerOutOfBounds parseWithBounds (Just lowerBoundInclusive) Nothing n = if lowerBoundInclusive <= n then pure $ ParsedInteger n - else Left "Integer is out of bounds" + else Left IntegerOutOfBounds parseWithBounds Nothing (Just upperBoundInclusive) n = if upperBoundInclusive >= n then pure $ ParsedInteger n - else Left "Integer is out of bounds" + else Left IntegerOutOfBounds parseWithBounds Nothing Nothing n = Right $ ParsedInteger n parsedToInteger :: ParsedInteger -> Integer diff --git a/src/Question.hs b/src/Question.hs --- a/src/Question.hs +++ b/src/Question.hs @@ -1,54 +1,104 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE QuasiQuotes #-} -module Question (Question (..), QuestionType (..), QuestionOptions (..), QuestionBuilder, renderQuestion, parseAnswers) where +module Question ( + Question (..), + QuestionType (..), + QuestionOptions (..), + QuestionBuilder, + IntegerQuestionBuilder, + HasOptional (..), + HasBounds (..), + runQuestionBuilder, + runIntegerQuestionBuilder, + defaultOptions, + renderQuestion, + parseAnswers, +) where import Control.Monad.Writer import Data.Aeson qualified as JSON import Data.Aeson.Key qualified as Key -import Data.Char (isAlphaNum) import Data.String.Interpolate import Data.Text qualified as Text import Lucid import ParsedInteger import Relude.Extra.Map as Map +import Text.Regex.TDFA ((=~)) data Question = Question { questionText :: Text , questionType :: QuestionType + , questionOptions :: QuestionOptions } deriving (Show) -data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionDate | QuestionInteger QuestionOptions | QuestionTime | QuestionFreeText deriving (Show) - --- | A builder monad for configuring question options (e.g. bounds for integer questions). -type QuestionBuilder = Writer (Endo QuestionOptions) +data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionDate | QuestionInteger | QuestionTime | QuestionFreeText | QuestionRegexText Text deriving (Show) data QuestionOptions = QuestionOptions - { lowerBoundInclusive :: Maybe Integer + { isOptional :: Bool + , lowerBoundInclusive :: Maybe Integer , upperBoundInclusive :: Maybe Integer } deriving (Show) +defaultOptions :: QuestionOptions +defaultOptions = QuestionOptions{isOptional = False, lowerBoundInclusive = Nothing, upperBoundInclusive = Nothing} + +-- | A builder monad for configuring shared question options (e.g. optionality). +newtype QuestionBuilder a = QuestionBuilder (Writer (Endo QuestionOptions) a) + deriving newtype (Functor, Applicative, Monad) + +-- | A builder monad for configuring integer question options (bounds and optionality). +newtype IntegerQuestionBuilder a = IntegerQuestionBuilder (Writer (Endo QuestionOptions) a) + deriving newtype (Functor, Applicative, Monad) + +-- | Typeclass for builders that support marking a question as optional. +class HasOptional m where + setOptional :: m + +-- | Typeclass for builders that support setting numeric bounds. +class HasBounds m where + setLowerBoundInclusive :: Integer -> m + setUpperBoundInclusive :: Integer -> m + +instance HasOptional (QuestionBuilder ()) where + setOptional = QuestionBuilder $ tell $ Endo $ \o -> o{isOptional = True} + +instance HasOptional (IntegerQuestionBuilder ()) where + setOptional = IntegerQuestionBuilder $ tell $ Endo $ \o -> o{isOptional = True} + +instance HasBounds (IntegerQuestionBuilder ()) where + setLowerBoundInclusive bound = IntegerQuestionBuilder $ tell $ Endo $ \o -> o{lowerBoundInclusive = Just bound} + setUpperBoundInclusive bound = IntegerQuestionBuilder $ tell $ Endo $ \o -> o{upperBoundInclusive = Just bound} + +data AnswerError = NoRegexMatch Text | MissingRequiredField Text | InvalidTimeFormatFor Text | InvalidDateFormatFor Text | InvalidLikertOptionFor Text | InvalidChoiceFor Text | InvalidIntegerFor Text IntegerBoundError | IntegerParseErrorFor Text deriving (Show) + +-- | Run a 'QuestionBuilder' to extract the configured 'QuestionOptions'. +runQuestionBuilder :: QuestionBuilder () -> QuestionOptions +runQuestionBuilder (QuestionBuilder w) = appEndo (execWriter w) defaultOptions + +-- | Run an 'IntegerQuestionBuilder' to extract the configured 'QuestionOptions'. +runIntegerQuestionBuilder :: IntegerQuestionBuilder () -> QuestionOptions +runIntegerQuestionBuilder (IntegerQuestionBuilder w) = appEndo (execWriter w) defaultOptions + runJust :: a -> Maybe b -> (b -> a) -> a runJust _ (Just x) f = f x runJust defaultValue Nothing _ = defaultValue -questionId :: Text -> Text -questionId questionText = Text.intercalate "-" (Text.words slug) - where - slug = Text.toLower $ Text.map (\c -> if isAlphaNum c || c == ' ' then c else ' ') questionText - {- | Generate a unique validation tooltip ID from question text. E.g. "How old are you?" -> "err-how-old-are-you" -} validationId :: Text -> Text -validationId questionText = "err-" <> questionId questionText +validationId questionText = "err " <> questionText renderQuestion :: Question -> Html () -renderQuestion Question{questionText, questionType} = do +renderQuestion Question{questionText, questionType, questionOptions} = do div_ [class_ "input"] $ do - let qId = questionId questionText + let qId = questionText let errId = validationId questionText + let isRequired = not (isOptional questionOptions) + let requiredAttrs = if isRequired then [required_ ""] else [] case questionType of QuestionChoice _ -> mempty QuestionLikert -> mempty @@ -72,11 +122,12 @@ legend_ $ toHtml questionText forM_ choices $ \c -> do div_ $ do - input_ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, required_ "", ariaErrormessage_ errId, script_ radioScript] + input_ $ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, ariaErrormessage_ errId, script_ radioScript] <> requiredAttrs label_ [Lucid.for_ (qId <> c)] $ toHtml c QuestionDate -> do - input_ [type_ "date", name_ questionText, required_ "", ariaErrormessage_ errId] - QuestionInteger (QuestionOptions{lowerBoundInclusive, upperBoundInclusive}) -> do + input_ $ [type_ "date", name_ questionText, ariaErrormessage_ errId] <> requiredAttrs + QuestionInteger -> do + let QuestionOptions{lowerBoundInclusive = lowerBound, upperBoundInclusive = upperBound} = questionOptions let validationScriptParts = [ [__i| on input @@ -85,7 +136,7 @@ |] , runJust "" - lowerBoundInclusive + lowerBound ( \lb -> [__i| on input @@ -95,7 +146,7 @@ ) , runJust "" - upperBoundInclusive + upperBound ( \ub -> [__i| @@ -119,13 +170,13 @@ , Just $ name_ questionText , Just $ step_ "1" , Just $ pattern_ "[0-9]+" - , Just $ required_ "" , Just $ script_ validationScript , Just $ ariaErrormessage_ errId , Just $ id_ "integer" - , fmap (min_ . show) lowerBoundInclusive - , fmap (max_ . show) upperBoundInclusive + , fmap (min_ . show) lowerBound + , fmap (max_ . show) upperBound ] + <> requiredAttrs QuestionLikert -> do let radioScript = [__i| @@ -149,71 +200,112 @@ legend_ $ toHtml questionText forM_ choices $ \c -> do div_ $ do - input_ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, required_ "", ariaErrormessage_ errId, script_ radioScript] + input_ $ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, ariaErrormessage_ errId, script_ radioScript] <> requiredAttrs label_ [Lucid.for_ (qId <> c)] $ toHtml c div_ $ do - input_ [id_ (qId <> "cannot-say"), type_ "radio", name_ qId, value_ "Cannot say", required_ "", script_ radioScript] + input_ $ [id_ (qId <> "cannot-say"), type_ "radio", name_ qId, value_ "Cannot say", script_ radioScript] <> requiredAttrs label_ [Lucid.for_ (qId <> "cannot-say")] $ "Cannot say" QuestionTime -> do - input_ [type_ "time", name_ questionText, required_ "", ariaErrormessage_ errId] + input_ $ [type_ "time", name_ questionText, ariaErrormessage_ errId] <> requiredAttrs QuestionFreeText -> do - textarea_ [name_ questionText, required_ "", ariaErrormessage_ errId] "" + textarea_ ([name_ questionText, ariaErrormessage_ errId] <> requiredAttrs) "" + QuestionRegexText regexPattern -> do + input_ $ [type_ "text", pattern_ regexPattern, name_ questionText, ariaErrormessage_ errId] <> requiredAttrs + when (isOptional questionOptions) $ + div_ [class_ "hint"] "Optional" div_ [id_ errId, class_ "validation-message"] mempty ariaErrormessage_ :: Text -> Attributes ariaErrormessage_ = term "aria-errormessage" +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft f (Left e) = Left (f e) +mapLeft _ (Right v) = (Right v) + parseAnswers :: [Question] -> Map Text Text -> Either Text [(JSON.Key, JSON.Value)] parseAnswers questions params = mapM (`parseAnswer` params) questions parseAnswer :: Question -> Map Text Text -> Either Text (JSON.Key, JSON.Value) -parseAnswer Question{questionText, questionType} params = case questionType of - QuestionCheckbox -> - let value = JSON.Bool $ isJust $ Map.lookup questionText params - in Right (Key.fromText questionText, value) - QuestionInteger 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 choices -> - case Map.lookup questionText params of - Nothing -> Left $ "Missing required field: " <> questionText - Just raw - | raw `elem` choices -> Right (Key.fromText questionText, JSON.toJSON raw) - | otherwise -> Left $ "Invalid choice for: " <> questionText <> ". Got: " <> raw - QuestionLikert -> - let likertOptions = - [ "Strongly disagree" - , "Somewhat disagree" - , "Neither agree nor disagree" - , "Somewhat agree" - , "Strongly agree" - , "Cannot say" - ] - in case lookup questionText params of - Nothing -> Left $ "Missing required field: " <> questionText - Just raw - | raw `elem` likertOptions -> Right (Key.fromText questionText, JSON.toJSON raw) - | otherwise -> Left $ "Invalid Likert option for: " <> questionText <> ". Got: " <> raw - QuestionDate -> - case lookup questionText params of - Nothing -> Left $ "Missing required field: " <> questionText - Just raw - | isValidDate raw -> Right (Key.fromText questionText, JSON.toJSON raw) - | otherwise -> Left $ "Invalid date format for: " <> questionText <> ". Expected YYYY-MM-DD" - QuestionTime -> - case lookup questionText params of - Nothing -> Left $ "Missing required field: " <> questionText - Just raw - | isValidTime raw -> Right (Key.fromText questionText, JSON.toJSON raw) - | otherwise -> Left $ "Invalid time format for: " <> questionText <> ". Expected HH:MM" - QuestionFreeText -> - 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) +parseAnswer Question{questionText, questionType, questionOptions} params = + case result of + Left e -> Left $ show e + Right parsed -> Right parsed + where + -- Normalize: treat empty/whitespace-only values as missing for optional fields + params' + | isOptional questionOptions = + case Map.lookup questionText params of + Just v | Text.null (Text.strip v) -> Map.delete questionText params + _ -> params + | otherwise = params + + result = + case questionType of + QuestionCheckbox -> + let value = JSON.Bool $ isJust $ Map.lookup questionText params' + in Right (Key.fromText questionText, value) + QuestionInteger -> do + let QuestionOptions{lowerBoundInclusive = lowerBound, upperBoundInclusive = upperBound} = questionOptions + case Map.lookup questionText params' of + Nothing + | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null) + | otherwise -> Left $ MissingRequiredField questionText + Just raw -> do + n <- maybeToRight (IntegerParseErrorFor questionText) (readMaybe (toString raw) :: Maybe Integer) + boundsCheckedInt <- mapLeft (InvalidIntegerFor questionText) $ parseWithBounds lowerBound upperBound n + pure (Key.fromText questionText, JSON.toJSON (parsedToInteger boundsCheckedInt)) + QuestionChoice choices -> + case Map.lookup questionText params' of + Nothing + | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null) + | otherwise -> Left $ MissingRequiredField questionText + Just raw + | raw `elem` choices -> Right (Key.fromText questionText, JSON.toJSON raw) + | otherwise -> Left $ InvalidChoiceFor questionText + QuestionLikert -> + let likertOptions = + [ "Strongly disagree" + , "Somewhat disagree" + , "Neither agree nor disagree" + , "Somewhat agree" + , "Strongly agree" + , "Cannot say" + ] + in case Map.lookup questionText params' of + Nothing + | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null) + | otherwise -> Left $ MissingRequiredField questionText + Just raw + | raw `elem` likertOptions -> Right (Key.fromText questionText, JSON.toJSON raw) + | otherwise -> Left $ InvalidLikertOptionFor questionText + QuestionDate -> + case Map.lookup questionText params' of + Nothing + | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null) + | otherwise -> Left $ MissingRequiredField questionText + Just raw + | isValidDate raw -> Right (Key.fromText questionText, JSON.toJSON raw) + | otherwise -> Left $ InvalidDateFormatFor questionText + QuestionTime -> + case Map.lookup questionText params' of + Nothing + | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null) + | otherwise -> Left $ MissingRequiredField questionText + Just raw + | isValidTime raw -> Right (Key.fromText questionText, JSON.toJSON raw) + | otherwise -> Left $ InvalidTimeFormatFor questionText + QuestionFreeText -> + case Map.lookup questionText params' of + Nothing + | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null) + | otherwise -> Left $ MissingRequiredField questionText + Just raw + | Text.null (Text.strip raw) -> Left $ MissingRequiredField questionText + | otherwise -> Right (Key.fromText questionText, JSON.toJSON raw) + QuestionRegexText regex -> do + case Map.lookup questionText params' of + Nothing -> if isOptional questionOptions then Right (Key.fromText questionText, JSON.Null) else Left (MissingRequiredField questionText) + Just answer -> if answer =~ ("^" <> regex <> "$") then pure (Key.fromText questionText, JSON.toJSON answer) else Left (NoRegexMatch questionText) 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 @@ -121,6 +121,13 @@ margin-top: 0.2rem; } + .hint { + font-size: 0.8rem; + font-weight: 400; + color: \#666; + margin-bottom: 0.25rem; + } + .input>label, fieldset>legend { display: block; font-weight: 600;