git.iko.soy/denis
on master help sign in
Added complex queries. Resolved #44
commit31f3f0df4d51d55c5d5db121a2912b7e8d439ea4 authoriko <ilyakooo0@gmail.com> dateSat 20 Apr 2019, 23:45 (8 years ago) parent99add81
7 files changed+235−92
compare with master
unifiedsplit
denis/docs/Docs.hs+9−4 denis/src/Data/Query.hs+74−61 denis/src/Data/User.hs+6−2 denis/src/Server/API.hs+10−10 denis/src/Server/API/Channels.hs+7−6 denis/src/Server/API/Posts.hs+9−9 denis/src/Server/Query/ComplexQuery.hs+120
denis/docs/Docs.hs+9−4
@@ -21,27 +21,32 @@ import Server.Logger
2121import Server.Auth
2222import Server.API.Channels
2323import Data.Aeson
24+import qualified Data.Text.IO as T
25+import Servant.Server.Experimental.Auth
26+import Network.Wai
27+
2428
2529docsWriter :: HasDocs api => String -> Proxy api -> IO ()
26−docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs
30+docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs
2731
2832main = do
2933 docsWriter "posts" $ pretty (Proxy :: Proxy ("posts" :> PostApi))
3034 docsWriter "all" $ pretty serverProxy
3135 docsWriter "authentication" $ pretty (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>
32− Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))
36+ Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))
3337 docsWriter "channels" $ pretty (Proxy :: Proxy ("channels" :> ChannelsApi))
38+ T.writeFile ("docs/Home.md") . (\t -> "```\n" <> t <> "```\n") $ layoutWithContext serverProxy (undefined :: Context (AuthHandler Request UserId ': '[]))
3439
3540
3641instance ToSample Char where
3742 toSamples _ = singleSample 'c'
38−
43+
3944instance ToSample Int64 where
4045 toSamples _ = samples [1, 7, 2, 19]
4146
4247instance ToSample Word64 where
4348 toSamples _ = samples [1, 7, 2, 19]
44−
49+
4550instance ToSample Log where
4651 toSamples _ = noSamples
4752
denis/src/Data/Query.hs+74−61
@@ -5,7 +5,8 @@
55 OverloadedStrings ,
66 TypeApplications ,
77 TypeOperators,
8− PartialTypeSignatures #-}
8+ PartialTypeSignatures,
9+ FlexibleInstances #-}
910
1011{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
1112
@@ -21,13 +22,15 @@ module Data.Query (
2122 getPostsForUser,
2223 Limit,
2324 publishPost,
24− PostResponse(..),
2525 getChannelPosts,
2626 updateChannel,
2727 createNewChannel,
2828 getAllChannels,
2929 getAnonymousChannelPosts,
30− deleteNamedChannel
30+ deleteNamedChannel,
31+ HasUsers(..),
32+ wrapIntoUsers,
33+ ResponseWithUsers(..)
3134) where
3235
3336import Squeal.PostgreSQL
@@ -57,12 +60,11 @@ import Data.Text (Text)
5760import Data.Channel.NamedChannel
5861import Data.Channel.AnonymousChannel
5962import Data.Maybe (fromMaybe)
60−import Data.Monoid (mempty)
6163
6264-- MARK: Documentation
6365
64−instance ToSample PostResponse where
65− toSamples _ = samples $ PostResponse <$> (map snd $ toSamples Proxy) <*> [M.fromList $ map (tupleFirst userId . snd) (toSamples Proxy)]
66+instance (ToSample r) => ToSample (ResponseWithUsers r) where
67+ toSamples _ = samples $ ResponseWithUsers <$> (map snd $ toSamples Proxy) <*> [M.fromList $ map (tupleFirst userId . snd) (toSamples Proxy)]
6668
6769
6870-- MARK: Generalized Post Queries
@@ -74,7 +76,7 @@ postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
7476postsQ te = selectStar $ te (from $ table #posts)
7577
7678postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped
77−postViewT te = from $ subquery (postsQ te `As` #posts) &
79+postViewT te = from $ subquery (postsQ te `As` #posts) &
7880 innerJoin (table #postElements)
7981 (#posts ! #postRowId .== #postElements ! #rowElementId)
8082
@@ -90,7 +92,7 @@ getPostQ oTe te = select (
9092 #postElements ! #rowElementLatex :*
9193 #postElements ! #rowElementImage :*
9294 #postElements ! #rowElementQuote :*
93− #postElements ! #rowElementAttachment)
95+ #postElements ! #rowElementAttachment)
9496 (oTe $ postViewT te)
9597
9698
@@ -113,14 +115,14 @@ getPostQ oTe te = select (
113115-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows
114116-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0
115117-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
116−-- return $ M.lookup qId rows >>= rowsToQuote rows
118+-- return $ M.lookup qId rows >>= rowsToQuote rows
117119
118120getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)
119121getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)
120122
121123verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
122124verifiedUserIdsQ uIds = case idsToColumn uIds of
123− Just idQ -> Just $ select (#users ! #userId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
125+ Just idQ -> Just $ select (#users ! #userId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
124126 innerJoin (table #users)
125127 (#ids ! #id .== #users ! #userId))
126128 Nothing -> Nothing
@@ -128,7 +130,7 @@ verifiedUserIdsQ uIds = case idsToColumn uIds of
128130
129131getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG User))
130132getUsersQ uIds = case idsToColumn uIds of
131− Just idQ -> Just $ selectDotStar #users $ from (subquery (idQ `As` #ids) &
133+ Just idQ -> Just $ selectDotStar #users $ from (subquery (idQ `As` #ids) &
132134 innerJoin (table #users)
133135 (#ids ! #id .== #users ! #userId))
134136 Nothing -> Nothing
@@ -138,7 +140,7 @@ getAllUsersQ = selectStar $ from $ table #users
138140
139141getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
140142getPostsByIdQ pIds = case idsToColumn pIds of
141− Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
143+ Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
142144 innerJoin (subquery $ getPostQ id id `As` #posts)
143145 (#ids ! #id .== #posts ! #postRowId))
144146 Nothing -> Nothing
@@ -147,25 +149,25 @@ getPostsByIdQ pIds = case idsToColumn pIds of
147149type Limit = Word64
148150
149151getLastNPostsQ :: Limit -> Query Schema params (RowPG PostRowResponse)
150−getLastNPostsQ lim = getPostQ
152+getLastNPostsQ lim = getPostQ
151153 (limit lim . orderBy [#posts ! #postRowUpdateTime & Desc]) id
152154
153155getLastNPostsForUserQ :: Limit -> Query Schema (TuplePG (Only UserId)) (RowPG PostRowResponse)
154−getLastNPostsForUserQ lim = getPostQ
155− (limit lim . orderBy [#posts ! #postRowUpdateTime & Desc])
156+getLastNPostsForUserQ lim = getPostQ
157+ (limit lim . orderBy [#posts ! #postRowUpdateTime & Desc])
156158 (where_ $ #postRowAuthorId .== param @1)
157−
159+
158160createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
159−createPostRowQ = insertRow #posts
161+createPostRowQ = insertRow #posts
160162 (Default `as` #postRowId :*
161163 Set (param @1) `as` #postRowAuthorId :*
162164 Set currentTimestamp `as` #postRowUpdateTime :*
163− Set (param @2) `as` #postRowTags)
164− OnConflictDoRaise
165+ Set (param @2) `as` #postRowTags)
166+ OnConflictDoRaise
165167 (Returning $ #postRowId `as` #fromOnly)
166168
167169createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
168−createPostElementRowsQ = insertRow_ #postElements
170+createPostElementRowsQ = insertRow_ #postElements
169171 (Set (param @1) `as` #rowElementId :*
170172 Set (param @2) `as` #rowElementOrd :*
171173 Set (param @3) `as` #rowElementMarkdown :*
@@ -175,7 +177,7 @@ createPostElementRowsQ = insertRow_ #postElements
175177 Set (param @7) `as` #rowElementAttachment)
176178
177179getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
178−getChannelForUserQ = selectStar $
180+getChannelForUserQ = selectStar $
179181 from (table #channels) &
180182 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
181183
@@ -193,7 +195,7 @@ createNamedChannelQ = insertRow #channels
193195 Set (param @2) `as` #namedChannelFullName :*
194196 Set (param @3) `as` #namedChannelFullTags :*
195197 Set (param @4) `as` #namedChannelFullPeopleIds
196− )
198+ )
197199 OnConflictDoRaise
198200 (Returning $ #namedChannelFullId `as` #fromOnly)
199201
@@ -208,31 +210,24 @@ updateNamedChannelQ = update_ #channels
208210 Set (param @3) `as` #namedChannelFullName :*
209211 Set (param @4) `as` #namedChannelFullTags :*
210212 Set (param @5) `as` #namedChannelFullPeopleIds
211− )
213+ )
212214 (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)
213−
215+
214216
215217getChannelPostsQ :: Limit -> [UserId] -> Vector Text -> Query Schema '[] (RowPG PostRowResponse)
216−getChannelPostsQ lim uIds tags = selectStar $ from (subquery $ postsQ' `As` #bar) &
218+getChannelPostsQ lim uIds tags = selectStar $ from (subquery $ postsQ' `As` #bar) &
217219 orderBy [#postRowUpdateTime & Desc] & limit lim
218− where
220+ where
219221 unionWithUsers = case idsToColumn uIds of
220− Just uIdsQ -> selectDotStar #posts' (from $ subquery (uIdsQ `As` #uIds) &
222+ Just uIdsQ -> selectDotStar #posts' (from $ subquery (uIdsQ `As` #uIds) &
221223 innerJoin (subquery $ getPostQ id id `As` #posts')
222224 (#uIds ! #id .== #posts' ! #postRowAuthorId)) &
223225 union
224226 Nothing -> id
225227 postsQ' = unionWithUsers $ getPostQ id $ where_ $ jsonbLit tags .?| #postRowTags
226−
227228
228−-- MARK: FrontEnd Data Structures
229229
230−data PostResponse = PostResponse {
231− posts :: [Post],
232− users :: M.Map UserId User
233−} deriving (Generic)
234−
235−instance ToJSON PostResponse
230+-- MARK: FrontEnd Data Structures
236231
237232data NamedChannelCreation = NamedChannelCreation {
238233 namedChannelCreationOwner :: UserId,
@@ -274,31 +269,31 @@ getChannelForUser uId cId = do
274269
275270-- TODO: Reject bad requests. Should be binary.
276271verifiedUsers :: [UserId] -> StaticPQ [UserId]
277−verifiedUsers uIds =
272+verifiedUsers uIds =
278273 case verifiedUserIdsQ uIds of
279274 Just uIdsQ -> fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
280275 Nothing -> return []
281276
282277-- MARK: FrontEnd functions
283278
284−getPostsForUser :: Word64 -> UserId -> StaticPQ (Maybe PostResponse)
285−getPostsForUser lim uId = do
279+getPostsForUser :: Word64 -> UserId -> StaticPQ (Maybe (ResponseWithUsers [Post]))
280+getPostsForUser lim uId = do
286281 postRows <- runQueryParams (getLastNPostsForUserQ lim) (Only uId) >>= getRows
287− rowsToPosts postRows `liftMaybe` wrapIntoPostResponse
282+ rowsToPosts postRows `liftMaybe` wrapIntoResponse
288283
289−getPosts :: [PostId] -> StaticPQ (Maybe PostResponse)
290−getPosts pId =
284+getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))
285+getPosts pId =
291286 case getPostsByIdQ pId of
292287 Just psQ -> do
293288 postRows <- runQuery psQ >>= getRows
294− rowsToPosts postRows `liftMaybe` wrapIntoPostResponse
289+ rowsToPosts postRows `liftMaybe` wrapIntoResponse
295290 Nothing -> return Nothing
296291
297−getLastPosts :: Word64 -> StaticPQ (Maybe PostResponse)
298−getLastPosts n = do
292+getLastPosts :: Word64 -> StaticPQ (Maybe (ResponseWithUsers [Post]))
293+getLastPosts n = do
299294 postRows <- runQuery (getLastNPostsQ n) >>= getRows
300− rowsToPosts postRows `liftMaybe` wrapIntoPostResponse
301−
295+ rowsToPosts postRows `liftMaybe` wrapIntoResponse
296+
302297getUser :: UserId -> StaticPQ User
303298getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0
304299
@@ -307,7 +302,7 @@ getUsers ids = getUsersQ ids `liftMaybe` (fmap Just . (runQuery >=> getRows))
307302
308303getAllUsers :: StaticPQ [User]
309304getAllUsers = runQuery getAllUsersQ >>= getRows
310−
305+
311306publishPost :: UserId -> PostCreation -> StaticPQ PostId
312307publishPost uId pc = commitedTransactionallyUpdate $ do
313308 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
@@ -330,20 +325,20 @@ updateChannel uId req = commitedTransactionallyUpdate $ do
330325 _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
331326 return ()
332327
333−getChannelPosts :: UserId -> Limit -> NamedChannelId -> StaticPQ PostResponse
328+getChannelPosts :: UserId -> Limit -> NamedChannelId -> StaticPQ (ResponseWithUsers [Post])
334329getChannelPosts uId lim cId = do
335330 channel <- getChannelForUser uId cId
336− postRows <- runQuery (getChannelPostsQ lim (toList $ namedChannelFullPeopleIds channel) (namedChannelFullTags channel))
331+ postRows <- runQuery (getChannelPostsQ lim (toList $ namedChannelFullPeopleIds channel) (namedChannelFullTags channel))
337332 >>= getRows
338− fmap (fromMaybe $ PostResponse mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse
333+ fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
339334
340−getAnonymousChannelPosts :: Limit -> AnonymousChannel -> StaticPQ PostResponse
335+getAnonymousChannelPosts :: Limit -> AnonymousChannel -> StaticPQ (ResponseWithUsers [Post])
341336getAnonymousChannelPosts lim (AnonymousChannel tags people) = do
342337 postRows <- runQuery (getChannelPostsQ lim people tags) >>= getRows
343− fmap (fromMaybe $ PostResponse mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse
338+ fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
344339
345340getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
346−getAllChannels uId = fmap (map removeUserFromChannel) $
341+getAllChannels uId = fmap (map removeUserFromChannel) $
347342 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
348343
349344deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
@@ -352,7 +347,7 @@ deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do
352347 _ <- manipulateParams deleteNamedChannelQ (Only cId)
353348 return ()
354349
355−
350+
356351-- MARK: Utils
357352
358353foldMaybe :: [Maybe a] -> Maybe [a]
@@ -360,9 +355,6 @@ foldMaybe [] = Just []
360355foldMaybe (Nothing : _) = Nothing
361356foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
362357
363−userIdsFromPostResponse :: [Post] -> [UserId]
364−userIdsFromPostResponse = Set.toList . Set.fromList . map postAuthorId
365−
366358rowsToPosts :: [PostRowResponse] -> Maybe [Post]
367359rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)
368360
@@ -379,10 +371,31 @@ idsToColumn (i:ii) = Just $ values (unsafeIntToExpr i `as` #id) $ map ((`as` #id
379371unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty
380372unsafeIntToExpr = UnsafeExpression . pack . show
381373
382−wrapIntoPostResponse :: [Post] -> StaticPQ (Maybe PostResponse)
383−wrapIntoPostResponse ps = do
384− pUsers <- getUsers $ userIdsFromPostResponse ps
385− return $ PostResponse ps . M.fromList . mapFirstBy userId <$> pUsers
374+data ResponseWithUsers r = ResponseWithUsers {
375+ response :: r,
376+ users :: M.Map UserId User
377+} deriving (Generic)
378+
379+instance (ToJSON r) => ToJSON (ResponseWithUsers r)
380+
381+instance (FromJSON r) => FromJSON (ResponseWithUsers r)
382+
383+class HasUsers r where
384+ userSet :: r -> Set.Set UserId
385+
386+ wrapIntoResponse :: r -> StaticPQ (Maybe (ResponseWithUsers r))
387+ wrapIntoResponse r = wrapIntoUsers r $ userSet r
388+
389+instance (Foldable t, HasUsers r) => HasUsers (t r) where
390+ userSet = foldMap userSet
391+
392+instance HasUsers Post where
393+ userSet = Set.singleton . postAuthorId
394+
395+wrapIntoUsers :: r -> Set.Set UserId -> StaticPQ (Maybe (ResponseWithUsers r))
396+wrapIntoUsers r us = do
397+ pUsers <- getUsers $ Set.toList us
398+ return $ ResponseWithUsers r . M.fromList . mapFirstBy userId <$> pUsers
386399
387400liftMaybe :: Applicative f => Maybe a -> (a -> f (Maybe b)) -> f (Maybe b)
388401liftMaybe Nothing _ = pure Nothing
denis/src/Data/User.hs+6−2
@@ -10,7 +10,7 @@
1010module Data.User (
1111 User(..),
1212 UserId
13−) where
13+) where
1414
1515import Data.Int (Int64)
1616import qualified Generics.SOP as SOP
@@ -45,4 +45,8 @@ instance ToJSON User where
4545 "firstName" .= fName,
4646 "middleName" .= mName,
4747 "lastName" .= lName
48− ]
48+ ]
49+
50+instance FromJSON User where
51+ parseJSON = withObject "named channel" $ \e ->
52+ User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName"
denis/src/Server/API.hs+10−10
@@ -1,4 +1,4 @@
1−{-# LANGUAGE
1+{-# LANGUAGE
22 FlexibleInstances,
33 DataKinds,
44 TypeOperators,
@@ -11,8 +11,8 @@ module Server.API (
1111 serverProxy,
1212 mkServerAPI,
1313 Authentication
14−) where
15−
14+) where
15+
1616import Data.Proxy
1717import Servant.API
1818import Data.User
@@ -26,23 +26,23 @@ import Server.Logger
2626import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))
2727import Server.API.Channels
2828import Control.Lens
29−
29+import Server.Query.ComplexQuery
3030
3131-- MARK: Documentation
3232
3333instance HasDocs api => HasDocs (Authentication :> api) where
3434 docsFor Proxy (endpoint, action) =
35− docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `498 Invalid Token` if the token is invalid or the token header is missing. Returns `401 Unathorized` if the token doesn't premit access to the requested data."]])
35+ docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `498 Invalid Token` if the token is invalid or the token header is missing. Returns `401 Unathorized` if the token doesn't permit access to the requested data."]])
3636
3737
3838-- MARK: Implementation
3939
4040type Authentication = AuthProtect "basicAuth"
4141
42−type API =
42+type API =
4343 LoggerAPI :<|>
4444 "authentication" :> AuthenticationHandler :<|>
45− Authentication :> (
45+ Authentication :> ComplexQuery :> (
4646 "authentication" :> "me" :> Post '[JSON] UserId :<|>
4747 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
4848 "users" :> "all" :> Post '[JSON] [User] :<|>
@@ -54,9 +54,9 @@ serverProxy :: Proxy API
5454serverProxy = Proxy
5555
5656mkServerAPI :: Logger -> ServerT API App
57−mkServerAPI l =
58− l :<|>
59− authenticationAPI :<|> (\uId ->
57+mkServerAPI l =
58+ l :<|>
59+ authenticationAPI :<|> (\uId ->
6060 return uId :<|>
6161 maybeNotFound . runQnotFound . getUsers :<|>
6262 runQnotFound getAllUsers :<|>
denis/src/Server/API/Channels.hs+7−6
@@ -20,14 +20,15 @@ import Data.Connection
2020import Server.LimitingRequest
2121import Data.Channel.NamedChannel
2222import Data.Channel.AnonymousChannel
23−
23+import qualified Data.Post as P
24+
2425-- MARK: Implementation
2526
2627type NamedChannelRequest = LimitingRequest NamedChannelId
2728
2829type ChannelsApi = Post '[JSON] [NamedChannel UserId] :<|>
29− "get" :> ReqBody '[JSON] NamedChannelRequest :> Post '[JSON] PostResponse :<|>
30− "getAnonymous" :> ReqBody '[JSON] (LimitingRequest AnonymousChannel) :> Post '[JSON] PostResponse :<|>
30+ "get" :> ReqBody '[JSON] NamedChannelRequest :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
31+ "getAnonymous" :> ReqBody '[JSON] (LimitingRequest AnonymousChannel) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
3132 "create" :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
3233 "update" :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
3334 "delete" :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent
@@ -39,10 +40,10 @@ channelsApi uId = getChannelsApi uId :<|> getChannel uId :<|> getAnonymousChanne
3940getChannelsApi :: UserId -> App [NamedChannel UserId]
4041getChannelsApi uId = runQnotFound $ getAllChannels uId
4142
42−getAnonymousChannelsApi :: LimitingRequest AnonymousChannel -> App PostResponse
43+getAnonymousChannelsApi :: LimitingRequest AnonymousChannel -> App (ResponseWithUsers [P.Post])
4344getAnonymousChannelsApi (LimitingRequest req lim) = runQnotFound $ getAnonymousChannelPosts lim req
4445
45−getChannel :: UserId -> NamedChannelRequest -> App PostResponse
46+getChannel :: UserId -> NamedChannelRequest -> App (ResponseWithUsers [P.Post])
4647getChannel uId (LimitingRequest cId lim) = runQnotFound $ getChannelPosts uId lim cId
4748
4849createChannelApi :: UserId -> NamedChannelCreationRequest -> App NamedChannelId
@@ -54,6 +55,6 @@ updateChannelApi uId req = do
5455 return NoContent
5556
5657deleteChannelApi :: UserId -> NamedChannelId -> App NoContent
57−deleteChannelApi uId cId = do
58+deleteChannelApi uId cId = do
5859 runQnotFound $ deleteNamedChannel uId cId
5960 return NoContent
denis/src/Server/API/Posts.hs+9−9
@@ -26,21 +26,21 @@ import Server.LimitingRequest
2626
2727type UserPostsRequest = LimitingRequest UserId
2828
29−type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] PostResponse :<|>
30− "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] PostResponse :<|>
31− "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] PostResponse :<|>
32− "publish" :> ReqBody '[JSON] P.PostCreation :> Post '[JSON] P.PostId
33−
29+type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
30+ "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
31+ "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
32+ "publish" :> ReqBody '[JSON] P.PostCreation :> Post '[JSON] P.PostId
33+
3434postApi :: UserId -> ServerT PostApi App
3535postApi uId = getPostsApi :<|> lastPosts :<|> getPostsForUserApi :<|> publishPostApi uId
3636
37−getPostsApi :: [P.PostId] -> App PostResponse
38−getPostsApi = maybeNotFound . runQnotFound . getPosts
37+getPostsApi :: [P.PostId] -> App (ResponseWithUsers [P.Post])
38+getPostsApi = maybeNotFound . runQnotFound . getPosts
3939
40−lastPosts :: Word64 -> App PostResponse
40+lastPosts :: Word64 -> App (ResponseWithUsers [P.Post])
4141lastPosts = maybeNotFound . runQnotFound . getLastPosts
4242
43−getPostsForUserApi :: UserPostsRequest -> App PostResponse
43+getPostsForUserApi :: UserPostsRequest -> App (ResponseWithUsers [P.Post])
4444getPostsForUserApi (LimitingRequest uId lim) = maybeNotFound . runQnotFound $ getPostsForUser lim uId
4545
4646publishPostApi :: UserId -> P.PostCreation -> App P.PostId
denis/src/Server/Query/ComplexQuery.hsnew file+120
@@ -0,0 +1,120 @@
1+{-# LANGUAGE
2+ FlexibleInstances,
3+ DataKinds,
4+ TypeOperators,
5+ OverloadedStrings,
6+ ScopedTypeVariables,
7+ MultiParamTypeClasses,
8+ KindSignatures,
9+ TypeFamilies,
10+ LambdaCase,
11+ PartialTypeSignatures,
12+ TupleSections #-}
13+
14+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
15+{-# OPTIONS_GHC -Wno-orphans #-}
16+
17+module Server.Query.ComplexQuery (
18+ ComplexQuery
19+) where
20+
21+import Data.ByteString.Lazy (ByteString)
22+import Data.ByteString.Builder (toLazyByteString)
23+import qualified Data.ByteString.Lazy.Char8 as BSC
24+import qualified Data.ByteString.Char8 as BC
25+import Servant.Server
26+import Data.Proxy
27+import Servant.API
28+import Servant.Server.Internal
29+import qualified Data.Text as T
30+import GHC.Conc
31+import Network.Wai.Internal
32+import Control.Monad.IO.Class
33+import Control.Concurrent.STM.TVar
34+import Data.IORef (newIORef,modifyIORef',readIORef)
35+import Network.Wai
36+import Control.Monad
37+import Control.Monad.Error.Class
38+import Servant.Docs hiding (Response)
39+import qualified Data.Map as M
40+
41+-- MARK: Documentation
42+
43+instance (HasDocs api) => HasDocs (ComplexQuery :> api) where
44+ docsFor _ = docsFor (Proxy :: Proxy (ComplexApi :<|> api))
45+
46+instance {-# Overlapping #-} ToSample (ComplexQueryRequest) where
47+ toSamples _ = samples $ [
48+ M.fromList [("posts/last", "8"), ("users/all", "")],
49+ M.fromList [("channels/","[{\"people\":[1],\"name\":\"newChannelName\",\"id\":7,\"tags\":[]},{\"people\":[1],\"name\":\"newChannelName\",\"id\":6,\"tags\":[]},{\"people\":[1],\"name\":\"newChannelName\",\"id\":5,\"tags\":[]},{\"people\":[1,1,2,2,2],\"name\":\"sssss\",\"id\":4,\"tags\":[\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsAlsoHashTag\",\"cs\"]},{\"people\":[1,7,2,19],\"name\":\"ChannelName\",\"id\":1,\"tags\":[\"sos\"]}]"),("posts/last", "{\"users\":{\"1\":{\"middleName\":\"FirstUser\",\"lastName\":\"FirstUser\",\"firstName\":\"FirstUser\",\"id\":1}},\"response\":[{\"body\":[{\"markdown\":\"hello\"}],\"authorId\":1,\"id\":28,\"updated\":\"2019-04-13T16:14:38.495832Z\",\"tags\":[]}]}")]]
50+
51+-- MARK: Implementation
52+
53+data ComplexQuery
54+
55+
56+type ComplexQueryRequest = M.Map T.Text String
57+type ComplexQueryRepsonse = M.Map T.Text String
58+
59+type ComplexQueryDescription = Description "Complex query\nNOTE: both request and response samples are the same. The first one is the request, the second one is the response.\nAllows you to query several endpoints within one request.\nThe order of queries (both execution and response) is not determined. If one of the queries returns a non-2XX response, the first such response is returned.\n## Do not perform modifications in this query. You will have no way of telling whether it succeeded."
60+
61+type ComplexApi = "complex" :> ComplexQueryDescription :> ReqBody '[JSON] (ComplexQueryRequest) :> Post '[JSON] (ComplexQueryRepsonse)
62+
63+instance HasServer api context => HasServer (ComplexQuery :> api :: *) context where
64+
65+ type ServerT (ComplexQuery :> api) m = ServerT api m
66+
67+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
68+
69+ route _ context subserver = choice complex rest
70+ where
71+ rest = route (Proxy :: Proxy api) context subserver
72+ complexProxy = Proxy :: Proxy (ComplexApi)
73+ complexServer :: _ -> Request -> ComplexQueryRequest -> Handler (ComplexQueryRepsonse)
74+ complexServer env req query = do
75+ responses <- liftIO . newTVarIO $ Right M.empty
76+ recieved <- liftIO $ forM (M.toList query) $ uncurry $ \queryPath body -> do
77+ newReq <- replaceBody (BSC.pack body) req
78+ serverRest (replacePath queryPath newReq) $ respond responses queryPath
79+ recieved `seq` do
80+ result <- liftIO $ readTVarIO responses
81+ case result of
82+ Left err -> throwError err
83+ Right resp -> return resp
84+ where
85+ serverRest = runRouterEnv (route (Proxy :: Proxy api) context subserver) env
86+ respond :: TVar (Either ServantErr (M.Map T.Text String)) -> T.Text -> RouteResult Response -> IO ResponseReceived
87+ respond responses queryPath = (>> return ResponseReceived) .
88+ \case
89+ (Fail err) -> atomically . writeTVar responses $ Left err
90+ (FailFatal err) -> atomically . writeTVar responses $ Left err
91+ (Route r) -> do
92+ body <- BSC.unpack <$> responseBody r
93+ atomically . modifyTVar responses $ fmap (M.insert queryPath body)
94+ complex = RawRouter $ \env req ->
95+ (flip runRouterEnv env $ route complexProxy context (emptyDelayed (Route $ complexServer env req))) req
96+
97+-- ref: https://stackoverflow.com/questions/45467648/how-to-read-response-body-in-wai-middleware
98+responseBody :: Response -> IO ByteString
99+responseBody res =
100+ let (_,_,body) = responseToStream res in
101+ body $ \f -> do
102+ content <- newIORef mempty
103+ f (\chunk -> modifyIORef' content (<> chunk)) (return ())
104+ toLazyByteString <$> readIORef content
105+
106+replaceBody :: ByteString -> Request -> IO Request
107+replaceBody newB resp = do
108+ t <- newTVarIO True
109+ return resp {
110+ requestBody = do
111+ v <- atomically $ do
112+ oldValue <- readTVar t
113+ writeTVar t False
114+ return oldValue
115+ return $ if v then BSC.toStrict newB else BC.empty
116+ }
117+
118+replacePath :: T.Text -> Request -> Request
119+replacePath newPath req = req {
120+ pathInfo = T.splitOn "/" newPath}