~alcinnz/Hearth

ref: ad72934e6b720b68ecba478e737a5237b5b57513 Hearth/app/Main.hs -rw-r--r-- 1.3 KiB
ad72934e — Adrian Cochrane Add a topsites listing with history page 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 (/= ';')