-
Notifications
You must be signed in to change notification settings - Fork 6
/
Main.hs
166 lines (151 loc) · 4.94 KB
/
Main.hs
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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
module Main where
import Control.Monad (forever)
import Data.ByteString.Lazy qualified as BL
import Data.String.Conversions (cs)
import Data.String.Interpolate (i)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as L
import Data.Text.Lazy.Encoding qualified as L
import Effectful
import Effectful.Concurrent.STM
import Effectful.Dispatch.Dynamic
import Effectful.Reader.Static
import Effectful.State.Static.Local
import Example.Concurrent qualified as Concurrent
import Example.Contacts qualified as Contacts
import Example.Counter qualified as Counter
import Example.Effects.Debug as Debug
import Example.Effects.Users as Users
import Example.Errors qualified as Errors
import Example.Forms qualified as Forms
import Example.LazyLoading qualified as LazyLoading
import Example.Redirects qualified as Redirects
import Example.Search qualified as Search
import Example.Sessions qualified as Sessions
import Example.Simple qualified as Simple
import Example.Style qualified as Style
import Example.Transitions qualified as Transitions
import GHC.Generics (Generic)
import Network.HTTP.Types (Method, QueryItem, methodPost, status200, status404)
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Middleware.Static (addBase, staticPolicy)
import Network.WebSockets (Connection, PendingConnection, acceptRequest, defaultConnectionOptions)
import Web.Hyperbole
import Web.Hyperbole.Effect.Server (Request (..))
-- import Network.Wai.Handler.WebSockets (websocketsOr)
main :: IO ()
main = do
putStrLn "Starting Examples on http://localhost:3000"
users <- Users.initUsers
count <- runEff $ runConcurrent Counter.initCounter
Warp.run 3000 $
staticPolicy (addBase "client/dist") $
app users count
data AppRoute
= Main
| Simple
| Hello Hello
| Contacts
| Transitions
| Query
| Counter
| Forms
| LiveSearch
| Sessions
| Redirects
| RedirectNow
| LazyLoading
| Concurrent
| Errors
deriving (Eq, Generic)
instance Route AppRoute where
baseRoute = Just Main
data Hello
= Greet Text
| Redirected
deriving (Eq, Generic, Route)
app :: UserStore -> TVar Int -> Application
app users count = do
liveApp
toDocument
(runApp . routeRequest $ router)
where
runApp :: (IOE :> es) => Eff (Concurrent : Debug : Users : es) a -> Eff es a
runApp = runUsersIO users . runDebugIO . runConcurrent
router :: forall es. (Hyperbole :> es, Users :> es, Debug :> es, Concurrent :> es, IOE :> es) => AppRoute -> Eff es Response
router (Hello h) = page $ hello h
router Simple = page Simple.simplePage
router Contacts = page Contacts.page
router Counter = page $ Counter.page count
router Transitions = page Transitions.page
router Forms = page Forms.page
router Sessions = page Sessions.page
router LazyLoading = page LazyLoading.page
router Concurrent = page Concurrent.page
router Redirects = page Redirects.page
router LiveSearch = page Search.page
router Errors = page Errors.page
router RedirectNow = do
redirect (routeUrl $ Hello Redirected)
router Query = do
p <- reqParam "key"
view $ el (pad 20) $ do
text "key: "
text p
router Main = do
view $ do
col (gap 10 . pad 20) $ do
el (bold . fontSize 32) "Examples"
route (Hello (Greet "World")) lnk "Hello World"
route Simple lnk "Simple"
route Counter lnk "Counter"
route Transitions lnk "Transitions"
route Forms lnk "Forms"
link "/query?key=value" lnk "Query Params"
route Sessions lnk "Sessions"
route Redirects lnk "Redirects"
route RedirectNow lnk "Redirect Now"
route LazyLoading lnk "Lazy Loading"
route LiveSearch lnk "Live Search"
route Contacts lnk "Contacts (Advanced)"
route Errors lnk "Errors"
lnk = Style.link
-- Nested Router
hello :: (Hyperbole :> es, Debug :> es) => Hello -> Page es ()
hello Redirected = handle () $ do
pure $ el_ "You were redirected"
hello (Greet s) = handle () $ do
r <- request
pure $ col (gap 10 . pad 10) $ do
el_ $ do
text "Greetings: "
text s
el_ $ do
text "Host: "
text $ cs $ show r.host
el_ $ do
text "Path: "
text $ cs $ show r.path
el_ $ do
text "Query: "
text $ cs $ show r.query
el_ $ do
text "Cookies: "
text $ cs $ show r.cookies
-- Use the embedded version for real applications (see basicDocument).
-- The link to /hyperbole.js here is just to make local development easier
toDocument :: BL.ByteString -> BL.ByteString
toDocument cnt =
[i|<html>
<head>
<title>Hyperbole Examples</title>
<script type="text/javascript" src="/hyperbole.js"></script>
<style type="text/css">#{cssResetEmbed}</style>
</head>
<body>#{cnt}</body>
</html>|]