blob: 6d934f9600e4ccb3d0420c84fd267552d06b6f7f (
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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- | Server
module Ibb where
import Alpha
import Biz.Ibb
import qualified Biz.Ibb.Keep as Keep
import Data.Maybe (fromMaybe)
import Data.Acid (AcidState)
import qualified Data.Acid.Abstract as Acid
import qualified Lucid as L
import Lucid.Base
import Miso
import Network.HTTP.Types
import Network.RemoteData
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 "rise: ibb"
port <- read
<$> fromMaybe "3000"
<$> lookupEnv "PORT" :: IO Int
keep <- Keep.openLocal "keep/"
say "port: 3000"
run port $ logStdout $ compress $ app $ keep
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/all.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 AppRoutes HtmlPage Action
handle404 :: Application
handle404 _ respond = respond
$ responseLBS status404 [("Content-Type", "text/html")]
$ renderBS
$ toHtml
$ HtmlPage
$ notfound
type Routes = "static" :> Raw
:<|> ServerRoutes
:<|> "api" :> ApiRoutes
:<|> Raw
app :: AcidState Keep.IbbKeep -> Application
app keep = serve
(Proxy @Routes)
$ static
:<|> serverHandlers
:<|> apiHandlers keep
:<|> Tagged handle404
where
static = serveDirectoryWith (defaultWebAppSettings "ibb.jsexe")
type ApiRoutes =
"people" :> Get '[JSON] [Person]
serverHandlers :: Server ServerRoutes
serverHandlers = homeHandler
where
send f u =
pure $ HtmlPage $ f Model { uri = u, people = NotAsked }
homeHandler = send home goHome
-- | for now we just have one api endpoint, which returns all the people
apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes
apiHandlers keep = do
people <- Acid.query' keep $ Keep.GetPeople 20
return $ people
|
