@@ -9,8 +9,7 @@
99 FlexibleInstances,
1010 KindSignatures,
1111 DeriveAnyClass,
12− RecordWildCards,
13− ScopedTypeVariables #-}
12+ RecordWildCards #-}
1413
1514{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
1615
@@ -54,19 +53,7 @@ module Data.Query (
5453 tryVerifyToken,
5554 getVerifiedToken,
5655 UserCreation(..),
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
56+ createUser
7057 ) where
7158
7259import Squeal.PostgreSQL
@@ -96,7 +83,7 @@ import Data.Text (Text)
9683import qualified Data.Text as T
9784import Data.Channel.NamedChannel
9885import Data.Channel.AnonymousChannel
99−import Data.Maybe (fromMaybe, catMaybes, isJust)
86+import Data.Maybe (fromMaybe)
10087import Squeal.PostgreSQL.Render
10188import Data.GroupChat
10289import Data.Message
@@ -108,8 +95,7 @@ import Data.Foldable (fold)
10895import Data.Char
10996import qualified Data.Vector as V
11097import Server.Auth.Token
111−import Server.Error
112−import Data.Text.Validator
98+import Data.Int
11399
114100-- MARK: Documentation
115101
@@ -206,8 +192,7 @@ getUsersQ uIds = case idsToColumn uIds of
206192 #faculties ! #facultyPath `as` #userRowFacultyPath :*
207193 #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
208194 #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
209− #faculties ! #facultyTags `as` #userRowFacultyTags :*
210− #faculties ! #facultyAddress `as` #userRowFacultyAddress
195+ #faculties ! #facultyTags `as` #userRowFacultyTags
211196 ) (from (subquery (idQ `As` #ids) &
212197 innerJoin (table #users)
213198 (#ids ! #id .== #users ! #userRowId) &
@@ -230,8 +215,7 @@ getAllUsersQ = select (
230215 #faculties ! #facultyPath `as` #userRowFacultyPath :*
231216 #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
232217 #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
233− #faculties ! #facultyTags `as` #userRowFacultyTags :*
234− #faculties ! #facultyAddress `as` #userRowFacultyAddress
218+ #faculties ! #facultyTags `as` #userRowFacultyTags
235219 ) (from ((table #users) &
236220 innerJoin (table #faculties)
237221 (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&
@@ -297,40 +281,12 @@ getChannelForUserQ = selectStar $
297281 from (table #channels) &
298282 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
299283
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−
312284getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
313285getAllChannelsForUserQ = selectStar $
314286 from (table #channels) &
315287 where_ (#namedChannelFullOwner .== param @1) &
316288 orderBy [#namedChannelFullId & Desc]
317289
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−
334290updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
335291updateFacultyQ = insertRow #faculties
336292 (
@@ -339,8 +295,7 @@ updateFacultyQ = insertRow #faculties
339295 Set (param @3) `as` #facultyPath :*
340296 Set (param @4) `as` #facultyCampusName :*
341297 Set (param @5) `as` #facultyCampusCode :*
342− Set (param @6) `as` #facultyTags :*
343− Set (param @7) `as` #facultyAddress
298+ Set (param @6) `as` #facultyTags
344299 )
345300 (OnConflictDoNothing)
346301 (Returning Nil)
@@ -361,11 +316,6 @@ createNamedChannelQ = insertRow #channels
361316 OnConflictDoRaise
362317 (Returning $ #namedChannelFullId `as` #fromOnly)
363318
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−
369319deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
370320deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
371321
@@ -398,7 +348,7 @@ getChannelPostsQ lim dir uIds tags = getLastPostsQ
398348 Just uIdsQ -> (`in_` uIdsQ)
399349 Nothing -> const $ false
400350
401−getTagsQ :: Query Schema params (RowPG (Only String))
351+getTagsQ :: Query Schema '[] (RowPG (Only String))
402352getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
403353 from (table #posts)
404354
@@ -409,26 +359,15 @@ createMessageQ :: Manipulation
409359createMessageQ = insertRow #messages
410360 (
411361 Default `as` #messageStorageId :*
412− Set (notNull $ param @1) `as` #messageStorageAuthorId :*
362+ Set (param @1) `as` #messageStorageAuthorId :*
413363 Set (param @2) `as` #messageStorageDestinationGroupId :*
414364 Set (param @3) `as` #messageStorageDestinationUserId :*
415− Set (notNull $ param @4) `as` #messageStorageBody :*
365+ Set (param @4) `as` #messageStorageBody :*
416366 Set currentTimestamp `as` #messageStorageTime
417367 )
418368 OnConflictDoRaise
419369 (Returning $ #messageStorageId `as` #fromOnly)
420370
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−
432371createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
433372createGroupChatQ = insertRow #groupChats
434373 (
@@ -504,7 +443,7 @@ getChatsQ lim dir = select (
504443 (ifThenElse
505444 (#messageStorageAuthorId .== param @1)
506445 #messageStorageDestinationUserId
507− #messageStorageAuthorId) `as` #messageUserId) $
446+ (notNull #messageStorageAuthorId)) `as` #messageUserId) $
508447 from (table #messages) &
509448 where_ (isNotNull #messageStorageDestinationUserId .&&
510449 (#messageStorageAuthorId .== param @1 .||
@@ -571,83 +510,21 @@ getGroupChatForUserQ = selectStar $
571510getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
572511getFacultySearchResultQ = selectStar (from (table #faculties) &
573512 where_ (vector @@ query) &
574− orderBy [
575− tsRankCd vector1 query & Desc,
576− tsRankCd vector2 query & Desc,
577− tsRankCd vector query & Desc
578− ])
513+ orderBy [tsRankCd vector query & Desc])
579514 where
580515 vector = tsVector "russian" (textArrayToText [
581516 #facultyName,
582517 #facultyPath,
583518 #facultyCampusName,
584519 (arrayToText #facultyTags)])
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
520+ query = tsQuery (param @1)
644521
645522tsRankCd
646523 :: Expression schema from grouping params ('NotNull 'PGtext)
647524 -> Expression schema from grouping params ('NotNull 'PGtext)
648525 -> Expression schema from grouping params ('NotNull 'PGfloat4)
649526tsRankCd vector query = UnsafeExpression $
650− "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])
527+ "ts_rank_cd" <> parenthesized (commaSeparated . map renderExpression $ [vector, query])
651528
652529tsVector
653530 :: ByteString -- ^ Language
@@ -656,24 +533,10 @@ tsVector
656533tsVector lang x = UnsafeExpression $
657534 "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
658535
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−
665536tsQuery
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'
673537 :: Expression schema from grouping params ('NotNull 'PGtext)
674538 -> Expression schema from grouping params ('NotNull 'PGtext)
675−tsQuery' x = UnsafeExpression $
676− "to_tsquery" <> parenthesized (renderExpression x)
539+tsQuery = unsafeFunction "to_tsquery"
677540
678541arrayToText
679542 :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
@@ -719,10 +582,7 @@ createTokenQ = insertRow_ #tokens (
719582 Set (param @2) `as` #tokenValue :*
720583 Set (param @3) `as` #tokenExpiryDate :*
721584 Set (param @4) `as` #tokenVerificationCode :*
722− Set (param @5) `as` #tokenActivationTriesLeft :*
723− Set (param @6) `as` #tokenUserAgent :*
724− Set (param @7) `as` #tokenActivationCode :*
725− Set (param @8) `as` #tokenDeactivationCode
585+ Set (param @5) `as` #tokenActivationTriesLeft
726586 )
727587
728588updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
@@ -731,10 +591,7 @@ updateTokenQ = update_ #tokens (
731591 Same `as` #tokenValue :*
732592 Set (param @3) `as` #tokenExpiryDate :*
733593 Set (param @4) `as` #tokenVerificationCode :*
734− Set (param @5) `as` #tokenActivationTriesLeft :*
735− Set (param @6) `as` #tokenUserAgent :*
736− Set (param @7) `as` #tokenActivationCode :*
737− Set (param @8) `as` #tokenDeactivationCode)
594+ Set (param @5) `as` #tokenActivationTriesLeft)
738595 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
739596
740597deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
@@ -757,47 +614,14 @@ getTokenQ = selectStar (from (table #tokens) &
757614 where_ (#tokenUserId .== param @1 .&&
758615 #tokenValue .== param @2))
759616
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−
771617getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
772618getVerifiedTokenQ = selectStar (from (table #tokens) &
773619 where_ (#tokenUserId .== param @1 .&&
774620 #tokenValue .== param @2 .&&
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))
621+ isNull #tokenVerificationCode))
790622
791623-- MARK: FrontEnd Data Structures
792624
793−instance HasValidatableText UserCreation where
794− validateText UserCreation{..} = all validateText [
795− userCreationFirstName,
796− userCreationMiddleName,
797− userCreationLastName,
798− userCreationUserFaculty,
799− userCreationUserEmail]
800−
801625data UserCreation = UserCreation {
802626 userCreationFirstName :: Text,
803627 userCreationMiddleName :: Text,
@@ -816,18 +640,9 @@ instance ToJSON UserCreation where
816640 ]
817641
818642instance FromJSON UserCreation where
819− parseJSON = withObject "user creation" $ \e ->
643+ parseJSON = withObject "named channel" $ \e ->
820644 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
821645
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−
831646data NamedChannelCreation = NamedChannelCreation {
832647 namedChannelCreationOwner :: UserId,
833648 namedChannelCreationName :: Text,
@@ -863,13 +678,11 @@ getChannelForUser uId cId = do
863678 Nothing -> lift $ S.throwError S.err404
864679
865680-- TODO: Reject bad requests. Should be binary.
866−verifyUsers :: [UserId] -> StaticPQ ()
867−verifyUsers uIds =
681+verifiedUsers :: [UserId] -> StaticPQ [UserId]
682+verifiedUsers uIds =
868683 case verifiedUserIdsQ uIds of
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 ()
684+ Just uIdsQ -> fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
685+ Nothing -> return []
873686
874687deleteGroupChat :: GroupChatId -> StaticPQ ()
875688deleteGroupChat gId = do
@@ -931,40 +744,30 @@ getAllUsers :: StaticPQ [User Faculty]
931744getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
932745
933746publishPost :: UserId -> PostCreation -> StaticPQ PostId
934−publishPost uId pc = commitedTransactionallyUpdate $ do
747+publishPost uId pc = commitedTransactionallyUpdate $ do
935748 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
936749 case pId' of
937750 (Just (Only pId)) -> do
938− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
751+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)
939752 return pId
940753 _ -> lift $ S.throwError S.err404
941754
942755createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
943756createNewChannel uId req = commitedTransactionallyUpdate $ do
944− let uIds = toList $ namedChannelCreationRequestPeopleIds req
945− verifyUsers uIds
757+ uIds <- verifiedUsers . toList $ namedChannelCreationRequestPeopleIds req
946758 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
947759 return $ fmap fromOnly cId
948760
949−channelCountForUser :: UserId -> StaticPQ Int64
950−channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
951−
952761updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
953−updateChannel uId req = do
954− let uIds = namedChannelPeopleIds req
955− verifyUsers (toList uIds)
762+updateChannel uId req = commitedTransactionallyUpdate $ do
763+ uIds <- fmap fromList . verifiedUsers . toList $ namedChannelPeopleIds req
956764 _ <- getChannelForUser uId $ namedChannelId req
957− _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
765+ _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
958766 return ()
959767
960768getFaculty :: Text -> StaticPQ Faculty
961769getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
962770
963−isValidFaculty :: FacultyUrl -> StaticPQ Bool
964−isValidFaculty url = do
965− (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
966− return $ isJust faculty
967−
968771updateFaculty :: Faculty -> StaticPQ ()
969772updateFaculty fac = void $ manipulateParams updateFacultyQ fac
970773
@@ -1001,13 +804,13 @@ getAllChannels uId = fmap (map removeUserFromChannel) $
1001804 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
1002805
1003806deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
1004−deleteNamedChannel uId cId = do
807+deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do
1005808 _ <- getChannelForUser uId cId
1006− _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
809+ _ <- manipulateParams deleteNamedChannelQ (Only cId)
1007810 return ()
1008811
1009−getTags :: Limit -> StaticPQ [String]
1010−getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
812+getTags :: StaticPQ [String]
813+getTags = map fromOnly <$> (runQuery getTagsQ >>= getRows)
1011814
1012815getDialogs
1013816 :: UserId
@@ -1040,40 +843,36 @@ getMessagesInGroupChat
1040843getMessagesInGroupChat selfId gId mId lim dir = do
1041844 _ <- getGroupChatForUser selfId gId
1042845 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
1043− return . catMaybes . map restoreMessage $ resp
846+ (return . sequence . map restoreMessage $ resp) >>= fromMaybe500
1044847
1045848sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
1046−sendMessage selfId (MessageCreation (Just gId) uId@Nothing (Jsonb body)) = do
849+sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
1047850 _ <- getGroupChatForUser selfId gId
1048− (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, Jsonb $ stripPostElement body)
851+ (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, body)
1049852 >>= firstRow >>= fromMaybe500
1050853 return mId
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)
854+sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do
855+ (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, body)
1054856 >>= firstRow >>= fromMaybe500
1055857 return mId
1056858sendMessage _ _ = lift $ S.throwError S.err400
1057859
1058860createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
1059861createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
1060− verifyUsers . M.keys $ chatUsers
1061− commitedTransactionallyUpdate $ do
1062− let chatUsers' = M.insert uId maxChatPermissions chatUsers
1063− (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)
1064− >>= firstRow >>= fromMaybe500
1065− _ <- manipulateParams createPhantomMessageQ (Only chatId)
1066− return chatId
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
1067868
1068869updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
1069−updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
1070− verifyUsers . M.keys $ perms
1071− commitedTransactionallyUpdate $ do
1072− (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId
1073− let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'
1074− unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401
1075− let newPerms = M.insert uId userPerm perms
1076− void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
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)
1077876
1078877leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
1079878leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
@@ -1090,60 +889,30 @@ getGroupChatForUser uId gId = do
1090889 (Just c) -> return c
1091890 Nothing -> lift $ S.throwError S.err404
1092891
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−
1098892getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
1099893getFacultyFromQuery query =
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)
894+ runQueryParams getFacultySearchResultQ (Only . queryFromText $ query) >>= getRows
1114895
1115896createToken :: Token -> StaticPQ ()
1116897createToken token = void $ manipulateParams createTokenQ token
1117898
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
1130899
1131900-- NOTE: Not transactional
1132901validateToken :: Token -> StaticPQ ()
1133902validateToken token = do
1134− void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing, tokenActivationCode = Nothing}
903+ void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing}
1135904 void $ manipulateParams validateUserQ $ Only $ tokenUserId token
1136905
1137906invalidateToken :: UserId -> ByteString -> StaticPQ ()
1138907invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
1139908
1140−tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)
909+tryVerifyToken :: UserId -> ByteString -> Int32 -> StaticPQ (Maybe Token)
1141910tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
1142− token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow
911+ token' <- runQueryParams getTokenQ (uId, tokenData) >>= firstRow
1143912 case token' of
1144913 Nothing -> return Nothing
1145914 Just token -> do
1146− if (tokenVerificationCode token == Just (hashVerificationCode code))
915+ if (tokenVerificationCode token == Just code)
1147916 then validateToken token >> (return $ Just token)
1148917 else do
1149918 let triesLeft = tokenActivationTriesLeft token - 1
@@ -1154,37 +923,11 @@ tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
1154923 _ <- manipulateParams updateTokenQ newToken
1155924 return Nothing
1156925
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−
1171926getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
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)
927+getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, tokenData) >>= firstRow
1176928
1177929-- MARK: Utils
1178930
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−
1188931data UserRow = UserRow {
1189932 userRowId :: UserId,
1190933 userRowFirstName :: Text,
@@ -1198,8 +941,7 @@ data UserRow = UserRow {
1198941 userRowFacultyPath :: T.Text,
1199942 userRowFacultyCampusName :: T.Text,
1200943 userRowFacultyCampusCode :: T.Text,
1201− userRowFacultyTags :: V.Vector T.Text,
1202− userRowFacultyAddress :: T.Text
944+ userRowFacultyTags :: V.Vector T.Text
1203945} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
1204946
1205947rowToUser :: UserRow -> User Faculty
@@ -1214,27 +956,13 @@ rowToUser UserRow{..} = User {
1214956 facultyPath = userRowFacultyPath,
1215957 facultyCampusName = userRowFacultyCampusName,
1216958 facultyCampusCode = userRowFacultyCampusCode,
1217− facultyTags = userRowFacultyTags,
1218− facultyAddress = userRowFacultyAddress
959+ facultyTags = userRowFacultyTags
1219960 },
1220961 userEmail = userRowEmail
1221962 }
1222963
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−
1233964queryFromText :: 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 <> ":*"
965+queryFromText = T.unwords . L.intersperse "&" . map (`T.append` ":*") . filter (not . T.null) . T.split (not . isAlphaNum)
1238966
1239967directionToOperator
1240968 :: P.PaginationDirection