blob: dd26d9676b092cabb1e160b8139aaa05f8eadcc4 (
plain)
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- | Server
module Ibb where
import Alpha
import Biz.Ibb
import Data.Maybe (fromMaybe)
import Data.Proxy
import qualified Lucid as L
import Lucid.Base
import Miso
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Application.Static
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.RequestLogger
import Servant
import System.Environment (lookupEnv)
main :: IO ()
main = do
say "running"
port <- read
<$> fromMaybe "3000"
<$> lookupEnv "PORT" :: IO Int
run port $ logStdout $ compress $ app
where
compress = gzip def { gzipFiles = GzipCompress }
newtype HtmlPage a = HtmlPage a
deriving (Show, Eq)
instance L.ToHtml a => L.ToHtml (HtmlPage a) where
toHtmlRaw = L.toHtml
toHtml (HtmlPage x) =
L.doctypehtml_ $ do
L.head_ $ do
L.meta_ [L.charset_ "utf-8"]
jsRef "/static/app.js"
L.body_ (L.toHtml x)
where
jsRef href = L.with (L.script_ mempty)
[ makeAttribute "src" href
, makeAttribute "type" "text/javascript"
-- , makeAttribute "async" mempty
-- , makeAttribute "defer" mempty
]
type ServerRoutes = ToServerRoutes Routes HtmlPage Action
handle404 :: Application
handle404 _ respond = respond
$ responseLBS status404 [("Content-Type", "text/html")]
$ renderBS
$ toHtml
$ HtmlPage
$ notfound
type Api = "static" :> Raw
:<|> ServerRoutes
:<|> Raw
app :: Application
app = serve (Proxy @Api)
$ static :<|> serverHandlers :<|> Tagged handle404
where
static = serveDirectoryWith (defaultWebAppSettings "ibb.jsexe")
serverHandlers :: Server ServerRoutes
serverHandlers = homeHandler
where
send f u =
pure $ HtmlPage $ f Model { uri = u, people = NotAsked }
homeHandler = send home goHome
|
