blob: e84398770e87f486eea986b84f27f150243bb35b (
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
100
101
102
103
104
105
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# 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 GitHash (giHash, tGitInfoCwd)
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_ $ do
page
L.p_ gitCommit
where
page = L.toHtml x
gitCommit = L.toHtml $ giHash $$tGitInfoCwd
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 =
Acid.query' keep $ Keep.GetPeople 20
|
