@@ -1,1316 +0,0 @@
1−{-# LANGUAGE
2− DataKinds,
3− DeriveGeneric,
4− OverloadedLabels,
5− OverloadedStrings,
6− TypeApplications,
7− TypeOperators,
8− PartialTypeSignatures,
9− FlexibleInstances,
10− KindSignatures,
11− DeriveAnyClass,
12− RecordWildCards,
13− ScopedTypeVariables #-}
14−
15−{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
16−
17−
18−module Data.Query (
19− Schema,
20− createTables,
21− getPosts,
22− -- getUser,
23− getUsers,
24− getAllUsers,
25− getLastPosts,
26− getPostsForUser,
27− Limit,
28− publishPost,
29− getChannelPosts,
30− updateChannel,
31− createNewChannel,
32− getAllChannels,
33− getAnonymousChannelPosts,
34− deleteNamedChannel,
35− HasUsers(..),
36− wrapIntoUsers,
37− ResponseWithUsers(..),
38− getTags,
39− getDialogs,
40− getMessagesInUserChat,
41− getMessagesInGroupChat,
42− sendMessage,
43− createGroupChat,
44− updateGroupChat,
45− leaveGroupChat,
46− getGroupChatForUser,
47− getFaculty,
48− updateFaculty,
49− getFacultyFromQuery,
50− getUserWithEmail,
51− createToken,
52− validateToken,
53− invalidateToken,
54− tryVerifyToken,
55− getVerifiedToken,
56− UserCreation(..),
57− createUser,
58− tryActivateToken,
59− deactivateToken,
60− searchUsers,
61− searchTags,
62− updateUser,
63− UserUpdateRow(..),
64− killAllTokens,
65− channelCountForUser,
66− pruneAuth,
67− searchChannels,
68− isValidFaculty,
69− groupChatIsValidForUser
70− ) where
71−
72−import Squeal.PostgreSQL
73−import Data.User
74−import Data.Post
75−import Data.Schema
76−import Data.Function (on)
77−import Data.Connection
78−import Data.PostElement
79−import qualified Servant as S
80−import Control.Monad
81−import Control.Monad.Morph
82−import Data.Word (Word64)
83−import qualified Data.List as L
84−import qualified Data.Map.Strict as M
85−import qualified Data.Set as Set
86−import qualified Generics.SOP as SOP
87−import qualified GHC.Generics as GHC
88−import Data.Int (Int64)
89−import Data.ByteString.Char8 (pack)
90−import GHC.Generics (Generic)
91−import Data.Aeson hiding (Null)
92−import Servant.Docs
93−import Data.Proxy
94−import Data.Vector (Vector, toList, fromList)
95−import Data.Text (Text)
96−import qualified Data.Text as T
97−import Data.Channel.NamedChannel
98−import Data.Channel.AnonymousChannel
99−import Data.Maybe (fromMaybe, catMaybes, isJust)
100−import Squeal.PostgreSQL.Render
101−import Data.GroupChat
102−import Data.Message
103−import Server.Query.Dialog
104−import qualified Server.Query.Pagination as P
105−import Data.Faculty
106−import Data.ByteString (ByteString)
107−import Data.Foldable (fold)
108−import Data.Char
109−import qualified Data.Vector as V
110−import Server.Auth.Token
111−import Server.Error
112−import Data.Text.Validator
113−
114−-- MARK: Documentation
115−
116−instance (ToSample r) => ToSample (ResponseWithUsers r) where
117− toSamples _ = samples $ ResponseWithUsers <$> (map snd $ toSamples Proxy) <*> [M.fromList $ map (tupleFirst userId . snd) (toSamples Proxy)]
118−
119−
120−-- MARK: Generalized Post Queries
121−
122−type TableEndo schema params from grouping = TableExpression schema params from grouping ->
123− TableExpression schema params from grouping
124−
125−postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
126−postsQ te = selectStar $ te (from $ table #posts)
127−
128−postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped
129−postViewT te = from $ subquery (postsQ te `As` #posts) &
130− innerJoin (table #postElements)
131− (#posts ! #postRowId .== #postElements ! #rowElementId)
132−
133−getPostQ
134− :: TableEndo Schema params _ 'Ungrouped
135− -- ^ PostRowResponse endo
136− -> TableEndo Schema params _ 'Ungrouped
137− -- ^ PostRow endo
138− -> Query Schema params (RowPG PostRowResponse)
139−getPostQ oTe te = select (
140− #posts ! #postRowId :*
141− #posts ! #postRowAuthorId :*
142− #posts ! #postRowUpdateTime :*
143− #posts ! #postRowTags :*
144− -- #rowElementId :*
145− #postElements ! #rowElementOrd :*
146− #postElements ! #rowElementMarkdown :*
147− #postElements ! #rowElementLatex :*
148− #postElements ! #rowElementImage :*
149− #postElements ! #rowElementQuote :*
150− #postElements ! #rowElementAttachment)
151− (oTe $ postViewT te)
152−
153−
154−-- MARK: Concrete Queries
155−
156−-- getQuoteRowsQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG (ElementRow Post))
157−-- getQuoteRowsQ = UnsafeQuery "WITH RECURSIVE getQuote AS ( \
158−-- \SELECT * FROM \"quoteElements\" quote WHERE \"rowElementId\" = $1 \
159−-- \UNION ALL \
160−-- \SELECT newQuote.* FROM \"quoteElements\" newQuote \
161−-- \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
162−-- \) \
163−-- \SELECT * FROM getQuote"
164−
165−-- getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
166−-- getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
167−
168−-- getQuote :: QuoteId -> PQ Quote
169−-- getQuote qId = do
170−-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows
171−-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0
172−-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
173−-- return $ M.lookup qId rows >>= rowsToQuote rows
174−
175−getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))
176−getUserWithEmailQ = select (
177− #userRowId `as` #userId :*
178− #userRowFirstName `as` #firstName :*
179− #userRowMiddleName `as` #middleName :*
180− #userRowLastName `as` #lastName :*
181− #userRowFacultyUrl `as` #userFaculty :*
182− #userRowEmail `as` #userEmail
183− ) (from (table #users) &
184− where_ (#userRowEmail .== param @1) &
185− where_ (notNull #userRowIsValidated))
186−
187−verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
188−verifiedUserIdsQ uIds = case idsToColumn uIds of
189− Just idQ -> Just $ select (#users ! #userRowId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
190− innerJoin (table #users)
191− (#ids ! #id .== #users ! #userRowId))
192− Nothing -> Nothing
193−
194−getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))
195−getUsersQ uIds = case idsToColumn uIds of
196− Just idQ -> Just $ select (
197− #users ! #userRowId :*
198− #users ! #userRowFirstName :*
199− #users ! #userRowMiddleName :*
200− #users ! #userRowLastName :*
201− #users ! #userRowFacultyUrl :*
202− #users ! #userRowEmail :*
203− #users ! #userRowIsValidated :*
204− #faculties ! #facultyName `as` #userRowFacultyName :*
205− #faculties ! #facultyUrl `as` #userRowFacultyURL :*
206− #faculties ! #facultyPath `as` #userRowFacultyPath :*
207− #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
208− #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
209− #faculties ! #facultyTags `as` #userRowFacultyTags :*
210− #faculties ! #facultyAddress `as` #userRowFacultyAddress
211− ) (from (subquery (idQ `As` #ids) &
212− innerJoin (table #users)
213− (#ids ! #id .== #users ! #userRowId) &
214− innerJoin (table #faculties)
215− (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl)) &
216− where_ (notNull $ #users ! #userRowIsValidated))
217− Nothing -> Nothing
218−
219−getAllUsersQ :: Query Schema '[] (RowPG UserRow)
220−getAllUsersQ = select (
221− #users ! #userRowId :*
222− #users ! #userRowFirstName :*
223− #users ! #userRowMiddleName :*
224− #users ! #userRowLastName :*
225− #users ! #userRowFacultyUrl :*
226− #users ! #userRowEmail :*
227− #users ! #userRowIsValidated :*
228− #faculties ! #facultyName `as` #userRowFacultyName :*
229− #faculties ! #facultyUrl `as` #userRowFacultyURL :*
230− #faculties ! #facultyPath `as` #userRowFacultyPath :*
231− #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
232− #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
233− #faculties ! #facultyTags `as` #userRowFacultyTags :*
234− #faculties ! #facultyAddress `as` #userRowFacultyAddress
235− ) (from ((table #users) &
236− innerJoin (table #faculties)
237− (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&
238− where_ (notNull $ #users ! #userRowIsValidated))
239−
240−getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
241−getPostsByIdQ pIds = case idsToColumn pIds of
242− Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
243− innerJoin (subquery $ getPostQ
244− (orderBy [#postElements ! #rowElementId & Desc, #postElements ! #rowElementOrd & Asc]) id `As` #posts)
245− (#ids ! #id .== #posts ! #postRowId))
246− Nothing -> Nothing
247−
248−type Limit = Word64
249−
250−isNotFalse
251− :: Expression schema from grouping params ('Null ty)
252− -- ^ possibly @NULL@
253− -> Condition schema from grouping params
254−isNotFalse x = UnsafeExpression $ renderExpression x <+> "IS NOT FALSE"
255−
256−getLastPostsQ
257− :: TableEndo _ _ _ _
258− -> Limit
259− -> P.PaginationDirection
260− -> Query Schema ('Null (PG Int64) ': params) (RowPG PostRowResponse)
261−getLastPostsQ te lim dir = getPostQ
262− (orderBy [#postElements ! #rowElementId & Desc, #postElements ! #rowElementOrd & Asc])
263− (limit lim .
264− te .
265− where_ (ifThenElse (isNull $ param @1) true $ #posts ! #postRowId .^ param @1) .
266− orderBy [#posts ! #postRowId & order])
267− where
268− ((.^), order) = directionToOperator dir
269−
270−getLastNPostsForUserQ
271− :: Limit
272− -> P.PaginationDirection
273− -> Query Schema (TuplePG (Maybe PostId, UserId)) (RowPG PostRowResponse)
274−getLastNPostsForUserQ = getLastPostsQ $ where_ (#posts ! #postRowAuthorId .== param @2)
275−
276−createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
277−createPostRowQ = insertRow #posts
278− (Default `as` #postRowId :*
279− Set (param @1) `as` #postRowAuthorId :*
280− Set currentTimestamp `as` #postRowUpdateTime :*
281− Set (param @2) `as` #postRowTags)
282− OnConflictDoRaise
283− (Returning $ #postRowId `as` #fromOnly)
284−
285−createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
286−createPostElementRowsQ = insertRow_ #postElements
287− (Set (param @1) `as` #rowElementId :*
288− Set (param @2) `as` #rowElementOrd :*
289− Set (param @3) `as` #rowElementMarkdown :*
290− Set (param @4) `as` #rowElementLatex :*
291− Set (param @5) `as` #rowElementImage :*
292− Set (param @6) `as` #rowElementQuote :*
293− Set (param @7) `as` #rowElementAttachment)
294−
295−getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
296−getChannelForUserQ = selectStar $
297− from (table #channels) &
298− where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
299−
300−updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))
301−updateUserQ = update #users (
302− Same `as` #userRowId :*
303− Set (param @2) `as` #userRowFirstName :*
304− Set (param @3) `as` #userRowMiddleName :*
305− Set (param @4) `as` #userRowLastName :*
306− Set (param @5) `as` #userRowFacultyUrl :*
307− Same `as` #userRowEmail :*
308− Same `as` #userRowIsValidated)
309− (#userRowId .== param @1)
310− (Returning $ #userRowId `as` #fromOnly)
311−
312−getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
313−getAllChannelsForUserQ = selectStar $
314− from (table #channels) &
315− where_ (#namedChannelFullOwner .== param @1) &
316− orderBy [#namedChannelFullId & Desc]
317−
318−searchChannelsForUserQ :: Query Schema (TuplePG (UserId, Text)) (RowPG NamedChannelFull)
319−searchChannelsForUserQ = selectStar $
320− from (table #channels) &
321− where_ (#namedChannelFullOwner .== param @1) &
322− orderBy [
323− tsRankCd vector1 query & Desc,
324− tsRankCd vector query & Desc
325− ]
326− where
327− vector = tsVector' (textArrayToText [
328− #namedChannelFullName,
329− unsafeFunction "unnest" #namedChannelFullTags
330− ])
331− vector1 = tsVector' #namedChannelFullName
332− query = tsQuery' (param @2)
333−
334−updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
335−updateFacultyQ = insertRow #faculties
336− (
337− Set (param @1) `as` #facultyName :*
338− Set (param @2) `as` #facultyUrl :*
339− Set (param @3) `as` #facultyPath :*
340− Set (param @4) `as` #facultyCampusName :*
341− Set (param @5) `as` #facultyCampusCode :*
342− Set (param @6) `as` #facultyTags :*
343− Set (param @7) `as` #facultyAddress
344− )
345− (OnConflictDoNothing)
346− (Returning Nil)
347−
348−getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
349−getFacultyQ = selectStar (from (table #faculties) &
350− where_ (#facultyUrl .== param @1))
351−
352−createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
353−createNamedChannelQ = insertRow #channels
354− (
355− Default `as` #namedChannelFullId :*
356− Set (param @1) `as` #namedChannelFullOwner :*
357− Set (param @2) `as` #namedChannelFullName :*
358− Set (param @3) `as` #namedChannelFullTags :*
359− Set (param @4) `as` #namedChannelFullPeopleIds
360− )
361− OnConflictDoRaise
362− (Returning $ #namedChannelFullId `as` #fromOnly)
363−
364−countChannelsQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only Int64))
365−countChannelsQ = select (countStar `as` #fromOnly) (from (table #channels) &
366− where_ (#namedChannelFullOwner .== param @1) &
367− groupBy #namedChannelFullOwner)
368−
369−deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
370−deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
371−
372−updateNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelFull) '[]
373−updateNamedChannelQ = update_ #channels
374− (
375− Same `as` #namedChannelFullId :*
376− Same `as` #namedChannelFullOwner :*
377− Set (param @3) `as` #namedChannelFullName :*
378− Set (param @4) `as` #namedChannelFullTags :*
379− Set (param @5) `as` #namedChannelFullPeopleIds
380− )
381− (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)
382−
383−getChannelPostsQ
384− :: Limit
385− -> P.PaginationDirection
386− -> [UserId]
387− -> Vector Text
388− -> Query
389− Schema
390− (TuplePG (Only (Maybe PostId))) -- post id from which to start
391− (RowPG PostRowResponse)
392−getChannelPostsQ lim dir uIds tags = getLastPostsQ
393− (where_ $ jsonbLit tags .?| #postRowTags .|| isUser #postRowAuthorId)
394− lim
395− dir
396− where
397− isUser = case idsToColumn uIds of
398− Just uIdsQ -> (`in_` uIdsQ)
399− Nothing -> const $ false
400−
401−getTagsQ :: Query Schema params (RowPG (Only String))
402−getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
403− from (table #posts)
404−
405−createMessageQ :: Manipulation
406− Schema
407− (TuplePG (UserId, Maybe GroupChatId, Maybe UserId, Jsonb (PostElement (MessageCreation))))
408− (RowPG (Only MessageId))
409−createMessageQ = insertRow #messages
410− (
411− Default `as` #messageStorageId :*
412− Set (notNull $ param @1) `as` #messageStorageAuthorId :*
413− Set (param @2) `as` #messageStorageDestinationGroupId :*
414− Set (param @3) `as` #messageStorageDestinationUserId :*
415− Set (notNull $ param @4) `as` #messageStorageBody :*
416− Set currentTimestamp `as` #messageStorageTime
417− )
418− OnConflictDoRaise
419− (Returning $ #messageStorageId `as` #fromOnly)
420−
421−createPhantomMessageQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]
422−createPhantomMessageQ = insertRow_ #messages
423− (
424− Default `as` #messageStorageId :*
425− Set null_ `as` #messageStorageAuthorId :*
426− Set (notNull $ param @1) `as` #messageStorageDestinationGroupId :*
427− Set null_ `as` #messageStorageDestinationUserId :*
428− Set null_ `as` #messageStorageBody :*
429− Set currentTimestamp `as` #messageStorageTime
430− )
431−
432−createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
433−createGroupChatQ = insertRow #groupChats
434− (
435− Default `as` #groupChatId :*
436− Set (param @1) `as` #groupChatUsers :*
437− Set (param @2) `as` #groupChatName
438− )
439− OnConflictDoRaise
440− (Returning $ #groupChatId `as` #fromOnly)
441−
442−updateGroupChatQ :: Manipulation Schema (TuplePG GroupChat) '[]
443−updateGroupChatQ = update_ #groupChats
444− (
445− Same `as` #groupChatId :*
446− Set (param @2) `as` #groupChatUsers :*
447− Set (param @3) `as` #groupChatName
448− )
449− (#groupChatId .== param @1)
450−
451−type ChatsQueryResponse = '[
452− "messageId" ::: 'NotNull (PG UserId),
453− "messageGroupId" ::: 'Null (PG UserId),
454− "messageUserId" ::: 'Null (PG UserId)
455− ]
456−
457−type ConditionOp schema from grouping params nullity0 nullity1 (ty :: PGType)
458− = Expression schema from grouping params (nullity0 ty)
459− -> Expression schema from grouping params (nullity1 ty)
460− -> Condition schema from grouping params
461−
462−type ChatQueryParams = TuplePG
463− ( UserId
464− , Maybe String -- Just UserId as String
465− , Maybe MessageId
466− )
467−
468−getChatsQ
469− :: Limit
470− -> P.PaginationDirection
471− -> Query Schema ChatQueryParams (RowPG ChatsResponse)
472−getChatsQ lim dir = select (
473− #chats ! #messageId `as` #chatResponseMessageId :*
474− #messages ! #messageStorageAuthorId `as` #chatResponseMessageAuthorId :*
475− #messages ! #messageStorageDestinationGroupId `as` #chatResponseMessageDestinationGroupId :*
476− #messages ! #messageStorageDestinationUserId `as` #chatResponseMessageDestinationUserId :*
477− #messages ! #messageStorageBody `as` #chatResponseMessageBody :*
478− #messages ! #messageStorageTime `as` #chatResponseMessageTime :*
479− #groupChats ! #groupChatUsers `as` #chatResponseGroupUsers :*
480− #groupChats ! #groupChatName `as` #chatResponseGroupName
481− ) $ from (
482− (subquery $ chatsQ `As` #chats) &
483− innerJoin
484− (table #messages)
485− (#chats ! #messageId .== #messages ! #messageStorageId) &
486− leftOuterJoin
487− (table #groupChats)
488− (#groupChats ! #groupChatId .== #chats ! #messageGroupId)) &
489− where_ (isNull (#groupChats ! #groupChatUsers) .||
490− (#groupChats ! #groupChatUsers .? param @2)) &
491− where_ (isNotFalse $ #chats ! #messageId .^ param @3) &
492− orderBy [#chats ! #messageId & order] &
493− limit lim &
494− orderBy [#chats ! #messageId & Desc]
495− where
496− ((.^), order) = directionToOperator dir
497− chatsQ :: Query Schema _ ChatsQueryResponse
498− chatsQ = unionAll groupChats userChats
499− where
500− allUserMessages :: Query Schema _ ChatsQueryResponse
501− allUserMessages = select (
502− #messageStorageId `as` #messageId :*
503− null_ `as` #messageGroupId :*
504− (ifThenElse
505− (#messageStorageAuthorId .== param @1)
506− #messageStorageDestinationUserId
507− #messageStorageAuthorId) `as` #messageUserId) $
508− from (table #messages) &
509− where_ (isNotNull #messageStorageDestinationUserId .&&
510− (#messageStorageAuthorId .== param @1 .||
511− #messageStorageDestinationUserId .== param @1))
512− userChats :: Query Schema _ ChatsQueryResponse
513− userChats = select (
514− max_ #messageId `as` #messageId :*
515− null_ `as` #messageGroupId :*
516− #messageUserId `as` #messageUserId) $
517− from (subquery $ allUserMessages `As` #allUserMessages) &
518− groupBy (#allUserMessages ! #messageUserId)
519− groupChats :: Query Schema _ ChatsQueryResponse
520− groupChats = select (
521− max_ #messageStorageId `as` #messageId :*
522− #messageStorageDestinationGroupId `as` #messageGroupId :*
523− null_ `as` #messageUserId) $
524− from (table #messages) &
525− where_ (isNotNull #messageStorageDestinationGroupId) &
526− groupBy #messageStorageDestinationGroupId
527−
528−getMessagesQ
529− :: Limit
530− -> P.PaginationDirection
531− -> Query Schema (TuplePG
532− ( UserId
533− , UserId
534− , Maybe MessageId
535− )) (RowPG MessageStorage)
536−getMessagesQ lim dir = selectStar (from (table #messages) &
537− where_ (isNotNull #messageStorageDestinationUserId .&&
538− ((#messageStorageAuthorId .== param @1 .&& #messageStorageDestinationUserId .== param @2) .||
539− (#messageStorageDestinationUserId .== param @1 .&& #messageStorageAuthorId .== param @2))) &
540− where_ (isNotFalse $ #messageStorageId .^ param @3) &
541− orderBy [#messageStorageId & order] &
542− limit lim &
543− orderBy [#messageStorageId & Desc])
544− where
545− ((.^), order) = directionToOperator dir
546−
547−getGroupMessagesQ
548− :: Limit
549− -> P.PaginationDirection
550− -> Query Schema (TuplePG
551− ( GroupChatId
552− , Maybe MessageId
553− )) (RowPG MessageStorage)
554−getGroupMessagesQ lim dir = selectStar (from (table #messages) &
555− where_ (isNotNull #messageStorageDestinationGroupId .&&
556− (#messageStorageDestinationGroupId .== param @1)) &
557− where_ (isNotFalse $ #messageStorageId .^ param @2) &
558− orderBy [#messageStorageId & order] &
559− limit lim &
560− orderBy [#messageStorageId & Desc])
561− where
562− ((.^), order) = directionToOperator dir
563−
564−-- String -- user id as String
565−getGroupChatForUserQ :: Query Schema (TuplePG (String, GroupChatId)) (RowPG GroupChat)
566−getGroupChatForUserQ = selectStar $
567− (from (table #groupChats)) &
568− where_ (#groupChatId .== param @2) &
569− where_ (#groupChatUsers .? param @1)
570−
571−getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
572−getFacultySearchResultQ = selectStar (from (table #faculties) &
573− where_ (vector @@ query) &
574− orderBy [
575− tsRankCd vector1 query & Desc,
576− tsRankCd vector2 query & Desc,
577− tsRankCd vector query & Desc
578− ])
579− where
580− vector = tsVector "russian" (textArrayToText [
581− #facultyName,
582− #facultyPath,
583− #facultyCampusName,
584− (arrayToText #facultyTags)])
585− vector1 = tsVector "russian" #facultyName
586− vector2 = tsVector "russian" (textArrayToText [
587− #facultyName,
588− #facultyPath])
589− query = tsQuery "russian" (param @1)
590−
591−searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
592−searchUsersQ = select (
593− #users ! #userRowId :*
594− #users ! #userRowFirstName :*
595− #users ! #userRowMiddleName :*
596− #users ! #userRowLastName :*
597− #users ! #userRowFacultyUrl :*
598− #users ! #userRowEmail :*
599− #users ! #userRowIsValidated :*
600− #faculties ! #facultyName `as` #userRowFacultyName :*
601− #faculties ! #facultyUrl `as` #userRowFacultyURL :*
602− #faculties ! #facultyPath `as` #userRowFacultyPath :*
603− #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
604− #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
605− #faculties ! #facultyTags `as` #userRowFacultyTags :*
606− #faculties ! #facultyAddress `as` #userRowFacultyAddress
607− ) (from ((table #users) &
608− innerJoin (table #faculties)
609− (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl)) &
610− where_ (notNull $ #users ! #userRowIsValidated) &
611− where_ (vector @@ query) &
612− orderBy [tsRankCd vector query & Desc] &
613− limit 100)
614− where
615− vector = tsVector' (textArrayToText [
616− #users ! #userRowFirstName,
617− #users ! #userRowMiddleName,
618− #users ! #userRowLastName
619− ])
620− query = tsQuery' (param @1)
621−
622−tagsByFrquencyQ :: Query Schema params '["tag" ::: 'NotNull (PG Text), "count" ::: 'NotNull 'PGint8]
623−tagsByFrquencyQ = select
624− (#fromOnly `as` #tag :* count #fromOnly `as` #count)
625− (from (subquery $ getTagsQ `As` #tt) &
626− groupBy #fromOnly)
627−
628−getNpopularTagsQ :: Limit -> Query Schema param (RowPG (Only Text))
629−getNpopularTagsQ lim = select (#tag `as` #fromOnly)
630− (from (subquery $ tagsByFrquencyQ `As` #tt) &
631− orderBy [#count & Desc] &
632− limit lim)
633−
634−
635−searchTagsQ :: Query Schema (TuplePG (Only Text)) (RowPG (Only Text))
636−searchTagsQ = select (#tag `as` #fromOnly) $
637− from (subquery (tagsByFrquencyQ `As` #tt)) &
638− where_ (vector @@ query) &
639− orderBy [#count & Desc] &
640− limit 100
641− where
642− query = tsQuery' (param @1)
643− vector = tsVector' #tag
644−
645−tsRankCd
646− :: Expression schema from grouping params ('NotNull 'PGtext)
647− -> Expression schema from grouping params ('NotNull 'PGtext)
648− -> Expression schema from grouping params ('NotNull 'PGfloat4)
649−tsRankCd vector query = UnsafeExpression $
650− "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])
651−
652−tsVector
653− :: ByteString -- ^ Language
654− -> Expression schema from grouping params ('NotNull 'PGtext)
655− -> Expression schema from grouping params ('NotNull 'PGtext)
656−tsVector lang x = UnsafeExpression $
657− "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
658−
659−tsVector'
660− :: Expression schema from grouping params ('NotNull 'PGtext)
661− -> Expression schema from grouping params ('NotNull 'PGtext)
662−tsVector' x = UnsafeExpression $
663− "to_tsvector" <> parenthesized (renderExpression x)
664−
665−tsQuery
666− :: ByteString -- ^ Language
667− -> Expression schema from grouping params ('NotNull 'PGtext)
668− -> Expression schema from grouping params ('NotNull 'PGtext)
669−tsQuery lang x = UnsafeExpression $
670− "to_tsquery" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
671−
672−tsQuery'
673− :: Expression schema from grouping params ('NotNull 'PGtext)
674− -> Expression schema from grouping params ('NotNull 'PGtext)
675−tsQuery' x = UnsafeExpression $
676− "to_tsquery" <> parenthesized (renderExpression x)
677−
678−arrayToText
679− :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
680− -> Expression schema from grouping params ('NotNull 'PGtext)
681−arrayToText x = UnsafeExpression $
682− "array_to_string" <> parenthesized (commaSeparated [renderExpression x, "' '"])
683−
684−(@@)
685− :: Expression schema from grouping params (nullity0 'PGtext)
686− -> Expression schema from grouping params (nullity1 'PGtext)
687− -> Expression schema from grouping params (nullity2 'PGbool)
688−(@@) = unsafeBinaryOp "@@"
689−
690−space :: Expression schema from grouping params ('NotNull 'PGtext)
691−space = UnsafeExpression "' '"
692−
693−textArrayToText
694− :: [Expression schema from grouping params ('NotNull 'PGtext)]
695− -> Expression schema from grouping params ('NotNull 'PGtext)
696−textArrayToText = fold . L.intersperse space
697−
698−createUserQ :: Manipulation Schema (TuplePG UserCreation) (RowPG (Only UserId))
699−createUserQ = insertRow #users (
700− Default `as` #userRowId :*
701− Set (param @1) `as` #userRowFirstName :*
702− Set (param @2) `as` #userRowMiddleName :*
703− Set (param @3) `as` #userRowLastName :*
704− Set (param @4) `as` #userRowFacultyUrl :*
705− Set (param @5) `as` #userRowEmail :*
706− Set false `as` #userRowIsValidated)
707− OnConflictDoRaise
708− (Returning (#userRowId `as` #fromOnly))
709−
710−removeUnverifiedUserQ :: Manipulation Schema (TuplePG (Only UserEmail)) '[]
711−removeUnverifiedUserQ = deleteFrom_ #users
712− (#userRowEmail .== param @1 .&&
713− (not_ . notNull $ #userRowIsValidated))
714−
715−
716−createTokenQ :: Manipulation Schema (TuplePG Token) '[]
717−createTokenQ = insertRow_ #tokens (
718− Set (param @1) `as` #tokenUserId :*
719− Set (param @2) `as` #tokenValue :*
720− Set (param @3) `as` #tokenExpiryDate :*
721− Set (param @4) `as` #tokenVerificationCode :*
722− Set (param @5) `as` #tokenActivationTriesLeft :*
723− Set (param @6) `as` #tokenUserAgent :*
724− Set (param @7) `as` #tokenActivationCode :*
725− Set (param @8) `as` #tokenDeactivationCode
726− )
727−
728−updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
729−updateTokenQ = update_ #tokens (
730− Same `as` #tokenUserId :*
731− Same `as` #tokenValue :*
732− Set (param @3) `as` #tokenExpiryDate :*
733− Set (param @4) `as` #tokenVerificationCode :*
734− Set (param @5) `as` #tokenActivationTriesLeft :*
735− Set (param @6) `as` #tokenUserAgent :*
736− Set (param @7) `as` #tokenActivationCode :*
737− Set (param @8) `as` #tokenDeactivationCode)
738− (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
739−
740−deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
741−deleteTokenQ = deleteFrom_ #tokens
742− (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
743−
744−validateUserQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
745−validateUserQ = update_ #users (
746− Same `as` #userRowId :*
747− Same `as` #userRowFirstName :*
748− Same `as` #userRowMiddleName :*
749− Same `as` #userRowLastName :*
750− Same `as` #userRowFacultyUrl :*
751− Same `as` #userRowEmail :*
752− Set true `as` #userRowIsValidated)
753− (#userRowId .== param @1)
754−
755−getTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
756−getTokenQ = selectStar (from (table #tokens) &
757− where_ (#tokenUserId .== param @1 .&&
758− #tokenValue .== param @2))
759−
760−getTokenActivationQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
761−getTokenActivationQ = selectStar (from (table #tokens) &
762− where_ (#tokenUserId .== param @1 .&&
763− #tokenActivationCode .== param @2))
764−
765−deactivateTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) (RowPG (Only Text))
766−deactivateTokenQ = deleteFrom #tokens
767− (#tokenUserId .== param @1 .&&
768− #tokenDeactivationCode .== param @2)
769− (Returning (#tokenUserAgent `as` #fromOnly))
770−
771−getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
772−getVerifiedTokenQ = selectStar (from (table #tokens) &
773− where_ (#tokenUserId .== param @1 .&&
774− #tokenValue .== param @2 .&&
775− isNull #tokenVerificationCode .&&
776− currentTimestamp .< #tokenExpiryDate))
777−
778−killAllTokensQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
779−killAllTokensQ = deleteFrom_ #tokens
780− (#tokenUserId .== param @1)
781−
782−pruneDeadTokensQ :: Manipulation Schema '[] '[]
783−pruneDeadTokensQ = deleteFrom_ #tokens
784− (#tokenExpiryDate .< currentTimestamp)
785−
786−pruneGhostUsersQ :: Manipulation Schema '[] '[]
787−pruneGhostUsersQ = deleteFrom_ #users
788− ((not_ . in_ #userRowId $ select (#tokens ! #tokenUserId `as` #id) (from $ table #tokens)) .&&
789− (not_ . notNull $ #userRowIsValidated))
790−
791−-- MARK: FrontEnd Data Structures
792−
793−instance HasValidatableText UserCreation where
794− validateText UserCreation{..} = all validateText [
795− userCreationFirstName,
796− userCreationMiddleName,
797− userCreationLastName,
798− userCreationUserFaculty,
799− userCreationUserEmail]
800−
801−data UserCreation = UserCreation {
802− userCreationFirstName :: Text,
803− userCreationMiddleName :: Text,
804− userCreationLastName :: Text,
805− userCreationUserFaculty :: FacultyUrl,
806− userCreationUserEmail :: Text
807−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
808−
809−instance ToJSON UserCreation where
810− toJSON (UserCreation fName mName lName faculty email) = object [
811− "firstName" .= fName,
812− "middleName" .= mName,
813− "lastName" .= lName,
814− "faculty" .= faculty,
815− "email" .= email
816− ]
817−
818−instance FromJSON UserCreation where
819− parseJSON = withObject "user creation" $ \e ->
820− UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
821−
822−data UserUpdateRow = UserUpdateRow {
823− userUpdateRowId :: UserId,
824− userUpdateRowFirstName :: Text,
825− userUpdateRowMiddleName :: Text,
826− userUpdateRowLastName :: Text,
827− userUpdateRowUserFaculty :: FacultyUrl
828−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
829−
830−
831−data NamedChannelCreation = NamedChannelCreation {
832− namedChannelCreationOwner :: UserId,
833− namedChannelCreationName :: Text,
834− namedChannelCreationTags :: Vector Text,
835− namedChannelCreationPeopleIds :: Vector UserId
836−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
837−
838−addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
839−addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
840−
841−data NamedChannelFull = NamedChannelFull {
842− namedChannelFullId :: NamedChannelId,
843− namedChannelFullOwner :: UserId,
844− namedChannelFullName :: Text,
845− namedChannelFullTags :: Vector Text,
846− namedChannelFullPeopleIds :: Vector UserId
847−} deriving GHC.Generic
848−
849−instance SOP.Generic NamedChannelFull
850−instance SOP.HasDatatypeInfo NamedChannelFull
851−
852−addUserToChannelUpdate :: UserId -> NamedChannel UserId -> NamedChannelFull
853−addUserToChannelUpdate uId (NamedChannel cId cName cTags cPeople) = NamedChannelFull cId uId cName cTags cPeople
854−
855−removeUserFromChannel :: NamedChannelFull -> NamedChannel UserId
856−removeUserFromChannel (NamedChannelFull cId _ cName cTags cPeople) = NamedChannel cId cName cTags cPeople
857−
858−getChannelForUser :: UserId -> NamedChannelId -> StaticPQ NamedChannelFull
859−getChannelForUser uId cId = do
860− channel <- runQueryParams getChannelForUserQ (uId, cId) >>= firstRow
861− case (channel :: Maybe NamedChannelFull) of
862− (Just c) -> return c
863− Nothing -> lift $ S.throwError S.err404
864−
865−-- TODO: Reject bad requests. Should be binary.
866−verifyUsers :: [UserId] -> StaticPQ ()
867−verifyUsers uIds =
868− case verifiedUserIdsQ uIds of
869− Just uIdsQ -> do
870− (us :: [UserId]) <- fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
871− when (length us /= length uIds) $ lift $ S.throwError impossibleContent
872− Nothing -> return ()
873−
874−deleteGroupChat :: GroupChatId -> StaticPQ ()
875−deleteGroupChat gId = do
876− _ <- manipulateParams deleteGroupChatQ (Only gId)
877− _ <- manipulateParams deleteGroupChatMessagesQ (Only gId)
878− return ()
879− where
880− deleteGroupChatQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]
881− deleteGroupChatQ = deleteFrom_ #groupChats
882− (#groupChatId .== param @1)
883− deleteGroupChatMessagesQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]
884− deleteGroupChatMessagesQ = deleteFrom_ #messages
885− (#messageStorageDestinationGroupId .== param @1)
886−
887−-- NOTE: Not transactional
888−createUser :: UserCreation -> StaticPQ UserId
889−createUser creation = do
890− _ <- manipulateParams removeUnverifiedUserQ (Only $ userCreationUserEmail creation)
891− rowThing <- manipulateParams createUserQ creation >>= firstRow >>= fromMaybe500
892− return (fromOnly rowThing)
893−
894−-- MARK: FrontEnd functions
895−
896−-- Nothing <=> no user
897−getPostsForUser
898− :: Maybe PostId
899− -> Limit
900− -> P.PaginationDirection
901− -> UserId
902− -> StaticPQ (Maybe (ResponseWithUsers [Post]))
903−getPostsForUser pId lim dir uId = do
904− postRows <- runQueryParams (getLastNPostsForUserQ lim dir) (pId, uId) >>= getRows
905− wrapIntoResponse (fromMaybe [] . rowsToPosts $ postRows)
906−
907−getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))
908−getPosts pId =
909− case getPostsByIdQ pId of
910− Just psQ -> do
911− postRows <- runQuery psQ >>= getRows
912− rowsToPosts postRows `liftMaybe` wrapIntoResponse
913− Nothing -> return Nothing
914−
915−getLastPosts
916− :: Maybe PostId
917− -> Limit
918− -> P.PaginationDirection
919− -> StaticPQ (Maybe (ResponseWithUsers [Post]))
920−getLastPosts pId lim dir = do
921− postRows <- runQueryParams (getLastPostsQ id lim dir) (Only pId) >>= getRows
922− rowsToPosts postRows `liftMaybe` wrapIntoResponse
923−
924−getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))
925−getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow
926−
927−getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])
928−getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))
929−
930−getAllUsers :: StaticPQ [User Faculty]
931−getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
932−
933−publishPost :: UserId -> PostCreation -> StaticPQ PostId
934−publishPost uId pc = commitedTransactionallyUpdate $ do
935− pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
936− case pId' of
937− (Just (Only pId)) -> do
938− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
939− return pId
940− _ -> lift $ S.throwError S.err404
941−
942−createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
943−createNewChannel uId req = commitedTransactionallyUpdate $ do
944− let uIds = toList $ namedChannelCreationRequestPeopleIds req
945− verifyUsers uIds
946− cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
947− return $ fmap fromOnly cId
948−
949−channelCountForUser :: UserId -> StaticPQ Int64
950−channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
951−
952−updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
953−updateChannel uId req = do
954− let uIds = namedChannelPeopleIds req
955− verifyUsers (toList uIds)
956− _ <- getChannelForUser uId $ namedChannelId req
957− _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
958− return ()
959−
960−getFaculty :: Text -> StaticPQ Faculty
961−getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
962−
963−isValidFaculty :: FacultyUrl -> StaticPQ Bool
964−isValidFaculty url = do
965− (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
966− return $ isJust faculty
967−
968−updateFaculty :: Faculty -> StaticPQ ()
969−updateFaculty fac = void $ manipulateParams updateFacultyQ fac
970−
971−getChannelPosts
972− :: UserId
973− -> Maybe PostId
974− -> Limit
975− -> P.PaginationDirection
976− -> NamedChannelId
977− -> StaticPQ (ResponseWithUsers [Post])
978−getChannelPosts uId pId lim dir cId = do
979− channel <- getChannelForUser uId cId
980− postRows <- runQueryParams (getChannelPostsQ
981− lim
982− dir
983− (toList $ namedChannelFullPeopleIds channel)
984− (namedChannelFullTags channel))
985− (Only pId)
986− >>= getRows
987− fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
988−
989−getAnonymousChannelPosts
990− :: Maybe PostId
991− -> Limit
992− -> P.PaginationDirection
993− -> AnonymousChannel
994− -> StaticPQ (ResponseWithUsers [Post])
995−getAnonymousChannelPosts pId lim dir (AnonymousChannel tags people) = do
996− postRows <- runQueryParams (getChannelPostsQ lim dir people tags) (Only pId) >>= getRows
997− fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
998−
999−getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
1000−getAllChannels uId = fmap (map removeUserFromChannel) $
1001− runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
1002−
1003−deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
1004−deleteNamedChannel uId cId = do
1005− _ <- getChannelForUser uId cId
1006− _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
1007− return ()
1008−
1009−getTags :: Limit -> StaticPQ [String]
1010−getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
1011−
1012−getDialogs
1013− :: UserId
1014− -> Maybe MessageId
1015− -> Limit
1016− -> P.PaginationDirection
1017− -> StaticPQ (ResponseWithUsers [Dialog])
1018−getDialogs uId mId lim dir = do
1019− resp <- runQueryParams (getChatsQ lim dir) (uId, Just $ show uId, mId) >>= getRows
1020− (>>= fromMaybe500) $ (responseToDialogs uId resp `liftMaybe` wrapIntoResponse)
1021−
1022−getMessagesInUserChat
1023− :: UserId
1024− -> UserId
1025− -> Maybe MessageId
1026− -> Limit
1027− -> P.PaginationDirection
1028− -> StaticPQ [Message]
1029−getMessagesInUserChat selfId uId mId lim dir = do
1030− resp <- runQueryParams (getMessagesQ lim dir) (selfId, uId, mId) >>= getRows
1031− fromMaybe500 . sequence . map restoreMessage $ resp
1032−
1033−getMessagesInGroupChat
1034− :: UserId
1035− -> GroupChatId
1036− -> Maybe MessageId
1037− -> Limit
1038− -> P.PaginationDirection
1039− -> StaticPQ [Message]
1040−getMessagesInGroupChat selfId gId mId lim dir = do
1041− _ <- getGroupChatForUser selfId gId
1042− resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
1043− return . catMaybes . map restoreMessage $ resp
1044−
1045−sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
1046−sendMessage selfId (MessageCreation (Just gId) uId@Nothing (Jsonb body)) = do
1047− _ <- getGroupChatForUser selfId gId
1048− (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, Jsonb $ stripPostElement body)
1049− >>= firstRow >>= fromMaybe500
1050− return mId
1051−sendMessage selfId (MessageCreation gId@Nothing (Just uId) (Jsonb body)) = do
1052− verifyUsers [uId]
1053− (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, Jsonb $ stripPostElement body)
1054− >>= firstRow >>= fromMaybe500
1055− return mId
1056−sendMessage _ _ = lift $ S.throwError S.err400
1057−
1058−createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
1059−createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
1060− verifyUsers . M.keys $ chatUsers
1061− commitedTransactionallyUpdate $ do
1062− let chatUsers' = M.insert uId maxChatPermissions chatUsers
1063− (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)
1064− >>= firstRow >>= fromMaybe500
1065− _ <- manipulateParams createPhantomMessageQ (Only chatId)
1066− return chatId
1067−
1068−updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
1069−updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
1070− verifyUsers . M.keys $ perms
1071− commitedTransactionallyUpdate $ do
1072− (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId
1073− let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'
1074− unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401
1075− let newPerms = M.insert uId userPerm perms
1076− void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
1077−
1078−leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
1079−leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
1080− gChat@(GroupChat _ (Jsonb perms) _) <- getGroupChatForUser uId gId
1081− let newPerms = M.delete uId perms
1082− if M.null newPerms
1083− then deleteGroupChat gId
1084− else void $ manipulateParams updateGroupChatQ gChat{groupChatUsers = Jsonb newPerms}
1085−
1086−getGroupChatForUser :: UserId -> GroupChatId -> StaticPQ GroupChat
1087−getGroupChatForUser uId gId = do
1088− chat <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
1089− case (chat) of
1090− (Just c) -> return c
1091− Nothing -> lift $ S.throwError S.err404
1092−
1093−groupChatIsValidForUser :: UserId -> GroupChatId -> StaticPQ Bool
1094−groupChatIsValidForUser uId gId = do
1095− (chat :: Maybe GroupChat) <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
1096− return $ isJust chat
1097−
1098−getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
1099−getFacultyFromQuery query =
1100− runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
1101−
1102−searchUsers :: T.Text -> StaticPQ [User Faculty]
1103−searchUsers query = do
1104− unless (validateText query) $ lift $ throwError lengthExceeded
1105− if (T.null . T.filter isAlpha $ query)
1106− then return []
1107− else map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
1108−
1109−searchTags :: T.Text -> StaticPQ [Text]
1110−searchTags "" = return []
1111−searchTags query = map fromOnly <$>
1112− (runQueryParams searchTagsQ
1113− (Only . (<> ":*") . T.strip $ query) >>= getRows)
1114−
1115−createToken :: Token -> StaticPQ ()
1116−createToken token = void $ manipulateParams createTokenQ token
1117−
1118−killAllTokens :: UserId -> StaticPQ ()
1119−killAllTokens = void . manipulateParams killAllTokensQ . Only
1120−
1121−pruneAuth :: StaticPQ ()
1122−pruneAuth = do
1123− _ <- commitedTransactionallyUpdate . manipulate $ pruneDeadTokensQ
1124− _ <- commitedTransactionallyUpdate . manipulate $ pruneGhostUsersQ
1125− return ()
1126−
1127−searchChannels :: UserId -> Text -> StaticPQ [NamedChannel UserId]
1128−searchChannels uId query = fmap (map removeUserFromChannel) $
1129− runQueryParams searchChannelsForUserQ (uId, queryFromText query) >>= getRows
1130−
1131−-- NOTE: Not transactional
1132−validateToken :: Token -> StaticPQ ()
1133−validateToken token = do
1134− void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing, tokenActivationCode = Nothing}
1135− void $ manipulateParams validateUserQ $ Only $ tokenUserId token
1136−
1137−invalidateToken :: UserId -> ByteString -> StaticPQ ()
1138−invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
1139−
1140−tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)
1141−tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
1142− token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow
1143− case token' of
1144− Nothing -> return Nothing
1145− Just token -> do
1146− if (tokenVerificationCode token == Just (hashVerificationCode code))
1147− then validateToken token >> (return $ Just token)
1148− else do
1149− let triesLeft = tokenActivationTriesLeft token - 1
1150− if triesLeft <= 0
1151− then invalidateToken (tokenUserId token) (tokenValue token) >> return Nothing
1152− else do
1153− let newToken = token{tokenActivationTriesLeft = triesLeft}
1154− _ <- manipulateParams updateTokenQ newToken
1155− return Nothing
1156−
1157−tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1158−tryActivateToken uId activationData = do
1159− let hData = hash activationData
1160− token' <- runQueryParams getTokenActivationQ (uId, hData) >>= firstRow
1161− case token' of
1162− Nothing -> return Nothing
1163− Just token -> do
1164− if (tokenActivationCode token == Just hData)
1165− then commitedTransactionallyUpdate (validateToken token) >> (return $ Just token)
1166− else return Nothing
1167−
1168−deactivateToken :: UserId -> ByteString -> StaticPQ (Maybe Text)
1169−deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow)
1170−
1171−getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1172−getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
1173−
1174−updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
1175−updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
1176−
1177−-- MARK: Utils
1178−
1179−normalizeUser :: UserUpdateRow -> UserUpdateRow
1180−normalizeUser UserUpdateRow{..} = UserUpdateRow {
1181− userUpdateRowId = userUpdateRowId,
1182− userUpdateRowFirstName = T.strip $ userUpdateRowFirstName,
1183− userUpdateRowMiddleName = T.strip $ userUpdateRowMiddleName,
1184− userUpdateRowLastName = T.strip $ userUpdateRowLastName,
1185− userUpdateRowUserFaculty = T.toLower . T.strip $ userUpdateRowUserFaculty
1186−}
1187−
1188−data UserRow = UserRow {
1189− userRowId :: UserId,
1190− userRowFirstName :: Text,
1191− userRowMiddleName :: Text,
1192− userRowLastName :: Text,
1193− userRowFacultyUrl :: FacultyUrl,
1194− userRowEmail :: Text,
1195− userRowIsValidated :: Bool,
1196− userRowFacultyName :: T.Text,
1197− userRowFacultyURL :: FacultyUrl,
1198− userRowFacultyPath :: T.Text,
1199− userRowFacultyCampusName :: T.Text,
1200− userRowFacultyCampusCode :: T.Text,
1201− userRowFacultyTags :: V.Vector T.Text,
1202− userRowFacultyAddress :: T.Text
1203−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
1204−
1205−rowToUser :: UserRow -> User Faculty
1206−rowToUser UserRow{..} = User {
1207− userId = userRowId,
1208− firstName = userRowFirstName,
1209− middleName = userRowMiddleName,
1210− lastName = userRowLastName,
1211− userFaculty = Faculty {
1212− facultyName = userRowFacultyName,
1213− facultyUrl = userRowFacultyURL,
1214− facultyPath = userRowFacultyPath,
1215− facultyCampusName = userRowFacultyCampusName,
1216− facultyCampusCode = userRowFacultyCampusCode,
1217− facultyTags = userRowFacultyTags,
1218− facultyAddress = userRowFacultyAddress
1219− },
1220− userEmail = userRowEmail
1221− }
1222−
1223−queryFromTextAbbr :: Text -> Text
1224−queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
1225− where
1226− processTerm :: Text -> Text
1227− processTerm t = "(" <> t <> ":*" <> (
1228− if T.length t <= 5
1229− then (" | (" <>) . (<> ")") . T.unwords . L.intersperse "<->" . map (<> ":*") . map T.singleton . T.unpack $ t
1230− else mempty
1231− ) <> ")"
1232−
1233−queryFromText :: Text -> Text
1234−queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)
1235− where
1236− processTerm :: Text -> Text
1237− processTerm t = t <> ":*"
1238−
1239−directionToOperator
1240− :: P.PaginationDirection
1241− -> (ConditionOp schema0 from0 grouping0 params0 nullity0 nullity1 (ty :: PGType),
1242− (Expression schema2 from2 grouping2 params2 _ -> SortExpression schema2 from2 grouping2 params2))
1243−directionToOperator P.BackPagination = ((.<), Desc)
1244−directionToOperator P.ForwardPagination = ((.>), Asc)
1245−
1246−foldMaybe :: [Maybe a] -> Maybe [a]
1247−foldMaybe [] = Just []
1248−foldMaybe (Nothing : _) = Nothing
1249−foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
1250−
1251−rowsToPosts :: [PostRowResponse] -> Maybe [Post]
1252−rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)
1253−
1254−tupleFirst :: (a -> b) -> a -> (b, a)
1255−tupleFirst f a = (f a, a)
1256−
1257−mapFirstBy :: (a -> b) -> [a] -> [(b, a)]
1258−mapFirstBy f = map $ tupleFirst f
1259−
1260−idsToColumn :: [Int64] -> Maybe (Query schema params '["id" ::: 'NotNull 'PGint8])
1261−idsToColumn [] = Nothing
1262−idsToColumn (i:ii) = Just $ values (unsafeIntToExpr i `as` #id) $ map ((`as` #id) . unsafeIntToExpr) ii
1263−
1264−unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty
1265−unsafeIntToExpr = UnsafeExpression . pack . show
1266−
1267−data ResponseWithUsers r = ResponseWithUsers {
1268− response :: r,
1269− users :: M.Map UserId (User Faculty)
1270−} deriving (Generic)
1271−
1272−instance (ToJSON r) => ToJSON (ResponseWithUsers r)
1273−
1274−instance (FromJSON r) => FromJSON (ResponseWithUsers r)
1275−
1276−class HasUsers r where
1277− userSet :: r -> Set.Set UserId
1278−
1279− wrapIntoResponse :: r -> StaticPQ (Maybe (ResponseWithUsers r))
1280− wrapIntoResponse r = wrapIntoUsers r $ userSet r
1281−
1282−instance HasUsers Dialog where
1283− userSet (GroupDialog chat _) = userSet chat
1284− userSet (UserDialog _ mess) = userSet mess
1285−
1286−instance HasUsers GroupChat where
1287− userSet (GroupChat _ (Jsonb gUsers) _) = Set.fromList . M.keys $ gUsers
1288−
1289−instance HasUsers Message where
1290− userSet (Message _ aId (UserChatDestination uId) _ _) = Set.fromList [aId, uId]
1291− userSet (Message _ aId (GroupChatDestination _) _ _) = Set.singleton aId
1292−
1293−instance (Foldable t, HasUsers r) => HasUsers (t r) where
1294− userSet = foldMap userSet
1295−
1296−instance HasUsers Post where
1297− userSet = Set.singleton . postAuthorId
1298−
1299−wrapIntoUsers :: r -> Set.Set UserId -> StaticPQ (Maybe (ResponseWithUsers r))
1300−wrapIntoUsers r us
1301− | Set.null us = return . Just $ ResponseWithUsers r M.empty
1302− | otherwise = do
1303− pUsers <- getUsers $ Set.toList us
1304− return $ ResponseWithUsers r . M.fromList . mapFirstBy userId <$> pUsers
1305−
1306−liftMaybe :: Applicative f => Maybe a -> (a -> f (Maybe b)) -> f (Maybe b)
1307−liftMaybe Nothing _ = pure Nothing
1308−liftMaybe (Just a) f = f a
1309−
1310−fromMaybe500 :: Maybe a -> StaticPQ a
1311−fromMaybe500 Nothing = lift $ S.throwError S.err500
1312−fromMaybe500 (Just a) = return a
1313−
1314−fromMaybe404 :: Maybe a -> StaticPQ a
1315−fromMaybe404 Nothing = lift $ S.throwError S.err404
1316−fromMaybe404 (Just a) = return a