From 2d9cd8737c9d8e4803dedfcc79f35a8ac0944e3a Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 11 Jan 2024 16:47:33 +1300 Subject: [PATCH] Add addressbar, POST-handlers, & i18n --- Hearth.cabal | 7 ++++--- app/Main.hs | 26 ++++++++++++++++++++++---- tpl/index.html | 11 +++++++++++ 3 files changed, 37 insertions(+), 7 deletions(-) diff --git a/Hearth.cabal b/Hearth.cabal index 5f2e6ee..5fd6567 100644 --- a/Hearth.cabal +++ b/Hearth.cabal @@ -52,7 +52,7 @@ build-type: Simple 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/*.json common warnings ghc-options: -Wall @@ -72,7 +72,7 @@ library -- Other library packages from which modules are imported. build-depends: base ^>=4.17.0.0, ginger>0.10 && <1, bytestring, text, - file-embed, mtl, filepath + file-embed, mtl, filepath, aeson -- Directories containing source files. hs-source-dirs: src-lib @@ -98,7 +98,8 @@ executable Hearth base ^>=4.17.0.0, Hearth, 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 + wai-extra >= 3.1 && < 4, http-types >= 0.12.3 && < 0.13, + text >= 2.0.1 && < 2.1, bytestring >= 0.11 && < 1 -- Directories containing source files. hs-source-dirs: app diff --git a/app/Main.hs b/app/Main.hs index 2a3ef7e..f27e612 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,10 +4,16 @@ module Main where import Network.Wai.Handler.Warp import Network.Wai import Network.HTTP.Types +import Network.Wai.Parse + import Data.Text.Lazy (fromStrict) -import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.Text as Txt +import qualified Data.Text.Lazy.Encoding as LTxt +import Data.Text.Encoding (decodeUtf8) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) -import Hearth (renderPage) +import Hearth (renderPage, handleForm) main :: IO () main = do @@ -15,6 +21,18 @@ main = do servePage :: Application servePage req respond = case requestMethod req of - "GET" | Just resp <- renderPage (rawPathInfo req) (queryString req) -> - respond $ responseLBS status200 [] $ encodeUtf8 $ fromStrict resp + "GET" | Just resp <- renderPage (rawPathInfo req) (queryString req) (headerAcceptLang req) -> + respond $ responseLBS status200 [] $ LTxt.encodeUtf8 $ fromStrict resp + "POST" -> do + (query, _) <- parseRequestBodyEx defaultParseRequestBodyOptions lbsBackEnd req + redirect <- handleForm (rawPathInfo req) query + respond $ responseLBS status301 [(hLocation, redirect)] "" _ -> respond $ responseLBS status404 [] "Page not found!" + +headerAcceptLang :: Request -> [Txt.Text] +headerAcceptLang = parseAcceptLang . lookup hAcceptLanguage . requestHeaders +parseAcceptLang :: Maybe ByteString -> [Txt.Text] +parseAcceptLang = map dropParam . Txt.splitOn "," . decodeUtf8 . fromMaybe "en" + where dropParam = Txt.takeWhile (/= ';') + + diff --git a/tpl/index.html b/tpl/index.html index e69de29..8c0eaba 100644 --- a/tpl/index.html +++ b/tpl/index.html @@ -0,0 +1,11 @@ + + + + + {{ _["Homepage"] }} + + +
+

+
+ -- 2.30.2