diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -26,6 +26,7 @@ [] -> ("form.html", "0") doc <- HTML.readFile filename let form = ensureButtons $ fromJust $ parseDocument doc $ Txt.pack ident + putStrLn "http://127.0.0.1:2018/" runEnv 2018 $ servePage form servePage :: Form -> Application diff --git a/bureaucromancy.cabal b/bureaucromancy.cabal --- a/bureaucromancy.cabal +++ b/bureaucromancy.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.1 +version: 0.1.0.2 -- A short (one-line) description of the package. synopsis: Parse webforms & render to interactive hypertext @@ -52,7 +52,7 @@ extra-doc-files: CHANGELOG.md -- Extra source files to be distributed with the package, such as examples, or a tutorial module. --- extra-source-files: +extra-source-files: tpl/**/*.html, i18n/*.txt common warnings ghc-options: -Wall @@ -68,7 +68,7 @@ Text.HTML.Form.Colours, Text.HTML.Form.Validate -- Modules included in this library but not exported. - -- other-modules: + other-modules: Text.HTML.Form.I18n -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -78,7 +78,7 @@ file-embed-lzma >=0.0.1 && <1, file-embed >=0.0.15 && < 0.1, mtl >2 && <3, bytestring >=0.11 && <1, text >=2 && <3, containers >=0.6 && <1, xml-conduit >= 1.9 && <2, network-uri >=2.6 && <3, regex-tdfa >=1.3 && <2, - filepath >=1.4 && <2, directory >=1.2 && <2, + filepath >=1.4 && <2, directory >=1.2 && <2, aeson, hourglass >= 0.2.12 && < 0.3, tz >= 0.1 && < 0.2 -- Directories containing source files. @@ -102,8 +102,9 @@ -- Other library packages from which modules are imported. build-depends: - base >=4.16.4.0 && <5, - bureaucromancy, warp, wai, http-types, text, html-conduit + base >=4.16.4.0 && <5, bureaucromancy, + warp >= 3.3.31 && < 3.4, wai >= 3.2.3 && < 3.3, http-types >= 0.12.3 && < 0.13, + text >= 2.0.1 && < 2.1, html-conduit >= 1.3.2 && < 1.4 -- Directories containing source files. hs-source-dirs: app @@ -135,5 +136,5 @@ -- Test dependencies. build-depends: - base ^>=4.16.4.0, + base >=4.16.4.0 && <5, bureaucromancy diff --git a/i18n/en.txt b/i18n/en.txt new file mode 100644 --- /dev/null +++ b/i18n/en.txt @@ -0,0 +1,65 @@ +# Colour Pallet +Slate: Slate +Gray: Gray +Zinc: Zinc +Neutral: Neutral +Stone: Stone +Red: Red +Orange: Orange +Amber: Amber +Yellow: Yellow +Lime: Lime +Green: Green +Emerald: Emerald +Teal: Teal +Cyan: Cyan +Sky: Sky +Blue: Blue +Indigo: Indigo +Violet: Violet +Fuchsia: Fuchsia +Pink: Pink +Rose: Rose + +# Error messages +err required: Required! +err format: Invalid format! +err min chars: Must be at least %0 characters! +err max chars: Must be at most %0 characters! +err min: Must be at least %0! +err max: Must be at most %0! +err increments: Must be in increments of %0 from %1! +err colour: Invalid colour value! +err email: Obviously invalid email address, needs an '@'! +err number: Invalid number! +err URL: Invalid web address! +err time: Invalid time format! +errored: Please correct errors listed in sidebar before submitting this form! + +# Months +January: January +February: February +March: March +April: April +May: May +June: June +July: July +August: August +September: September +October: October +November: November +December: December + +# Keyboard +SPACE: SPACE +DEL: DEL +CLEAR: CLEAR + +# Other +Start!: Start! +Now: Now +# Combines to "Upload to" with "Upload" linked. +# Not great idea to split this phrase into 2 strings, but I don't want to link "to"... +Upload Link: Upload +Upload suffix: to +Restore defaults: Restore defaults diff --git a/src/Text/HTML/Form.hs b/src/Text/HTML/Form.hs --- a/src/Text/HTML/Form.hs +++ b/src/Text/HTML/Form.hs @@ -2,7 +2,8 @@ -- | Parse webforms out of webpages module Text.HTML.Form (Form(..), Input(..), OptionGroup(..), Option(..), FileSelector(..), defaultFileData, ImageData(..), defaultImageData, - TextArea(..), defaultTextArea, parseElement, parseDocument, ensureButtons) where + TextArea(..), defaultTextArea, parseElement, parseElement', + parseDocument, parseDocument', ensureButtons) where import Data.Text (Text) import qualified Data.Text as Txt @@ -39,7 +40,9 @@ -- | The purpose of this form, typically using an external vocabulary. rel :: Text, -- | What data should be sent to the endpoint. - inputs :: [Input] + inputs :: [Input], + -- | Which human language the form is written? To which additional messages should be localized? + lang :: String } -- | Individual piece of data to send to a webservice. @@ -189,7 +192,9 @@ mAttr n = listToMaybe . laxAttribute n -- | Parse a form from the selected HTML element. parseElement :: Cursor -> Maybe Form -parseElement el | _:_ <- laxElement "form" el = Just Form { +parseElement = parseElement' "en" +parseElement' :: Text -> Cursor -> Maybe Form +parseElement' language el | _:_ <- laxElement "form" el = Just Form { action = attr'' "action" el (fromMaybe nullURI . parseURIReference) ".", enctype = attr "enctype" el "", method = attr "method" el "GET", @@ -199,7 +204,9 @@ autocomplete = hasAttr "autocomplete" el, formName = attr "name" el "", rel = attr "rel" el "", - inputs = mapMaybe parseInput $ queryInputs el + inputs = mapMaybe parseInput $ queryInputs el, + lang = Txt.unpack $ fromMaybe language $ listToMaybe $ + mapMaybe (mAttr "lang") $ orSelf ancestor el } | otherwise = Nothing @@ -431,10 +438,12 @@ -- | Parse a named or numerically-indexed form from an HTML document. parseDocument :: Document -> Text -> Maybe Form -parseDocument doc n +parseDocument = parseDocument' "en" +parseDocument' :: Text -> Document -> Text -> Maybe Form +parseDocument' language doc n | Just n' <- readMaybe $ Txt.unpack n, n' < length (forms doc') = - parseElement (forms doc' !! n') - | el:_ <- (forms >=> attributeIs "name" n) doc' = parseElement el + parseElement' language (forms doc' !! n') + | el:_ <- (forms >=> attributeIs "name" n) doc' = parseElement' language el | otherwise = Nothing where forms = orSelf descendant >=> laxElement "form" diff --git a/src/Text/HTML/Form/Colours.hs b/src/Text/HTML/Form/Colours.hs --- a/src/Text/HTML/Form/Colours.hs +++ b/src/Text/HTML/Form/Colours.hs @@ -2,6 +2,8 @@ -- for where we can't provide free-form colour selection. module Text.HTML.Form.Colours(tailwindColours, Colour) where +import Text.HTML.Form.I18n (i18n) + -- Finally a good use for Tailwind! -- Otherwise it strikes me as little more than an illegible alternative to -- the `style` attribute! @@ -9,75 +11,75 @@ -- | Stores a CSS hexcode, with preceding "#" type Colour = String -- | The Tailwind colour pallet: https://v1.tailwindcss.com/docs/customizing-colors#default-color-palette -tailwindColours :: [(String, [(Int, Colour)])] -tailwindColours = [ - "Slate"~>[50~>"#f8fafc", 100~>"#f1f5f9", 200~>"#e2e8f0", 300~>"#cbd5e1", +tailwindColours :: String -> [(String, [(Int, Colour)])] +tailwindColours lang = [ + i "Slate"~>[50~>"#f8fafc", 100~>"#f1f5f9", 200~>"#e2e8f0", 300~>"#cbd5e1", 400~>"#94a3b8", 500~>"#64748b", 600~>"#475569", 700~>"#334155", 800~>"#1e293b", 900~>"#0f172a", 950~>"#020617"], - "Gray"~>[50~>"#f9fafb", 100~>"#f3f4f6", 200~>"#e5e7eb", 300~>"#d1d5db", + i "Gray"~>[50~>"#f9fafb", 100~>"#f3f4f6", 200~>"#e5e7eb", 300~>"#d1d5db", 400~>"#9ca3af", 500~>"#6b7280", 600~>"#4b5563", 700~>"#374151", 800~>"#1f2937", 900~>"#111827", 950~>"#030712"], - "Zinc"~>[50~>"#fafafa", 100~>"#f4f4f5", 200~>"#e4e4e7", 300~>"#d4d4d8", + i "Zinc"~>[50~>"#fafafa", 100~>"#f4f4f5", 200~>"#e4e4e7", 300~>"#d4d4d8", 400~>"#a1a1aa", 500~>"#71717a", 600~>"#52525b", 700~>"#3f3f46", 800~>"#27272a", 900~>"#18181b", 950~>"#09090b"], - "Neutral"~>[50~>"#fafafa", 100~>"#f5f5f5", 200~>"#e5e5e5", 300~>"#d4d4d4", + i "Neutral"~>[50~>"#fafafa", 100~>"#f5f5f5", 200~>"#e5e5e5", 300~>"#d4d4d4", 400~>"#a3a3a3", 500~>"#737373", 600~>"#404040", 700~>"#404040", 800~>"#262626", 900~>"#171717", 950~>"#0a0a0a"], - "Stone"~>[50~>"#fafaf9", 100~>"#f5f5f4", 200~>"#e7e5e4", 300~>"#d6d3d1", + i "Stone"~>[50~>"#fafaf9", 100~>"#f5f5f4", 200~>"#e7e5e4", 300~>"#d6d3d1", 400~>"#a8a29e", 500~>"#78716c", 600~>"#57534e", 700~>"#44403c", 800~>"#292524", 900~>"#1c1917", 950~>"#0c0a09"], - "Red"~>[50~>"#fef2f2", 100~>"#fee2e2", 200~>"#fecaca", 300~>"#fca5a5", + i "Red"~>[50~>"#fef2f2", 100~>"#fee2e2", 200~>"#fecaca", 300~>"#fca5a5", 400~>"#f87171", 500~>"#ef4444", 600~>"#dc2626", 700~>"#b91c1c", 800~>"#991b1b", 900~>"#7f1d1d", 950~>"#450a0a"], - "Orange"~>[50~>"#fff7ed", 100~>"#ffedd5", 200~>"#fed7aa", 300~>"#fdba74", + i "Orange"~>[50~>"#fff7ed", 100~>"#ffedd5", 200~>"#fed7aa", 300~>"#fdba74", 400~>"#fb923c", 500~>"#f97316", 600~>"#ea580c", 700~>"#c2410c", 800~>"#9a3412", 900~>"#7c2d12", 950~>"#431407"], - "Amber"~>[50~>"#fffbeb", 100~>"#fef3c7", 200~>"#fde68a", 300~>"#fcd34d", + i "Amber"~>[50~>"#fffbeb", 100~>"#fef3c7", 200~>"#fde68a", 300~>"#fcd34d", 400~>"#fbbf24", 500~>"#f59e0b", 600~>"#d97706", 700~>"#b45309", 800~>"#92400e", 900~>"#78350f", 950~>"#451a03"], - "Yellow"~>[50~>"#fefce8", 100~>"#fef9c3", 200~>"#fef08a", 300~>"#fde047", + i "Yellow"~>[50~>"#fefce8", 100~>"#fef9c3", 200~>"#fef08a", 300~>"#fde047", 400~>"#facc15", 500~>"#eab308", 600~>"#ca8a04", 700~>"#a16207", 800~>"#854d0e", 900~>"#713f12", 950~>"#422006"], - "Lime"~>[50~>"#f7fee7", 100~>"#ecfccb", 200~>"#d9f99d", 300~>"#bef264", + i "Lime"~>[50~>"#f7fee7", 100~>"#ecfccb", 200~>"#d9f99d", 300~>"#bef264", 400~>"#a3e635", 500~>"#84cc16", 600~>"#65a30d", 700~>"#4d7c0f", 800~>"#3f6212", 900~>"#365314", 950~>"#1a2e05"], - "Green"~>[50~>"#f0fdf4", 100~>"#dcfce7", 200~>"#bbf7d0", 300~>"#86efac", + i "Green"~>[50~>"#f0fdf4", 100~>"#dcfce7", 200~>"#bbf7d0", 300~>"#86efac", 400~>"#4ade80", 500~>"#22c55e", 600~>"#16a34a", 700~>"#15803d", 800~>"#166534", 900~>"#14532d", 950~>"#052e16"], - "Emerald"~>[50~>"#ecfdf5", 100~>"#d1fae5", 200~>"#a7f3d0", 300~>"#6ee7b7", + i "Emerald"~>[50~>"#ecfdf5", 100~>"#d1fae5", 200~>"#a7f3d0", 300~>"#6ee7b7", 400~>"#34d399", 500~>"#10b981", 600~>"#059669", 700~>"#047857", 800~>"#065f46", 900~>"#064e3b", 950~>"#022c22"], - "Teal"~>[50~>"#f0fdfa", 100~>"#ccfbf1", 200~>"#99f6e4", 300~>"#5eead4", + i "Teal"~>[50~>"#f0fdfa", 100~>"#ccfbf1", 200~>"#99f6e4", 300~>"#5eead4", 400~>"#2dd4bf", 500~>"#14b8a6", 600~>"#0f766e", 700~>"#0f766e", 800~>"#115e59", 900~>"#134e4a", 950~>"#042f2e"], - "Cyan"~>[50~>"#ecfeff", 100~>"#cffafe", 200~>"#a5f3fc", 300~>"#67e8f9", + i "Cyan"~>[50~>"#ecfeff", 100~>"#cffafe", 200~>"#a5f3fc", 300~>"#67e8f9", 400~>"#22d3ee", 500~>"#06b6d4", 600~>"#0891b2", 700~>"#0e7490", 800~>"#155e75", 900~>"#164e63", 950~>"#083344"], - "Sky"~>[50~>"#f0f9ff", 100~>"#e0f2fe", 200~>"#bae6fd", 300~>"#7dd3fc", + i "Sky"~>[50~>"#f0f9ff", 100~>"#e0f2fe", 200~>"#bae6fd", 300~>"#7dd3fc", 400~>"#38bdf8", 500~>"#0ea5e9", 600~>"#0284c7", 700~>"#0369a1", 800~>"#075985", 900~>"#0c4a6e", 950~>"#082f49"], - "Blue"~>[50~>"#eff6ff", 100~>"#dbeafe", 200~>"#bfdbfe", 300~>"#93c5fd", + i "Blue"~>[50~>"#eff6ff", 100~>"#dbeafe", 200~>"#bfdbfe", 300~>"#93c5fd", 400~>"#60a5fa", 500~>"#3b82f6", 600~>"#2563eb", 700~>"#1d4ed8", 800~>"#1e40af", 900~>"#1e3a8a", 950~>"#172554"], - "Indigo"~>[50~>"#eef2ff", 100~>"#e0e7ff", 200~>"#c7d2fe", 300~>"#a5b4fc", + i "Indigo"~>[50~>"#eef2ff", 100~>"#e0e7ff", 200~>"#c7d2fe", 300~>"#a5b4fc", 400~>"#818cf8", 500~>"#6366f1", 600~>"#4f46e5", 700~>"#4338ca", 800~>"#3730a3", 900~>"#312e81", 950~>"#1e1b4b"], - "Violet"~>[50~>"#f5f3ff", 100~>"#ede9fe", 200~>"#ddd6fe", 300~>"#c4b5fd", + i "Violet"~>[50~>"#f5f3ff", 100~>"#ede9fe", 200~>"#ddd6fe", 300~>"#c4b5fd", 400~>"#a78bfa", 500~>"#8b5cf6", 600~>"#7c3aed", 700~>"#6d28d9", 800~>"#5b21b6", 900~>"#4c1d95", 950~>"#2e1065"], - "Purple"~>[50~>"#faf5ff", 100~>"#f3e8ff", 200~>"#e9d5ff", 300~>"#d8b4fe", + i "Purple"~>[50~>"#faf5ff", 100~>"#f3e8ff", 200~>"#e9d5ff", 300~>"#d8b4fe", 400~>"#c084fc", 500~>"#a855f7", 600~>"#9333ea", 700~>"#7e22ce", 800~>"#6b21a8", 900~>"#581c87", 950~>"#3b0764"], - "Fuchsia"~>[50~>"#fdf4ff", 100~>"#fae8ff", 200~>"#f5d0fe", 300~>"#f0abfc", + i "Fuchsia"~>[50~>"#fdf4ff", 100~>"#fae8ff", 200~>"#f5d0fe", 300~>"#f0abfc", 400~>"#e879f9", 500~>"#d946ef", 600~>"#c026d3", 700~>"#a21caf", 800~>"#86198f", 900~>"#701a75", 950~>"#4a044e"], - "Pink"~>[50~>"#fdf2f8", 100~>"#fce7f3", 200~>"#fbcfe8", 300~>"#f9a8d4", + i "Pink"~>[50~>"#fdf2f8", 100~>"#fce7f3", 200~>"#fbcfe8", 300~>"#f9a8d4", 400~>"#f472b6", 500~>"#ec4899", 600~>"#db2777", 700~>"#be185d", 800~>"#9d174d", 900~>"#831843", 950~>"#500724"], - "Rose"~>[50~>"#fff1f2", 100~>"#ffe4e6", 200~>"#fecdd3", 300~>"#fda4af", + i "Rose"~>[50~>"#fff1f2", 100~>"#ffe4e6", 200~>"#fecdd3", 300~>"#fda4af", 400~>"#fb7185", 500~>"#f43f5e", 600~>"#e11d48", 700~>"#be123c", 800~>"#9f1239", 900~>"#881337", 950~>"#4c0519"] - ] + ] where i = i18n lang (~>) :: a -> b -> (a, b) a ~> b = (a, b) diff --git a/src/Text/HTML/Form/I18n.hs b/src/Text/HTML/Form/I18n.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/Form/I18n.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TemplateHaskell #-} +module Text.HTML.Form.I18n(strings, langs, i18n, i18n', i18n2, stringsJSON) where + +import Data.FileEmbed (embedDir, makeRelativeToProject) +import Data.Text.Encoding (decodeUtf8Lenient) +import Data.Text (unpack, pack, strip, replace) +import Data.ByteString (ByteString) +import System.FilePath (dropExtension) + +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Key as K +import Data.Aeson (Value(String, Object)) + +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) + +files :: [(FilePath, ByteString)] +files = $(embedDir =<< makeRelativeToProject "i18n") +bs2str :: ByteString -> String +bs2str = unpack . decodeUtf8Lenient + +strings :: String -> [(String, String)] +strings = fromMaybe [] . + flip lookup [(dropExtension k, parseKVs $ bs2str v) | (k, v) <- files] +langs :: [String] +langs = map dropExtension $ map fst files + +i18n :: String -> String -> String +i18n lang key = fromMaybe key $ lookup key $ strings lang + +i18n' :: Show a => String -> String -> a -> String +i18n' lang key subs = replace' "%0" (show subs) $ i18n lang key +i18n2 :: (Show a, Show b) => String -> String -> a -> b -> String +i18n2 lang key subs1 subs2 = replace' "%1" (show subs2) $ i18n' lang key subs1 + +stringsJSON :: String -> Value +stringsJSON = Object . KM.fromList . map inner . strings + where inner (k, v) = (K.fromString k, String $ pack v) + +------ +--- Support +------ + +parseKVs :: String -> [(String, String)] +parseKVs = map inner . filter (isPrefixOf "#") . filter null . map strip' . lines + where inner line = let (k, v) = break (==':') line in (strip' k, strip' v) + +-- | Removes any whitespace at the start or end of a string +strip' :: String -> String +strip' = unpack . strip . pack + +-- | Substitutes one string for another +replace' :: String -> String -> String -> String +replace' needle alt = unpack . replace (pack needle) (pack alt) . pack diff --git a/src/Text/HTML/Form/Validate.hs b/src/Text/HTML/Form/Validate.hs --- a/src/Text/HTML/Form/Validate.hs +++ b/src/Text/HTML/Form/Validate.hs @@ -4,7 +4,8 @@ module Text.HTML.Form.Validate(isInputValid, isInputValid', isFormValid, isFormValid', inputErrorMessage, inputErrorMessage', normalizeInput, normalizeForm) where -import Text.HTML.Form +import Text.HTML.Form hiding (lang) +import Text.HTML.Form.I18n import qualified Data.Text as Txt import Text.Read (readMaybe) import Data.Hourglass @@ -22,82 +23,78 @@ -- | Is the given input valid? isInputValid :: Input -> Bool -isInputValid = null . inputErrorMessage +isInputValid = null . inputErrorMessage "en" -- | Is the given input once normalized valid? isInputValid' :: Input -> Bool -isInputValid' = null . inputErrorMessage' +isInputValid' = null . inputErrorMessage' "en" -- | Describe why a form input is invalid, or return the empty string. -inputErrorMessage :: Input -> String -inputErrorMessage Input { inputType = "hidden" } = "" -- Don't validate hiddens! -inputErrorMessage self@Input { required = True } - | inputType self == "checkbox", not $ checked self = "Required!" +inputErrorMessage :: String -> Input -> String +inputErrorMessage _ Input { inputType = "hidden" } = "" -- Don't validate hiddens! +inputErrorMessage lang self@Input { required = True } + | inputType self == "checkbox", not $ checked self = i18n lang "err required" -- Not validating "radio", needs different API... - | value self == "" = "Required!" -inputErrorMessage Input { value = "" } = "" -- Skip further checks for empty! -inputErrorMessage self@Input { pattern = Just re } - | not $ re `matchTest` value self = "Invalid format!" -inputErrorMessage Input { lengthRange = (Just min', _), value = val } - | Txt.length val < min' = "Must be at least " ++ show min' ++ " characters!" -inputErrorMessage Input { lengthRange = (_, Just max'), value = val } - | Txt.length val > max' = "Must be at most " ++ show max' ++ " characters!" -inputErrorMessage Input { range = (Just min', _), value = val } + | value self == "" = i18n lang "err required" +inputErrorMessage _ Input { value = "" } = "" -- Skip further checks for empty! +inputErrorMessage lang self@Input { pattern = Just re } + | not $ re `matchTest` value self = i18n lang "err format" +inputErrorMessage lang Input { lengthRange = (Just min', _), value = val } + | Txt.length val < min' = i18n' lang "err min chars" min' +inputErrorMessage lang Input { lengthRange = (_, Just max'), value = val } + | Txt.length val > max' = i18n' lang "err max chars" max' +inputErrorMessage lang Input { range = (Just min', _), value = val } | Just x <- readMaybe' val :: Maybe Float, Just y <- readMaybe' min', x < y = - "Must be at least " ++ Txt.unpack min' ++ "!" -inputErrorMessage Input { range = (_, Just max'), value = val } + i18n' lang "err min" min' +inputErrorMessage lang Input { range = (_, Just max'), value = val } | Just x <- readMaybe' val :: Maybe Float, Just y <- readMaybe' max', x > y = - "Must be at most " ++ Txt.unpack max' ++ "!" -inputErrorMessage Input { range = (Just min', _), step = Just step', value = val } + i18n' lang "err max" max' +inputErrorMessage lang Input { range = (Just min', _), step = Just step', value = val } | Just x <- readMaybe' val :: Maybe Integer, Just y <- readMaybe' min', Just z <- readMaybe' step', z /= 0, rem (x - y) z == 0 = - ("Must be in increments of " ++ Txt.unpack step' ++ " from " - ++ Txt.unpack min' ++ "!") -inputErrorMessage Input { range = (Just min', _), value = val } + i18n2 lang "err increments" step' min' +inputErrorMessage lang Input { range = (Just min', _), value = val } | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min', - x < y = "Must be at least " ++ Txt.unpack min' ++ "!" -inputErrorMessage Input { range = (_, Just max'), value = val } + x < y = i18n' lang "err min" min' +inputErrorMessage lang Input { range = (_, Just max'), value = val } | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack max', - x > y = "Must be at most " ++ Txt.unpack max' ++ "!" -inputErrorMessage Input { + x > y = i18n' lang "err max" max' +inputErrorMessage lang Input { range = (Just min', _), step = Just step', inputType = ty, value = val } | ty == "date", Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min', Just z <- readMaybe' step', timeDiff x y `rem` toSeconds mempty { durationSeconds = 24*z } == Seconds 0 = - ("Must be in increments of " ++ Txt.unpack step' ++ " days from " ++ - Txt.unpack min' ++ "!") + i18n2 lang "err increments" step' min' | ty == "month" = "" -- Not prepared to properly validate this... | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min', Just z <- readMaybe' step', timeDiff x y `rem` Seconds z == Seconds 0 = - ("Must be in increments of " ++ Txt.unpack step' ++ "s from " ++ - Txt.unpack min' ++ "!") + i18n2 lang "err increments" step' min' -- Validation specific to input types -inputErrorMessage self@Input { inputType = "color" } - | ("#[0-9a-fA-F]{6}" :: String) =~ value self = "Invalid colour value!" -inputErrorMessage self@Input { inputType = "date" } = isTime' self -inputErrorMessage self@Input { inputType = "datetime" } = isTime' self -inputErrorMessage self@Input { inputType = "datetime-local" } = isTime' self +inputErrorMessage lang self@Input { inputType = "color" } + | ("#[0-9a-fA-F]{6}" :: String) =~ value self = i18n lang "err colour" +inputErrorMessage lang self@Input { inputType = "date" } = isTime' lang self +inputErrorMessage lang self@Input { inputType = "datetime" } = isTime' lang self +inputErrorMessage l self@Input { inputType = "datetime-local" } = isTime' l self -- This validation is less strict than many sites expect, but don't over-validate... -inputErrorMessage self@Input { inputType = "email" } - | '@' `Txt.elem` value self = - "Obviously invalid email address, needs an '@'!" -inputErrorMessage self@Input { inputType = "month" } = isTime' self -inputErrorMessage Input { inputType = "number", value = val } - | isNothing (readMaybe' val :: Maybe Float) = "Invalid number!" -inputErrorMessage Input { inputType = "range", value = val } - | isNothing (readMaybe' val :: Maybe Float) = "Invalid number!" -inputErrorMessage self@Input { inputType = "time" } = isTime' self -inputErrorMessage self@Input { inputType = "url" } - | isURL $ value self = "Invalid web address!" -inputErrorMessage self@Input { inputType = "week" } = isTime' self -inputErrorMessage _ = "" +inputErrorMessage lang self@Input { inputType = "email" } + | '@' `Txt.elem` value self = i18n lang "err email" +inputErrorMessage lang self@Input { inputType = "month" } = isTime' lang self +inputErrorMessage lang Input { inputType = "number", value = val } + | isNothing (readMaybe' val :: Maybe Float) = i18n lang "err number" +inputErrorMessage lang Input { inputType = "range", value = val } + | isNothing (readMaybe' val :: Maybe Float) = i18n lang "err number" +inputErrorMessage lang self@Input { inputType = "time" } = isTime' lang self +inputErrorMessage lang self@Input { inputType = "url" } + | isURL $ value self = i18n lang "err URL" +inputErrorMessage lang self@Input { inputType = "week" } = isTime' lang self +inputErrorMessage _ _ = "" -- | Describe why an input, once normalized, is invalid? Or returns empty string. -inputErrorMessage' :: Input -> [Char] -inputErrorMessage' = inputErrorMessage . normalizeInput +inputErrorMessage' :: String -> Input -> [Char] +inputErrorMessage' lang = inputErrorMessage lang . normalizeInput -- | Helper to parse the time stored in an input. parseTime :: String -> Maybe DateTime @@ -106,9 +103,9 @@ isTime :: Input -> Bool isTime = isJust . parseTime . Txt.unpack . value -- | Emit an error message if an input doesn't store a valid time. -isTime' :: Input -> String -isTime' x | isTime x = "" - | otherwise = "Invalid time format!" +isTime' :: String -> Input -> String +isTime' lang x | isTime x = "" + | otherwise = i18n lang "err time" -- | Parse a Text into any type that can be parsed from strings. readMaybe' :: Read a => Txt.Text -> Maybe a readMaybe' = readMaybe . Txt.unpack diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs --- a/src/Text/HTML/Form/WebApp.hs +++ b/src/Text/HTML/Form/WebApp.hs @@ -182,18 +182,19 @@ _ -> toGVal () renderInput form ix input@Input { inputType = "color" } [] qs = template' "color.html" form ix input qs $ \x -> case x of - "colours" -> V.list $ L.map colourGVal tailwindColours + "colours" -> V.list $ L.map colourGVal $ tailwindColours $ lang form "shades" -> toGVal False "subfolder" -> toGVal False _ -> toGVal () renderInput form ix input@Input { inputType = "color" } [c, ""] qs = template' "color.html" form ix input qs $ \x -> case x of - "colours" -> V.list $ L.map colourGVal tailwindColours - "shades" -> case Txt.unpack c `lookup` tailwindColours of + "colours" -> V.list $ L.map colourGVal $ tailwindColours l + "shades" -> case Txt.unpack c `lookup` tailwindColours l of Just shades -> V.list $ L.map shadeGVal shades Nothing -> toGVal False "subfolder" -> toGVal True _ -> toGVal () + where l = lang form renderInput form ix input [keyboard] qs = renderInput form ix input [keyboard, ""] qs renderInput form ix input [keyboard, ""] qs | Just (Just _) <- resolveSource path = diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs --- a/src/Text/HTML/Form/WebApp/Ginger.hs +++ b/src/Text/HTML/Form/WebApp/Ginger.hs @@ -29,6 +29,7 @@ import Text.HTML.Form.Validate (inputErrorMessage') import Text.HTML.Form.Query (applyQuery) +import Text.HTML.Form.I18n (stringsJSON) -- | A key-value query string. type Query = [(ByteString, Maybe ByteString)] @@ -52,14 +53,16 @@ ctxt :: Text -> GVal (Run SourcePos (Writer Html) Html) ctxt "Q" = query2gval query ctxt "form" = form2gval form - ctxt "inputs" = list' $ Prelude.map (flip input2gval query) $ + ctxt "inputs" = list' $ Prelude.map (\x -> input2gval language x query) $ Prelude.zip [0..] $ inputs form - ctxt "input" = input2gval (ix, input) query + ctxt "input" = input2gval language (ix, input) query ctxt "xURI" = fromFunction xURI + ctxt "_" = toGVal $ stringsJSON language ctxt x = ctxt' x xURI [(_, uri)] = let uri' = Txt.unpack $ asText uri in return$toGVal$Txt.pack $ escapeURIString isUnescapedInURIComponent uri' xURI _ = return $ toGVal () + language = lang form -- | Lookup the given template from a compiled-in directory. resolveSource :: FilePath -> Maybe (Maybe [Char]) @@ -97,11 +100,11 @@ ] -- | Convert an input to Ginger's datamodel. -input2gval :: (Int, Input) -> Query -> GVal m -input2gval (ix, input) query = orderedDict [ +input2gval :: String -> (Int, Input) -> Query -> GVal m +input2gval language (ix, input) query = orderedDict [ "index" ~> ix, "label" ~> label input, - "error" ~> inputErrorMessage' (applyQuery input + "error" ~> inputErrorMessage' language (applyQuery input [(B8.unpack k, B8.unpack $ fromMaybe "" v) | (k, v) <- query]), "description" ~> html (description input), "inputType" ~> inputType input, diff --git a/tpl/base.html b/tpl/base.html new file mode 100644 --- /dev/null +++ b/tpl/base.html @@ -0,0 +1,71 @@ + + + + {{form.method}} {{form.action}} + + + + +

{{form.method}} {{form.action}}

+
+ {% set selected=input.index %} + + + {% block main %} + {% if input.list %}{% endif %} + + {% block control %}
+ {{ input.description }} +
{% endblock %} + {% endblock %} +
+ + diff --git a/tpl/cal/timezone.html b/tpl/cal/timezone.html new file mode 100644 --- /dev/null +++ b/tpl/cal/timezone.html @@ -0,0 +1,13 @@ +{% extends "/base.html" %} + +{%- block main -%}
+ +
+
+

{{ T.zone }}

+ +
{%- endblock -%} diff --git a/tpl/cal/year-numpad.html b/tpl/cal/year-numpad.html new file mode 100644 --- /dev/null +++ b/tpl/cal/year-numpad.html @@ -0,0 +1,28 @@ +{% extends "/base.html" %} + +{%- block main -%}
+

{{ T.year }}

+
+ + + + + + + + + + + + + + + + + + + + + +
789
456
123
{{ _["DEL"] }}0✓
+
{%- endblock -%} diff --git a/tpl/checkbox.html b/tpl/checkbox.html new file mode 100644 --- /dev/null +++ b/tpl/checkbox.html @@ -0,0 +1,1 @@ +{% extends "base.html" %} diff --git a/tpl/color.html b/tpl/color.html new file mode 100644 --- /dev/null +++ b/tpl/color.html @@ -0,0 +1,21 @@ +{% extends "base.html" %} + +{%- block main -%} + {% if shades %}
+ +
{% endif %} +
+ +
+{%- endblock -%} diff --git a/tpl/files.html b/tpl/files.html new file mode 100644 --- /dev/null +++ b/tpl/files.html @@ -0,0 +1,15 @@ +{% extends "base.html" %} + +{%- block main -%} + + + +{%- endblock -%} diff --git a/tpl/gregorian.html b/tpl/gregorian.html new file mode 100644 --- /dev/null +++ b/tpl/gregorian.html @@ -0,0 +1,91 @@ +{% extends "base.html" %} + +{%- block control -%}
+ + +

↓ + {% if input.inputType != "time" %} + {{ T.year }} + ↑ + + ↓ + {{ T.month }} + ↑ + {% endif %} + + {% if input.inputType != "month" %} + {% if input.inputType != "time" %} + ↓ + {{ T.date }} + ↑ + {% endif %} + + {# NOTE: "week" handling is largely a matter of switching to +/- 7days #} + {% if input.inputType != "date" && input.inputType != "week" %} + ↓ + {{ T.hour|pad2 }} + ↑ + : + ↓ + {{ T.minute|pad2 }} + ↑ + {{ T.meridiem }} + + {% if input.inputType != "datetime-local" && input.inputType != "time" %} + ↓ + {{ T.zone }} + ↑

+ {% endif %} + {% endif %} + {% endif %} +

Now + +

+ {% if input.inputType != "time" %} + + {% endif %} + + {% if input.inputType != "month" %} + {# TODO: Do we want to refine this for "week" inputs? #} + {% if input.inputType != "time" %} + + {% endif %} + + {% if input.inputType != "date" && input.inputType != "week" %} + + + {% endif %} + {% endif %} +
+
{%- endblock -%} diff --git a/tpl/image-button.html b/tpl/image-button.html new file mode 100644 --- /dev/null +++ b/tpl/image-button.html @@ -0,0 +1,15 @@ +{% extends "base.html" %} + +{# NOTE: This is pretty much a legacy input type now. + We should be sending x/y coordinates to the server, + but that'd be frustrating to operate using e.g. a TV remote. #} + +{%- block main -%}
+ {{ input.alt }} +
{{ input.description }}
+
+ +

{{ _["Upload Link"] }} {{ _["Upload Suffix"] }} + {{ input.form.action|default(form.action) }} + ({{ input.form.method|default(form.method) }})

+
{%- endblock -%} diff --git a/tpl/keyboards/latin1.html b/tpl/keyboards/latin1.html new file mode 100644 --- /dev/null +++ b/tpl/keyboards/latin1.html @@ -0,0 +1,78 @@ +{% extends "/base.html" %} + +{%- block control -%}
+ {% if input.type != 'password' %} +

{{ input.value }} + {% if input.multiple %}↲{% endif %}

+
+ {% endif %} +

abc | ABC | + !@# | + àêï | + ÀÊÏ

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + {% if input.inputType == "email" || input.inputType == "url" %} + {% if input.inputType == "email" %} + + {% else %} + + {% endif %} + + {% endif %} + + + + + +
abcdef
ghijkl
mnopqr
stuvwx
yz1234
567890
@/..com + .org +
{{ _["SPACE"] }}{{ _["DEL"] }}{{ _["CLEAR"] }}
+
{%- endblock -%} diff --git a/tpl/keyboards/latin1/latin1-accent-lower.html b/tpl/keyboards/latin1/latin1-accent-lower.html new file mode 100644 --- /dev/null +++ b/tpl/keyboards/latin1/latin1-accent-lower.html @@ -0,0 +1,70 @@ +{% extends "/base.html" %} + +{%- block control -%}
+ {% if input.type != 'password' %} +

{{ input.value }} + {% if input.multiple %}↲{% endif %}

+
+ {% endif %} +

abc | ABC | + !@# | àêï | + ÀÊÏ

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + {% if input.inputType == "email" || input.inputType == "url" %} + {% if input.inputType == "email" %} + + {% else %} + + {% endif %} + + {% endif %} + + + + + + +
àáâäãå
èéêëçæ
ìíîïðñ
òóôöõø
ùúûüýÿ
@/..com + .org +
þ{{ _["SPACE"] }}{{ _["DEL"] }}{{ _["CLEAR"] }}
+
{%- endblock -%} diff --git a/tpl/keyboards/latin1/latin1-accent.html b/tpl/keyboards/latin1/latin1-accent.html new file mode 100644 --- /dev/null +++ b/tpl/keyboards/latin1/latin1-accent.html @@ -0,0 +1,71 @@ +{% extends "/base.html" %} + +{%- block control -%}
+ {% if input.type != 'password' %} +

{{ input.value }} + {% if input.multiple %}↲{% endif %}

+
+ {% endif %} +

abc | ABC | + !@# | + àêï | + ÀÊÏ

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + {% if input.inputType == "email" || input.inputType == "url" %} + {% if input.inputType == "email" %} + + {% else %} + + {% endif %} + + {% endif %} + + + + + + +
ÀÁÂÄÃÅ
ÈÉÊËÇÆ
ÌÍÎÏÐÑ
ÒÓÔÖÕØ
ÙÚÛÜÝß
@/..com + .org +
Þ{{ _["SPACE"] }}{{ _["DEL"] }}{{ _["CLEAR"] }}
+
{%- endblock -%} diff --git a/tpl/keyboards/latin1/latin1-symbol.html b/tpl/keyboards/latin1/latin1-symbol.html new file mode 100644 --- /dev/null +++ b/tpl/keyboards/latin1/latin1-symbol.html @@ -0,0 +1,111 @@ +{% extends "/base.html" %} + +{%- block control -%}
+ {% if input.type != 'password' %} +

{{ input.value }} + {% if input.multiple %}↲{% endif %}

+
+ {% endif %} +

abc | ABC | + !@# | àêï | + ÀÊÏ

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + {% if input.inputType == "email" || input.inputType == "url" %} + {% if input.inputType == "email" %} + + {% else %} + + {% endif %} + + {% endif %} + + + + + + +
?,.:;()
/="'![]
\~`|@{}
¸%^&*<>
#$-_´·
×¢£¤¥«»
÷§¨©ª¡¦
µ¬¯®°±¿
º¹²³¼½¾
@/..com + .org +
+{{ _["SPACE"] }}{{ _["DEL"] }}{{ _["CLEAR"] }}
+
{%- endblock -%} diff --git a/tpl/keyboards/latin1/latin1-upper.html b/tpl/keyboards/latin1/latin1-upper.html new file mode 100644 --- /dev/null +++ b/tpl/keyboards/latin1/latin1-upper.html @@ -0,0 +1,78 @@ +{% extends "/base.html" %} + +{%- block control -%}
+ {% if input.type != 'password' %} +

{{ input.value }} + {% if input.multiple %}↲{% endif %}

+
+ {% endif %} +

abc | ABC | + !@# | + àêï | + ÀÊÏ

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + {% if input.inputType == "email" || input.inputType == "url" %} + {% if input.inputType == "email" %} + + {% else %} + + {% endif %} + + {% endif %} + + + + + +
ABCDEF
GHIJKL
MNOPQR
STUVWX
YZ1234
567890
@/..com + .org +
{{ _["SPACE"] }}{{ _["DEL"] }}{{ _["CLEAR"] }}
+
{%- endblock -%} diff --git a/tpl/number.html b/tpl/number.html new file mode 100644 --- /dev/null +++ b/tpl/number.html @@ -0,0 +1,34 @@ +{% extends "base.html" %} + +{%- block main -%}
+

↓ + {{ input.value }} + ↑

+
+ + + + + + + + + + + + + + + + + + + + + + + + + +
789-
456{{ _["SPACE"] }}
123{{ _["DEL"] }}
.0,{{ _["CLEAR"] }}
+
{%- endblock -%} diff --git a/tpl/radio.html b/tpl/radio.html new file mode 100644 --- /dev/null +++ b/tpl/radio.html @@ -0,0 +1,1 @@ +{% extends "base.html" %} diff --git a/tpl/reset.html b/tpl/reset.html new file mode 100644 --- /dev/null +++ b/tpl/reset.html @@ -0,0 +1,7 @@ +{% extends "base.html" %} + +{%- block main -%}
+
{{ input.description }}
+
+

{{ _["Restore defaults"] }}

+
{%- endblock -%} diff --git a/tpl/select.html b/tpl/select.html new file mode 100644 --- /dev/null +++ b/tpl/select.html @@ -0,0 +1,32 @@ +{% extends "base.html" %} + +{%- block main -%}
+

{{ input.label }}

+ {{ input.description }} +
+ +
{%- endblock -%} diff --git a/tpl/submit.html b/tpl/submit.html new file mode 100644 --- /dev/null +++ b/tpl/submit.html @@ -0,0 +1,14 @@ +{% extends "base.html" %} + +{%- block main -%}
+
{{ input.description }}
+
+ {% if isFormValid %} + +

Upload to + {{ input.form.action|default(form.action) }} + ({{ input.form.method|default(form.method) }})

+ {% else %} +

{{ _["errored"] }}

+ {% endif %} +
{%- endblock -%} diff --git a/tpl/tel.html b/tpl/tel.html new file mode 100644 --- /dev/null +++ b/tpl/tel.html @@ -0,0 +1,32 @@ +{% extends "base.html" %} + +{%- block control -%}
+

{{ input.value }}

+
+ + + + + + + + + + + + + + + + + + + + + + + + + +
789-
456{{ _["SPACE"] }}
123{{ _["DEL"] }}
*0#.
+
{%- endblock -%}