blob: dae17ef5b6b110db586fe87f5fe94dcc7bb9d324 (
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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- | Server
module Com.InfluencedByBooks.Server where
import qualified Clay
import Com.InfluencedByBooks.Core
import qualified Com.InfluencedByBooks.Keep as Keep
import qualified Com.InfluencedByBooks.Look as Look
import Com.Simatime.Alpha
import Com.Simatime.Network
import Data.Acid (AcidState)
import qualified Data.Acid.Abstract as Acid
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text.Lazy.Encoding as Lazy
import qualified Lucid as L
import Lucid.Base
import Miso
import Network.HTTP.Media ((//), (/:))
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 "rise: ibb"
staticDir <- fromMaybe "static"
<$> lookupEnv "STATIC_DIR" :: IO [Char]
port <- read
<$> fromMaybe "3000"
<$> lookupEnv "PORT" :: IO Int
keep <- Keep.openLocal "_keep/"
say "port: 3000"
run port $ logStdout $ compress $ app staticDir $ 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/ibb.js"
cssRef "/css/main.css"
L.body_ $ do
page
where
page = L.toHtml x
jsRef href = L.with (L.script_ mempty)
[ makeAttribute "src" href
, makeAttribute "type" "text/javascript"
, makeAttribute "async" mempty
, makeAttribute "defer" mempty
]
cssRef href = L.with
(L.link_ mempty)
[L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action
handle404 :: Application
handle404 _ respond = respond
$ responseLBS status404 [("Content-Type", "text/html")]
$ renderBS
$ toHtml
$ HtmlPage
$ notfound
newtype CSS = CSS { unCSS :: Text }
instance MimeRender CSS Text where
mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
instance Accept CSS where
contentType _ = "text" // "css" /: ("charset", "utf-8")
type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
type Routes
= "static" :> Raw
:<|> CssRoute
:<|> ServerRoutes
:<|> "api" :> ApiRoutes
:<|> Raw
cssHandlers :: Server CssRoute
cssHandlers = return . Lazy.toStrict . Clay.render
$ Look.main
app :: [Char] -> AcidState Keep.IbbKeep -> Application
app staticDir keep = serve
(Proxy @Routes)
$ static
:<|> cssHandlers
:<|> serverHandlers
:<|> apiHandlers keep
:<|> Tagged handle404
where
static = serveDirectoryWith
(defaultWebAppSettings $ staticDir)
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
|
