@@ -9,7 +9,8 @@
9 FlexibleInstances,
9 FlexibleInstances,
10 KindSignatures,
10 KindSignatures,
11 DeriveAnyClass,
11 DeriveAnyClass,
12− RecordWildCards #-}
12+ RecordWildCards,
13+ ScopedTypeVariables #-}
14{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
15{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
@@ -58,7 +59,14 @@ module Data.Query (
58 deactivateToken,
59 deactivateToken,
59 searchUsers,
60 searchUsers,
60 searchTags,
61 searchTags,
61− updateUser
62+ updateUser,
69+ groupChatIsValidForUser
64import Squeal.PostgreSQL
72import Squeal.PostgreSQL
@@ -88,7 +96,7 @@ import Data.Text (Text)
88import qualified Data.Text as T
96import qualified Data.Text as T
89import Data.Channel.NamedChannel
97import Data.Channel.NamedChannel
90import Data.Channel.AnonymousChannel
98import Data.Channel.AnonymousChannel
91−import Data.Maybe (fromMaybe)
99+import Data.Maybe (fromMaybe, catMaybes, isJust)
92import Squeal.PostgreSQL.Render
100import Squeal.PostgreSQL.Render
93import Data.GroupChat
101import Data.GroupChat
94import Data.Message
102import Data.Message
@@ -100,6 +108,8 @@ import Data.Foldable (fold)
100import Data.Char
108import Data.Char
101import qualified Data.Vector as V
109import qualified Data.Vector as V
102import Server.Auth.Token
110import Server.Auth.Token
112+import Data.Text.Validator
104-- MARK: Documentation
114-- MARK: Documentation
@@ -287,7 +297,7 @@ getChannelForUserQ = selectStar $
287 from (table #channels) &
297 from (table #channels) &
288 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
298 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
290−updateUserQ :: Manipulation Schema (TuplePG (User FacultyUrl)) (RowPG (Only UserId))
300+updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))
291updateUserQ = update #users (
301updateUserQ = update #users (
292 Same `as` #userRowId :*
302 Same `as` #userRowId :*
293 Set (param @2) `as` #userRowFirstName :*
303 Set (param @2) `as` #userRowFirstName :*
@@ -296,7 +306,7 @@ updateUserQ = update #users (
296 Set (param @5) `as` #userRowFacultyUrl :*
306 Set (param @5) `as` #userRowFacultyUrl :*
297 Same `as` #userRowEmail :*
307 Same `as` #userRowEmail :*
298 Same `as` #userRowIsValidated)
308 Same `as` #userRowIsValidated)
299− (#userRowId .== param @1 .&& #userRowEmail .== param @6)
309+ (#userRowId .== param @1)
300 (Returning $ #userRowId `as` #fromOnly)
310 (Returning $ #userRowId `as` #fromOnly)
302getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
312getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
@@ -305,6 +315,22 @@ getAllChannelsForUserQ = selectStar $
305 where_ (#namedChannelFullOwner .== param @1) &
315 where_ (#namedChannelFullOwner .== param @1) &
306 orderBy [#namedChannelFullId & Desc]
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)
308updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
334updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
309updateFacultyQ = insertRow #faculties
335updateFacultyQ = insertRow #faculties
@@ -335,6 +361,11 @@ createNamedChannelQ = insertRow #channels
335 OnConflictDoRaise
361 OnConflictDoRaise
336 (Returning $ #namedChannelFullId `as` #fromOnly)
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)
338deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
369deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
339deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
370deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
@@ -378,15 +409,26 @@ createMessageQ :: Manipulation
378createMessageQ = insertRow #messages
409createMessageQ = insertRow #messages
380 Default `as` #messageStorageId :*
411 Default `as` #messageStorageId :*
381− Set (param @1) `as` #messageStorageAuthorId :*
412+ Set (notNull $ param @1) `as` #messageStorageAuthorId :*
382 Set (param @2) `as` #messageStorageDestinationGroupId :*
413 Set (param @2) `as` #messageStorageDestinationGroupId :*
383 Set (param @3) `as` #messageStorageDestinationUserId :*
414 Set (param @3) `as` #messageStorageDestinationUserId :*
384− Set (param @4) `as` #messageStorageBody :*
415+ Set (notNull $ param @4) `as` #messageStorageBody :*
385 Set currentTimestamp `as` #messageStorageTime
416 Set currentTimestamp `as` #messageStorageTime
387 OnConflictDoRaise
418 OnConflictDoRaise
388 (Returning $ #messageStorageId `as` #fromOnly)
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
390createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
432createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
391createGroupChatQ = insertRow #groupChats
433createGroupChatQ = insertRow #groupChats
@@ -462,7 +504,7 @@ getChatsQ lim dir = select (
462 (ifThenElse
504 (ifThenElse
463 (#messageStorageAuthorId .== param @1)
505 (#messageStorageAuthorId .== param @1)
464 #messageStorageDestinationUserId
506 #messageStorageDestinationUserId
465− (notNull #messageStorageAuthorId)) `as` #messageUserId) $
507+ #messageStorageAuthorId) `as` #messageUserId) $
466 from (table #messages) &
508 from (table #messages) &
467 where_ (isNotNull #messageStorageDestinationUserId .&&
509 where_ (isNotNull #messageStorageDestinationUserId .&&
468 (#messageStorageAuthorId .== param @1 .||
510 (#messageStorageAuthorId .== param @1 .||
@@ -529,13 +571,21 @@ getGroupChatForUserQ = selectStar $
529getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
571getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
530getFacultySearchResultQ = selectStar (from (table #faculties) &
572getFacultySearchResultQ = selectStar (from (table #faculties) &
531 where_ (vector @@ query) &
573 where_ (vector @@ query) &
575+ tsRankCd vector1 query & Desc,
576+ tsRankCd vector2 query & Desc,
532− orderBy [tsRankCd vector query & Desc])
577+ tsRankCd vector query & Desc
534 vector = tsVector "russian" (textArrayToText [
580 vector = tsVector "russian" (textArrayToText [
535 #facultyName,
581 #facultyName,
536 #facultyPath,
582 #facultyPath,
537 #facultyCampusName,
583 #facultyCampusName,
538 (arrayToText #facultyTags)])
584 (arrayToText #facultyTags)])
585+ vector1 = tsVector "russian" #facultyName
586+ vector2 = tsVector "russian" (textArrayToText [
539 query = tsQuery "russian" (param @1)
589 query = tsQuery "russian" (param @1)
541searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
591searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
@@ -597,7 +647,7 @@ tsRankCd
597 -> Expression schema from grouping params ('NotNull 'PGtext)
647 -> Expression schema from grouping params ('NotNull 'PGtext)
598 -> Expression schema from grouping params ('NotNull 'PGfloat4)
648 -> Expression schema from grouping params ('NotNull 'PGfloat4)
599tsRankCd vector query = UnsafeExpression $
649tsRankCd vector query = UnsafeExpression $
600− "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"])
603 :: ByteString -- ^ Language
653 :: ByteString -- ^ Language
@@ -725,8 +775,29 @@ getVerifiedTokenQ = selectStar (from (table #tokens) &
725 isNull #tokenVerificationCode .&&
775 isNull #tokenVerificationCode .&&
726 currentTimestamp .< #tokenExpiryDate))
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))
728-- MARK: FrontEnd Data Structures
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]
730data UserCreation = UserCreation {
801data UserCreation = UserCreation {
731 userCreationFirstName :: Text,
802 userCreationFirstName :: Text,
732 userCreationMiddleName :: Text,
803 userCreationMiddleName :: Text,
@@ -745,9 +816,18 @@ instance ToJSON UserCreation where
747instance FromJSON UserCreation where
818instance FromJSON UserCreation where
748− parseJSON = withObject "named channel" $ \e ->
819+ parseJSON = withObject "user creation" $ \e ->
749 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
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)
751data NamedChannelCreation = NamedChannelCreation {
831data NamedChannelCreation = NamedChannelCreation {
752 namedChannelCreationOwner :: UserId,
832 namedChannelCreationOwner :: UserId,
753 namedChannelCreationName :: Text,
833 namedChannelCreationName :: Text,
@@ -783,11 +863,13 @@ getChannelForUser uId cId = do
783 Nothing -> lift $ S.throwError S.err404
863 Nothing -> lift $ S.throwError S.err404
785-- TODO: Reject bad requests. Should be binary.
865-- TODO: Reject bad requests. Should be binary.
786−verifiedUsers :: [UserId] -> StaticPQ [UserId]
866+verifyUsers :: [UserId] -> StaticPQ ()
787−verifiedUsers uIds =
867+verifyUsers uIds =
788 case verifiedUserIdsQ uIds of
868 case verifiedUserIdsQ uIds of
789− Just uIdsQ -> fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
870+ (us :: [UserId]) <- fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
871+ when (length us /= length uIds) $ lift $ S.throwError impossibleContent
790− Nothing -> return []
872+ Nothing -> return ()
792deleteGroupChat :: GroupChatId -> StaticPQ ()
874deleteGroupChat :: GroupChatId -> StaticPQ ()
793deleteGroupChat gId = do
875deleteGroupChat gId = do
@@ -849,30 +931,40 @@ getAllUsers :: StaticPQ [User Faculty]
849getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
931getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
851publishPost :: UserId -> PostCreation -> StaticPQ PostId
933publishPost :: UserId -> PostCreation -> StaticPQ PostId
852−publishPost uId pc = commitedTransactionallyUpdate $ do
934+publishPost uId pc = commitedTransactionallyUpdate $ do
853 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
935 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
854 case pId' of
936 case pId' of
855 (Just (Only pId)) -> do
937 (Just (Only pId)) -> do
856− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)
938+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
857 return pId
939 return pId
858 _ -> lift $ S.throwError S.err404
940 _ -> lift $ S.throwError S.err404
860createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
942createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
861createNewChannel uId req = commitedTransactionallyUpdate $ do
943createNewChannel uId req = commitedTransactionallyUpdate $ do
862− uIds <- verifiedUsers . toList $ namedChannelCreationRequestPeopleIds req
944+ let uIds = toList $ namedChannelCreationRequestPeopleIds req
863 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
946 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
864 return $ fmap fromOnly cId
947 return $ fmap fromOnly cId
949+channelCountForUser :: UserId -> StaticPQ Int64
950+channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
866updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
952updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
867−updateChannel uId req = commitedTransactionallyUpdate $ do
953+updateChannel uId req = do
868− uIds <- fmap fromList . verifiedUsers . toList $ namedChannelPeopleIds req
954+ let uIds = namedChannelPeopleIds req
955+ verifyUsers (toList uIds)
869 _ <- getChannelForUser uId $ namedChannelId req
956 _ <- getChannelForUser uId $ namedChannelId req
870− _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
957+ _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
871 return ()
958 return ()
873getFaculty :: Text -> StaticPQ Faculty
960getFaculty :: Text -> StaticPQ Faculty
874getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
961getFaculty 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
876updateFaculty :: Faculty -> StaticPQ ()
968updateFaculty :: Faculty -> StaticPQ ()
877updateFaculty fac = void $ manipulateParams updateFacultyQ fac
969updateFaculty fac = void $ manipulateParams updateFacultyQ fac
@@ -909,12 +1001,11 @@ getAllChannels uId = fmap (map removeUserFromChannel) $
909 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
1001 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
911deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
1003deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
912−deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do
1004+deleteNamedChannel uId cId = do
913 _ <- getChannelForUser uId cId
1005 _ <- getChannelForUser uId cId
914− _ <- manipulateParams deleteNamedChannelQ (Only cId)
1006+ _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
915 return ()
1007 return ()
917−-- Returns n most popular
918getTags :: Limit -> StaticPQ [String]
1009getTags :: Limit -> StaticPQ [String]
919getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
1010getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
@@ -949,36 +1040,40 @@ getMessagesInGroupChat
949getMessagesInGroupChat selfId gId mId lim dir = do
1040getMessagesInGroupChat selfId gId mId lim dir = do
950 _ <- getGroupChatForUser selfId gId
1041 _ <- getGroupChatForUser selfId gId
951 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
1042 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
952− (return . sequence . map restoreMessage $ resp) >>= fromMaybe500
1043+ return . catMaybes . map restoreMessage $ resp
954sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
1045sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
955−sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
1046+sendMessage selfId (MessageCreation (Just gId) uId@Nothing (Jsonb body)) = do
956 _ <- getGroupChatForUser selfId gId
1047 _ <- getGroupChatForUser selfId gId
957− (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, body)
1048+ (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, Jsonb $ stripPostElement body)
958 >>= firstRow >>= fromMaybe500
1049 >>= firstRow >>= fromMaybe500
959 return mId
1050 return mId
960−sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do
1051+sendMessage selfId (MessageCreation gId@Nothing (Just uId) (Jsonb body)) = do
961− (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, body)
1053+ (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, Jsonb $ stripPostElement body)
962 >>= firstRow >>= fromMaybe500
1054 >>= firstRow >>= fromMaybe500
963 return mId
1055 return mId
964sendMessage _ _ = lift $ S.throwError S.err400
1056sendMessage _ _ = lift $ S.throwError S.err400
966createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
1058createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
967createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
1059createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
1060+ verifyUsers . M.keys $ chatUsers
1061+ commitedTransactionallyUpdate $ do
968− let chatUsers' = M.insert uId maxChatPermissions chatUsers
1062+ let chatUsers' = M.insert uId maxChatPermissions chatUsers
969− (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)
1063+ (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)
970− >>= firstRow >>= fromMaybe500
1064+ >>= firstRow >>= fromMaybe500
971− -- TODO: Do somehting with this
1065+ _ <- manipulateParams createPhantomMessageQ (Only chatId)
972− _ <- sendMessage uId $ MessageCreation (Just chatId) Nothing (Jsonb $ Markdown "henlo")
973− return chatId
1066+ return chatId
975updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
1068updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
976−updateGroupChat uId (GroupChat gId (Jsonb perms) name) = commitedTransactionallyUpdate $ do
1069+updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
1070+ verifyUsers . M.keys $ perms
1071+ commitedTransactionallyUpdate $ do
977− (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId
1072+ (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId
978− let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'
1073+ let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'
979− unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401
1074+ unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401
980− let newPerms = M.insert uId userPerm perms
1075+ let newPerms = M.insert uId userPerm perms
981− void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
1076+ void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
983leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
1078leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
984leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
1079leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
@@ -995,15 +1090,24 @@ getGroupChatForUser uId gId = do
995 (Just c) -> return c
1090 (Just c) -> return c
996 Nothing -> lift $ S.throwError S.err404
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
998getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
1098getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
999getFacultyFromQuery query =
1099getFacultyFromQuery query =
1000 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
1100 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
1002searchUsers :: T.Text -> StaticPQ [User Faculty]
1102searchUsers :: T.Text -> StaticPQ [User Faculty]
1003−searchUsers query =
1103+searchUsers query = do
1104+ unless (validateText query) $ lift $ throwError lengthExceeded
1105+ if (T.null . T.filter isAlpha $ query)
1004− map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
1107+ else map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
1006searchTags :: T.Text -> StaticPQ [Text]
1109searchTags :: T.Text -> StaticPQ [Text]
1110+searchTags "" = return []
1007searchTags query = map fromOnly <$>
1111searchTags query = map fromOnly <$>
1008 (runQueryParams searchTagsQ
1112 (runQueryParams searchTagsQ
1009 (Only . (<> ":*") . T.strip $ query) >>= getRows)
1113 (Only . (<> ":*") . T.strip $ query) >>= getRows)
@@ -1011,6 +1115,18 @@ searchTags query = map fromOnly <$>
1011createToken :: Token -> StaticPQ ()
1115createToken :: Token -> StaticPQ ()
1012createToken token = void $ manipulateParams createTokenQ token
1116createToken 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
1015-- NOTE: Not transactional
1131-- NOTE: Not transactional
1016validateToken :: Token -> StaticPQ ()
1132validateToken :: Token -> StaticPQ ()
@@ -1055,19 +1171,18 @@ deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ
1055getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1171getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1056getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
1172getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
1058−updateUser :: (User FacultyUrl) -> StaticPQ (Maybe UserId)
1174+updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
1059updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
1175updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
1061-- MARK: Utils
1177-- MARK: Utils
1063−normalizeUser :: User FacultyUrl -> User FacultyUrl
1179+normalizeUser :: UserUpdateRow -> UserUpdateRow
1064−normalizeUser User{..} = User {
1180+normalizeUser UserUpdateRow{..} = UserUpdateRow {
1065− userId = userId,
1181+ userUpdateRowId = userUpdateRowId,
1066− firstName = T.strip $ firstName,
1182+ userUpdateRowFirstName = T.strip $ userUpdateRowFirstName,
1067− middleName = T.strip $ middleName,
1183+ userUpdateRowMiddleName = T.strip $ userUpdateRowMiddleName,
1068− lastName = T.strip $ lastName,
1184+ userUpdateRowLastName = T.strip $ userUpdateRowLastName,
1069− userFaculty = T.toLower . T.strip $ userFaculty,
1185+ userUpdateRowUserFaculty = T.toLower . T.strip $ userUpdateRowUserFaculty
1070− userEmail = T.toLower . T.strip $ userEmail
1073data UserRow = UserRow {
1188data UserRow = UserRow {
@@ -1116,7 +1231,7 @@ queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (no
1116 ) <> ")"
1231 ) <> ")"
1118queryFromText :: Text -> Text
1233queryFromText :: Text -> Text
1119−queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
1234+queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)
1121 processTerm :: Text -> Text
1236 processTerm :: Text -> Text
1122 processTerm t = t <> ":*"
1237 processTerm t = t <> ":*"