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
|
{-# 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.Look
import qualified Biz.Devalloc.Core as Core
import qualified Biz.Devalloc.Path as Path
import qualified Clay
import qualified Control.Exception as Exception
import qualified Data.Text as Text
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 Network.Wai.Application.Static (defaultWebAppSettings)
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)
putText <| "node: " <> (Text.pack <| node cfg)
let static = serveDirectoryWith <| defaultWebAppSettings <| node cfg
return (cfg, serve (Proxy @AllPaths) <| serverHandlers static)
shutdown :: (Config, Application) -> IO ()
shutdown _ = pure ()
run :: (Config, Wai.Application) -> IO ()
run (cfg, app) = Warp.run (port cfg) (logStdout app)
type HostPaths = ToServerRoutes Path.Paths HtmlApp Core.Move
type AllPaths = ("static" :> Raw) :<|> HostPaths :<|> 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"
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/static/devalloc.js"
}
instance Envy.FromEnv Config
home :: Handler (HtmlApp (View Core.Move))
home =
Core.Form {Core.uri = Path.home}
|> Core.view
|> HtmlApp
|> pure
signup :: Handler (HtmlApp (View Core.Move))
signup =
Core.Form {Core.uri = Path.signup}
|> Core.view
|> HtmlApp
|> pure
serverHandlers :: Tagged Handler Application -> Server AllPaths
serverHandlers static = static :<|> (home :<|> signup) :<|> cssHandlers
look :: Clay.Css
look = do
Biz.Look.fuckingStyle
"body" Clay.? Biz.Look.fontStack
|
