@@ -9,8 +9,7 @@
9 FlexibleInstances,
9 FlexibleInstances,
10 KindSignatures,
10 KindSignatures,
11 DeriveAnyClass,
11 DeriveAnyClass,
12− RecordWildCards,
12+ RecordWildCards #-}
13− ScopedTypeVariables #-}
15{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
14{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
@@ -57,16 +56,7 @@ module Data.Query (
57 createUser,
56 createUser,
58 tryActivateToken,
57 tryActivateToken,
59 deactivateToken,
58 deactivateToken,
60− searchUsers,
59+ searchUsers
69− groupChatIsValidForUser
72import Squeal.PostgreSQL
62import Squeal.PostgreSQL
@@ -96,7 +86,7 @@ import Data.Text (Text)
96import qualified Data.Text as T
86import qualified Data.Text as T
97import Data.Channel.NamedChannel
87import Data.Channel.NamedChannel
98import Data.Channel.AnonymousChannel
88import Data.Channel.AnonymousChannel
99−import Data.Maybe (fromMaybe, catMaybes, isJust)
89+import Data.Maybe (fromMaybe)
100import Squeal.PostgreSQL.Render
90import Squeal.PostgreSQL.Render
101import Data.GroupChat
91import Data.GroupChat
102import Data.Message
92import Data.Message
@@ -108,8 +98,6 @@ import Data.Foldable (fold)
108import Data.Char
98import Data.Char
109import qualified Data.Vector as V
99import qualified Data.Vector as V
110import Server.Auth.Token
100import Server.Auth.Token
112−import Data.Text.Validator
114-- MARK: Documentation
102-- MARK: Documentation
@@ -297,40 +285,12 @@ getChannelForUserQ = selectStar $
297 from (table #channels) &
285 from (table #channels) &
298 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
286 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
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)
312getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
288getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
313getAllChannelsForUserQ = selectStar $
289getAllChannelsForUserQ = selectStar $
314 from (table #channels) &
290 from (table #channels) &
315 where_ (#namedChannelFullOwner .== param @1) &
291 where_ (#namedChannelFullOwner .== param @1) &
316 orderBy [#namedChannelFullId & Desc]
292 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)
334updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
294updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
335updateFacultyQ = insertRow #faculties
295updateFacultyQ = insertRow #faculties
@@ -361,11 +321,6 @@ createNamedChannelQ = insertRow #channels
361 OnConflictDoRaise
321 OnConflictDoRaise
362 (Returning $ #namedChannelFullId `as` #fromOnly)
322 (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)
369deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
324deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
370deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
325deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
@@ -398,7 +353,7 @@ getChannelPostsQ lim dir uIds tags = getLastPostsQ
398 Just uIdsQ -> (`in_` uIdsQ)
353 Just uIdsQ -> (`in_` uIdsQ)
399 Nothing -> const $ false
354 Nothing -> const $ false
401−getTagsQ :: Query Schema params (RowPG (Only String))
356+getTagsQ :: Query Schema '[] (RowPG (Only String))
402getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
357getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
403 from (table #posts)
358 from (table #posts)
@@ -409,26 +364,15 @@ createMessageQ :: Manipulation
409createMessageQ = insertRow #messages
364createMessageQ = insertRow #messages
411 Default `as` #messageStorageId :*
366 Default `as` #messageStorageId :*
412− Set (notNull $ param @1) `as` #messageStorageAuthorId :*
367+ Set (param @1) `as` #messageStorageAuthorId :*
413 Set (param @2) `as` #messageStorageDestinationGroupId :*
368 Set (param @2) `as` #messageStorageDestinationGroupId :*
414 Set (param @3) `as` #messageStorageDestinationUserId :*
369 Set (param @3) `as` #messageStorageDestinationUserId :*
415− Set (notNull $ param @4) `as` #messageStorageBody :*
370+ Set (param @4) `as` #messageStorageBody :*
416 Set currentTimestamp `as` #messageStorageTime
371 Set currentTimestamp `as` #messageStorageTime
418 OnConflictDoRaise
373 OnConflictDoRaise
419 (Returning $ #messageStorageId `as` #fromOnly)
374 (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
432createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
376createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
433createGroupChatQ = insertRow #groupChats
377createGroupChatQ = insertRow #groupChats
@@ -504,7 +448,7 @@ getChatsQ lim dir = select (
504 (ifThenElse
448 (ifThenElse
505 (#messageStorageAuthorId .== param @1)
449 (#messageStorageAuthorId .== param @1)
506 #messageStorageDestinationUserId
450 #messageStorageDestinationUserId
507− #messageStorageAuthorId) `as` #messageUserId) $
451+ (notNull #messageStorageAuthorId)) `as` #messageUserId) $
508 from (table #messages) &
452 from (table #messages) &
509 where_ (isNotNull #messageStorageDestinationUserId .&&
453 where_ (isNotNull #messageStorageDestinationUserId .&&
510 (#messageStorageAuthorId .== param @1 .||
454 (#messageStorageAuthorId .== param @1 .||
@@ -571,21 +515,13 @@ getGroupChatForUserQ = selectStar $
571getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
515getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
572getFacultySearchResultQ = selectStar (from (table #faculties) &
516getFacultySearchResultQ = selectStar (from (table #faculties) &
573 where_ (vector @@ query) &
517 where_ (vector @@ query) &
575− tsRankCd vector1 query & Desc,
576− tsRankCd vector2 query & Desc,
577− tsRankCd vector query & Desc
518+ orderBy [tsRankCd vector query & Desc])
580 vector = tsVector "russian" (textArrayToText [
520 vector = tsVector "russian" (textArrayToText [
581 #facultyName,
521 #facultyName,
582 #facultyPath,
522 #facultyPath,
583 #facultyCampusName,
523 #facultyCampusName,
584 (arrayToText #facultyTags)])
524 (arrayToText #facultyTags)])
585− vector1 = tsVector "russian" #facultyName
586− vector2 = tsVector "russian" (textArrayToText [
589 query = tsQuery "russian" (param @1)
525 query = tsQuery "russian" (param @1)
591searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
527searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
@@ -619,35 +555,12 @@ searchUsersQ = select (
620 query = tsQuery' (param @1)
556 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)
559 :: Expression schema from grouping params ('NotNull 'PGtext)
647 -> Expression schema from grouping params ('NotNull 'PGtext)
560 -> Expression schema from grouping params ('NotNull 'PGtext)
648 -> Expression schema from grouping params ('NotNull 'PGfloat4)
561 -> Expression schema from grouping params ('NotNull 'PGfloat4)
649tsRankCd vector query = UnsafeExpression $
562tsRankCd vector query = UnsafeExpression $
650− "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])
563+ "ts_rank_cd" <> parenthesized (commaSeparated . map renderExpression $ [vector, query])
653 :: ByteString -- ^ Language
566 :: ByteString -- ^ Language
@@ -772,32 +685,10 @@ getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
772getVerifiedTokenQ = selectStar (from (table #tokens) &
685getVerifiedTokenQ = selectStar (from (table #tokens) &
773 where_ (#tokenUserId .== param @1 .&&
686 where_ (#tokenUserId .== param @1 .&&
774 #tokenValue .== param @2 .&&
687 #tokenValue .== param @2 .&&
775− isNull #tokenVerificationCode .&&
688+ 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
690-- MARK: FrontEnd Data Structures
793−instance HasValidatableText UserCreation where
794− validateText UserCreation{..} = all validateText [
795− userCreationFirstName,
796− userCreationMiddleName,
797− userCreationLastName,
798− userCreationUserFaculty,
799− userCreationUserEmail]
801data UserCreation = UserCreation {
692data UserCreation = UserCreation {
802 userCreationFirstName :: Text,
693 userCreationFirstName :: Text,
803 userCreationMiddleName :: Text,
694 userCreationMiddleName :: Text,
@@ -816,18 +707,9 @@ instance ToJSON UserCreation where
818instance FromJSON UserCreation where
709instance FromJSON UserCreation where
819− parseJSON = withObject "user creation" $ \e ->
710+ parseJSON = withObject "named channel" $ \e ->
820 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
711 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)
831data NamedChannelCreation = NamedChannelCreation {
713data NamedChannelCreation = NamedChannelCreation {
832 namedChannelCreationOwner :: UserId,
714 namedChannelCreationOwner :: UserId,
833 namedChannelCreationName :: Text,
715 namedChannelCreationName :: Text,
@@ -863,13 +745,11 @@ getChannelForUser uId cId = do
863 Nothing -> lift $ S.throwError S.err404
745 Nothing -> lift $ S.throwError S.err404
865-- TODO: Reject bad requests. Should be binary.
747-- TODO: Reject bad requests. Should be binary.
866−verifyUsers :: [UserId] -> StaticPQ ()
748+verifiedUsers :: [UserId] -> StaticPQ [UserId]
867−verifyUsers uIds =
749+verifiedUsers uIds =
868 case verifiedUserIdsQ uIds of
750 case verifiedUserIdsQ uIds of
870− (us :: [UserId]) <- fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
751+ Just uIdsQ -> fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
871− when (length us /= length uIds) $ lift $ S.throwError impossibleContent
872− Nothing -> return ()
752+ Nothing -> return []
874deleteGroupChat :: GroupChatId -> StaticPQ ()
754deleteGroupChat :: GroupChatId -> StaticPQ ()
875deleteGroupChat gId = do
755deleteGroupChat gId = do
@@ -931,40 +811,30 @@ getAllUsers :: StaticPQ [User Faculty]
931getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
811getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
933publishPost :: UserId -> PostCreation -> StaticPQ PostId
813publishPost :: UserId -> PostCreation -> StaticPQ PostId
934−publishPost uId pc = commitedTransactionallyUpdate $ do
814+publishPost uId pc = commitedTransactionallyUpdate $ do
935 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
815 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
936 case pId' of
816 case pId' of
937 (Just (Only pId)) -> do
817 (Just (Only pId)) -> do
938− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
818+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)
939 return pId
819 return pId
940 _ -> lift $ S.throwError S.err404
820 _ -> lift $ S.throwError S.err404
942createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
822createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
943createNewChannel uId req = commitedTransactionallyUpdate $ do
823createNewChannel uId req = commitedTransactionallyUpdate $ do
944− let uIds = toList $ namedChannelCreationRequestPeopleIds req
824+ uIds <- verifiedUsers . toList $ namedChannelCreationRequestPeopleIds req
946 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
825 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
947 return $ fmap fromOnly cId
826 return $ fmap fromOnly cId
949−channelCountForUser :: UserId -> StaticPQ Int64
950−channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
952updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
828updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
953−updateChannel uId req = do
829+updateChannel uId req = commitedTransactionallyUpdate $ do
954− let uIds = namedChannelPeopleIds req
830+ uIds <- fmap fromList . verifiedUsers . toList $ namedChannelPeopleIds req
955− verifyUsers (toList uIds)
956 _ <- getChannelForUser uId $ namedChannelId req
831 _ <- getChannelForUser uId $ namedChannelId req
957− _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
832+ _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
958 return ()
833 return ()
960getFaculty :: Text -> StaticPQ Faculty
835getFaculty :: Text -> StaticPQ Faculty
961getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
836getFaculty 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
968updateFaculty :: Faculty -> StaticPQ ()
838updateFaculty :: Faculty -> StaticPQ ()
969updateFaculty fac = void $ manipulateParams updateFacultyQ fac
839updateFaculty fac = void $ manipulateParams updateFacultyQ fac
@@ -1001,13 +871,13 @@ getAllChannels uId = fmap (map removeUserFromChannel) $
1001 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
871 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
1003deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
873deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
1004−deleteNamedChannel uId cId = do
874+deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do
1005 _ <- getChannelForUser uId cId
875 _ <- getChannelForUser uId cId
1006− _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
876+ _ <- manipulateParams deleteNamedChannelQ (Only cId)
1007 return ()
877 return ()
1009−getTags :: Limit -> StaticPQ [String]
879+getTags :: StaticPQ [String]
1010−getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
880+getTags = map fromOnly <$> (runQuery getTagsQ >>= getRows)
1012getDialogs
882getDialogs
1013 :: UserId
883 :: UserId
@@ -1040,40 +910,36 @@ getMessagesInGroupChat
1040getMessagesInGroupChat selfId gId mId lim dir = do
910getMessagesInGroupChat selfId gId mId lim dir = do
1041 _ <- getGroupChatForUser selfId gId
911 _ <- getGroupChatForUser selfId gId
1042 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
912 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
1043− return . catMaybes . map restoreMessage $ resp
913+ (return . sequence . map restoreMessage $ resp) >>= fromMaybe500
1045sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
915sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
1046−sendMessage selfId (MessageCreation (Just gId) uId@Nothing (Jsonb body)) = do
916+sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
1047 _ <- getGroupChatForUser selfId gId
917 _ <- getGroupChatForUser selfId gId
1048− (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, Jsonb $ stripPostElement body)
918+ (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, body)
1049 >>= firstRow >>= fromMaybe500
919 >>= firstRow >>= fromMaybe500
1050 return mId
920 return mId
1051−sendMessage selfId (MessageCreation gId@Nothing (Just uId) (Jsonb body)) = do
921+sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do
1053− (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, Jsonb $ stripPostElement body)
922+ (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, body)
1054 >>= firstRow >>= fromMaybe500
923 >>= firstRow >>= fromMaybe500
1055 return mId
924 return mId
1056sendMessage _ _ = lift $ S.throwError S.err400
925sendMessage _ _ = lift $ S.throwError S.err400
1058createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
927createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
1059createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
928createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
1060− verifyUsers . M.keys $ chatUsers
1061− commitedTransactionallyUpdate $ do
1062− let chatUsers' = M.insert uId maxChatPermissions chatUsers
929+ let chatUsers' = M.insert uId maxChatPermissions chatUsers
1063− (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)
930+ (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)
1064− >>= firstRow >>= fromMaybe500
931+ >>= firstRow >>= fromMaybe500
1065− _ <- manipulateParams createPhantomMessageQ (Only chatId)
932+ -- TODO: Do somehting with this
933+ _ <- sendMessage uId $ MessageCreation (Just chatId) Nothing (Jsonb $ Markdown "henlo")
1066− return chatId
934+ return chatId
1068updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
936updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
1069−updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
937+updateGroupChat uId (GroupChat gId (Jsonb perms) name) = commitedTransactionallyUpdate $ do
1070− verifyUsers . M.keys $ perms
1071− commitedTransactionallyUpdate $ do
1072− (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId
938+ (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId
1073− let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'
939+ let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'
1074− unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401
940+ unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401
1075− let newPerms = M.insert uId userPerm perms
941+ let newPerms = M.insert uId userPerm perms
1076− void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
942+ void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
1078leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
944leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
1079leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
945leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
@@ -1090,43 +956,17 @@ getGroupChatForUser uId gId = do
1090 (Just c) -> return c
956 (Just c) -> return c
1091 Nothing -> lift $ S.throwError S.err404
957 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
1098getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
959getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
1099getFacultyFromQuery query =
960getFacultyFromQuery query =
1100 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
961 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
1102searchUsers :: T.Text -> StaticPQ [User Faculty]
963searchUsers :: T.Text -> StaticPQ [User Faculty]
1103−searchUsers query = do
964+searchUsers query =
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)
965+ 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)
1115createToken :: Token -> StaticPQ ()
967createToken :: Token -> StaticPQ ()
1116createToken token = void $ manipulateParams createTokenQ token
968createToken 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
971-- NOTE: Not transactional
1132validateToken :: Token -> StaticPQ ()
972validateToken :: Token -> StaticPQ ()
@@ -1171,20 +1011,8 @@ deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ
1171getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1011getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1172getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
1012getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
1174−updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
1175−updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
1177-- MARK: Utils
1014-- MARK: Utils
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
1188data UserRow = UserRow {
1016data UserRow = UserRow {
1189 userRowId :: UserId,
1017 userRowId :: UserId,
1190 userRowFirstName :: Text,
1018 userRowFirstName :: Text,
@@ -1231,7 +1059,7 @@ queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (no
1231 ) <> ")"
1059 ) <> ")"
1233queryFromText :: Text -> Text
1061queryFromText :: Text -> Text
1234−queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)
1062+queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
1236 processTerm :: Text -> Text
1064 processTerm :: Text -> Text
1237 processTerm t = t <> ":*"
1065 processTerm t = t <> ":*"