This repository has been archived by the owner on Aug 18, 2020. It is now read-only.
/
Response.hs
284 lines (238 loc) · 9.97 KB
/
Response.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
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
module Cardano.Wallet.API.Response (
Metadata (..)
, ResponseStatus(..)
, WalletResponse(..)
, JSONValidationError(..)
-- * Generating responses for collections
, respondWith
, fromSlice
-- * Generating responses for single resources
, single
-- * A slice of a collection
, SliceOf(..)
, ValidJSON
) where
import Prelude
import Universum (Buildable, Exception, Text, decodeUtf8, toText,
(<>))
import Cardano.Wallet.API.Indices (Indexable', IxSet')
import Cardano.Wallet.API.Request (RequestParams (..))
import Cardano.Wallet.API.Request.Filter (FilterOperations (..))
import Cardano.Wallet.API.Request.Pagination (Page (..),
PaginationMetadata (..), PaginationParams (..),
PerPage (..))
import Cardano.Wallet.API.Request.Sort (SortOperations (..))
import Cardano.Wallet.API.Response.Filter.IxSet as FilterBackend
import Cardano.Wallet.API.Response.JSend (ResponseStatus (..))
import Cardano.Wallet.API.Response.Sort.IxSet as SortBackend
import Cardano.Wallet.API.V1.Errors (ToServantError (..))
import Cardano.Wallet.API.V1.Swagger.Example (Example, example)
import Control.Lens hiding ((.=))
import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode, encode,
object, pairs, (.:), (.=))
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.TH
import Data.Aeson.Types (Value (..), typeMismatch)
import Data.Swagger as S hiding (Example, example)
import Data.Typeable
import Formatting (bprint, build, (%))
import Generics.SOP.TH (deriveGeneric)
import GHC.Generics (Generic)
import Servant (err400)
import Servant.API.ContentTypes (Accept (..), JSON, MimeRender (..),
MimeUnrender (..), OctetStream)
import Test.QuickCheck
import qualified Data.Aeson.Options as Serokell
import qualified Data.Char as Char
import qualified Data.HashMap.Strict as HMS
import qualified Formatting.Buildable
-- | Extra information associated with an HTTP response.
data Metadata = Metadata
{ metaPagination :: PaginationMetadata
-- ^ Pagination-specific metadata
} deriving (Show, Eq, Generic)
deriveJSON Serokell.defaultOptions ''Metadata
instance Arbitrary Metadata where
arbitrary = Metadata <$> arbitrary
instance ToSchema Metadata where
declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
{ S.fieldLabelModifier =
over (ix 0) Char.toLower . drop 4 -- length "meta"
}
instance Buildable Metadata where
build Metadata{..} =
bprint ("{ pagination="%build%" }") metaPagination
instance Example Metadata
-- | An `WalletResponse` models, unsurprisingly, a response (successful or not)
-- produced by the wallet backend.
-- Includes extra informations like pagination parameters etc.
data WalletResponse a = WalletResponse
{ wrData :: a
-- ^ The wrapped domain object.
, wrStatus :: ResponseStatus
-- ^ The <https://labs.omniti.com/labs/jsend jsend> status.
, wrMeta :: Metadata
-- ^ Extra metadata to be returned.
} deriving (Show, Eq, Generic, Functor)
data SliceOf a = SliceOf {
paginatedSlice :: [a]
-- ^ A paginated fraction of the resource
, paginatedTotal :: Int
-- ^ The total number of entries
}
instance Arbitrary a => Arbitrary (SliceOf a) where
arbitrary = SliceOf <$> arbitrary <*> arbitrary
deriveJSON Serokell.defaultOptions ''WalletResponse
instance Arbitrary a => Arbitrary (WalletResponse a) where
arbitrary = WalletResponse <$> arbitrary <*> arbitrary <*> arbitrary
instance ToJSON a => MimeRender OctetStream (WalletResponse a) where
mimeRender _ = encode
instance (ToSchema a, Typeable a) => ToSchema (WalletResponse a) where
declareNamedSchema _ = do
let a = Proxy @a
tyName = toText . show $ typeRep a
aRef <- declareSchemaRef a
respRef <- declareSchemaRef (Proxy @ResponseStatus)
metaRef <- declareSchemaRef (Proxy @Metadata)
pure $ NamedSchema (Just $ "WalletResponse<" <> tyName <> ">") $ mempty
& type_ .~ SwaggerObject
& required .~ ["data", "status", "meta"]
& properties .~
[ ("data", aRef)
, ("status", respRef)
, ("meta", metaRef)
]
instance Buildable a => Buildable (WalletResponse a) where
build WalletResponse{..} = bprint
("\n\tstatus="%build
%"\n\tmeta="%build
%"\n\tdata="%build
)
wrStatus
wrMeta
wrData
instance Example a => Example (WalletResponse a) where
example = WalletResponse <$> example
<*> pure SuccessStatus
<*> example
-- | Inefficient function to build a response out of a @generator@ function. When the data layer will
-- be rewritten the obvious solution is to slice & dice the data as soon as possible (aka out of the DB), in this order:
--
-- 1. Query/Filtering operations (affects the number of total entries for pagination);
-- 2. Sorting operations
-- 3. Pagination
--
-- See also <https://specs.openstack.org/openstack/api-wg/guidelines/pagination_filter_sort.html this document>, which
-- states:
-- "Paginating responses should be done after applying the filters in a query, because it’s possible for there
-- to be no matches in the first page of results, and returning an empty page is a poor API when the user explicitly
-- requested a number of results."
--
-- NOTE: We have chosen have an approach such that we are sorting the whole dataset after filtering and using
-- lazyness to avoid work. This might not be optimal in terms of performances and we might need to swap sorting
-- and pagination.
--
respondWith :: (Monad m, Indexable' a)
=> RequestParams
-> FilterOperations a
-- ^ Filtering operations to perform on the data.
-> SortOperations a
-- ^ Sorting operations to perform on the data.
-> m (IxSet' a)
-- ^ The monadic action which produces the results.
-> m (WalletResponse [a])
respondWith RequestParams{..} fops sorts generator = do
(theData, paginationMetadata) <- paginate rpPaginationParams . sortData sorts . applyFilters fops <$> generator
return WalletResponse {
wrData = theData
, wrStatus = SuccessStatus
, wrMeta = Metadata paginationMetadata
}
paginate :: PaginationParams -> [a] -> ([a], PaginationMetadata)
paginate params@PaginationParams{..} rawResultSet =
let totalEntries = length rawResultSet
(PerPage pp) = ppPerPage
(Page cp) = ppPage
metadata = paginationParamsToMeta params totalEntries
slice = take pp . drop ((cp - 1) * pp)
in (slice rawResultSet, metadata)
paginationParamsToMeta :: PaginationParams -> Int -> PaginationMetadata
paginationParamsToMeta PaginationParams{..} totalEntries =
let perPage@(PerPage pp) = ppPerPage
currentPage = ppPage
totalPages = max 1 $ ceiling (fromIntegral totalEntries / (fromIntegral pp :: Double))
in PaginationMetadata {
metaTotalPages = totalPages
, metaPage = currentPage
, metaPerPage = perPage
, metaTotalEntries = totalEntries
}
fromSlice :: PaginationParams -> SliceOf a -> WalletResponse [a]
fromSlice params (SliceOf theData totalEntries) = WalletResponse {
wrData = theData
, wrStatus = SuccessStatus
, wrMeta = Metadata (paginationParamsToMeta params totalEntries)
}
-- | Creates a 'WalletResponse' with just a single record into it.
single :: a -> WalletResponse a
single theData = WalletResponse {
wrData = theData
, wrStatus = SuccessStatus
, wrMeta = Metadata (PaginationMetadata 1 (Page 1) (PerPage 1) 1)
}
--
-- Creating a better user experience when it comes to errors.
--
data ValidJSON deriving Typeable
instance FromJSON a => MimeUnrender ValidJSON a where
mimeUnrender _ bs = case eitherDecode bs of
Left err -> Left $ decodeUtf8 $ encodePretty (JSONValidationFailed $ toText err)
Right v -> return v
instance Accept ValidJSON where
contentType _ = contentType (Proxy @ JSON)
instance ToJSON a => MimeRender ValidJSON a where
mimeRender _ = mimeRender (Proxy @ JSON)
--
-- Error from parsing / validating JSON inputs
--
newtype JSONValidationError
= JSONValidationFailed Text
deriving (Generic, Show, Eq)
deriveGeneric ''JSONValidationError
instance ToJSON JSONValidationError where
toEncoding (JSONValidationFailed weValidationError) = pairs $ mconcat
[ "message" .= String "JSONValidationFailed"
, "status" .= String "error"
, "diagnostic" .= object
[ "validationError" .= weValidationError
]
]
instance FromJSON JSONValidationError where
parseJSON (Object o)
| HMS.member "message" o =
case HMS.lookup "message" o of
Just "JSONValidationFailed" ->
JSONValidationFailed <$> ((o .: "diagnostic") >>= (.: "validationError"))
_ ->
fail "Incorrect JSON encoding for JSONValidationError"
| otherwise =
fail "Incorrect JSON encoding for JSONValidationError"
parseJSON invalid =
typeMismatch "JSONValidationError" invalid
instance Exception JSONValidationError
instance Arbitrary JSONValidationError where
arbitrary = oneof
[ pure $ JSONValidationFailed "JSON validation failed."
]
instance Buildable JSONValidationError where
build = \case
JSONValidationFailed _ ->
bprint "Couldn't decode a JSON input."
instance ToServantError JSONValidationError where
declareServantError = \case
JSONValidationFailed _ ->
err400