From b7acdbaa7957bbd8b008c339473a439cbabd0419 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 28 Oct 2023 19:32:44 +1300 Subject: [PATCH] Add (partial) support image buttons. --- app/Main.hs | 12 ++++++++++-- src/Text/HTML/Form.hs | 11 ++++++++--- src/Text/HTML/Form/Query.hs | 2 ++ src/Text/HTML/Form/WebApp.hs | 25 ++++++++++++++++++++----- src/Text/HTML/Form/WebApp/Ginger.hs | 10 ++++++---- 5 files changed, 46 insertions(+), 14 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 77a980c..f753263 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,13 +7,15 @@ import Network.HTTP.Types import System.Environment (getArgs) import Text.HTML.Form.WebApp +import Text.HTML.Form.Query import Text.HTML.Form import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.Text.Encoding as Txt import Data.Text.Lazy (fromStrict) import qualified Data.Text as Txt import qualified Text.HTML.DOM as HTML -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, fromMaybe) main :: IO () main = do @@ -29,5 +31,11 @@ servePage :: Form -> Application servePage form req respond = do ret <- renderPage form (pathInfo req) (queryString req) case ret of - Just txt -> respond $ responseLBS status200 [] $ encodeUtf8 $ fromStrict txt + Just (Right txt) -> + respond $ responseLBS status200 [] $ encodeUtf8 $ fromStrict txt + Just (Left qs) -> respond $ responseLBS status200 [] $ + encodeUtf8 $ fromStrict $ Txt.pack $ renderQueryString' + [(utf8 k, utf8 $ fromMaybe "" v) | (k, v) <- qs] Nothing -> respond $ responseLBS status404 [] "Unknown input or operation!" + +utf8 = Txt.unpack . Txt.decodeUtf8 diff --git a/src/Text/HTML/Form.hs b/src/Text/HTML/Form.hs index 59634a3..3cb16c5 100644 --- a/src/Text/HTML/Form.hs +++ b/src/Text/HTML/Form.hs @@ -143,7 +143,10 @@ queryInputs form = (allInputs >=> inForm) form nestedInForm x = listToMaybe ((ancestor >=> laxElement "form") x) == Just form parseInput :: Cursor -> Maybe Input parseInput el | _:_ <- laxElement "input" el = Just Input { - label = fromMaybe (attr "name" el "") $ fmap text label', + label = fromMaybe + -- Additional fallbacks are primarily for buttons + (attr "name" el $ attr "value" el $ attr "alt" el $ + attr "type" el "text") $ fmap text label', description = fromMaybe (mkEl $ attr "title" el "") $ fmap node $ elByID (attr "aria-describedby" el "") `orElse` label', inputType = attr "type" el "text", @@ -151,8 +154,10 @@ parseInput el | _:_ <- laxElement "input" el = Just Input { inputAutocomplete = attr "autocomplete" el "on", autofocus = hasAttr "autofocus" el, checked = hasAttr "checked" el, - disabled = hasAttr "disabled" el, - readonly = hasAttr "readonly" el, + -- NOTE: No remaining harm in displaying hidden inputs, + -- might be informative... + disabled = hasAttr "disabled" el || attr "type" el "" == "hidden", + readonly = hasAttr "readonly" el || attr "type" el "" == "hidden", multiple = hasAttr "multiple" el, dirname = attr "dirname" el "", inputName = attr "name" el "", diff --git a/src/Text/HTML/Form/Query.hs b/src/Text/HTML/Form/Query.hs index 3bfcb62..2dbf4ae 100644 --- a/src/Text/HTML/Form/Query.hs +++ b/src/Text/HTML/Form/Query.hs @@ -17,6 +17,8 @@ renderQueryString' query = intercalate "&" [ renderQuery' :: Form -> [(String, String)] renderQuery' form = concatMap renderInput' $ inputs form renderInput' :: Input -> [(String, String)] +renderInput' Input { inputType = inputType' } + | inputType' `elem` ["submit", "reset", "button"] = [] renderInput' Input { checked = False, inputType = inputType' } | inputType' `elem` ["radio", "checkbox"] = [] renderInput' Input { inputType = "" } [] qs = template "select.html" form ix input qs +renderInput form ix input@Input { inputType="submit" } [] qs = + template "submit.html" form ix input qs +renderInput _ _ input@Input { inputType="submit" } ["_"] qs = + return $ Just $ Left $ set (inputName input) (value input) qs +renderInput form ix input@Input { inputType="image" } [] qs = + template "image-button.html" form ix input qs +renderInput _ _ input@Input { inputType="image" } ["_"] qs = + return $ Just $ Left $ set (inputName input) (value input) qs +renderInput form ix input@Input { inputType="reset" } [] qs = + template "reset.html" form ix input qs +renderInput form ix input@Input { inputType="reset" } ["_"] _ = + template "reset.html" form ix input + [(utf8' k, Just $ utf8' v) | (k, v) <- renderQuery' form] renderInput form ix input [keyboard] qs = renderInput form ix input [keyboard, ""] qs renderInput form ix input [keyboard, ""] qs | Just (Just _) <- resolveSource path = @@ -92,7 +106,7 @@ renderInput form ix input [] qs = do | otherwise = "latin1" template ("keyboards/" ++ keyboard' ++ ".html") form ix input qs renderInput _ _ input _ _ = - return $ Just $ Txt.concat ["Unknown input type: ", inputType input] + return $ Just $ Right $ Txt.concat ["Unknown input type: ", inputType input] utf8 :: Text -> ByteString utf8 = Txt.encodeUtf8 @@ -100,6 +114,7 @@ utf8' :: String -> ByteString utf8' = utf8 . Txt.pack set :: Text -> Text -> [(ByteString, Maybe ByteString)] -> [(ByteString, Maybe ByteString)] +set "" _ qs = qs -- Mostly for buttons! set k' v' qs = (utf8 k', Just $ utf8 v'):[q | q@(k, _) <- qs, k /= utf8 k'] unset :: Text -> Text -> [(ByteString, Maybe ByteString)] -> [(ByteString, Maybe ByteString)] diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs index 5621d22..c8e2962 100644 --- a/src/Text/HTML/Form/WebApp/Ginger.hs +++ b/src/Text/HTML/Form/WebApp/Ginger.hs @@ -27,13 +27,15 @@ import Data.Maybe (fromMaybe, isJust) import qualified Data.Map as M type Query = [(ByteString, Maybe ByteString)] -template :: Monad m => String -> Form -> Int -> Input -> Query -> m (Maybe Text) +template :: Monad m => String -> Form -> Int -> Input -> Query -> + m (Maybe (Either Query Text)) template name form ix input query | Just (Right tpl) <- parseGingerFile resolveSource name = - return $ Just $ htmlSource $ flip runGinger tpl $ makeContextHtml ctxt + return $ Just $ Right $ htmlSource $ + flip runGinger tpl $ makeContextHtml ctxt | Just (Left err) <- parseGingerFile resolveSource name = - return $ Just $ Txt.pack $ show err - | otherwise = return $ Just "Unexpected error!" + return $ Just $ Right $ Txt.pack $ show err + | otherwise = return $ Just $ Right "Unexpected error!" where ctxt :: Text -> GVal (Run SourcePos (Writer Html) Html) ctxt "Q" = query2gval query -- 2.30.2