~alcinnz/Hearth

ref: 2d9cd8737c9d8e4803dedfcc79f35a8ac0944e3a Hearth/app/Main.hs -rw-r--r-- 1.3 KiB
2d9cd873 — Adrian Cochrane Add addressbar, POST-handlers, & i18n 11 months ago 
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
{-# LANGUAGE OverloadedStrings #-}
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 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, handleForm)

main :: IO ()
main = do
  runEnv 2019 servePage

servePage :: Application
servePage req respond = case requestMethod req of
  "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 (/= ';')