/
Core.hs
185 lines (161 loc) · 5.78 KB
/
Core.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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
{-# LANGUAGE OverloadedStrings #-}
module Level04.Core
( runApp
, prepareAppReqs
, app
) where
import Control.Applicative (liftA2)
import Control.Monad (join)
import Network.Wai (Application, Request,
Response, pathInfo,
requestMethod, responseLBS,
strictRequestBody)
import Network.Wai.Handler.Warp (run)
import Data.Aeson (ToJSON, encode)
import qualified Data.ByteString.Lazy.Char8 as LBS
import Network.HTTP.Types (Status, hContentType,
status200, status400,
status404, status500)
import Data.Either (Either (Left, Right),
either)
import Data.Semigroup ((<>))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
import Level04.Conf (Conf, firstAppConfig)
import qualified Level04.DB as DB
import Level04.Types (ContentType (JSON, PlainText),
Error (EmptyCommentText, EmptyTopic, UnknownRoute),
RqType (AddRq, ListRq, ViewRq),
mkCommentText, mkTopic,
renderContentType)
-- Our start-up is becoming more complicated and could fail in new and
-- interesting ways. But we also want to be able to capture these errors in a
-- single type so that we can deal with the entire start-up process as a whole.
data StartUpError
= DBInitErr SQLiteResponse
deriving Show
runApp :: IO ()
runApp = error "runApp needs re-implementing"
-- We need to complete the following steps to prepare our app requirements:
--
-- 1) Load the configuration.
-- 2) Attempt to initialise the database.
--
-- Our application configuration is defined in Conf.hs
--
prepareAppReqs
:: IO ( Either StartUpError DB.FirstAppDB )
prepareAppReqs =
error "prepareAppReqs not implemented"
-- | Some helper functions to make our lives a little more DRY.
mkResponse
:: Status
-> ContentType
-> LBS.ByteString
-> Response
mkResponse sts ct =
responseLBS sts [(hContentType, renderContentType ct)]
resp200
:: ContentType
-> LBS.ByteString
-> Response
resp200 =
mkResponse status200
resp404
:: ContentType
-> LBS.ByteString
-> Response
resp404 =
mkResponse status404
resp400
:: ContentType
-> LBS.ByteString
-> Response
resp400 =
mkResponse status400
-- Some new helpers for different statuses and content types
resp500
:: ContentType
-> LBS.ByteString
-> Response
resp500 =
mkResponse status500
resp200Json
:: ToJSON a
=> a
-> Response
resp200Json =
mkResponse status200 JSON . encode
-- |
app
:: DB.FirstAppDB -- ^ Add the Database record to our app so we can use it
-> Application
app db rq cb = do
rq' <- mkRequest rq
resp <- handleRespErr <$> handleRErr rq'
cb resp
where
handleRespErr :: Either Error Response -> Response
handleRespErr = either mkErrorResponse id
-- We want to pass the Database through to the handleRequest so it's
-- available to all of our handlers.
handleRErr :: Either Error RqType -> IO (Either Error Response)
handleRErr = either ( pure . Left ) ( handleRequest db )
-- | Handle each of the different types of request. See how the types have helped narrow our focus
-- to only those types of request that we care about. Along with ensuring that once the data has
-- reached this point, we don't have to continually check if it is valid or usable. The types and
-- data structures that we created have taken care of that for us at an earlier stage, simplifying
-- this function.
--
-- For both the 'ViewRq' and 'ListRq' functions, we'll need to pass the correct 'Encoder' to the
-- 'resp200Json' function.
handleRequest
:: DB.FirstAppDB
-> RqType
-> IO (Either Error Response)
handleRequest _db (AddRq _ _) =
(resp200 PlainText "Success" <$) <$> error "AddRq handler not implemented"
handleRequest _db (ViewRq _) =
error "ViewRq handler not implemented"
handleRequest _db ListRq =
error "ListRq handler not implemented"
mkRequest
:: Request
-> IO ( Either Error RqType )
mkRequest rq =
case ( pathInfo rq, requestMethod rq ) of
-- Commenting on a given topic
( [t, "add"], "POST" ) -> mkAddRequest t <$> strictRequestBody rq
-- View the comments on a given topic
( [t, "view"], "GET" ) -> pure ( mkViewRequest t )
-- List the current topics
( ["list"], "GET" ) -> pure mkListRequest
-- Finally we don't care about any other requests so throw your hands in the air
_ -> pure ( Left UnknownRoute )
mkAddRequest
:: Text
-> LBS.ByteString
-> Either Error RqType
mkAddRequest ti c = AddRq
<$> mkTopic ti
<*> (mkCommentText . decodeUtf8 . LBS.toStrict) c
mkViewRequest
:: Text
-> Either Error RqType
mkViewRequest =
fmap ViewRq . mkTopic
mkListRequest
:: Either Error RqType
mkListRequest =
Right ListRq
mkErrorResponse
:: Error
-> Response
mkErrorResponse UnknownRoute =
resp404 PlainText "Unknown Route"
mkErrorResponse EmptyCommentText =
resp400 PlainText "Empty Comment"
mkErrorResponse EmptyTopic =
resp400 PlainText "Empty Topic"