@@ -1,113 +1,289 @@
1{-# LANGUAGE
1{-# LANGUAGE
2− DataKinds ,
2+ DataKinds,
3− DeriveGeneric ,
3+ DeriveGeneric,
4 OverloadedLabels,
4 OverloadedLabels,
5− OverloadedStrings ,
5+ OverloadedStrings,
6− TypeApplications ,
6+ TypeApplications,
7− TypeOperators #-}
7+ TypeOperators,
8+ PartialTypeSignatures,
13+ ScopedTypeVariables #-}
15+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
9module Data.Query (
18module Data.Query (
11 createTables,
20 createTables,
12− getPost,
21+ getPosts,
13− getUser,
22+ -- getUser,
14− createDraft,
23+ getUsers,
15− updateDraft,
24+ getAllUsers,
18 getLastPosts,
25 getLastPosts,
19− getPostsForUser
26+ getPostsForUser,
33+ getAnonymousChannelPosts,
37+ ResponseWithUsers(..),
40+ getMessagesInUserChat,
41+ getMessagesInGroupChat,
69+ groupChatIsValidForUser
22import Squeal.PostgreSQL
72import Squeal.PostgreSQL
23−import Squeal.PostgreSQL.Expression
24−import Squeal.PostgreSQL.Schema
25import Data.User
73import Data.User
26import Data.Post
74import Data.Post
27import Data.Schema
75import Data.Schema
29import Data.Function (on)
76import Data.Function (on)
30−import qualified Data.Map.Lazy as M
32import Data.Connection
77import Data.Connection
33import Data.PostElement
78import Data.PostElement
34−import Control.Monad.Base
35−import Control.Monad ((<$!>))
36import qualified Servant as S
79import qualified Servant as S
37import Control.Monad.Morph
81import Control.Monad.Morph
39import Data.Word (Word64)
82import 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)
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
103+import Server.Query.Dialog
104+import qualified Server.Query.Pagination as P
106+import Data.ByteString (ByteString)
107+import Data.Foldable (fold)
109+import qualified Data.Vector as V
110+import Server.Auth.Token
112+import Data.Text.Validator
114+-- MARK: Documentation
116+instance (ToSample r) => ToSample (ResponseWithUsers r) where
117+ toSamples _ = samples $ ResponseWithUsers <$> (map snd $ toSamples Proxy) <*> [M.fromList $ map (tupleFirst userId . snd) (toSamples Proxy)]
120+-- MARK: Generalized Post Queries
122+type TableEndo schema params from grouping = TableExpression schema params from grouping ->
123+ TableExpression schema params from grouping
125+postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
126+postsQ te = selectStar $ te (from $ table #posts)
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)
134+ :: TableEndo Schema params _ 'Ungrouped
135+ -- ^ PostRowResponse endo
136+ -> TableEndo Schema params _ 'Ungrouped
138+ -> Query Schema params (RowPG PostRowResponse)
139+getPostQ oTe te = select (
140+ #posts ! #postRowId :*
141+ #posts ! #postRowAuthorId :*
142+ #posts ! #postRowUpdateTime :*
143+ #posts ! #postRowTags :*
145+ #postElements ! #rowElementOrd :*
146+ #postElements ! #rowElementMarkdown :*
147+ #postElements ! #rowElementLatex :*
148+ #postElements ! #rowElementImage :*
149+ #postElements ! #rowElementQuote :*
150+ #postElements ! #rowElementAttachment)
151+ (oTe $ postViewT te)
42−getQuoteRowsQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG (ElementRow Post))
154+-- MARK: Concrete Queries
43−getQuoteRowsQ = UnsafeQuery "WITH RECURSIVE getQuote AS ( \
44− \SELECT * FROM \"quoteElements\" quote WHERE \"rowElementId\" = $1 \
46− \SELECT newQuote.* FROM \"quoteElements\" newQuote \
47− \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
49− \SELECT * FROM getQuote"
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 \
160+-- \SELECT newQuote.* FROM \"quoteElements\" newQuote \
161+-- \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
163+-- \SELECT * FROM getQuote"
51−getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
165+-- getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
52−getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
166+-- getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
54-- getQuote :: QuoteId -> PQ Quote
168-- getQuote :: QuoteId -> PQ Quote
55-- getQuote qId = do
169-- getQuote qId = do
56-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows
170-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows
57-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0
171-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0
58-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
172-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
59−-- return $ M.lookup qId rows >>= rowsToQuote rows
173+-- return $ M.lookup qId rows >>= rowsToQuote rows
61−getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)
62−getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)
64−getPostRowQ :: Query Schema (TuplePG (Only PostId)) (RowPG PostRow)
175+getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))
65−getPostRowQ = selectStar $ from (table #posts) & where_ (#postRowId .== param @1)
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))
67−getDraftRowQ :: Query Schema (TuplePG (Only DraftId)) (RowPG PostRow)
187+verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
68−getDraftRowQ = selectStar $ from (table #drafts) & where_ (#postRowId .== param @1)
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))
70−getPostElementsQ :: Query Schema (TuplePG (Only PostId)) (RowPG (ElementRow Post))
194+getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))
71−getPostElementsQ = selectStar $ from (table #postElements) & where_ (#rowElementId .== param @1)
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))
73−getDraftElementsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
219+getAllUsersQ :: Query Schema '[] (RowPG UserRow)
74−getDraftElementsQ = selectStar $ from (table #draftElements) & where_ (#rowElementId .== param @1)
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))
76−getPost :: PostId -> StaticPQ (Maybe Post)
240+getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
77−getPost pId = do
241+getPostsByIdQ pIds = case idsToColumn pIds of
78− postRow <- runQueryParams getPostRowQ (Only pId) >>= getRow 0
242+ Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
79− postRowElements <- runQueryParams getPostElementsQ (Only pId) >>= getRows
243+ innerJoin (subquery $ getPostQ
80− return $ rowsToPost M.empty M.empty postRow postRowElements
244+ (orderBy [#postElements ! #rowElementId & Desc, #postElements ! #rowElementOrd & Asc]) id `As` #posts)
245+ (#ids ! #id .== #posts ! #postRowId))
82−getLastPostRowsQ :: Word64 -> Query Schema '[] (RowPG (Only PostId))
248+type Limit = Word64
83−getLastPostRowsQ n = select (#postRowId `as` #fromOnly) $
84− (from $ table #posts) &
85− orderBy [#postRowId & Desc] &
88−getLastPosts :: Word64 -> StaticPQ [Post]
250+isNotFalse
89−getLastPosts n = do
251+ :: Expression schema from grouping params ('Null ty)
90− postIds <- runQuery (getLastPostRowsQ n) >>= getRows
252+ -- ^ possibly @NULL@
91− catMaybes <$> traverse getPost (map fromOnly postIds)
253+ -> Condition schema from grouping params
254+isNotFalse x = UnsafeExpression $ renderExpression x <+> "IS NOT FALSE"
93−getUser :: UserId -> StaticPQ User
256+getLastPostsQ
94−getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0
257+ :: TableEndo _ _ _ _
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])
265+ where_ (ifThenElse (isNull $ param @1) true $ #posts ! #postRowId .^ param @1) .
266+ orderBy [#posts ! #postRowId & order])
268+ ((.^), order) = directionToOperator dir
270+getLastNPostsForUserQ
272+ -> P.PaginationDirection
273+ -> Query Schema (TuplePG (Maybe PostId, UserId)) (RowPG PostRowResponse)
274+getLastNPostsForUserQ = getLastPostsQ $ where_ (#posts ! #postRowAuthorId .== param @2)
97−createDraftRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
276+createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
98−createDraftRowQ = insertRow #drafts
277+createPostRowQ = insertRow #posts
278+ (Default `as` #postRowId :*
99− (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
279+ Set (param @1) `as` #postRowAuthorId :*
280+ Set currentTimestamp `as` #postRowUpdateTime :*
281+ Set (param @2) `as` #postRowTags)
100− OnConflictDoRaise
282+ OnConflictDoRaise
101 (Returning $ #postRowId `as` #fromOnly)
283 (Returning $ #postRowId `as` #fromOnly)
103−createPostRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only PostId))
285+createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
104−createPostRowQ = insertRow #posts
286+createPostElementRowsQ = insertRow_ #postElements
105− (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
107− (Returning $ #postRowId `as` #fromOnly)
109−createDraftElementRowsQ :: Manipulation Schema (TuplePG (ElementRow Draft)) '[]
110−createDraftElementRowsQ = insertRow_ #draftElements
111 (Set (param @1) `as` #rowElementId :*
287 (Set (param @1) `as` #rowElementId :*
112 Set (param @2) `as` #rowElementOrd :*
288 Set (param @2) `as` #rowElementOrd :*
113 Set (param @3) `as` #rowElementMarkdown :*
289 Set (param @3) `as` #rowElementMarkdown :*
@@ -116,93 +292,1025 @@ createDraftElementRowsQ = insertRow_ #draftElements
116 Set (param @6) `as` #rowElementQuote :*
292 Set (param @6) `as` #rowElementQuote :*
117 Set (param @7) `as` #rowElementAttachment)
293 Set (param @7) `as` #rowElementAttachment)
119−createPostElementRowsQ :: Manipulation Schema (TuplePG (ElementRow Post)) '[]
295+getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
120−createPostElementRowsQ = insertRow_ #postElements
296+getChannelForUserQ = selectStar $
121− (Set (param @1) `as` #rowElementId :*
297+ from (table #channels) &
122− Set (param @2) `as` #rowElementOrd :*
298+ where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
123− Set (param @3) `as` #rowElementMarkdown :*
299+
124− Set (param @4) `as` #rowElementLatex :*
300+updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))
125− Set (param @5) `as` #rowElementImage :*
301+updateUserQ = update #users (
126− Set (param @6) `as` #rowElementQuote :*
302+ Same `as` #userRowId :*
127− Set (param @7) `as` #rowElementAttachment)
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)
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]
318+searchChannelsForUserQ :: Query Schema (TuplePG (UserId, Text)) (RowPG NamedChannelFull)
319+searchChannelsForUserQ = selectStar $
320+ from (table #channels) &
321+ where_ (#namedChannelFullOwner .== param @1) &
323+ tsRankCd vector1 query & Desc,
324+ tsRankCd vector query & Desc
327+ vector = tsVector' (textArrayToText [
328+ #namedChannelFullName,
329+ unsafeFunction "unnest" #namedChannelFullTags
331+ vector1 = tsVector' #namedChannelFullName
332+ query = tsQuery' (param @2)
334+updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
335+updateFacultyQ = insertRow #faculties
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
345+ (OnConflictDoNothing)
348+getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
349+getFacultyQ = selectStar (from (table #faculties) &
350+ where_ (#facultyUrl .== param @1))
352+createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
353+createNamedChannelQ = insertRow #channels
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
362+ (Returning $ #namedChannelFullId `as` #fromOnly)
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)
369+deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
370+deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
372+updateNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelFull) '[]
373+updateNamedChannelQ = update_ #channels
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
381+ (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)
385+ -> P.PaginationDirection
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)
397+ isUser = case idsToColumn uIds of
398+ Just uIdsQ -> (`in_` uIdsQ)
399+ Nothing -> const $ false
401+getTagsQ :: Query Schema params (RowPG (Only String))
402+getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
405+createMessageQ :: Manipulation
407+ (TuplePG (UserId, Maybe GroupChatId, Maybe UserId, Jsonb (PostElement (MessageCreation))))
408+ (RowPG (Only MessageId))
409+createMessageQ = insertRow #messages
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
419+ (Returning $ #messageStorageId `as` #fromOnly)
421+createPhantomMessageQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]
422+createPhantomMessageQ = insertRow_ #messages
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
432+createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
433+createGroupChatQ = insertRow #groupChats
435+ Default `as` #groupChatId :*
436+ Set (param @1) `as` #groupChatUsers :*
437+ Set (param @2) `as` #groupChatName
440+ (Returning $ #groupChatId `as` #fromOnly)
442+updateGroupChatQ :: Manipulation Schema (TuplePG GroupChat) '[]
443+updateGroupChatQ = update_ #groupChats
445+ Same `as` #groupChatId :*
446+ Set (param @2) `as` #groupChatUsers :*
447+ Set (param @3) `as` #groupChatName
449+ (#groupChatId .== param @1)
451+type ChatsQueryResponse = '[
452+ "messageId" ::: 'NotNull (PG UserId),
453+ "messageGroupId" ::: 'Null (PG UserId),
454+ "messageUserId" ::: 'Null (PG UserId)
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
462+type ChatQueryParams = TuplePG
464+ , Maybe String -- Just UserId as String
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
482+ (subquery $ chatsQ `As` #chats) &
485+ (#chats ! #messageId .== #messages ! #messageStorageId) &
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] &
494+ orderBy [#chats ! #messageId & Desc]
496+ ((.^), order) = directionToOperator dir
497+ chatsQ :: Query Schema _ ChatsQueryResponse
498+ chatsQ = unionAll groupChats userChats
500+ allUserMessages :: Query Schema _ ChatsQueryResponse
501+ allUserMessages = select (
502+ #messageStorageId `as` #messageId :*
503+ null_ `as` #messageGroupId :*
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
530+ -> P.PaginationDirection
531+ -> Query Schema (TuplePG
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] &
543+ orderBy [#messageStorageId & Desc])
545+ ((.^), order) = directionToOperator dir
549+ -> P.PaginationDirection
550+ -> Query Schema (TuplePG
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] &
560+ orderBy [#messageStorageId & Desc])
562+ ((.^), order) = directionToOperator dir
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)
571+getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
572+getFacultySearchResultQ = selectStar (from (table #faculties) &
573+ where_ (vector @@ query) &
575+ tsRankCd vector1 query & Desc,
576+ tsRankCd vector2 query & Desc,
577+ tsRankCd vector query & Desc
580+ vector = tsVector "russian" (textArrayToText [
584+ (arrayToText #facultyTags)])
585+ vector1 = tsVector "russian" #facultyName
586+ vector2 = tsVector "russian" (textArrayToText [
589+ query = tsQuery "russian" (param @1)
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] &
615+ vector = tsVector' (textArrayToText [
616+ #users ! #userRowFirstName,
617+ #users ! #userRowMiddleName,
618+ #users ! #userRowLastName
620+ query = tsQuery' (param @1)
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) &
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] &
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] &
642+ query = tsQuery' (param @1)
643+ vector = tsVector' #tag
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"])
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])
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)
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])
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)
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, "' '"])
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 "@@"
690+space :: Expression schema from grouping params ('NotNull 'PGtext)
691+space = UnsafeExpression "' '"
694+ :: [Expression schema from grouping params ('NotNull 'PGtext)]
695+ -> Expression schema from grouping params ('NotNull 'PGtext)
696+textArrayToText = fold . L.intersperse space
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)
708+ (Returning (#userRowId `as` #fromOnly))
710+removeUnverifiedUserQ :: Manipulation Schema (TuplePG (Only UserEmail)) '[]
711+removeUnverifiedUserQ = deleteFrom_ #users
712+ (#userRowEmail .== param @1 .&&
713+ (not_ . notNull $ #userRowIsValidated))
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
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)
740+deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
741+deleteTokenQ = deleteFrom_ #tokens
742+ (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
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)
755+getTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
756+getTokenQ = selectStar (from (table #tokens) &
757+ where_ (#tokenUserId .== param @1 .&&
758+ #tokenValue .== param @2))
760+getTokenActivationQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
761+getTokenActivationQ = selectStar (from (table #tokens) &
762+ where_ (#tokenUserId .== param @1 .&&
763+ #tokenActivationCode .== param @2))
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))
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))
778+killAllTokensQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
779+killAllTokensQ = deleteFrom_ #tokens
780+ (#tokenUserId .== param @1)
782+pruneDeadTokensQ :: Manipulation Schema '[] '[]
783+pruneDeadTokensQ = deleteFrom_ #tokens
784+ (#tokenExpiryDate .< currentTimestamp)
786+pruneGhostUsersQ :: Manipulation Schema '[] '[]
787+pruneGhostUsersQ = deleteFrom_ #users
788+ ((not_ . in_ #userRowId $ select (#tokens ! #tokenUserId `as` #id) (from $ table #tokens)) .&&
789+ (not_ . notNull $ #userRowIsValidated))
791+-- MARK: FrontEnd Data Structures
793+instance HasValidatableText UserCreation where
794+ validateText UserCreation{..} = all validateText [
795+ userCreationFirstName,
796+ userCreationMiddleName,
797+ userCreationLastName,
798+ userCreationUserFaculty,
799+ userCreationUserEmail]
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)
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,
818+instance FromJSON UserCreation where
819+ parseJSON = withObject "user creation" $ \e ->
820+ UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
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)
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)
838+addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
839+addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
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
849+instance SOP.Generic NamedChannelFull
850+instance SOP.HasDatatypeInfo NamedChannelFull
852+addUserToChannelUpdate :: UserId -> NamedChannel UserId -> NamedChannelFull
853+addUserToChannelUpdate uId (NamedChannel cId cName cTags cPeople) = NamedChannelFull cId uId cName cTags cPeople
855+removeUserFromChannel :: NamedChannelFull -> NamedChannel UserId
856+removeUserFromChannel (NamedChannelFull cId _ cName cTags cPeople) = NamedChannel cId cName cTags cPeople
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
865+-- TODO: Reject bad requests. Should be binary.
866+verifyUsers :: [UserId] -> StaticPQ ()
868+ case verifiedUserIdsQ uIds of
870+ (us :: [UserId]) <- fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
871+ when (length us /= length uIds) $ lift $ S.throwError impossibleContent
872+ Nothing -> return ()
874+deleteGroupChat :: GroupChatId -> StaticPQ ()
875+deleteGroupChat gId = do
876+ _ <- manipulateParams deleteGroupChatQ (Only gId)
877+ _ <- manipulateParams deleteGroupChatMessagesQ (Only gId)
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)
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)
894+-- MARK: FrontEnd functions
896+-- Nothing <=> no user
900+ -> P.PaginationDirection
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)
907+getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))
909+ case getPostsByIdQ pId of
911+ postRows <- runQuery psQ >>= getRows
912+ rowsToPosts postRows `liftMaybe` wrapIntoResponse
913+ Nothing -> return Nothing
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
924+getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))
925+getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow
927+getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])
928+getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))
930+getAllUsers :: StaticPQ [User Faculty]
931+getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
933+publishPost :: UserId -> PostCreation -> StaticPQ PostId
934+publishPost uId pc = commitedTransactionallyUpdate $ do
935+ pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
937+ (Just (Only pId)) -> do
938+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
940+ _ -> lift $ S.throwError S.err404
942+createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
943+createNewChannel uId req = commitedTransactionallyUpdate $ do
944+ let uIds = toList $ namedChannelCreationRequestPeopleIds req
946+ cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
947+ return $ fmap fromOnly cId
949+channelCountForUser :: UserId -> StaticPQ Int64
950+channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
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})
960+getFaculty :: Text -> StaticPQ Faculty
961+getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
963+isValidFaculty :: FacultyUrl -> StaticPQ Bool
964+isValidFaculty url = do
965+ (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
966+ return $ isJust faculty
968+updateFaculty :: Faculty -> StaticPQ ()
969+updateFaculty fac = void $ manipulateParams updateFacultyQ fac
975+ -> P.PaginationDirection
977+ -> StaticPQ (ResponseWithUsers [Post])
978+getChannelPosts uId pId lim dir cId = do
979+ channel <- getChannelForUser uId cId
980+ postRows <- runQueryParams (getChannelPostsQ
983+ (toList $ namedChannelFullPeopleIds channel)
984+ (namedChannelFullTags channel))
987+ fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
989+getAnonymousChannelPosts
992+ -> P.PaginationDirection
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
999+getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
1000+getAllChannels uId = fmap (map removeUserFromChannel) $
1001+ runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
1003+deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
1004+deleteNamedChannel uId cId = do
1005+ _ <- getChannelForUser uId cId
1006+ _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
1009+getTags :: Limit -> StaticPQ [String]
1010+getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
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)
1022+getMessagesInUserChat
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
1033+getMessagesInGroupChat
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
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
1051+sendMessage selfId (MessageCreation gId@Nothing (Just uId) (Jsonb body)) = do
1053+ (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, Jsonb $ stripPostElement body)
1054+ >>= firstRow >>= fromMaybe500
1056+sendMessage _ _ = lift $ S.throwError S.err400
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)
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)
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
1083+ then deleteGroupChat gId
1084+ else void $ manipulateParams updateGroupChatQ gChat{groupChatUsers = Jsonb newPerms}
1086+getGroupChatForUser :: UserId -> GroupChatId -> StaticPQ GroupChat
1087+getGroupChatForUser uId gId = do
1088+ chat <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
1090+ (Just c) -> return c
1091+ Nothing -> lift $ S.throwError S.err404
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
1098+getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
1099+getFacultyFromQuery query =
1100+ runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
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)
1107+ else map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
1109+searchTags :: T.Text -> StaticPQ [Text]
1110+searchTags "" = return []
1111+searchTags query = map fromOnly <$>
1112+ (runQueryParams searchTagsQ
1113+ (Only . (<> ":*") . T.strip $ query) >>= getRows)
1115+createToken :: Token -> StaticPQ ()
1116+createToken token = void $ manipulateParams createTokenQ token
1118+killAllTokens :: UserId -> StaticPQ ()
1119+killAllTokens = void . manipulateParams killAllTokensQ . Only
1121+pruneAuth :: StaticPQ ()
1123+ _ <- commitedTransactionallyUpdate . manipulate $ pruneDeadTokensQ
1124+ _ <- commitedTransactionallyUpdate . manipulate $ pruneGhostUsersQ
1127+searchChannels :: UserId -> Text -> StaticPQ [NamedChannel UserId]
1128+searchChannels uId query = fmap (map removeUserFromChannel) $
1129+ runQueryParams searchChannelsForUserQ (uId, queryFromText query) >>= getRows
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
1137+invalidateToken :: UserId -> ByteString -> StaticPQ ()
1138+invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
1140+tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)
1141+tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
1142+ token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow
1144+ Nothing -> return Nothing
1146+ if (tokenVerificationCode token == Just (hashVerificationCode code))
1147+ then validateToken token >> (return $ Just token)
1149+ let triesLeft = tokenActivationTriesLeft token - 1
1151+ then invalidateToken (tokenUserId token) (tokenValue token) >> return Nothing
1153+ let newToken = token{tokenActivationTriesLeft = triesLeft}
1154+ _ <- manipulateParams updateTokenQ newToken
1157+tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1158+tryActivateToken uId activationData = do
1159+ let hData = hash activationData
1160+ token' <- runQueryParams getTokenActivationQ (uId, hData) >>= firstRow
1162+ Nothing -> return Nothing
1164+ if (tokenActivationCode token == Just hData)
1165+ then commitedTransactionallyUpdate (validateToken token) >> (return $ Just token)
1166+ else return Nothing
1168+deactivateToken :: UserId -> ByteString -> StaticPQ (Maybe Text)
1169+deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow)
1171+getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1172+getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
1174+updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
1175+updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
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
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)
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
1220+ userEmail = userRowEmail
1223+queryFromTextAbbr :: Text -> Text
1224+queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
1226+ processTerm :: Text -> Text
1227+ processTerm t = "(" <> t <> ":*" <> (
1229+ then (" | (" <>) . (<> ")") . T.unwords . L.intersperse "<->" . map (<> ":*") . map T.singleton . T.unpack $ t
1233+queryFromText :: Text -> Text
1234+queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)
1236+ processTerm :: Text -> Text
1237+ processTerm t = t <> ":*"
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)
1246+foldMaybe :: [Maybe a] -> Maybe [a]
1247+foldMaybe [] = Just []
1248+foldMaybe (Nothing : _) = Nothing
1249+foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
1251+rowsToPosts :: [PostRowResponse] -> Maybe [Post]
1252+rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)
1254+tupleFirst :: (a -> b) -> a -> (b, a)
1255+tupleFirst f a = (f a, a)
1257+mapFirstBy :: (a -> b) -> [a] -> [(b, a)]
1258+mapFirstBy f = map $ tupleFirst f
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
1264+unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty
1265+unsafeIntToExpr = UnsafeExpression . pack . show
1267+data ResponseWithUsers r = ResponseWithUsers {
1269+ users :: M.Map UserId (User Faculty)
1270+} deriving (Generic)
1272+instance (ToJSON r) => ToJSON (ResponseWithUsers r)
1274+instance (FromJSON r) => FromJSON (ResponseWithUsers r)
1276+class HasUsers r where
1277+ userSet :: r -> Set.Set UserId
1279+ wrapIntoResponse :: r -> StaticPQ (Maybe (ResponseWithUsers r))
1280+ wrapIntoResponse r = wrapIntoUsers r $ userSet r
1282+instance HasUsers Dialog where
1283+ userSet (GroupDialog chat _) = userSet chat
1284+ userSet (UserDialog _ mess) = userSet mess
1286+instance HasUsers GroupChat where
1287+ userSet (GroupChat _ (Jsonb gUsers) _) = Set.fromList . M.keys $ gUsers
1289+instance HasUsers Message where
1290+ userSet (Message _ aId (UserChatDestination uId) _ _) = Set.fromList [aId, uId]
1291+ userSet (Message _ aId (GroupChatDestination _) _ _) = Set.singleton aId
1293+instance (Foldable t, HasUsers r) => HasUsers (t r) where
1294+ userSet = foldMap userSet
1296+instance HasUsers Post where
1297+ userSet = Set.singleton . postAuthorId
1299+wrapIntoUsers :: r -> Set.Set UserId -> StaticPQ (Maybe (ResponseWithUsers r))
1301+ | Set.null us = return . Just $ ResponseWithUsers r M.empty
1303+ pUsers <- getUsers $ Set.toList us
1304+ return $ ResponseWithUsers r . M.fromList . mapFirstBy userId <$> pUsers
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
129−createDraft :: UserId -> [PostElement Draft] -> StaticPQ Draft
1310+fromMaybe500 :: Maybe a -> StaticPQ a
130−createDraft uId els = transactionally_ $ do
131− dId' <- manipulateParams createDraftRowQ (Only uId)
132− dId <- lift $ fromOnly <$> getRow 0 dId'
133− traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els
134− return $ mkDraft dId uId els
136−getDraftsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
137−getDraftsForUserQ = select (#postRowId `as` #fromOnly) $
138− (from $ table #drafts) &
139− where_ (#postRowAuthorId .== param @1)
141−getPostsForUserLimitingQ :: Word64 -> Query Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
142−getPostsForUserLimitingQ lim = select (#postRowId `as` #fromOnly) $
143− (from $ table #posts) &
144− where_ (#postRowAuthorId .== param @1) &
147−getPostsForUser :: Word64 -> UserId -> StaticPQ [Post]
148−getPostsForUser lim uId = do
149− postIds <- runQueryParams (getPostsForUserLimitingQ lim) (Only uId) >>= getRows
150− catMaybes <$> traverse getPost (map fromOnly postIds)
153−getDraft :: DraftId -> StaticPQ (Maybe Draft)
155− draftRow <- runQueryParams getDraftRowQ (Only dId) >>= getRow 0
156− draftRowElements <- runQueryParams getDraftElementsQ (Only dId) >>= getRows
157− return $ rowsToPost M.empty M.empty draftRow draftRowElements
159−getDrafts :: UserId -> StaticPQ [Draft]
161− draftRow <- runQueryParams getDraftsForUserQ (Only uId) >>= getRows
162− catMaybes <$> traverse getDraft (map fromOnly draftRow)
164−getDraftForUserWithIdQ :: Query Schema (TuplePG (UserId, DraftId)) (RowPG PostRow)
165−getDraftForUserWithIdQ = selectStar $
166− (from $ table #drafts) &
167− where_ (#postRowAuthorId .== param @1 .&& #postRowId .== param @2)
169−deleteElementsForIdQ :: Manipulation Schema (TuplePG (Only DraftId)) '[]
170−deleteElementsForIdQ = deleteFrom_ #draftElements (#rowElementId .== param @1)
172−deleteDraftQ :: Manipulation Schema (TuplePG (Only DraftId)) '[]
173−deleteDraftQ = deleteFrom_ #drafts (#postRowId .== param @1)
175−updateDraft :: UserId -> DraftId -> [PostElement Draft] -> StaticPQ ()
176−updateDraft uId dId els = transactionally_ $ do
177− rs <- runQueryParams getDraftForUserWithIdQ (uId, dId) >>= getRows
178− let c = length (rs :: [PostRow])
180− lift $ S.throwError S.err404
1311+fromMaybe500 Nothing = lift $ S.throwError S.err500
182− manipulateParams deleteElementsForIdQ (Only dId)
183− traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els
185−getDraftElementRowsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
186−getDraftElementRowsQ = selectStar $
187− (from $ table #draftElements) &
188− where_ (#rowElementId .== param @1) &
189− orderBy [#rowElementOrd & Asc]
191−publishDraft :: UserId -> DraftId -> StaticPQ ()
192−publishDraft uId dId = transactionally_ $ do
193− rs <- runQueryParams getDraftForUserWithIdQ (uId, dId) >>= getRows
194− let c = length (rs :: [PostRow])
196− lift $ S.throwError S.err404
198− els <- runQueryParams getDraftElementRowsQ (Only dId) >>= getRows
199− pId' <- manipulateParams createPostRowQ (Only uId)
200− pId <- lift $ fromOnly <$> getRow 0 pId'
201− traversePrepared_ createPostElementRowsQ $ map (fromDraft pId) els
202− manipulateParams deleteDraftQ (Only dId)
203− return ()
1312+fromMaybe500 (Just a) = return a
206−-- tupleFirst :: (a -> b) -> a -> (b, a)
207−-- tupleFirst f x = (f x, x)
1314+fromMaybe404 :: Maybe a -> StaticPQ a
1315+fromMaybe404 Nothing = lift $ S.throwError S.err404
1316+fromMaybe404 (Just a) = return a