~alcinnz/Hearth

ref: 4e15670910c6c8993103edc00b23f240b170cfa1 Hearth/app/Main.hs -rw-r--r-- 1.3 KiB
4e156709 — Adrian Cochrane Upload missing files, implement TopSites backend! 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 (/= ';')