blob: 9f1ac5f421774b923548cdb41adae5a8f7c8730a (
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- | Server
--
-- : exe ibb
--
-- : dep clay
-- : dep miso
-- : dep protolude
-- : dep servant
-- : dep text
-- : dep MonadRandom
-- : dep acid-state
-- : dep bytestring
-- : dep ixset
-- : dep random
-- : dep safecopy
-- : dep scotty
-- : dep servant-server
-- : dep text
module Biz.Ibb.Server where
import Alpha
import qualified Clay
import Biz.Ibb.Core
import qualified Biz.Ibb.Keep as Keep
import qualified Biz.Ibb.Look as Look
import Network.RemoteData
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
|
