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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- Developer allocation
--
-- : out devalloc-host
-- : dep clay
-- : dep cmark
-- : sys cmark
-- : dep envy
-- : dep lucid
-- : dep miso
-- : dep protolude
-- : dep servant
-- : dep servant-server
-- : dep warp
module Biz.Devalloc.Host
( main,
)
where
import Alpha
import Biz.App (CSS (..), HtmlApp (..))
-- import qualified CMark as Cmark
import qualified Biz.Devalloc.Page.Home as Home
import qualified Biz.Devalloc.Page.Signup as Signup
import qualified Biz.Look
import qualified Clay
import qualified Control.Exception as Exception
import qualified Lucid
import qualified Lucid.Base as Lucid
import Miso hiding (node)
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.RequestLogger (logStdout)
import Servant
import qualified System.Envy as Envy
main :: IO ()
main = Exception.bracket startup shutdown run
where
startup =
Envy.decodeWithDefaults Envy.defConfig >>= \cfg -> do
-- pitchText <- readFile <| pitches cfg
-- let pitch = Cmark.commonmarkToHtml [] pitchText
putText "@"
putText "devalloc"
putText <| "port: " <> (show <| port cfg)
return (cfg, serve (Proxy @AllRoutes) <| serverHandlers)
shutdown :: (Config, Application) -> IO ()
shutdown _ = pure ()
run :: (Config, Wai.Application) -> IO ()
run (cfg, app) = Warp.run (port cfg) (logStdout app)
type HomeServer = ToServerRoutes Home.Path HtmlApp Home.Move
type SignupServer = ToServerRoutes Signup.Path HtmlApp Signup.Move
type AllRoutes = HomeServer :<|> SignupServer :<|> CssRoute
type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
cssHandlers :: Server CssRoute
cssHandlers = return . toStrict <| Clay.render look
instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
toHtmlRaw = Lucid.toHtml
toHtml (HtmlApp x) =
Lucid.doctypehtml_ <| do
Lucid.head_ <| do
Lucid.meta_ [Lucid.charset_ "utf-8"]
jsRef "/static/all.js"
jsRef "//unpkg.com/turbolinks@5.2.0/dist/turbolinks.js"
cssRef "/css/main.css"
Lucid.body_ (Lucid.toHtml x)
where
jsRef _href =
Lucid.with
(Lucid.script_ mempty)
[ Lucid.makeAttribute "src" _href,
Lucid.makeAttribute "async" mempty,
Lucid.makeAttribute "defer" mempty
]
cssRef _href =
Lucid.with
(Lucid.link_ mempty)
[ Lucid.rel_ "stylesheet",
Lucid.type_ "text/css",
Lucid.href_ _href
]
data Config = Config
{ port :: Warp.Port,
-- | A yaml file of pitches
pitches :: FilePath,
node :: FilePath
}
deriving (Generic, Show)
instance Envy.DefConfig Config where
defConfig =
Config
{ port = 3000,
pitches = "./Biz/Devalloc/pitch.md",
node = "_/bild/dev/Devalloc.Node/static"
}
instance Envy.FromEnv Config
serverHandlers :: Server AllRoutes
serverHandlers = Home.host :<|> Signup.host :<|> cssHandlers
look :: Clay.Css
look = do
Biz.Look.fuckingStyle
"body" Clay.? Biz.Look.fontStack
|
