~alcinnz/bureaucromancy

ref: 9014ee29b761a6991879b5740e1ba1cdc23dd997 bureaucromancy/app/Main.hs -rw-r--r-- 1.3 KiB
9014ee29 — Adrian Cochrane Add file-input support, upload missing files. 1 year, 2 months ago
                                                                                
fa8b4fac Adrian Cochrane
9ecdfe8a Adrian Cochrane
fa8b4fac Adrian Cochrane
4e46e68a Adrian Cochrane
fa8b4fac Adrian Cochrane
b7acdbaa Adrian Cochrane
4e46e68a Adrian Cochrane
fa8b4fac Adrian Cochrane
b7acdbaa Adrian Cochrane
fa8b4fac Adrian Cochrane
4e46e68a Adrian Cochrane
a3d5ae54 Adrian Cochrane
b7acdbaa Adrian Cochrane
fa8b4fac Adrian Cochrane
9ecdfe8a Adrian Cochrane
4e46e68a Adrian Cochrane
a3d5ae54 Adrian Cochrane
4e46e68a Adrian Cochrane
fa8b4fac Adrian Cochrane
4e46e68a Adrian Cochrane
fa8b4fac Adrian Cochrane
b7acdbaa Adrian Cochrane
fa8b4fac Adrian Cochrane
b7acdbaa Adrian Cochrane
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
{-# 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
  runEnv 2018 $ servePage $ fromJust $ parseDocument doc $ Txt.pack ident

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