~alcinnz/bureaucromancy

ref: d6349351d838372d9199a690c5997382d13269c7 bureaucromancy/app/Main.hs -rw-r--r-- 1.3 KiB
d6349351 — Adrian Cochrane Validate form before submitting, ensure submit & reset buttons are present! 1 year, 30 days 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
39
40
41
42
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Network.Wai.Handler.Warp
import Network.Wai
import Network.HTTP.Types
import System.Environment (getArgs)

import Text.HTML.Form.WebApp
import Text.HTML.Form.Query
import Text.HTML.Form

import Data.Text.Lazy.Encoding (encodeUtf8)
import qualified Data.Text.Encoding as Txt
import Data.Text.Lazy (fromStrict)
import qualified Data.Text as Txt
import qualified Text.HTML.DOM as HTML
import Data.Maybe (fromJust, fromMaybe)

main :: IO ()
main = do
  args <- getArgs
  let (filename, ident) = case args of
        n:anchor:_ -> (n, anchor)
        [n] -> (n, "0")
        [] -> ("form.html", "0")
  doc <- HTML.readFile filename
  let form = ensureButtons $ fromJust $ parseDocument doc $ Txt.pack ident
  runEnv 2018 $ servePage form

servePage :: Form -> Application
servePage form req respond = do
    ret <- renderPage form (pathInfo req) (queryString req)
    case ret of
        Just (Right txt) ->
            respond $ responseLBS status200 [] $ encodeUtf8 $ fromStrict txt
        Just (Left qs) -> respond $ responseLBS status200 [] $
            encodeUtf8 $ fromStrict $ Txt.pack $ renderQueryString'
            [(utf8 k, utf8 $ fromMaybe "" v) | (k, v) <- qs]
        Nothing -> respond $ responseLBS status404 [] "Unknown input or operation!"

utf8 = Txt.unpack . Txt.decodeUtf8