@@ -9,7 +9,8 @@
99 FlexibleInstances,
1010 KindSignatures,
1111 DeriveAnyClass,
12− RecordWildCards #-}
12+ RecordWildCards,
13+ ScopedTypeVariables #-}
1314
1415{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
1516
@@ -53,7 +54,19 @@ module Data.Query (
5354 tryVerifyToken,
5455 getVerifiedToken,
5556 UserCreation(..),
56− createUser
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
5770 ) where
5871
5972import Squeal.PostgreSQL
@@ -83,7 +96,7 @@ import Data.Text (Text)
8396import qualified Data.Text as T
8497import Data.Channel.NamedChannel
8598import Data.Channel.AnonymousChannel
86−import Data.Maybe (fromMaybe)
99+import Data.Maybe (fromMaybe, catMaybes, isJust)
87100import Squeal.PostgreSQL.Render
88101import Data.GroupChat
89102import Data.Message
@@ -95,7 +108,8 @@ import Data.Foldable (fold)
95108import Data.Char
96109import qualified Data.Vector as V
97110import Server.Auth.Token
98−import Data.Int
111+import Server.Error
112+import Data.Text.Validator
99113
100114-- MARK: Documentation
101115
@@ -192,7 +206,8 @@ getUsersQ uIds = case idsToColumn uIds of
192206 #faculties ! #facultyPath `as` #userRowFacultyPath :*
193207 #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
194208 #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
195− #faculties ! #facultyTags `as` #userRowFacultyTags
209+ #faculties ! #facultyTags `as` #userRowFacultyTags :*
210+ #faculties ! #facultyAddress `as` #userRowFacultyAddress
196211 ) (from (subquery (idQ `As` #ids) &
197212 innerJoin (table #users)
198213 (#ids ! #id .== #users ! #userRowId) &
@@ -215,7 +230,8 @@ getAllUsersQ = select (
215230 #faculties ! #facultyPath `as` #userRowFacultyPath :*
216231 #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
217232 #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
218− #faculties ! #facultyTags `as` #userRowFacultyTags
233+ #faculties ! #facultyTags `as` #userRowFacultyTags :*
234+ #faculties ! #facultyAddress `as` #userRowFacultyAddress
219235 ) (from ((table #users) &
220236 innerJoin (table #faculties)
221237 (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&
@@ -281,12 +297,40 @@ getChannelForUserQ = selectStar $
281297 from (table #channels) &
282298 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
283299
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+
284312getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
285313getAllChannelsForUserQ = selectStar $
286314 from (table #channels) &
287315 where_ (#namedChannelFullOwner .== param @1) &
288316 orderBy [#namedChannelFullId & Desc]
289317
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+
290334updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
291335updateFacultyQ = insertRow #faculties
292336 (
@@ -295,7 +339,8 @@ updateFacultyQ = insertRow #faculties
295339 Set (param @3) `as` #facultyPath :*
296340 Set (param @4) `as` #facultyCampusName :*
297341 Set (param @5) `as` #facultyCampusCode :*
298− Set (param @6) `as` #facultyTags
342+ Set (param @6) `as` #facultyTags :*
343+ Set (param @7) `as` #facultyAddress
299344 )
300345 (OnConflictDoNothing)
301346 (Returning Nil)
@@ -316,6 +361,11 @@ createNamedChannelQ = insertRow #channels
316361 OnConflictDoRaise
317362 (Returning $ #namedChannelFullId `as` #fromOnly)
318363
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+
319369deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
320370deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
321371
@@ -348,7 +398,7 @@ getChannelPostsQ lim dir uIds tags = getLastPostsQ
348398 Just uIdsQ -> (`in_` uIdsQ)
349399 Nothing -> const $ false
350400
351−getTagsQ :: Query Schema '[] (RowPG (Only String))
401+getTagsQ :: Query Schema params (RowPG (Only String))
352402getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
353403 from (table #posts)
354404
@@ -359,15 +409,26 @@ createMessageQ :: Manipulation
359409createMessageQ = insertRow #messages
360410 (
361411 Default `as` #messageStorageId :*
362− Set (param @1) `as` #messageStorageAuthorId :*
412+ Set (notNull $ param @1) `as` #messageStorageAuthorId :*
363413 Set (param @2) `as` #messageStorageDestinationGroupId :*
364414 Set (param @3) `as` #messageStorageDestinationUserId :*
365− Set (param @4) `as` #messageStorageBody :*
415+ Set (notNull $ param @4) `as` #messageStorageBody :*
366416 Set currentTimestamp `as` #messageStorageTime
367417 )
368418 OnConflictDoRaise
369419 (Returning $ #messageStorageId `as` #fromOnly)
370420
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+
371432createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
372433createGroupChatQ = insertRow #groupChats
373434 (
@@ -443,7 +504,7 @@ getChatsQ lim dir = select (
443504 (ifThenElse
444505 (#messageStorageAuthorId .== param @1)
445506 #messageStorageDestinationUserId
446− (notNull #messageStorageAuthorId)) `as` #messageUserId) $
507+ #messageStorageAuthorId) `as` #messageUserId) $
447508 from (table #messages) &
448509 where_ (isNotNull #messageStorageDestinationUserId .&&
449510 (#messageStorageAuthorId .== param @1 .||
@@ -510,21 +571,83 @@ getGroupChatForUserQ = selectStar $
510571getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
511572getFacultySearchResultQ = selectStar (from (table #faculties) &
512573 where_ (vector @@ query) &
513− orderBy [tsRankCd vector query & Desc])
574+ orderBy [
575+ tsRankCd vector1 query & Desc,
576+ tsRankCd vector2 query & Desc,
577+ tsRankCd vector query & Desc
578+ ])
514579 where
515580 vector = tsVector "russian" (textArrayToText [
516581 #facultyName,
517582 #facultyPath,
518583 #facultyCampusName,
519584 (arrayToText #facultyTags)])
520− query = tsQuery (param @1)
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
521644
522645tsRankCd
523646 :: Expression schema from grouping params ('NotNull 'PGtext)
524647 -> Expression schema from grouping params ('NotNull 'PGtext)
525648 -> Expression schema from grouping params ('NotNull 'PGfloat4)
526649tsRankCd vector query = UnsafeExpression $
527− "ts_rank_cd" <> parenthesized (commaSeparated . map renderExpression $ [vector, query])
650+ "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])
528651
529652tsVector
530653 :: ByteString -- ^ Language
@@ -533,10 +656,24 @@ tsVector
533656tsVector lang x = UnsafeExpression $
534657 "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
535658
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+
536665tsQuery
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'
537673 :: Expression schema from grouping params ('NotNull 'PGtext)
538674 -> Expression schema from grouping params ('NotNull 'PGtext)
539−tsQuery = unsafeFunction "to_tsquery"
675+tsQuery' x = UnsafeExpression $
676+ "to_tsquery" <> parenthesized (renderExpression x)
540677
541678arrayToText
542679 :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
@@ -582,7 +719,10 @@ createTokenQ = insertRow_ #tokens (
582719 Set (param @2) `as` #tokenValue :*
583720 Set (param @3) `as` #tokenExpiryDate :*
584721 Set (param @4) `as` #tokenVerificationCode :*
585− Set (param @5) `as` #tokenActivationTriesLeft
722+ Set (param @5) `as` #tokenActivationTriesLeft :*
723+ Set (param @6) `as` #tokenUserAgent :*
724+ Set (param @7) `as` #tokenActivationCode :*
725+ Set (param @8) `as` #tokenDeactivationCode
586726 )
587727
588728updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
@@ -591,7 +731,10 @@ updateTokenQ = update_ #tokens (
591731 Same `as` #tokenValue :*
592732 Set (param @3) `as` #tokenExpiryDate :*
593733 Set (param @4) `as` #tokenVerificationCode :*
594− Set (param @5) `as` #tokenActivationTriesLeft)
734+ Set (param @5) `as` #tokenActivationTriesLeft :*
735+ Set (param @6) `as` #tokenUserAgent :*
736+ Set (param @7) `as` #tokenActivationCode :*
737+ Set (param @8) `as` #tokenDeactivationCode)
595738 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
596739
597740deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
@@ -614,14 +757,47 @@ getTokenQ = selectStar (from (table #tokens) &
614757 where_ (#tokenUserId .== param @1 .&&
615758 #tokenValue .== param @2))
616759
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+
617771getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
618772getVerifiedTokenQ = selectStar (from (table #tokens) &
619773 where_ (#tokenUserId .== param @1 .&&
620774 #tokenValue .== param @2 .&&
621− isNull #tokenVerificationCode))
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))
622790
623791-- MARK: FrontEnd Data Structures
624792
793+instance HasValidatableText UserCreation where
794+ validateText UserCreation{..} = all validateText [
795+ userCreationFirstName,
796+ userCreationMiddleName,
797+ userCreationLastName,
798+ userCreationUserFaculty,
799+ userCreationUserEmail]
800+
625801data UserCreation = UserCreation {
626802 userCreationFirstName :: Text,
627803 userCreationMiddleName :: Text,
@@ -640,9 +816,18 @@ instance ToJSON UserCreation where
640816 ]
641817
642818instance FromJSON UserCreation where
643− parseJSON = withObject "named channel" $ \e ->
819+ parseJSON = withObject "user creation" $ \e ->
644820 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
645821
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+
646831data NamedChannelCreation = NamedChannelCreation {
647832 namedChannelCreationOwner :: UserId,
648833 namedChannelCreationName :: Text,
@@ -678,11 +863,13 @@ getChannelForUser uId cId = do
678863 Nothing -> lift $ S.throwError S.err404
679864
680865-- TODO: Reject bad requests. Should be binary.
681−verifiedUsers :: [UserId] -> StaticPQ [UserId]
682−verifiedUsers uIds =
866+verifyUsers :: [UserId] -> StaticPQ ()
867+verifyUsers uIds =
683868 case verifiedUserIdsQ uIds of
684− Just uIdsQ -> fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
685− Nothing -> return []
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 ()
686873
687874deleteGroupChat :: GroupChatId -> StaticPQ ()
688875deleteGroupChat gId = do
@@ -744,30 +931,40 @@ getAllUsers :: StaticPQ [User Faculty]
744931getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
745932
746933publishPost :: UserId -> PostCreation -> StaticPQ PostId
747−publishPost uId pc = commitedTransactionallyUpdate $ do
934+publishPost uId pc = commitedTransactionallyUpdate $ do
748935 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
749936 case pId' of
750937 (Just (Only pId)) -> do
751− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)
938+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
752939 return pId
753940 _ -> lift $ S.throwError S.err404
754941
755942createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
756943createNewChannel uId req = commitedTransactionallyUpdate $ do
757− uIds <- verifiedUsers . toList $ namedChannelCreationRequestPeopleIds req
944+ let uIds = toList $ namedChannelCreationRequestPeopleIds req
945+ verifyUsers uIds
758946 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
759947 return $ fmap fromOnly cId
760948
949+channelCountForUser :: UserId -> StaticPQ Int64
950+channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
951+
761952updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
762−updateChannel uId req = commitedTransactionallyUpdate $ do
763− uIds <- fmap fromList . verifiedUsers . toList $ namedChannelPeopleIds req
953+updateChannel uId req = do
954+ let uIds = namedChannelPeopleIds req
955+ verifyUsers (toList uIds)
764956 _ <- getChannelForUser uId $ namedChannelId req
765− _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
957+ _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
766958 return ()
767959
768960getFaculty :: Text -> StaticPQ Faculty
769961getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
770962
963+isValidFaculty :: FacultyUrl -> StaticPQ Bool
964+isValidFaculty url = do
965+ (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
966+ return $ isJust faculty
967+
771968updateFaculty :: Faculty -> StaticPQ ()
772969updateFaculty fac = void $ manipulateParams updateFacultyQ fac
773970
@@ -804,13 +1001,13 @@ getAllChannels uId = fmap (map removeUserFromChannel) $
8041001 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
8051002
8061003deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
807−deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do
1004+deleteNamedChannel uId cId = do
8081005 _ <- getChannelForUser uId cId
809− _ <- manipulateParams deleteNamedChannelQ (Only cId)
1006+ _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
8101007 return ()
8111008
812−getTags :: StaticPQ [String]
813−getTags = map fromOnly <$> (runQuery getTagsQ >>= getRows)
1009+getTags :: Limit -> StaticPQ [String]
1010+getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
8141011
8151012getDialogs
8161013 :: UserId
@@ -843,36 +1040,40 @@ getMessagesInGroupChat
8431040getMessagesInGroupChat selfId gId mId lim dir = do
8441041 _ <- getGroupChatForUser selfId gId
8451042 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
846− (return . sequence . map restoreMessage $ resp) >>= fromMaybe500
1043+ return . catMaybes . map restoreMessage $ resp
8471044
8481045sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
849−sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
1046+sendMessage selfId (MessageCreation (Just gId) uId@Nothing (Jsonb body)) = do
8501047 _ <- getGroupChatForUser selfId gId
851− (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, body)
1048+ (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, Jsonb $ stripPostElement body)
8521049 >>= firstRow >>= fromMaybe500
8531050 return mId
854−sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do
855− (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, body)
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)
8561054 >>= firstRow >>= fromMaybe500
8571055 return mId
8581056sendMessage _ _ = lift $ S.throwError S.err400
8591057
8601058createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
8611059createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
862− let chatUsers' = M.insert uId maxChatPermissions chatUsers
863− (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)
864− >>= firstRow >>= fromMaybe500
865− -- TODO: Do somehting with this
866− _ <- sendMessage uId $ MessageCreation (Just chatId) Nothing (Jsonb $ Markdown "henlo")
867− return chatId
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
8681067
8691068updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
870−updateGroupChat uId (GroupChat gId (Jsonb perms) name) = commitedTransactionallyUpdate $ do
871− (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId
872− let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'
873− unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401
874− let newPerms = M.insert uId userPerm perms
875− void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
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)
8761077
8771078leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
8781079leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
@@ -889,30 +1090,60 @@ getGroupChatForUser uId gId = do
8891090 (Just c) -> return c
8901091 Nothing -> lift $ S.throwError S.err404
8911092
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+
8921098getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
8931099getFacultyFromQuery query =
894− runQueryParams getFacultySearchResultQ (Only . queryFromText $ query) >>= getRows
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)
8951114
8961115createToken :: Token -> StaticPQ ()
8971116createToken token = void $ manipulateParams createTokenQ token
8981117
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
8991130
9001131-- NOTE: Not transactional
9011132validateToken :: Token -> StaticPQ ()
9021133validateToken token = do
903− void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing}
1134+ void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing, tokenActivationCode = Nothing}
9041135 void $ manipulateParams validateUserQ $ Only $ tokenUserId token
9051136
9061137invalidateToken :: UserId -> ByteString -> StaticPQ ()
9071138invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
9081139
909−tryVerifyToken :: UserId -> ByteString -> Int32 -> StaticPQ (Maybe Token)
1140+tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)
9101141tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
911− token' <- runQueryParams getTokenQ (uId, tokenData) >>= firstRow
1142+ token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow
9121143 case token' of
9131144 Nothing -> return Nothing
9141145 Just token -> do
915− if (tokenVerificationCode token == Just code)
1146+ if (tokenVerificationCode token == Just (hashVerificationCode code))
9161147 then validateToken token >> (return $ Just token)
9171148 else do
9181149 let triesLeft = tokenActivationTriesLeft token - 1
@@ -923,11 +1154,37 @@ tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
9231154 _ <- manipulateParams updateTokenQ newToken
9241155 return Nothing
9251156
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+
9261171getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
927−getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, tokenData) >>= firstRow
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)
9281176
9291177-- MARK: Utils
9301178
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+
9311188data UserRow = UserRow {
9321189 userRowId :: UserId,
9331190 userRowFirstName :: Text,
@@ -941,7 +1198,8 @@ data UserRow = UserRow {
9411198 userRowFacultyPath :: T.Text,
9421199 userRowFacultyCampusName :: T.Text,
9431200 userRowFacultyCampusCode :: T.Text,
944− userRowFacultyTags :: V.Vector T.Text
1201+ userRowFacultyTags :: V.Vector T.Text,
1202+ userRowFacultyAddress :: T.Text
9451203} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
9461204
9471205rowToUser :: UserRow -> User Faculty
@@ -956,13 +1214,27 @@ rowToUser UserRow{..} = User {
9561214 facultyPath = userRowFacultyPath,
9571215 facultyCampusName = userRowFacultyCampusName,
9581216 facultyCampusCode = userRowFacultyCampusCode,
959− facultyTags = userRowFacultyTags
1217+ facultyTags = userRowFacultyTags,
1218+ facultyAddress = userRowFacultyAddress
9601219 },
9611220 userEmail = userRowEmail
9621221 }
9631222
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+
9641233queryFromText :: Text -> Text
965−queryFromText = T.unwords . L.intersperse "&" . map (`T.append` ":*") . filter (not . T.null) . T.split (not . isAlphaNum)
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 <> ":*"
9661238
9671239directionToOperator
9681240 :: P.PaginationDirection