@@ -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
@@ -55,7 +56,17 @@ module Data.Query (
5556 UserCreation(..),
5657 createUser,
5758 tryActivateToken,
58− deactivateToken
59+ deactivateToken,
60+ searchUsers,
61+ searchTags,
62+ updateUser,
63+ UserUpdateRow(..),
64+ killAllTokens,
65+ channelCountForUser,
66+ pruneAuth,
67+ searchChannels,
68+ isValidFaculty,
69+ groupChatIsValidForUser
5970 ) where
6071
6172import Squeal.PostgreSQL
@@ -85,7 +96,7 @@ import Data.Text (Text)
8596import qualified Data.Text as T
8697import Data.Channel.NamedChannel
8798import Data.Channel.AnonymousChannel
88−import Data.Maybe (fromMaybe, isJust)
99+import Data.Maybe (fromMaybe, catMaybes, isJust)
89100import Squeal.PostgreSQL.Render
90101import Data.GroupChat
91102import Data.Message
@@ -97,6 +108,8 @@ import Data.Foldable (fold)
97108import Data.Char
98109import qualified Data.Vector as V
99110import Server.Auth.Token
111+import Server.Error
112+import Data.Text.Validator
100113
101114-- MARK: Documentation
102115
@@ -284,12 +297,40 @@ getChannelForUserQ = selectStar $
284297 from (table #channels) &
285298 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
286299
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+
287312getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
288313getAllChannelsForUserQ = selectStar $
289314 from (table #channels) &
290315 where_ (#namedChannelFullOwner .== param @1) &
291316 orderBy [#namedChannelFullId & Desc]
292317
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+
293334updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
294335updateFacultyQ = insertRow #faculties
295336 (
@@ -320,6 +361,11 @@ createNamedChannelQ = insertRow #channels
320361 OnConflictDoRaise
321362 (Returning $ #namedChannelFullId `as` #fromOnly)
322363
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+
323369deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
324370deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
325371
@@ -352,7 +398,7 @@ getChannelPostsQ lim dir uIds tags = getLastPostsQ
352398 Just uIdsQ -> (`in_` uIdsQ)
353399 Nothing -> const $ false
354400
355−getTagsQ :: Query Schema '[] (RowPG (Only String))
401+getTagsQ :: Query Schema params (RowPG (Only String))
356402getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
357403 from (table #posts)
358404
@@ -363,15 +409,26 @@ createMessageQ :: Manipulation
363409createMessageQ = insertRow #messages
364410 (
365411 Default `as` #messageStorageId :*
366− Set (param @1) `as` #messageStorageAuthorId :*
412+ Set (notNull $ param @1) `as` #messageStorageAuthorId :*
367413 Set (param @2) `as` #messageStorageDestinationGroupId :*
368414 Set (param @3) `as` #messageStorageDestinationUserId :*
369− Set (param @4) `as` #messageStorageBody :*
415+ Set (notNull $ param @4) `as` #messageStorageBody :*
370416 Set currentTimestamp `as` #messageStorageTime
371417 )
372418 OnConflictDoRaise
373419 (Returning $ #messageStorageId `as` #fromOnly)
374420
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+
375432createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
376433createGroupChatQ = insertRow #groupChats
377434 (
@@ -447,7 +504,7 @@ getChatsQ lim dir = select (
447504 (ifThenElse
448505 (#messageStorageAuthorId .== param @1)
449506 #messageStorageDestinationUserId
450− (notNull #messageStorageAuthorId)) `as` #messageUserId) $
507+ #messageStorageAuthorId) `as` #messageUserId) $
451508 from (table #messages) &
452509 where_ (isNotNull #messageStorageDestinationUserId .&&
453510 (#messageStorageAuthorId .== param @1 .||
@@ -514,21 +571,83 @@ getGroupChatForUserQ = selectStar $
514571getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
515572getFacultySearchResultQ = selectStar (from (table #faculties) &
516573 where_ (vector @@ query) &
517− orderBy [tsRankCd vector query & Desc])
574+ orderBy [
575+ tsRankCd vector1 query & Desc,
576+ tsRankCd vector2 query & Desc,
577+ tsRankCd vector query & Desc
578+ ])
518579 where
519580 vector = tsVector "russian" (textArrayToText [
520581 #facultyName,
521582 #facultyPath,
522583 #facultyCampusName,
523584 (arrayToText #facultyTags)])
585+ vector1 = tsVector "russian" #facultyName
586+ vector2 = tsVector "russian" (textArrayToText [
587+ #facultyName,
588+ #facultyPath])
524589 query = tsQuery "russian" (param @1)
525590
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+
526645tsRankCd
527646 :: Expression schema from grouping params ('NotNull 'PGtext)
528647 -> Expression schema from grouping params ('NotNull 'PGtext)
529648 -> Expression schema from grouping params ('NotNull 'PGfloat4)
530649tsRankCd vector query = UnsafeExpression $
531− "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"])
532651
533652tsVector
534653 :: ByteString -- ^ Language
@@ -537,6 +656,12 @@ tsVector
537656tsVector lang x = UnsafeExpression $
538657 "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
539658
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+
540665tsQuery
541666 :: ByteString -- ^ Language
542667 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -544,6 +669,12 @@ tsQuery
544669tsQuery lang x = UnsafeExpression $
545670 "to_tsquery" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
546671
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+
547678arrayToText
548679 :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
549680 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -631,20 +762,42 @@ getTokenActivationQ = selectStar (from (table #tokens) &
631762 where_ (#tokenUserId .== param @1 .&&
632763 #tokenActivationCode .== param @2))
633764
634−deactivateTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) (RowPG (Only UserId))
765+deactivateTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) (RowPG (Only Text))
635766deactivateTokenQ = deleteFrom #tokens
636767 (#tokenUserId .== param @1 .&&
637768 #tokenDeactivationCode .== param @2)
638− (Returning (#tokenUserId `as` #fromOnly))
769+ (Returning (#tokenUserAgent `as` #fromOnly))
639770
640771getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
641772getVerifiedTokenQ = selectStar (from (table #tokens) &
642773 where_ (#tokenUserId .== param @1 .&&
643774 #tokenValue .== param @2 .&&
644− 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))
645790
646791-- MARK: FrontEnd Data Structures
647792
793+instance HasValidatableText UserCreation where
794+ validateText UserCreation{..} = all validateText [
795+ userCreationFirstName,
796+ userCreationMiddleName,
797+ userCreationLastName,
798+ userCreationUserFaculty,
799+ userCreationUserEmail]
800+
648801data UserCreation = UserCreation {
649802 userCreationFirstName :: Text,
650803 userCreationMiddleName :: Text,
@@ -663,9 +816,18 @@ instance ToJSON UserCreation where
663816 ]
664817
665818instance FromJSON UserCreation where
666− parseJSON = withObject "named channel" $ \e ->
819+ parseJSON = withObject "user creation" $ \e ->
667820 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
668821
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+
669831data NamedChannelCreation = NamedChannelCreation {
670832 namedChannelCreationOwner :: UserId,
671833 namedChannelCreationName :: Text,
@@ -701,11 +863,13 @@ getChannelForUser uId cId = do
701863 Nothing -> lift $ S.throwError S.err404
702864
703865-- TODO: Reject bad requests. Should be binary.
704−verifiedUsers :: [UserId] -> StaticPQ [UserId]
705−verifiedUsers uIds =
866+verifyUsers :: [UserId] -> StaticPQ ()
867+verifyUsers uIds =
706868 case verifiedUserIdsQ uIds of
707− Just uIdsQ -> fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
708− 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 ()
709873
710874deleteGroupChat :: GroupChatId -> StaticPQ ()
711875deleteGroupChat gId = do
@@ -767,30 +931,40 @@ getAllUsers :: StaticPQ [User Faculty]
767931getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
768932
769933publishPost :: UserId -> PostCreation -> StaticPQ PostId
770−publishPost uId pc = commitedTransactionallyUpdate $ do
934+publishPost uId pc = commitedTransactionallyUpdate $ do
771935 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
772936 case pId' of
773937 (Just (Only pId)) -> do
774− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)
938+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
775939 return pId
776940 _ -> lift $ S.throwError S.err404
777941
778942createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
779943createNewChannel uId req = commitedTransactionallyUpdate $ do
780− uIds <- verifiedUsers . toList $ namedChannelCreationRequestPeopleIds req
944+ let uIds = toList $ namedChannelCreationRequestPeopleIds req
945+ verifyUsers uIds
781946 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
782947 return $ fmap fromOnly cId
783948
949+channelCountForUser :: UserId -> StaticPQ Int64
950+channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
951+
784952updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
785−updateChannel uId req = commitedTransactionallyUpdate $ do
786− uIds <- fmap fromList . verifiedUsers . toList $ namedChannelPeopleIds req
953+updateChannel uId req = do
954+ let uIds = namedChannelPeopleIds req
955+ verifyUsers (toList uIds)
787956 _ <- getChannelForUser uId $ namedChannelId req
788− _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
957+ _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
789958 return ()
790959
791960getFaculty :: Text -> StaticPQ Faculty
792961getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
793962
963+isValidFaculty :: FacultyUrl -> StaticPQ Bool
964+isValidFaculty url = do
965+ (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
966+ return $ isJust faculty
967+
794968updateFaculty :: Faculty -> StaticPQ ()
795969updateFaculty fac = void $ manipulateParams updateFacultyQ fac
796970
@@ -827,13 +1001,13 @@ getAllChannels uId = fmap (map removeUserFromChannel) $
8271001 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
8281002
8291003deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
830−deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do
1004+deleteNamedChannel uId cId = do
8311005 _ <- getChannelForUser uId cId
832− _ <- manipulateParams deleteNamedChannelQ (Only cId)
1006+ _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
8331007 return ()
8341008
835−getTags :: StaticPQ [String]
836−getTags = map fromOnly <$> (runQuery getTagsQ >>= getRows)
1009+getTags :: Limit -> StaticPQ [String]
1010+getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
8371011
8381012getDialogs
8391013 :: UserId
@@ -866,36 +1040,40 @@ getMessagesInGroupChat
8661040getMessagesInGroupChat selfId gId mId lim dir = do
8671041 _ <- getGroupChatForUser selfId gId
8681042 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
869− (return . sequence . map restoreMessage $ resp) >>= fromMaybe500
1043+ return . catMaybes . map restoreMessage $ resp
8701044
8711045sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
872−sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
1046+sendMessage selfId (MessageCreation (Just gId) uId@Nothing (Jsonb body)) = do
8731047 _ <- getGroupChatForUser selfId gId
874− (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, body)
1048+ (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, Jsonb $ stripPostElement body)
8751049 >>= firstRow >>= fromMaybe500
8761050 return mId
877−sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do
878− (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)
8791054 >>= firstRow >>= fromMaybe500
8801055 return mId
8811056sendMessage _ _ = lift $ S.throwError S.err400
8821057
8831058createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
8841059createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
885− let chatUsers' = M.insert uId maxChatPermissions chatUsers
886− (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)
887− >>= firstRow >>= fromMaybe500
888− -- TODO: Do somehting with this
889− _ <- sendMessage uId $ MessageCreation (Just chatId) Nothing (Jsonb $ Markdown "henlo")
890− 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
8911067
8921068updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
893−updateGroupChat uId (GroupChat gId (Jsonb perms) name) = commitedTransactionallyUpdate $ do
894− (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId
895− let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'
896− unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401
897− let newPerms = M.insert uId userPerm perms
898− 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)
8991077
9001078leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
9011079leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
@@ -912,13 +1090,43 @@ getGroupChatForUser uId gId = do
9121090 (Just c) -> return c
9131091 Nothing -> lift $ S.throwError S.err404
9141092
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+
9151098getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
9161099getFacultyFromQuery query =
917− 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)
9181114
9191115createToken :: Token -> StaticPQ ()
9201116createToken token = void $ manipulateParams createTokenQ token
9211117
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
9221130
9231131-- NOTE: Not transactional
9241132validateToken :: Token -> StaticPQ ()
@@ -946,7 +1154,7 @@ tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
9461154 _ <- manipulateParams updateTokenQ newToken
9471155 return Nothing
9481156
949−tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe ByteString)
1157+tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
9501158tryActivateToken uId activationData = do
9511159 let hData = hash activationData
9521160 token' <- runQueryParams getTokenActivationQ (uId, hData) >>= firstRow
@@ -954,19 +1162,29 @@ tryActivateToken uId activationData = do
9541162 Nothing -> return Nothing
9551163 Just token -> do
9561164 if (tokenActivationCode token == Just hData)
957− then commitedTransactionallyUpdate (validateToken token) >> return (Just $ tokenValue token)
1165+ then commitedTransactionallyUpdate (validateToken token) >> (return $ Just token)
9581166 else return Nothing
9591167
960−deactivateToken :: UserId -> ByteString -> StaticPQ Bool
961−deactivateToken uId dData = do
962− res <- manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow
963− return $ isJust (res :: Maybe (Only UserId))
1168+deactivateToken :: UserId -> ByteString -> StaticPQ (Maybe Text)
1169+deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow)
9641170
9651171getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
9661172getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
9671173
1174+updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
1175+updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
1176+
9681177-- MARK: Utils
9691178
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+
9701188data UserRow = UserRow {
9711189 userRowId :: UserId,
9721190 userRowFirstName :: Text,
@@ -1002,8 +1220,8 @@ rowToUser UserRow{..} = User {
10021220 userEmail = userRowEmail
10031221 }
10041222
1005−queryFromText :: Text -> Text
1006−queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
1223+queryFromTextAbbr :: Text -> Text
1224+queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
10071225 where
10081226 processTerm :: Text -> Text
10091227 processTerm t = "(" <> t <> ":*" <> (
@@ -1012,6 +1230,12 @@ queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not .
10121230 else mempty
10131231 ) <> ")"
10141232
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+
10151239directionToOperator
10161240 :: P.PaginationDirection
10171241 -> (ConditionOp schema0 from0 grouping0 params0 nullity0 nullity1 (ty :: PGType),