~alcinnz/Hearth

ref: eb8647bf2cf818bad383a26ddfc93a77f3ea4d8c Hearth/app/Main.hs -rw-r--r-- 1.3 KiB
eb8647bf — Adrian Cochrane Remove backupfile. 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 (/= ';')