git.iko.soy/denis
on master help sign in
Added docs (?)
727d9caiko
denis/package.yaml+1
compare with master
unifiedsplit
@@ -67,6 +67,7 @@ dependencies:
67- generic-arbitrary
67- generic-arbitrary
68- quickcheck-instances
68- quickcheck-instances
69- http-client
69- http-client
70+- blaze-markup
70
71
71library:
72library:
72 source-dirs: src
73 source-dirs: src
denis/sql/indexes.sqldeleted−5
@@ -1,5 +0,0 @@
1−CREATE OR REPLACE FUNCTION my_array_to_text(text[])
2− RETURNS text LANGUAGE sql IMMUTABLE AS $$SELECT array_to_string($1, ' ')$$;
3−
4−CREATE INDEX "faculty_text" ON "faculties" USING GIN (to_tsvector('russian', "facultyName" || ' ' || "facultyPath" || ' ' || "facultyCampusName" || ' ' || my_array_to_text("facultyTags")))
5−
denis/src/Data/Channel/AnonymousChannel.hs+4−3
@@ -8,9 +8,7 @@
8 OverloadedStrings,
8 OverloadedStrings,
9 RecordWildCards #-}
9 RecordWildCards #-}
10
10
11−module Data.Channel.AnonymousChannel (
11+module Data.Channel.AnonymousChannel where
12− AnonymousChannel(..)
13−) where
14
12
15import qualified Generics.SOP as SOP
13import qualified Generics.SOP as SOP
16import qualified GHC.Generics as GHC
14import qualified GHC.Generics as GHC
@@ -34,8 +32,11 @@ instance HasValidatableText AnonymousChannel where
34
32
35-- MARK: Implementation
33-- MARK: Implementation
36
34
35+-- |Анонимные канал -- канал, который не хрнится на сервере.
37data AnonymousChannel = AnonymousChannel {
36data AnonymousChannel = AnonymousChannel {
37+ -- |Список тегов в канале
38 anonymousChannelTags :: V.Vector Text,
38 anonymousChannelTags :: V.Vector Text,
39+ -- |Список людей в анонимном канале
39 anonymousChannelPeopleIds :: [UserId]
40 anonymousChannelPeopleIds :: [UserId]
40} deriving GHC.Generic
41} deriving GHC.Generic
41
42
denis/src/Data/Channel/NamedChannel.hs+11−5
@@ -8,11 +8,7 @@ TypeOperators,
8OverloadedStrings,
8OverloadedStrings,
9RecordWildCards #-}
9RecordWildCards #-}
10
10
11−module Data.Channel.NamedChannel (
11+module Data.Channel.NamedChannel where
12− NamedChannelId,
13− NamedChannel(..),
14− NamedChannelCreationRequest(..)
15−) where
16
12
17import Data.Int (Int64)
13import Data.Int (Int64)
18import qualified Generics.SOP as SOP
14import qualified Generics.SOP as SOP
@@ -44,13 +40,19 @@ instance HasValidatableText (NamedChannelCreationRequest) where
44
40
45-- MARK: Implementation
41-- MARK: Implementation
46
42
43+-- |Тип -- идентификатор именнованного канала.
47type NamedChannelId = Int64
44type NamedChannelId = Int64
48
45
49-- Note: Channel owner only exists in sql
46-- Note: Channel owner only exists in sql
47+-- |Структура данных именованного канала.
50data NamedChannel u = NamedChannel {
48data NamedChannel u = NamedChannel {
49+ -- |Идентификатор именованного канала.
51 namedChannelId :: NamedChannelId,
50 namedChannelId :: NamedChannelId,
51+ -- |Имя именнованного канала.
52 namedChannelName :: Text,
52 namedChannelName :: Text,
53+ -- |Список тегов в именованном канале.
53 namedChannelTags :: V.Vector Text,
54 namedChannelTags :: V.Vector Text,
55+ -- |Список идентификаторов пользователей в именованном канале.
54 namedChannelPeopleIds :: V.Vector u
56 namedChannelPeopleIds :: V.Vector u
55} deriving GHC.Generic
57} deriving GHC.Generic
56
58
@@ -70,9 +72,13 @@ instance (FromJSON u, Ord u) => FromJSON (NamedChannel u) where
70
72
71-- MARK: NamedChannelCreationRequest
73-- MARK: NamedChannelCreationRequest
72
74
75+-- |Объект-запрос на создание именованного канала.
73data NamedChannelCreationRequest = NamedChannelCreationRequest {
76data NamedChannelCreationRequest = NamedChannelCreationRequest {
77+ -- |Название канала.
74 namedChannelCreationRequestName :: Text,
78 namedChannelCreationRequestName :: Text,
79+ -- |Список тегов в канале.
75 namedChannelCreationRequestTags :: V.Vector Text,
80 namedChannelCreationRequestTags :: V.Vector Text,
81+ -- |Список идентификаторов пользователей в канале.
76 namedChannelCreationRequestPeopleIds :: V.Vector UserId
82 namedChannelCreationRequestPeopleIds :: V.Vector UserId
77} deriving GHC.Generic
83} deriving GHC.Generic
78
84
denis/src/Data/Connection.hs+11−12
@@ -7,18 +7,7 @@
7 TypeOperators,
7 TypeOperators,
8 FlexibleContexts #-}
8 FlexibleContexts #-}
9
9
10−module Data.Connection (
10+module Data.Connection where
11− Connection,
12− StaticPQ,
13− runQ,
14− runQ',
15− runQnotFound,
16− runQerror,
17− maybeNotFound,
18− maybeInvalidToken,
19− commitedTransactionallyUpdate,
20− runQsilent
21−) where
22
11
23import Squeal.PostgreSQL
12import Squeal.PostgreSQL
24import Squeal.PostgreSQL.Pool
13import Squeal.PostgreSQL.Pool
@@ -30,39 +19,49 @@ import Servant.Server
30import Server.Error
19import Server.Error
31import Control.Monad.Trans.Control
20import Control.Monad.Trans.Control
32
21
22+-- |Монада для совершения запросов и манимпуляций с базой данных в рамках сервера.
33type StaticPQ = PoolPQ Schema Handler
23type StaticPQ = PoolPQ Schema Handler
34
24
25+-- |Функция, печатающая текст красным цветом в консоль.
35printRed :: (Show a) => a -> IO ()
26printRed :: (Show a) => a -> IO ()
36printRed a = do
27printRed a = do
37 putStr "\a\x001b[31m"
28 putStr "\a\x001b[31m"
38 print a
29 print a
39 putStr "\x001b[0m"
30 putStr "\x001b[0m"
40
31
32+-- |Функция, выполняющая запрос к бае данных.
41runQ :: ServantErr -> StaticPQ a -> App a
33runQ :: ServantErr -> StaticPQ a -> App a
42runQ err req = handleSqueal ((>> throwError err) . liftIO . printRed) $ asks getPool >>= lift . runPoolPQ req
34runQ err req = handleSqueal ((>> throwError err) . liftIO . printRed) $ asks getPool >>= lift . runPoolPQ req
43
35
36+-- |Функция, выполняющая запрос к бае данных.
44runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a
37runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a
45runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn
38runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn
46
39
40+-- |Функция, выполняющая запрос к бае данных.
47runQnotFound :: StaticPQ a -> App a
41runQnotFound :: StaticPQ a -> App a
48runQnotFound = runQ err404
42runQnotFound = runQ err404
49
43
44+-- |Функция, выполняющая запрос к бае данных.
50runQerror :: StaticPQ a -> App a
45runQerror :: StaticPQ a -> App a
51runQerror = runQ err500
46runQerror = runQ err500
52
47
48+-- |Функция, выполняющая запрос к бае данных.
53runQsilent :: StaticPQ a -> App ()
49runQsilent :: StaticPQ a -> App ()
54runQsilent req = handleSqueal (liftIO . print) $ asks getPool >>= lift . runPoolPQ req
50runQsilent req = handleSqueal (liftIO . print) $ asks getPool >>= lift . runPoolPQ req
55 >> return ()
51 >> return ()
56
52
53+-- |Функция, выкидывающая исключение при отсутсвии значения.
57maybeNotFound :: App (Maybe a) -> App a
54maybeNotFound :: App (Maybe a) -> App a
58maybeNotFound = (>>= (\t -> case t of
55maybeNotFound = (>>= (\t -> case t of
59 Just y -> return y
56 Just y -> return y
60 Nothing -> throwError err404))
57 Nothing -> throwError err404))
61
58
59+-- |Функция, выкидывающая исключение при отсутсвии значения.
62maybeInvalidToken :: App (Maybe a) -> App a
60maybeInvalidToken :: App (Maybe a) -> App a
63maybeInvalidToken = (>>= (\t -> case t of
61maybeInvalidToken = (>>= (\t -> case t of
64 Just y -> return y
62 Just y -> return y
65 Nothing -> throwError invalidToken))
63 Nothing -> throwError invalidToken))
66
64
65+-- |Функция, совершающая операцию внутри транакции базы данных.
67commitedTransactionallyUpdate :: (MonadBaseControl IO tx, MonadPQ schema tx) => tx x -> tx x
66commitedTransactionallyUpdate :: (MonadBaseControl IO tx, MonadPQ schema tx) => tx x -> tx x
68commitedTransactionallyUpdate = transactionally $ TransactionMode ReadCommitted ReadWrite NotDeferrable
67commitedTransactionallyUpdate = transactionally $ TransactionMode ReadCommitted ReadWrite NotDeferrable
denis/src/Data/CyclicBuffer.hs+6−5
@@ -1,18 +1,19 @@
1{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
1{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
2
2
3−module Data.CyclicBuffer (
3+module Data.CyclicBuffer where
4− CyclicBuffer(elems),
5− mkCyclicBuffer,
6− insertIntoCyclicBuffer
7−) where
8
4
5+-- |Объект циклического буфера
9data CyclicBuffer a = CyclicBuffer {
6data CyclicBuffer a = CyclicBuffer {
7+ -- |Элементы в циклическом буфере
10 elems :: [a],
8 elems :: [a],
9+ -- |Количество элементов в циклическом буфере
11 limit :: Int
10 limit :: Int
12}
11}
13
12
13+-- |Функция, создающая циклический буфер с данным размером
14mkCyclicBuffer :: Int -> CyclicBuffer a
14mkCyclicBuffer :: Int -> CyclicBuffer a
15mkCyclicBuffer lim = CyclicBuffer [] lim
15mkCyclicBuffer lim = CyclicBuffer [] lim
16
16
17+-- |Функция, добавлющая эоемент в циклический буфер
17insertIntoCyclicBuffer :: CyclicBuffer a -> a -> CyclicBuffer a
18insertIntoCyclicBuffer :: CyclicBuffer a -> a -> CyclicBuffer a
18insertIntoCyclicBuffer (CyclicBuffer els lim) el = CyclicBuffer (take lim $ el:els) lim
19insertIntoCyclicBuffer (CyclicBuffer els lim) el = CyclicBuffer (take lim $ el:els) lim
denis/src/Data/Faculty.hs+10−4
@@ -8,10 +8,7 @@
8 OverloadedStrings,
8 OverloadedStrings,
9 DeriveAnyClass #-}
9 DeriveAnyClass #-}
10
10
11−module Data.Faculty (
11+module Data.Faculty where
12− Faculty(..),
13− FacultyUrl
14− ) where
15
12
16import qualified Generics.SOP as SOP
13import qualified Generics.SOP as SOP
17import qualified GHC.Generics as GHC
14import qualified GHC.Generics as GHC
@@ -24,15 +21,24 @@ instance ToSample Faculty where
24 toSamples _ = singleSample $ Faculty "ПИ" "cs.hse.ru/bse" "ФКН -> ПИ" "Москва" "193729"
21 toSamples _ = singleSample $ Faculty "ПИ" "cs.hse.ru/bse" "ФКН -> ПИ" "Москва" "193729"
25 (V.fromList ["Программирование", "Естсественные науки"]) "Настоящий адрес факультета"
22 (V.fromList ["Программирование", "Естсественные науки"]) "Настоящий адрес факультета"
26
23
24+-- |Адрес сайта департамента
27type FacultyUrl = T.Text
25type FacultyUrl = T.Text
28
26
27+-- |Объект департамента
29data Faculty = Faculty {
28data Faculty = Faculty {
29+ -- |Название департамента
30 facultyName :: T.Text,
30 facultyName :: T.Text,
31+ -- |Адрес сайта департамента
31 facultyUrl :: FacultyUrl,
32 facultyUrl :: FacultyUrl,
33+ -- |Вспомогательный текст дапартамента с сайта
32 facultyPath :: T.Text,
34 facultyPath :: T.Text,
35+ -- |Название кампуса
33 facultyCampusName :: T.Text,
36 facultyCampusName :: T.Text,
37+ -- |Код кампуса департамента
34 facultyCampusCode :: T.Text,
38 facultyCampusCode :: T.Text,
39+ -- |Теги департамента
35 facultyTags :: V.Vector T.Text,
40 facultyTags :: V.Vector T.Text,
41+ -- |Адрес департамента
36 facultyAddress :: T.Text
42 facultyAddress :: T.Text
37} deriving (GHC.Generic, Show, SOP.Generic, SOP.HasDatatypeInfo)
43} deriving (GHC.Generic, Show, SOP.Generic, SOP.HasDatatypeInfo)
38
44
denis/src/Data/Faculty/Parser.hs+9−4
@@ -2,9 +2,7 @@
2 OverloadedStrings,
2 OverloadedStrings,
3 TupleSections #-}
3 TupleSections #-}
4
4
5−module Data.Faculty.Parser (
5+module Data.Faculty.Parser where
6− getFaculties
7− ) where
8
6
9import Network.HTTP.Req
7import Network.HTTP.Req
10import qualified Data.Text as T
8import qualified Data.Text as T
@@ -18,17 +16,20 @@ import Control.Monad.IO.Class
18import Data.Default
16import Data.Default
19import qualified Data.Vector as V
17import qualified Data.Vector as V
20
18
19+-- |Функция, возвращающая список факультетов с сайта ВШЭ.
21getFaculties :: MonadIO m => m [Faculty]
20getFaculties :: MonadIO m => m [Faculty]
22getFaculties = runReq def $ do
21getFaculties = runReq def $ do
23 campuses <- getCampuses
22 campuses <- getCampuses
24 concat <$> mapM (\c -> getFacultiesForCampus c) campuses
23 concat <$> mapM (\c -> getFacultiesForCampus c) campuses
25
24
25+-- |Функция для отправки HTTP запроса.
26sendReq
26sendReq
27 :: MonadHttp f
27 :: MonadHttp f
28 => Url scheme
28 => Url scheme
29 -> f LT.Text
29 -> f LT.Text
30sendReq url = decodeUtf8 . responseBody <$> req GET url NoReqBody lbsResponse mempty
30sendReq url = decodeUtf8 . responseBody <$> req GET url NoReqBody lbsResponse mempty
31
31
32+-- |Функция, возвращающая список кампусов с сайта ВШЭ.
32getCampuses :: Req [Campus]
33getCampuses :: Req [Campus]
33getCampuses = do
34getCampuses = do
34 let url = https "www.hse.ru" /: "org" /: "units"
35 let url = https "www.hse.ru" /: "org" /: "units"
@@ -45,7 +46,7 @@ getCampuses = do
45 code <- HM.lookup "hse-value" hm
46 code <- HM.lookup "hse-value" hm
46 return $ Campus (T.strip name) code
47 return $ Campus (T.strip name) code
47
48
48−
49+-- |Функция, возвращающая список подразделений для данного кампуса.
49getFacultiesForCampus :: Campus -> Req [Faculty]
50getFacultiesForCampus :: Campus -> Req [Faculty]
50getFacultiesForCampus (Campus cName cCode) = do
51getFacultiesForCampus (Campus cName cCode) = do
51 let url = https "www.hse.ru" /: "org" /: "units" /: "campus" /: cCode
52 let url = https "www.hse.ru" /: "org" /: "units" /: "campus" /: cCode
@@ -67,18 +68,22 @@ getFacultiesForCampus (Campus cName cCode) = do
67 let address = T.unwords . map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "link link_dark i") $ els
68 let address = T.unwords . map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "link link_dark i") $ els
68 return $ Faculty name url path cName cCode (V.fromList tags) address
69 return $ Faculty name url path cName cCode (V.fromList tags) address
69
70
71+-- |Функция, проверяющая, имеет ли данный HTML тег атрибут принадлежности к данному классу.
70classIs :: T.Text -> Element -> Bool
72classIs :: T.Text -> Element -> Bool
71classIs c = (== (Just c)) . HM.lookup "class" . eltAttrs
73classIs c = (== (Just c)) . HM.lookup "class" . eltAttrs
72
74
75+-- |Фозвращает список всех подэлементов данного HTML тега при поиске в глубину.
73elements :: [Node] -> [Element]
76elements :: [Node] -> [Element]
74elements ((NodeElement el):nn) = el : ((elements . eltChildren) el ++ elements nn)
77elements ((NodeElement el):nn) = el : ((elements . eltChildren) el ++ elements nn)
75elements _ = []
78elements _ = []
76
79
80+-- |Функция, возвращающая список всего текстового содержания HTML тегов.
77texts' :: HM.HashMap T.Text T.Text -> [Node] -> [(HM.HashMap T.Text T.Text, T.Text)]
81texts' :: HM.HashMap T.Text T.Text -> [Node] -> [(HM.HashMap T.Text T.Text, T.Text)]
78texts' hm (NodeContent t: nn) = (hm, t) : texts' hm nn
82texts' hm (NodeContent t: nn) = (hm, t) : texts' hm nn
79texts' hm ((NodeElement el):nn) = ((texts' (HM.union (eltAttrs el) hm) (eltChildren el)) ++ texts' hm nn)
83texts' hm ((NodeElement el):nn) = ((texts' (HM.union (eltAttrs el) hm) (eltChildren el)) ++ texts' hm nn)
80texts' _ _ = []
84texts' _ _ = []
81
85
86+-- |Объкт кампуса.
82data Campus = Campus {
87data Campus = Campus {
83 campusName :: T.Text,
88 campusName :: T.Text,
84 campusCode :: T.Text
89 campusCode :: T.Text
denis/src/Data/GroupChat.hs+12−9
@@ -12,15 +12,7 @@
12{-# OPTIONS_GHC -Wno-orphans #-}
12{-# OPTIONS_GHC -Wno-orphans #-}
13
13
14
14
15−module Data.GroupChat (
15+module Data.GroupChat where
16− GroupChat(..),
17− GroupChatPermissions(..),
18− GroupChatId,
19− UserPermissions,
20− GroupChatCreation(..),
21− maxChatPermissions,
22− minChatPermissions
23− ) where
24
16
25import Data.Aeson
17import Data.Aeson
26import Data.Int (Int64)
18import Data.Int (Int64)
@@ -56,12 +48,18 @@ instance HasValidatableText GroupChatCreation where
56instance ToSample UserPermissions where
48instance ToSample UserPermissions where
57 toSamples _ = singleSample $ M.fromList [(69, GroupChatPermissions True), (5051, GroupChatPermissions False)]
49 toSamples _ = singleSample $ M.fromList [(69, GroupChatPermissions True), (5051, GroupChatPermissions False)]
58
50
51+-- |Идентификатор групповой беседы.
59type GroupChatId = Int64
52type GroupChatId = Int64
53+-- |Права участников групповой беседы.
60type UserPermissions = M.Map UserId GroupChatPermissions
54type UserPermissions = M.Map UserId GroupChatPermissions
61
55
56+-- |Объект групповой беседы.
62data GroupChat = GroupChat {
57data GroupChat = GroupChat {
58+ -- |Идентификатор групповой беседы.
63 groupChatId :: GroupChatId,
59 groupChatId :: GroupChatId,
60+ -- |Права участников беседы.
64 groupChatUsers :: Jsonb UserPermissions,
61 groupChatUsers :: Jsonb UserPermissions,
62+ -- |Имя групповой беседы.
65 groupChatName :: Text
63 groupChatName :: Text
66} deriving (Show, GHC.Generic)
64} deriving (Show, GHC.Generic)
67
65
@@ -78,14 +76,18 @@ instance FromJSON GroupChat where
78 parseJSON = withObject "group chat" $ \e ->
76 parseJSON = withObject "group chat" $ \e ->
79 GroupChat <$> e .: "id" <*> (Jsonb <$> e .: "users") <*> e .: "name"
77 GroupChat <$> e .: "id" <*> (Jsonb <$> e .: "users") <*> e .: "name"
80
78
79+-- |Права участника беседы
81data GroupChatPermissions = GroupChatPermissions {
80data GroupChatPermissions = GroupChatPermissions {
82 -- canInvite :: Bool,
81 -- canInvite :: Bool,
83 -- canKick :: Bool,
82 -- canKick :: Bool,
83+ -- |Является ли данный участник администратором
84 isAdmin :: Bool
84 isAdmin :: Bool
85} deriving (Show, GHC.Generic)
85} deriving (Show, GHC.Generic)
86
86
87+-- |Максимально возможные права в групповой беседе.
87maxChatPermissions :: GroupChatPermissions
88maxChatPermissions :: GroupChatPermissions
88maxChatPermissions = GroupChatPermissions True -- True True
89maxChatPermissions = GroupChatPermissions True -- True True
90+-- |Минимально возможные права в групповой беседе.
89minChatPermissions :: GroupChatPermissions
91minChatPermissions :: GroupChatPermissions
90minChatPermissions = GroupChatPermissions False
92minChatPermissions = GroupChatPermissions False
91
93
@@ -100,6 +102,7 @@ instance SOP.HasDatatypeInfo GroupChatPermissions
100instance ToJSON GroupChatPermissions
102instance ToJSON GroupChatPermissions
101instance FromJSON GroupChatPermissions
103instance FromJSON GroupChatPermissions
102
104
105+-- |Объект для создания групповой беседы
103data GroupChatCreation = GroupChatCreation {
106data GroupChatCreation = GroupChatCreation {
104 groupChatCreationUsers :: Jsonb UserPermissions,
107 groupChatCreationUsers :: Jsonb UserPermissions,
105 groupChatCreationName :: Text
108 groupChatCreationName :: Text
denis/src/Data/Limits.hs+9−3
@@ -4,32 +4,38 @@ module Data.Limits where
4
4
5import Data.Int (Int64)
5import Data.Int (Int64)
6
6
7+-- |Максимально возможное количество количество символов в нвазвании канала.
7maxChannelName :: Int
8maxChannelName :: Int
8maxChannelName = 60
9maxChannelName = 60
9
10
11+-- |Максимально возможное количество количество символов в нвазвании групповой беседы.
10maxGroupChatName :: Int
12maxGroupChatName :: Int
11maxGroupChatName = 60
13maxGroupChatName = 60
12
14
13−maxMessageLimitName :: Int
15+-- |Максимальное количество элементов в элементе поста
14−maxMessageLimitName = 60
15−
16postElementLengthLimit :: Int
16postElementLengthLimit :: Int
17postElementLengthLimit = 35000
17postElementLengthLimit = 35000
18
18
19+-- |Максимальное число символов в поле пользователя
19userFieldLengthLimit :: Int
20userFieldLengthLimit :: Int
20userFieldLengthLimit = 50
21userFieldLengthLimit = 50
21
22
23+-- |максимальное число тегов
22maxNumberOfTags :: Int
24maxNumberOfTags :: Int
23maxNumberOfTags = 20
25maxNumberOfTags = 20
24
26
27+-- |максимальное число именнованных каналов у пользователя
25channelCountLimit :: Int64
28channelCountLimit :: Int64
26channelCountLimit = 128
29channelCountLimit = 128
27
30
31+-- |Максимальное число элементов, возвращаемых в списке запроса
28listLimit :: Int
32listLimit :: Int
29listLimit = 100
33listLimit = 100
30
34
35+-- |глобальное ограничение на количество символов в пользовательском тексте.
31globalTextLimit :: Int
36globalTextLimit :: Int
32globalTextLimit = 50000
37globalTextLimit = 50000
33
38
39+-- |Максимальное число пользователей в групповой беседе
34groupChatSizeLimit :: Int
40groupChatSizeLimit :: Int
35groupChatSizeLimit = 256
41groupChatSizeLimit = 256
denis/src/Data/Message.hs+29−11
@@ -11,15 +11,7 @@
11{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
11{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
12
12
13
13
14−module Data.Message (
14+module Data.Message where
15− MessageStorage(..),
16− Message(..),
17− MessageDetination(..),
18− MessageId,
19− restoreMessage,
20− storeMessage,
21− MessageCreation(..)
22− ) where
23
15
24import Data.Aeson
16import Data.Aeson
25import Data.PostElement
17import Data.PostElement
@@ -51,18 +43,31 @@ instance HasValidatableText Message where
51instance HasValidatableText MessageCreation where
43instance HasValidatableText MessageCreation where
52 validateText (MessageCreation _ _ (Jsonb mb)) = validateText mb
44 validateText (MessageCreation _ _ (Jsonb mb)) = validateText mb
53
45
46+-- |Идентификатор сообщения в групповой беседе.
54type GroupChatMessageId = Int64
47type GroupChatMessageId = Int64
55
48
49+-- |Адресат сообщения.
50+data MessageDetination
51+ -- |Групповая беседа.
56−data MessageDetination = GroupChatDestination GroupChatId | UserChatDestination UserId
52+ = GroupChatDestination GroupChatId
53+ -- |Пользоваель.
54+ | UserChatDestination UserId
57 deriving (Show)
55 deriving (Show)
58
56
57+-- |Идентификатор сообщения
59type MessageId = Int64
58type MessageId = Int64
60
59
60+-- |Объект обычного представления сообщения.
61data Message = Message {
61data Message = Message {
62+ -- |Идентификатор сообщения.
62 messageId :: MessageId,
63 messageId :: MessageId,
64+ -- |Идентификатор автора сообщения.
63 messageAuthorId :: UserId,
65 messageAuthorId :: UserId,
66+ -- |Адресат сообщения.
64 messageDestinationId :: MessageDetination,
67 messageDestinationId :: MessageDetination,
68+ -- |Содержание сообщения.
65 messageBody :: PostElement Message,
69 messageBody :: PostElement Message,
70+ -- |Время отправки сообщения.
66 messageTime :: UTCTime
71 messageTime :: UTCTime
67} deriving (Show)
72} deriving (Show)
68
73
@@ -86,13 +91,19 @@ instance FromJSON Message where
86 <*> e .: "body"
91 <*> e .: "body"
87 <*> e .: "time"
92 <*> e .: "time"
88
93
89−
94+-- |Объект для представления сообщения в базе данных.
90data MessageStorage = MessageStorage {
95data MessageStorage = MessageStorage {
96+ -- |Идентификатор сообщения.
91 messageStorageId :: MessageId,
97 messageStorageId :: MessageId,
98+ -- |Идентификатор автора сообщения.
92 messageStorageAuthorId :: Maybe UserId,
99 messageStorageAuthorId :: Maybe UserId,
100+ -- |Идентификатор групповой беседы как адресата сообщения.
93 messageStorageDestinationGroupId :: Maybe GroupChatId,
101 messageStorageDestinationGroupId :: Maybe GroupChatId,
102+ -- |Идентификатор пользователя как адресата сообщения.
94 messageStorageDestinationUserId :: Maybe UserId,
103 messageStorageDestinationUserId :: Maybe UserId,
104+ -- |Содержание сообщения.
95 messageStorageBody :: Maybe (Jsonb (PostElement Message)),
105 messageStorageBody :: Maybe (Jsonb (PostElement Message)),
106+ -- |Время отправки сообщения.
96 messageStorageTime :: UTCTime
107 messageStorageTime :: UTCTime
97} deriving GHC.Generic
108} deriving GHC.Generic
98
109
@@ -101,9 +112,11 @@ instance SOP.HasDatatypeInfo (MessageStorage)
101
112
102infixl 4 <>>
113infixl 4 <>>
103
114
115+-- |Оператор, применяющий функция в функторе к объекту вне функтора.
104(<>>) :: Applicative f => f (a -> b) -> a -> f b
116(<>>) :: Applicative f => f (a -> b) -> a -> f b
105f <>> a = f <*> pure a
117f <>> a = f <*> pure a
106
118
119+-- |Функция, переводящая представление сообщения из базы данных в обычное.
107restoreMessage :: MessageStorage -> Maybe Message
120restoreMessage :: MessageStorage -> Maybe Message
108restoreMessage (MessageStorage mId (Just aId) gId uId (Just (Jsonb pb)) mt) =
121restoreMessage (MessageStorage mId (Just aId) gId uId (Just (Jsonb pb)) mt) =
109 Message mId aId <$> case (gId, uId) of
122 Message mId aId <$> case (gId, uId) of
@@ -113,6 +126,7 @@ restoreMessage (MessageStorage mId (Just aId) gId uId (Just (Jsonb pb)) mt) =
113 <>> pb <>> mt
126 <>> pb <>> mt
114restoreMessage _ = Nothing
127restoreMessage _ = Nothing
115
128
129+-- |Функция переводящая обычное представление сообщения в представление для базы данных.
116storeMessage :: Message -> MessageStorage
130storeMessage :: Message -> MessageStorage
117storeMessage (Message mId aId dId pb mt) = case dId of
131storeMessage (Message mId aId dId pb mt) = case dId of
118 GroupChatDestination gId -> MessageStorage mId (Just aId) (Just gId) Nothing (Just (Jsonb pb)) mt
132 GroupChatDestination gId -> MessageStorage mId (Just aId) (Just gId) Nothing (Just (Jsonb pb)) mt
@@ -124,9 +138,13 @@ instance ToSample MessageCreation where
124 (MessageCreation (Just 5) Nothing <$>
138 (MessageCreation (Just 5) Nothing <$>
125 map (Jsonb . snd) (toSamples Proxy))
139 map (Jsonb . snd) (toSamples Proxy))
126
140
141+-- |Объект для создания сообщения.
127data MessageCreation = MessageCreation {
142data MessageCreation = MessageCreation {
143+ -- |Идентификатор групповой беседы - адресата сообщения.
128 messageCreationDestinationGroupId :: Maybe GroupChatId,
144 messageCreationDestinationGroupId :: Maybe GroupChatId,
145+ -- |Идентификатор пользователя - адресата сообщения.
129 messageCreationDestinationUserId :: Maybe UserId,
146 messageCreationDestinationUserId :: Maybe UserId,
147+ -- |Содержание сообщения.
130 messageCreationBody :: Jsonb (PostElement (MessageCreation))
148 messageCreationBody :: Jsonb (PostElement (MessageCreation))
131} deriving (Show, GHC.Generic)
149} deriving (Show, GHC.Generic)
132
150
denis/src/Data/Post.hs+25−10
@@ -7,15 +7,7 @@
7 TypeOperators,
7 TypeOperators,
8 OverloadedStrings #-}
8 OverloadedStrings #-}
9
9
10−module Data.Post (
10+module Data.Post where
11− Post(..),
12− PostElement,
13− rowsToPost,
14− PostId,
15− QuoteId,
16− PostRowResponse(..),
17− PostCreation(..)
18−) where
19
11
20import Data.Int (Int64)
12import Data.Int (Int64)
21import qualified Generics.SOP as SOP
13import qualified Generics.SOP as SOP
@@ -46,14 +38,22 @@ instance HasValidatableText PostCreation where
46
38
47-- MARK: Actual type
39-- MARK: Actual type
48
40
41+-- |Идентификатор поста.
49type PostId = Int64
42type PostId = Int64
43+-- |Идентификатор цитаты.
50type QuoteId = Int64
44type QuoteId = Int64
51
45
46+-- |Объект поста
52data Post = Post {
47data Post = Post {
48+ -- |Идентификатор поста.
53 postId :: Int64,
49 postId :: Int64,
50+ -- |Идентификатор автора поста.
54 postAuthorId :: Int64,
51 postAuthorId :: Int64,
52+ -- |Время последнего обновления поста.
55 updated :: UTCTime,
53 updated :: UTCTime,
54+ -- |Теги поста.
56 postTags :: V.Vector Text,
55 postTags :: V.Vector Text,
56+ -- |Содержание поста.
57 postBody :: [PostElement Post]
57 postBody :: [PostElement Post]
58} deriving (Show)
58} deriving (Show)
59
59
@@ -65,8 +65,11 @@ instance ToJSON Post where
65 "tags" .= tags,
65 "tags" .= tags,
66 "body" .= pb ]
66 "body" .= pb ]
67
67
68+-- |Объект для создания поста
68data PostCreation = PostCreation {
69data PostCreation = PostCreation {
70+ -- |Содержание поста.
69 postCreationBody :: [PostElement Post],
71 postCreationBody :: [PostElement Post],
72+ -- |Теги поста.
70 postCreationTags :: V.Vector Text
73 postCreationTags :: V.Vector Text
71} deriving GHC.Generic
74} deriving GHC.Generic
72
75
@@ -86,29 +89,41 @@ instance FromJSON PostCreation where
86-- MARK: Rows
89-- MARK: Rows
87
90
88-- Need to manually maintain. Future: https://github.com/morphismtech/squeal/issues/96
91-- Need to manually maintain. Future: https://github.com/morphismtech/squeal/issues/96
89−
92+-- |Объект поста при ответе с базы данных.
90data PostRowResponse = PostRowResponse {
93data PostRowResponse = PostRowResponse {
91 -- PostRow
94 -- PostRow
95+ -- |Идентификатор поста.
92 postRowId :: Int64,
96 postRowId :: Int64,
97+ -- |Идентификатор автора поста.
93 postRowAuthorId :: Int64,
98 postRowAuthorId :: Int64,
99+ -- |Время последнего обновления поста.
94 postRowUpdateTime :: UTCTime,
100 postRowUpdateTime :: UTCTime,
101+ -- |Теги поста.
95 postRowTags :: V.Vector Text,
102 postRowTags :: V.Vector Text,
96
103
97 -- ElementRow
104 -- ElementRow
105+ -- |Порядковый номер элемента поста.
98 rowElementOrd :: Int64,
106 rowElementOrd :: Int64,
107+ -- |Markdown элемент поста.
99 rowElementMarkdown :: Maybe Text,
108 rowElementMarkdown :: Maybe Text,
109+ -- |Latex элемент поста.
100 rowElementLatex :: Maybe Text,
110 rowElementLatex :: Maybe Text,
111+ -- |Изображение.
101 rowElementImage :: Maybe Text,
112 rowElementImage :: Maybe Text,
113+ -- |Цитата.
102 rowElementQuote :: Maybe Int64,
114 rowElementQuote :: Maybe Int64,
115+ -- |Файл.
103 rowElementAttachment :: Maybe Text
116 rowElementAttachment :: Maybe Text
104} deriving (GHC.Generic)
117} deriving (GHC.Generic)
105
118
106instance SOP.Generic PostRowResponse
119instance SOP.Generic PostRowResponse
107instance SOP.HasDatatypeInfo PostRowResponse
120instance SOP.HasDatatypeInfo PostRowResponse
108
121
122+-- |Функция, переводящая объект поста при ответе с базы данных в какой-то поста при помощи данного отображения.
109unRow :: MkElementRow x -> PostRowResponse -> x
123unRow :: MkElementRow x -> PostRowResponse -> x
110unRow f' (PostRowResponse _ _ _ _ _ a b c d e) = f' a b c d e
124unRow f' (PostRowResponse _ _ _ _ _ a b c d e) = f' a b c d e
111
125
126+-- |Функция, переводящая объект поста при ответе с базы данных в обычный объект поста.
112rowsToPost :: [PostRowResponse] -> Maybe Post
127rowsToPost :: [PostRowResponse] -> Maybe Post
113rowsToPost [] = Nothing
128rowsToPost [] = Nothing
114rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
129rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
denis/src/Data/PostElement.hs+32−22
@@ -9,15 +9,7 @@
9{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
9{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
10
10
11
11
12−module Data.PostElement (
12+module Data.PostElement where
13− elemenToRow,
14− rowsToElement,
15− MkElementRow,
16− PostElementRow(..),
17− PostElement(..),
18− elementsToRows,
19− PostQuote(..)
20−) where
21
13
22import Data.Int (Int64)
14import Data.Int (Int64)
23import qualified Generics.SOP as SOP
15import qualified Generics.SOP as SOP
@@ -47,10 +39,17 @@ instance HasValidatableText (PostElement p) where
47
39
48-- MARK: PostElement
40-- MARK: PostElement
49
41
42+-- |Обычный элемент поста.
50−data PostElement a = Markdown Text
43+data PostElement a
44+ -- |Markdown элемент поста.
45+ = Markdown Text
46+ -- |Latex элемент поста.
51 | Latex Text
47 | Latex Text
48+ -- |Изорбражение.
52 | Image Text
49 | Image Text
50+ -- |Цитата.
53 | Quote ()
51 | Quote ()
52+ -- |Документ.
54 | Attachment Text
53 | Attachment Text
55 deriving (Show, GHC.Generic)
54 deriving (Show, GHC.Generic)
56
55
@@ -72,8 +71,10 @@ instance FromJSON (PostElement t) where
72
71
73-- -- MARK: PostElementRows
72-- -- MARK: PostElementRows
74
73
74+-- |Тип отображения из элемента поста с базы данных в другой объект.
75type MkElementRow x = Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> x
75type MkElementRow x = Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> x
76
76
77+-- |Функция, переводящая обычный элемент поста в другой объект.
77elemenToRow :: MkElementRow x -> PostElement p -> x
78elemenToRow :: MkElementRow x -> PostElement p -> x
78elemenToRow f el = case el of
79elemenToRow f el = case el of
79 Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
80 Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
@@ -83,6 +84,7 @@ elemenToRow f el = case el of
83 Quote _ -> f Nothing Nothing Nothing Nothing Nothing
84 Quote _ -> f Nothing Nothing Nothing Nothing Nothing
84 Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
85 Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
85
86
87+-- |Отображение элемента поста с базы данных в обычный элемент поста.
86rowsToElement :: MkElementRow (Maybe (PostElement p))
88rowsToElement :: MkElementRow (Maybe (PostElement p))
87rowsToElement (Just m) Nothing Nothing Nothing Nothing = Just $ Markdown m
89rowsToElement (Just m) Nothing Nothing Nothing Nothing = Just $ Markdown m
88rowsToElement Nothing (Just l) Nothing Nothing Nothing = Just $ Latex l
90rowsToElement Nothing (Just l) Nothing Nothing Nothing = Just $ Latex l
@@ -92,37 +94,45 @@ rowsToElement Nothing Nothing (Just i) Nothing Nothing = Just $ Image i
92rowsToElement Nothing Nothing Nothing Nothing (Just a) = Just $ Attachment a
94rowsToElement Nothing Nothing Nothing Nothing (Just a) = Just $ Attachment a
93rowsToElement _ _ _ _ _ = Nothing
95rowsToElement _ _ _ _ _ = Nothing
94
96
97+-- |Объект поста с базы данных
95data PostElementRow a = PostElementRow {
98data PostElementRow a = PostElementRow {
99+ -- |Идентификатор элемента поста
96 rowElementId :: Int64,
100 rowElementId :: Int64,
101+ -- |Порядковый номер элемента поста.
97 rowElementOrd :: Int64,
102 rowElementOrd :: Int64,
103+ -- |Markdown элемент.
98 rowElementMarkdown :: Maybe Text,
104 rowElementMarkdown :: Maybe Text,
105+ -- |LaTeX элемент.
99 rowElementLatex :: Maybe Text,
106 rowElementLatex :: Maybe Text,
107+ -- |Изорбражение.
100 rowElementImage :: Maybe Text,
108 rowElementImage :: Maybe Text,
109+ -- |Цитата.
101 rowElementQuote :: Maybe Int64,
110 rowElementQuote :: Maybe Int64,
111+ -- |Приложение.
102 rowElementAttachment :: Maybe Text
112 rowElementAttachment :: Maybe Text
103} deriving (GHC.Generic)
113} deriving (GHC.Generic)
104
114
105instance SOP.Generic (PostElementRow a)
115instance SOP.Generic (PostElementRow a)
106instance SOP.HasDatatypeInfo (PostElementRow a)
116instance SOP.HasDatatypeInfo (PostElementRow a)
107
117
108−
118+-- |Функция, переводящая обычные элементы постоа в их представления для базы данных.
109elementsToRows :: Int64 -> [PostElement a] -> [PostElementRow a]
119elementsToRows :: Int64 -> [PostElement a] -> [PostElementRow a]
110elementsToRows pId els = map (\(el, f) -> elemenToRow f el) . zip els . map (PostElementRow pId) $ [0..]
120elementsToRows pId els = map (\(el, f) -> elemenToRow f el) . zip els . map (PostElementRow pId) $ [0..]
111
121
112
122
113-- -- MARK: Quote
123-- -- MARK: Quote
114
124
115−data PostQuote = PostQuote {
125+-- data PostQuote = PostQuote {
116− quoteId :: Int64,
126+-- quoteId :: Int64,
117− quoteBody :: [PostElement PostQuote],
127+-- quoteBody :: [PostElement PostQuote],
118− quotePostId :: Int64
128+-- quotePostId :: Int64
119−} deriving (Show, GHC.Generic)
129+-- } deriving (Show, GHC.Generic)
120−
130+
121−instance ToJSON PostQuote where
131+-- instance ToJSON PostQuote where
122− toJSON (PostQuote qId pb pId) = object [
132+-- toJSON (PostQuote qId pb pId) = object [
123− "id" .= qId,
133+-- "id" .= qId,
124− "postId" .= pId,
134+-- "postId" .= pId,
125− "quoteBody" .= pb ]
135+-- "quoteBody" .= pb ]
126
136
127
137
128-- -- MARK: PostQuoteRow
138-- -- MARK: PostQuoteRow
denis/src/Data/Query.hs+165−57
@@ -15,59 +15,7 @@
15{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
15{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
16
16
17
17
18−module Data.Query (
18+module Data.Query where
19− Schema,
20− createTables,
21− getPosts,
22− -- getUser,
23− getUsers,
24− getAllUsers,
25− getLastPosts,
26− getPostsForUser,
27− Limit,
28− publishPost,
29− getChannelPosts,
30− updateChannel,
31− createNewChannel,
32− getAllChannels,
33− getAnonymousChannelPosts,
34− deleteNamedChannel,
35− HasUsers(..),
36− wrapIntoUsers,
37− ResponseWithUsers(..),
38− getTags,
39− getDialogs,
40− getMessagesInUserChat,
41− getMessagesInGroupChat,
42− sendMessage,
43− createGroupChat,
44− updateGroupChat,
45− leaveGroupChat,
46− getGroupChatForUser,
47− getFaculty,
48− updateFaculty,
49− getFacultyFromQuery,
50− getUserWithEmail,
51− createToken,
52− validateToken,
53− invalidateToken,
54− tryVerifyToken,
55− getVerifiedToken,
56− 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
70− ) where
71
19
72import Squeal.PostgreSQL
20import Squeal.PostgreSQL
73import Data.User
21import Data.User
@@ -110,6 +58,9 @@ import qualified Data.Vector as V
110import Server.Auth.Token
58import Server.Auth.Token
111import Server.Error
59import Server.Error
112import Data.Text.Validator
60import Data.Text.Validator
61+import Control.Monad.Except
62+import Control.Monad.IO.Class
63+import Crypto.Hash.SHA512 (hash)
113
64
114-- MARK: Documentation
65-- MARK: Documentation
115
66
@@ -122,14 +73,17 @@ instance (ToSample r) => ToSample (ResponseWithUsers r) where
122type TableEndo schema params from grouping = TableExpression schema params from grouping ->
73type TableEndo schema params from grouping = TableExpression schema params from grouping ->
123 TableExpression schema params from grouping
74 TableExpression schema params from grouping
124
75
76+-- |Функция, возвращаяющая запрос на посты, прменяя к нему данный ндоморфизм.
125postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
77postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
126postsQ te = selectStar $ te (from $ table #posts)
78postsQ te = selectStar $ te (from $ table #posts)
127
79
80+-- |Функция, возвращающая посты
128postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped
81postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped
129postViewT te = from $ subquery (postsQ te `As` #posts) &
82postViewT te = from $ subquery (postsQ te `As` #posts) &
130 innerJoin (table #postElements)
83 innerJoin (table #postElements)
131 (#posts ! #postRowId .== #postElements ! #rowElementId)
84 (#posts ! #postRowId .== #postElements ! #rowElementId)
132
85
86+-- |Функция, возвращающая запрос на поста, примення два промежуточных эндоморфизма к таблице.
133getPostQ
87getPostQ
134 :: TableEndo Schema params _ 'Ungrouped
88 :: TableEndo Schema params _ 'Ungrouped
135 -- ^ PostRowResponse endo
89 -- ^ PostRowResponse endo
@@ -172,6 +126,7 @@ getPostQ oTe te = select (
172-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
126-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
173-- return $ M.lookup qId rows >>= rowsToQuote rows
127-- return $ M.lookup qId rows >>= rowsToQuote rows
174
128
129+-- |Запрос, возвращающий пользователя по адресу почты.
175getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))
130getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))
176getUserWithEmailQ = select (
131getUserWithEmailQ = select (
177 #userRowId `as` #userId :*
132 #userRowId `as` #userId :*
@@ -184,6 +139,7 @@ getUserWithEmailQ = select (
184 where_ (#userRowEmail .== param @1) &
139 where_ (#userRowEmail .== param @1) &
185 where_ (notNull #userRowIsValidated))
140 where_ (notNull #userRowIsValidated))
186
141
142+-- |Запрос, возвращающий подтвержденных пользователей.
187verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
143verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
188verifiedUserIdsQ uIds = case idsToColumn uIds of
144verifiedUserIdsQ uIds = case idsToColumn uIds of
189 Just idQ -> Just $ select (#users ! #userRowId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
145 Just idQ -> Just $ select (#users ! #userRowId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
@@ -191,6 +147,7 @@ verifiedUserIdsQ uIds = case idsToColumn uIds of
191 (#ids ! #id .== #users ! #userRowId))
147 (#ids ! #id .== #users ! #userRowId))
192 Nothing -> Nothing
148 Nothing -> Nothing
193
149
150+-- |Запрос, возвращающий пользователей с данными идентификаторами.
194getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))
151getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))
195getUsersQ uIds = case idsToColumn uIds of
152getUsersQ uIds = case idsToColumn uIds of
196 Just idQ -> Just $ select (
153 Just idQ -> Just $ select (
@@ -216,6 +173,7 @@ getUsersQ uIds = case idsToColumn uIds of
216 where_ (notNull $ #users ! #userRowIsValidated))
173 where_ (notNull $ #users ! #userRowIsValidated))
217 Nothing -> Nothing
174 Nothing -> Nothing
218
175
176+-- |Запорс, возвращающий всех пользователей.
219getAllUsersQ :: Query Schema '[] (RowPG UserRow)
177getAllUsersQ :: Query Schema '[] (RowPG UserRow)
220getAllUsersQ = select (
178getAllUsersQ = select (
221 #users ! #userRowId :*
179 #users ! #userRowId :*
@@ -237,6 +195,7 @@ getAllUsersQ = select (
237 (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&
195 (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&
238 where_ (notNull $ #users ! #userRowIsValidated))
196 where_ (notNull $ #users ! #userRowIsValidated))
239
197
198+-- |Запрос, возвращающий все посты по идентификатору.
240getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
199getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
241getPostsByIdQ pIds = case idsToColumn pIds of
200getPostsByIdQ pIds = case idsToColumn pIds of
242 Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
201 Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
@@ -245,14 +204,17 @@ getPostsByIdQ pIds = case idsToColumn pIds of
245 (#ids ! #id .== #posts ! #postRowId))
204 (#ids ! #id .== #posts ! #postRowId))
246 Nothing -> Nothing
205 Nothing -> Nothing
247
206
207+-- |Ограничение
248type Limit = Word64
208type Limit = Word64
249
209
210+-- |SQL оператор IS NOT FALSE
250isNotFalse
211isNotFalse
251 :: Expression schema from grouping params ('Null ty)
212 :: Expression schema from grouping params ('Null ty)
252 -- ^ possibly @NULL@
213 -- ^ possibly @NULL@
253 -> Condition schema from grouping params
214 -> Condition schema from grouping params
254isNotFalse x = UnsafeExpression $ renderExpression x <+> "IS NOT FALSE"
215isNotFalse x = UnsafeExpression $ renderExpression x <+> "IS NOT FALSE"
255
216
217+-- |Запрос, возвращающий последние посты.
256getLastPostsQ
218getLastPostsQ
257 :: TableEndo _ _ _ _
219 :: TableEndo _ _ _ _
258 -> Limit
220 -> Limit
@@ -267,12 +229,14 @@ getLastPostsQ te lim dir = getPostQ
267 where
229 where
268 ((.^), order) = directionToOperator dir
230 ((.^), order) = directionToOperator dir
269
231
232+-- |Запрос, возвращающий последние посты для данного пользователя.
270getLastNPostsForUserQ
233getLastNPostsForUserQ
271 :: Limit
234 :: Limit
272 -> P.PaginationDirection
235 -> P.PaginationDirection
273 -> Query Schema (TuplePG (Maybe PostId, UserId)) (RowPG PostRowResponse)
236 -> Query Schema (TuplePG (Maybe PostId, UserId)) (RowPG PostRowResponse)
274getLastNPostsForUserQ = getLastPostsQ $ where_ (#posts ! #postRowAuthorId .== param @2)
237getLastNPostsForUserQ = getLastPostsQ $ where_ (#posts ! #postRowAuthorId .== param @2)
275
238
239+-- |Запрос на создание поста.
276createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
240createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
277createPostRowQ = insertRow #posts
241createPostRowQ = insertRow #posts
278 (Default `as` #postRowId :*
242 (Default `as` #postRowId :*
@@ -282,6 +246,7 @@ createPostRowQ = insertRow #posts
282 OnConflictDoRaise
246 OnConflictDoRaise
283 (Returning $ #postRowId `as` #fromOnly)
247 (Returning $ #postRowId `as` #fromOnly)
284
248
249+-- |Запрос на создание элементов постов.
285createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
250createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
286createPostElementRowsQ = insertRow_ #postElements
251createPostElementRowsQ = insertRow_ #postElements
287 (Set (param @1) `as` #rowElementId :*
252 (Set (param @1) `as` #rowElementId :*
@@ -292,11 +257,13 @@ createPostElementRowsQ = insertRow_ #postElements
292 Set (param @6) `as` #rowElementQuote :*
257 Set (param @6) `as` #rowElementQuote :*
293 Set (param @7) `as` #rowElementAttachment)
258 Set (param @7) `as` #rowElementAttachment)
294
259
260+-- |Запрос, возвращающий канал для данного пользователя.
295getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
261getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
296getChannelForUserQ = selectStar $
262getChannelForUserQ = selectStar $
297 from (table #channels) &
263 from (table #channels) &
298 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
264 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
299
265
266+-- |Запрос, обновляющий данные о пользователе.
300updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))
267updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))
301updateUserQ = update #users (
268updateUserQ = update #users (
302 Same `as` #userRowId :*
269 Same `as` #userRowId :*
@@ -309,12 +276,14 @@ updateUserQ = update #users (
309 (#userRowId .== param @1)
276 (#userRowId .== param @1)
310 (Returning $ #userRowId `as` #fromOnly)
277 (Returning $ #userRowId `as` #fromOnly)
311
278
279+-- |Запрос, возвращающий каналы пользователя.
312getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
280getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
313getAllChannelsForUserQ = selectStar $
281getAllChannelsForUserQ = selectStar $
314 from (table #channels) &
282 from (table #channels) &
315 where_ (#namedChannelFullOwner .== param @1) &
283 where_ (#namedChannelFullOwner .== param @1) &
316 orderBy [#namedChannelFullId & Desc]
284 orderBy [#namedChannelFullId & Desc]
317
285
286+-- |Запрос, осуществляющий поиск по каналам данного пользователя.
318searchChannelsForUserQ :: Query Schema (TuplePG (UserId, Text)) (RowPG NamedChannelFull)
287searchChannelsForUserQ :: Query Schema (TuplePG (UserId, Text)) (RowPG NamedChannelFull)
319searchChannelsForUserQ = selectStar $
288searchChannelsForUserQ = selectStar $
320 from (table #channels) &
289 from (table #channels) &
@@ -331,6 +300,7 @@ searchChannelsForUserQ = selectStar $
331 vector1 = tsVector' #namedChannelFullName
300 vector1 = tsVector' #namedChannelFullName
332 query = tsQuery' (param @2)
301 query = tsQuery' (param @2)
333
302
303+-- |Запрос, обновляющий факультет.
334updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
304updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
335updateFacultyQ = insertRow #faculties
305updateFacultyQ = insertRow #faculties
336 (
306 (
@@ -345,10 +315,12 @@ updateFacultyQ = insertRow #faculties
345 (OnConflictDoNothing)
315 (OnConflictDoNothing)
346 (Returning Nil)
316 (Returning Nil)
347
317
318+-- |Запрос, возвращающий факультет.
348getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
319getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
349getFacultyQ = selectStar (from (table #faculties) &
320getFacultyQ = selectStar (from (table #faculties) &
350 where_ (#facultyUrl .== param @1))
321 where_ (#facultyUrl .== param @1))
351
322
323+-- |Запрос на создание нового именованного канала.
352createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
324createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
353createNamedChannelQ = insertRow #channels
325createNamedChannelQ = insertRow #channels
354 (
326 (
@@ -361,14 +333,17 @@ createNamedChannelQ = insertRow #channels
361 OnConflictDoRaise
333 OnConflictDoRaise
362 (Returning $ #namedChannelFullId `as` #fromOnly)
334 (Returning $ #namedChannelFullId `as` #fromOnly)
363
335
336+-- |Запрос, возвращающий количество каналов у данного пользователя.
364countChannelsQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only Int64))
337countChannelsQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only Int64))
365countChannelsQ = select (countStar `as` #fromOnly) (from (table #channels) &
338countChannelsQ = select (countStar `as` #fromOnly) (from (table #channels) &
366 where_ (#namedChannelFullOwner .== param @1) &
339 where_ (#namedChannelFullOwner .== param @1) &
367 groupBy #namedChannelFullOwner)
340 groupBy #namedChannelFullOwner)
368
341
342+-- |Запрос, удаляющий канал у данного пользователя.
369deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
343deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
370deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
344deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
371
345
346+-- |Запрос, обновляющий именованный канал.
372updateNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelFull) '[]
347updateNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelFull) '[]
373updateNamedChannelQ = update_ #channels
348updateNamedChannelQ = update_ #channels
374 (
349 (
@@ -380,6 +355,7 @@ updateNamedChannelQ = update_ #channels
380 )
355 )
381 (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)
356 (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)
382
357
358+-- |Запрос на каналы пользователя.
383getChannelPostsQ
359getChannelPostsQ
384 :: Limit
360 :: Limit
385 -> P.PaginationDirection
361 -> P.PaginationDirection
@@ -398,10 +374,12 @@ getChannelPostsQ lim dir uIds tags = getLastPostsQ
398 Just uIdsQ -> (`in_` uIdsQ)
374 Just uIdsQ -> (`in_` uIdsQ)
399 Nothing -> const $ false
375 Nothing -> const $ false
400
376
377+-- |Запрос на все хэштеги.
401getTagsQ :: Query Schema params (RowPG (Only String))
378getTagsQ :: Query Schema params (RowPG (Only String))
402getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
379getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
403 from (table #posts)
380 from (table #posts)
404
381
382+-- |Запорс на создание сообщения.
405createMessageQ :: Manipulation
383createMessageQ :: Manipulation
406 Schema
384 Schema
407 (TuplePG (UserId, Maybe GroupChatId, Maybe UserId, Jsonb (PostElement (MessageCreation))))
385 (TuplePG (UserId, Maybe GroupChatId, Maybe UserId, Jsonb (PostElement (MessageCreation))))
@@ -418,6 +396,7 @@ createMessageQ = insertRow #messages
418 OnConflictDoRaise
396 OnConflictDoRaise
419 (Returning $ #messageStorageId `as` #fromOnly)
397 (Returning $ #messageStorageId `as` #fromOnly)
420
398
399+-- |Запрос на создание фантомного сообщения.
421createPhantomMessageQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]
400createPhantomMessageQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]
422createPhantomMessageQ = insertRow_ #messages
401createPhantomMessageQ = insertRow_ #messages
423 (
402 (
@@ -429,6 +408,7 @@ createPhantomMessageQ = insertRow_ #messages
429 Set currentTimestamp `as` #messageStorageTime
408 Set currentTimestamp `as` #messageStorageTime
430 )
409 )
431
410
411+-- |Запрос на создание групповой беседы.
432createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
412createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
433createGroupChatQ = insertRow #groupChats
413createGroupChatQ = insertRow #groupChats
434 (
414 (
@@ -439,6 +419,7 @@ createGroupChatQ = insertRow #groupChats
439 OnConflictDoRaise
419 OnConflictDoRaise
440 (Returning $ #groupChatId `as` #fromOnly)
420 (Returning $ #groupChatId `as` #fromOnly)
441
421
422+-- |Запрос на обновление групповой беседы.
442updateGroupChatQ :: Manipulation Schema (TuplePG GroupChat) '[]
423updateGroupChatQ :: Manipulation Schema (TuplePG GroupChat) '[]
443updateGroupChatQ = update_ #groupChats
424updateGroupChatQ = update_ #groupChats
444 (
425 (
@@ -448,23 +429,27 @@ updateGroupChatQ = update_ #groupChats
448 )
429 )
449 (#groupChatId .== param @1)
430 (#groupChatId .== param @1)
450
431
432+-- |Тип строки, воозвращаемой в промежуточном запросе на все диалоги.
451type ChatsQueryResponse = '[
433type ChatsQueryResponse = '[
452 "messageId" ::: 'NotNull (PG UserId),
434 "messageId" ::: 'NotNull (PG UserId),
453 "messageGroupId" ::: 'Null (PG UserId),
435 "messageGroupId" ::: 'Null (PG UserId),
454 "messageUserId" ::: 'Null (PG UserId)
436 "messageUserId" ::: 'Null (PG UserId)
455 ]
437 ]
456
438
439+-- |Тип оператора сравнения.
457type ConditionOp schema from grouping params nullity0 nullity1 (ty :: PGType)
440type ConditionOp schema from grouping params nullity0 nullity1 (ty :: PGType)
458 = Expression schema from grouping params (nullity0 ty)
441 = Expression schema from grouping params (nullity0 ty)
459 -> Expression schema from grouping params (nullity1 ty)
442 -> Expression schema from grouping params (nullity1 ty)
460 -> Condition schema from grouping params
443 -> Condition schema from grouping params
461
444
445+-- |Тип параметров на запрос диалогов.
462type ChatQueryParams = TuplePG
446type ChatQueryParams = TuplePG
463 ( UserId
447 ( UserId
464 , Maybe String -- Just UserId as String
448 , Maybe String -- Just UserId as String
465 , Maybe MessageId
449 , Maybe MessageId
466 )
450 )
467
451
452+-- |Запрос на все диалоги.
468getChatsQ
453getChatsQ
469 :: Limit
454 :: Limit
470 -> P.PaginationDirection
455 -> P.PaginationDirection
@@ -525,6 +510,7 @@ getChatsQ lim dir = select (
525 where_ (isNotNull #messageStorageDestinationGroupId) &
510 where_ (isNotNull #messageStorageDestinationGroupId) &
526 groupBy #messageStorageDestinationGroupId
511 groupBy #messageStorageDestinationGroupId
527
512
513+-- |Запрос на сообщения.
528getMessagesQ
514getMessagesQ
529 :: Limit
515 :: Limit
530 -> P.PaginationDirection
516 -> P.PaginationDirection
@@ -544,6 +530,7 @@ getMessagesQ lim dir = selectStar (from (table #messages) &
544 where
530 where
545 ((.^), order) = directionToOperator dir
531 ((.^), order) = directionToOperator dir
546
532
533+-- |Запрос на сообщения в групповой беседе.
547getGroupMessagesQ
534getGroupMessagesQ
548 :: Limit
535 :: Limit
549 -> P.PaginationDirection
536 -> P.PaginationDirection
@@ -562,12 +549,14 @@ getGroupMessagesQ lim dir = selectStar (from (table #messages) &
562 ((.^), order) = directionToOperator dir
549 ((.^), order) = directionToOperator dir
563
550
564-- String -- user id as String
551-- String -- user id as String
552+-- |Запрос на групповую беседу для данного пользователя.
565getGroupChatForUserQ :: Query Schema (TuplePG (String, GroupChatId)) (RowPG GroupChat)
553getGroupChatForUserQ :: Query Schema (TuplePG (String, GroupChatId)) (RowPG GroupChat)
566getGroupChatForUserQ = selectStar $
554getGroupChatForUserQ = selectStar $
567 (from (table #groupChats)) &
555 (from (table #groupChats)) &
568 where_ (#groupChatId .== param @2) &
556 where_ (#groupChatId .== param @2) &
569 where_ (#groupChatUsers .? param @1)
557 where_ (#groupChatUsers .? param @1)
570
558
559+-- |Запрос на поиск факультета.
571getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
560getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
572getFacultySearchResultQ = selectStar (from (table #faculties) &
561getFacultySearchResultQ = selectStar (from (table #faculties) &
573 where_ (vector @@ query) &
562 where_ (vector @@ query) &
@@ -588,6 +577,7 @@ getFacultySearchResultQ = selectStar (from (table #faculties) &
588 #facultyPath])
577 #facultyPath])
589 query = tsQuery "russian" (param @1)
578 query = tsQuery "russian" (param @1)
590
579
580+-- |Запрос на поиск пользователя.
591searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
581searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
592searchUsersQ = select (
582searchUsersQ = select (
593 #users ! #userRowId :*
583 #users ! #userRowId :*
@@ -619,19 +609,21 @@ searchUsersQ = select (
619 ])
609 ])
620 query = tsQuery' (param @1)
610 query = tsQuery' (param @1)
621
611
612+-- |Запрос на теги по популярности.
622tagsByFrquencyQ :: Query Schema params '["tag" ::: 'NotNull (PG Text), "count" ::: 'NotNull 'PGint8]
613tagsByFrquencyQ :: Query Schema params '["tag" ::: 'NotNull (PG Text), "count" ::: 'NotNull 'PGint8]
623tagsByFrquencyQ = select
614tagsByFrquencyQ = select
624 (#fromOnly `as` #tag :* count #fromOnly `as` #count)
615 (#fromOnly `as` #tag :* count #fromOnly `as` #count)
625 (from (subquery $ getTagsQ `As` #tt) &
616 (from (subquery $ getTagsQ `As` #tt) &
626 groupBy #fromOnly)
617 groupBy #fromOnly)
627
618
619+-- |Запрос на данной количество самых популярных тегов.
628getNpopularTagsQ :: Limit -> Query Schema param (RowPG (Only Text))
620getNpopularTagsQ :: Limit -> Query Schema param (RowPG (Only Text))
629getNpopularTagsQ lim = select (#tag `as` #fromOnly)
621getNpopularTagsQ lim = select (#tag `as` #fromOnly)
630 (from (subquery $ tagsByFrquencyQ `As` #tt) &
622 (from (subquery $ tagsByFrquencyQ `As` #tt) &
631 orderBy [#count & Desc] &
623 orderBy [#count & Desc] &
632 limit lim)
624 limit lim)
633
625
634−
626+-- |Запрос на поиск по тегам.
635searchTagsQ :: Query Schema (TuplePG (Only Text)) (RowPG (Only Text))
627searchTagsQ :: Query Schema (TuplePG (Only Text)) (RowPG (Only Text))
636searchTagsQ = select (#tag `as` #fromOnly) $
628searchTagsQ = select (#tag `as` #fromOnly) $
637 from (subquery (tagsByFrquencyQ `As` #tt)) &
629 from (subquery (tagsByFrquencyQ `As` #tt)) &
@@ -642,6 +634,7 @@ searchTagsQ = select (#tag `as` #fromOnly) $
642 query = tsQuery' (param @1)
634 query = tsQuery' (param @1)
643 vector = tsVector' #tag
635 vector = tsVector' #tag
644
636
637+-- |PostgreSQL функция ts_rank_cd
645tsRankCd
638tsRankCd
646 :: Expression schema from grouping params ('NotNull 'PGtext)
639 :: Expression schema from grouping params ('NotNull 'PGtext)
647 -> Expression schema from grouping params ('NotNull 'PGtext)
640 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -649,6 +642,7 @@ tsRankCd
649tsRankCd vector query = UnsafeExpression $
642tsRankCd vector query = UnsafeExpression $
650 "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])
643 "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])
651
644
645+-- |PostgreSQL функция ts_vector
652tsVector
646tsVector
653 :: ByteString -- ^ Language
647 :: ByteString -- ^ Language
654 -> Expression schema from grouping params ('NotNull 'PGtext)
648 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -656,12 +650,14 @@ tsVector
656tsVector lang x = UnsafeExpression $
650tsVector lang x = UnsafeExpression $
657 "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
651 "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
658
652
653+-- |PostgreSQL функция ts_vector без языка.
659tsVector'
654tsVector'
660 :: Expression schema from grouping params ('NotNull 'PGtext)
655 :: Expression schema from grouping params ('NotNull 'PGtext)
661 -> Expression schema from grouping params ('NotNull 'PGtext)
656 -> Expression schema from grouping params ('NotNull 'PGtext)
662tsVector' x = UnsafeExpression $
657tsVector' x = UnsafeExpression $
663 "to_tsvector" <> parenthesized (renderExpression x)
658 "to_tsvector" <> parenthesized (renderExpression x)
664
659
660+-- |PostgreSQL функция ts_query.
665tsQuery
661tsQuery
666 :: ByteString -- ^ Language
662 :: ByteString -- ^ Language
667 -> Expression schema from grouping params ('NotNull 'PGtext)
663 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -669,32 +665,38 @@ tsQuery
669tsQuery lang x = UnsafeExpression $
665tsQuery lang x = UnsafeExpression $
670 "to_tsquery" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
666 "to_tsquery" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
671
667
668+-- |PostgreSQL функция ts_query без языка.
672tsQuery'
669tsQuery'
673 :: Expression schema from grouping params ('NotNull 'PGtext)
670 :: Expression schema from grouping params ('NotNull 'PGtext)
674 -> Expression schema from grouping params ('NotNull 'PGtext)
671 -> Expression schema from grouping params ('NotNull 'PGtext)
675tsQuery' x = UnsafeExpression $
672tsQuery' x = UnsafeExpression $
676 "to_tsquery" <> parenthesized (renderExpression x)
673 "to_tsquery" <> parenthesized (renderExpression x)
677
674
675+-- |PostgreSQL функция array_to_string
678arrayToText
676arrayToText
679 :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
677 :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
680 -> Expression schema from grouping params ('NotNull 'PGtext)
678 -> Expression schema from grouping params ('NotNull 'PGtext)
681arrayToText x = UnsafeExpression $
679arrayToText x = UnsafeExpression $
682 "array_to_string" <> parenthesized (commaSeparated [renderExpression x, "' '"])
680 "array_to_string" <> parenthesized (commaSeparated [renderExpression x, "' '"])
683
681
682+-- |PostgreSQL оператор @@
684(@@)
683(@@)
685 :: Expression schema from grouping params (nullity0 'PGtext)
684 :: Expression schema from grouping params (nullity0 'PGtext)
686 -> Expression schema from grouping params (nullity1 'PGtext)
685 -> Expression schema from grouping params (nullity1 'PGtext)
687 -> Expression schema from grouping params (nullity2 'PGbool)
686 -> Expression schema from grouping params (nullity2 'PGbool)
688(@@) = unsafeBinaryOp "@@"
687(@@) = unsafeBinaryOp "@@"
689
688
689+-- |Пробел.
690space :: Expression schema from grouping params ('NotNull 'PGtext)
690space :: Expression schema from grouping params ('NotNull 'PGtext)
691space = UnsafeExpression "' '"
691space = UnsafeExpression "' '"
692
692
693+-- |Функция, переводящая список варажений текста в одно выражение текста через пробел.
693textArrayToText
694textArrayToText
694 :: [Expression schema from grouping params ('NotNull 'PGtext)]
695 :: [Expression schema from grouping params ('NotNull 'PGtext)]
695 -> Expression schema from grouping params ('NotNull 'PGtext)
696 -> Expression schema from grouping params ('NotNull 'PGtext)
696textArrayToText = fold . L.intersperse space
697textArrayToText = fold . L.intersperse space
697
698
699+-- |Запрос, создающий пользователя.
698createUserQ :: Manipulation Schema (TuplePG UserCreation) (RowPG (Only UserId))
700createUserQ :: Manipulation Schema (TuplePG UserCreation) (RowPG (Only UserId))
699createUserQ = insertRow #users (
701createUserQ = insertRow #users (
700 Default `as` #userRowId :*
702 Default `as` #userRowId :*
@@ -707,12 +709,13 @@ createUserQ = insertRow #users (
707 OnConflictDoRaise
709 OnConflictDoRaise
708 (Returning (#userRowId `as` #fromOnly))
710 (Returning (#userRowId `as` #fromOnly))
709
711
712+-- |Запрос, удалющий пользователей, которые не подтвердили свой профиль.
710removeUnverifiedUserQ :: Manipulation Schema (TuplePG (Only UserEmail)) '[]
713removeUnverifiedUserQ :: Manipulation Schema (TuplePG (Only UserEmail)) '[]
711removeUnverifiedUserQ = deleteFrom_ #users
714removeUnverifiedUserQ = deleteFrom_ #users
712 (#userRowEmail .== param @1 .&&
715 (#userRowEmail .== param @1 .&&
713 (not_ . notNull $ #userRowIsValidated))
716 (not_ . notNull $ #userRowIsValidated))
714
717
715−
718+-- |Запрос, создающий токен.
716createTokenQ :: Manipulation Schema (TuplePG Token) '[]
719createTokenQ :: Manipulation Schema (TuplePG Token) '[]
717createTokenQ = insertRow_ #tokens (
720createTokenQ = insertRow_ #tokens (
718 Set (param @1) `as` #tokenUserId :*
721 Set (param @1) `as` #tokenUserId :*
@@ -725,6 +728,7 @@ createTokenQ = insertRow_ #tokens (
725 Set (param @8) `as` #tokenDeactivationCode
728 Set (param @8) `as` #tokenDeactivationCode
726 )
729 )
727
730
731+-- |Запрос, обновляющий токен.
728updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
732updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
729updateTokenQ = update_ #tokens (
733updateTokenQ = update_ #tokens (
730 Same `as` #tokenUserId :*
734 Same `as` #tokenUserId :*
@@ -737,10 +741,12 @@ updateTokenQ = update_ #tokens (
737 Set (param @8) `as` #tokenDeactivationCode)
741 Set (param @8) `as` #tokenDeactivationCode)
738 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
742 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
739
743
744+-- |Запрос, удалющий токен.
740deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
745deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
741deleteTokenQ = deleteFrom_ #tokens
746deleteTokenQ = deleteFrom_ #tokens
742 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
747 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
743
748
749+-- |Запрос, подтверждающий профиль пользователя.
744validateUserQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
750validateUserQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
745validateUserQ = update_ #users (
751validateUserQ = update_ #users (
746 Same `as` #userRowId :*
752 Same `as` #userRowId :*
@@ -752,22 +758,26 @@ validateUserQ = update_ #users (
752 Set true `as` #userRowIsValidated)
758 Set true `as` #userRowIsValidated)
753 (#userRowId .== param @1)
759 (#userRowId .== param @1)
754
760
761+-- |Запрос, возвращающий токен.
755getTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
762getTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
756getTokenQ = selectStar (from (table #tokens) &
763getTokenQ = selectStar (from (table #tokens) &
757 where_ (#tokenUserId .== param @1 .&&
764 where_ (#tokenUserId .== param @1 .&&
758 #tokenValue .== param @2))
765 #tokenValue .== param @2))
759
766
767+-- |Запрос, возвращающий токен по хэшу кода активации.
760getTokenActivationQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
768getTokenActivationQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
761getTokenActivationQ = selectStar (from (table #tokens) &
769getTokenActivationQ = selectStar (from (table #tokens) &
762 where_ (#tokenUserId .== param @1 .&&
770 where_ (#tokenUserId .== param @1 .&&
763 #tokenActivationCode .== param @2))
771 #tokenActivationCode .== param @2))
764
772
773+-- |Запрос, даективирующий токен.
765deactivateTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) (RowPG (Only Text))
774deactivateTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) (RowPG (Only Text))
766deactivateTokenQ = deleteFrom #tokens
775deactivateTokenQ = deleteFrom #tokens
767 (#tokenUserId .== param @1 .&&
776 (#tokenUserId .== param @1 .&&
768 #tokenDeactivationCode .== param @2)
777 #tokenDeactivationCode .== param @2)
769 (Returning (#tokenUserAgent `as` #fromOnly))
778 (Returning (#tokenUserAgent `as` #fromOnly))
770
779
780+-- |Запрос, возвращающий подтвержденный токен.
771getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
781getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
772getVerifiedTokenQ = selectStar (from (table #tokens) &
782getVerifiedTokenQ = selectStar (from (table #tokens) &
773 where_ (#tokenUserId .== param @1 .&&
783 where_ (#tokenUserId .== param @1 .&&
@@ -775,14 +785,17 @@ getVerifiedTokenQ = selectStar (from (table #tokens) &
775 isNull #tokenVerificationCode .&&
785 isNull #tokenVerificationCode .&&
776 currentTimestamp .< #tokenExpiryDate))
786 currentTimestamp .< #tokenExpiryDate))
777
787
788+-- |Запрос, даективирующий все токены для данного пользователя.
778killAllTokensQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
789killAllTokensQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
779killAllTokensQ = deleteFrom_ #tokens
790killAllTokensQ = deleteFrom_ #tokens
780 (#tokenUserId .== param @1)
791 (#tokenUserId .== param @1)
781
792
793+-- |Запрос, удаляющий недействительные токены.
782pruneDeadTokensQ :: Manipulation Schema '[] '[]
794pruneDeadTokensQ :: Manipulation Schema '[] '[]
783pruneDeadTokensQ = deleteFrom_ #tokens
795pruneDeadTokensQ = deleteFrom_ #tokens
784 (#tokenExpiryDate .< currentTimestamp)
796 (#tokenExpiryDate .< currentTimestamp)
785
797
798+-- |Запрос, удаляющий неактивированных пользователей.
786pruneGhostUsersQ :: Manipulation Schema '[] '[]
799pruneGhostUsersQ :: Manipulation Schema '[] '[]
787pruneGhostUsersQ = deleteFrom_ #users
800pruneGhostUsersQ = deleteFrom_ #users
788 ((not_ . in_ #userRowId $ select (#tokens ! #tokenUserId `as` #id) (from $ table #tokens)) .&&
801 ((not_ . in_ #userRowId $ select (#tokens ! #tokenUserId `as` #id) (from $ table #tokens)) .&&
@@ -798,11 +811,17 @@ instance HasValidatableText UserCreation where
798 userCreationUserFaculty,
811 userCreationUserFaculty,
799 userCreationUserEmail]
812 userCreationUserEmail]
800
813
814+-- |Объект для создания пользователя.
801data UserCreation = UserCreation {
815data UserCreation = UserCreation {
816+ -- |Имя.
802 userCreationFirstName :: Text,
817 userCreationFirstName :: Text,
818+ -- |Отчество.
803 userCreationMiddleName :: Text,
819 userCreationMiddleName :: Text,
820+ -- |Фамилия.
804 userCreationLastName :: Text,
821 userCreationLastName :: Text,
822+ -- |Факультет.
805 userCreationUserFaculty :: FacultyUrl,
823 userCreationUserFaculty :: FacultyUrl,
824+ -- |Адрес почты.
806 userCreationUserEmail :: Text
825 userCreationUserEmail :: Text
807} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
826} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
808
827
@@ -819,42 +838,62 @@ instance FromJSON UserCreation where
819 parseJSON = withObject "user creation" $ \e ->
838 parseJSON = withObject "user creation" $ \e ->
820 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
839 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
821
840
841+-- |Объект для обновления пользователя.
822data UserUpdateRow = UserUpdateRow {
842data UserUpdateRow = UserUpdateRow {
843+ -- |Идентификатор пользователя.
823 userUpdateRowId :: UserId,
844 userUpdateRowId :: UserId,
845+ -- |Имя.
824 userUpdateRowFirstName :: Text,
846 userUpdateRowFirstName :: Text,
847+ -- |Отчество.
825 userUpdateRowMiddleName :: Text,
848 userUpdateRowMiddleName :: Text,
849+ -- |Фамилия.
826 userUpdateRowLastName :: Text,
850 userUpdateRowLastName :: Text,
851+ -- |Факультет.
827 userUpdateRowUserFaculty :: FacultyUrl
852 userUpdateRowUserFaculty :: FacultyUrl
828} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
853} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
829
854
830−
855+-- |Объект для создания канала.
831data NamedChannelCreation = NamedChannelCreation {
856data NamedChannelCreation = NamedChannelCreation {
857+ -- |Владелец канала.
832 namedChannelCreationOwner :: UserId,
858 namedChannelCreationOwner :: UserId,
859+ -- |Название канала.
833 namedChannelCreationName :: Text,
860 namedChannelCreationName :: Text,
861+ -- |Теги в канале.
834 namedChannelCreationTags :: Vector Text,
862 namedChannelCreationTags :: Vector Text,
863+ -- |Люди в канале.
835 namedChannelCreationPeopleIds :: Vector UserId
864 namedChannelCreationPeopleIds :: Vector UserId
836} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
865} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
837
866
867+-- |Функция, добавлющая в структуру пользователя.
838addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
868addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
839addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
869addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
840
870
871+-- |Полный объект канала.
841data NamedChannelFull = NamedChannelFull {
872data NamedChannelFull = NamedChannelFull {
873+ -- |Идентификатор.
842 namedChannelFullId :: NamedChannelId,
874 namedChannelFullId :: NamedChannelId,
875+ -- |Владелец.
843 namedChannelFullOwner :: UserId,
876 namedChannelFullOwner :: UserId,
877+ -- |Название.
844 namedChannelFullName :: Text,
878 namedChannelFullName :: Text,
879+ -- |Теги.
845 namedChannelFullTags :: Vector Text,
880 namedChannelFullTags :: Vector Text,
881+ -- |пользователи.
846 namedChannelFullPeopleIds :: Vector UserId
882 namedChannelFullPeopleIds :: Vector UserId
847} deriving GHC.Generic
883} deriving GHC.Generic
848
884
849instance SOP.Generic NamedChannelFull
885instance SOP.Generic NamedChannelFull
850instance SOP.HasDatatypeInfo NamedChannelFull
886instance SOP.HasDatatypeInfo NamedChannelFull
851
887
888+-- |Добавляет в структуру пользователя.
852addUserToChannelUpdate :: UserId -> NamedChannel UserId -> NamedChannelFull
889addUserToChannelUpdate :: UserId -> NamedChannel UserId -> NamedChannelFull
853addUserToChannelUpdate uId (NamedChannel cId cName cTags cPeople) = NamedChannelFull cId uId cName cTags cPeople
890addUserToChannelUpdate uId (NamedChannel cId cName cTags cPeople) = NamedChannelFull cId uId cName cTags cPeople
854
891
892+-- |Убирает пользователя из структуры.
855removeUserFromChannel :: NamedChannelFull -> NamedChannel UserId
893removeUserFromChannel :: NamedChannelFull -> NamedChannel UserId
856removeUserFromChannel (NamedChannelFull cId _ cName cTags cPeople) = NamedChannel cId cName cTags cPeople
894removeUserFromChannel (NamedChannelFull cId _ cName cTags cPeople) = NamedChannel cId cName cTags cPeople
857
895
896+-- |Возвращаает канал для данного человека.
858getChannelForUser :: UserId -> NamedChannelId -> StaticPQ NamedChannelFull
897getChannelForUser :: UserId -> NamedChannelId -> StaticPQ NamedChannelFull
859getChannelForUser uId cId = do
898getChannelForUser uId cId = do
860 channel <- runQueryParams getChannelForUserQ (uId, cId) >>= firstRow
899 channel <- runQueryParams getChannelForUserQ (uId, cId) >>= firstRow
@@ -862,7 +901,7 @@ getChannelForUser uId cId = do
862 (Just c) -> return c
901 (Just c) -> return c
863 Nothing -> lift $ S.throwError S.err404
902 Nothing -> lift $ S.throwError S.err404
864
903
865−-- TODO: Reject bad requests. Should be binary.
904+-- |Проверяет, существует ли пользователь.
866verifyUsers :: [UserId] -> StaticPQ ()
905verifyUsers :: [UserId] -> StaticPQ ()
867verifyUsers uIds =
906verifyUsers uIds =
868 case verifiedUserIdsQ uIds of
907 case verifiedUserIdsQ uIds of
@@ -871,6 +910,7 @@ verifyUsers uIds =
871 when (length us /= length uIds) $ lift $ S.throwError impossibleContent
910 when (length us /= length uIds) $ lift $ S.throwError impossibleContent
872 Nothing -> return ()
911 Nothing -> return ()
873
912
913+-- |Удаляет групповую беседу.
874deleteGroupChat :: GroupChatId -> StaticPQ ()
914deleteGroupChat :: GroupChatId -> StaticPQ ()
875deleteGroupChat gId = do
915deleteGroupChat gId = do
876 _ <- manipulateParams deleteGroupChatQ (Only gId)
916 _ <- manipulateParams deleteGroupChatQ (Only gId)
@@ -885,6 +925,7 @@ deleteGroupChat gId = do
885 (#messageStorageDestinationGroupId .== param @1)
925 (#messageStorageDestinationGroupId .== param @1)
886
926
887-- NOTE: Not transactional
927-- NOTE: Not transactional
928+-- |Создает пользователя.
888createUser :: UserCreation -> StaticPQ UserId
929createUser :: UserCreation -> StaticPQ UserId
889createUser creation = do
930createUser creation = do
890 _ <- manipulateParams removeUnverifiedUserQ (Only $ userCreationUserEmail creation)
931 _ <- manipulateParams removeUnverifiedUserQ (Only $ userCreationUserEmail creation)
@@ -894,6 +935,7 @@ createUser creation = do
894-- MARK: FrontEnd functions
935-- MARK: FrontEnd functions
895
936
896-- Nothing <=> no user
937-- Nothing <=> no user
938+-- |Возвращаает посты от данного пользователя.
897getPostsForUser
939getPostsForUser
898 :: Maybe PostId
940 :: Maybe PostId
899 -> Limit
941 -> Limit
@@ -904,6 +946,7 @@ getPostsForUser pId lim dir uId = do
904 postRows <- runQueryParams (getLastNPostsForUserQ lim dir) (pId, uId) >>= getRows
946 postRows <- runQueryParams (getLastNPostsForUserQ lim dir) (pId, uId) >>= getRows
905 wrapIntoResponse (fromMaybe [] . rowsToPosts $ postRows)
947 wrapIntoResponse (fromMaybe [] . rowsToPosts $ postRows)
906
948
949+-- |Возвращаает посты по идентификатором.
907getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))
950getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))
908getPosts pId =
951getPosts pId =
909 case getPostsByIdQ pId of
952 case getPostsByIdQ pId of
@@ -912,6 +955,7 @@ getPosts pId =
912 rowsToPosts postRows `liftMaybe` wrapIntoResponse
955 rowsToPosts postRows `liftMaybe` wrapIntoResponse
913 Nothing -> return Nothing
956 Nothing -> return Nothing
914
957
958+-- |Возвращает последние посты.
915getLastPosts
959getLastPosts
916 :: Maybe PostId
960 :: Maybe PostId
917 -> Limit
961 -> Limit
@@ -921,15 +965,19 @@ getLastPosts pId lim dir = do
921 postRows <- runQueryParams (getLastPostsQ id lim dir) (Only pId) >>= getRows
965 postRows <- runQueryParams (getLastPostsQ id lim dir) (Only pId) >>= getRows
922 rowsToPosts postRows `liftMaybe` wrapIntoResponse
966 rowsToPosts postRows `liftMaybe` wrapIntoResponse
923
967
968+-- |Возвращает пользователя по адресу почты.
924getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))
969getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))
925getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow
970getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow
926
971
972+-- |возвращает пользователей по идентификаторам.
927getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])
973getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])
928getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))
974getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))
929
975
976+-- |Возвращает всех пользователей.
930getAllUsers :: StaticPQ [User Faculty]
977getAllUsers :: StaticPQ [User Faculty]
931getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
978getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
932
979
980+-- |Публичует пост.
933publishPost :: UserId -> PostCreation -> StaticPQ PostId
981publishPost :: UserId -> PostCreation -> StaticPQ PostId
934publishPost uId pc = commitedTransactionallyUpdate $ do
982publishPost uId pc = commitedTransactionallyUpdate $ do
935 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
983 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
@@ -939,6 +987,7 @@ publishPost uId pc = commitedTransactionallyUpdate $ do
939 return pId
987 return pId
940 _ -> lift $ S.throwError S.err404
988 _ -> lift $ S.throwError S.err404
941
989
990+-- |Создает канал.
942createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
991createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
943createNewChannel uId req = commitedTransactionallyUpdate $ do
992createNewChannel uId req = commitedTransactionallyUpdate $ do
944 let uIds = toList $ namedChannelCreationRequestPeopleIds req
993 let uIds = toList $ namedChannelCreationRequestPeopleIds req
@@ -946,9 +995,11 @@ createNewChannel uId req = commitedTransactionallyUpdate $ do
946 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
995 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
947 return $ fmap fromOnly cId
996 return $ fmap fromOnly cId
948
997
998+-- |Возвращает канал для данного пользователя.
949channelCountForUser :: UserId -> StaticPQ Int64
999channelCountForUser :: UserId -> StaticPQ Int64
950channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
1000channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
951
1001
1002+-- |Обновляет канал.
952updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
1003updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
953updateChannel uId req = do
1004updateChannel uId req = do
954 let uIds = namedChannelPeopleIds req
1005 let uIds = namedChannelPeopleIds req
@@ -957,17 +1008,21 @@ updateChannel uId req = do
957 _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
1008 _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
958 return ()
1009 return ()
959
1010
1011+-- |Возвращает факультет.
960getFaculty :: Text -> StaticPQ Faculty
1012getFaculty :: Text -> StaticPQ Faculty
961getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
1013getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
962
1014
1015+-- |Проверяет, является ли данный факультет валидным.
963isValidFaculty :: FacultyUrl -> StaticPQ Bool
1016isValidFaculty :: FacultyUrl -> StaticPQ Bool
964isValidFaculty url = do
1017isValidFaculty url = do
965 (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
1018 (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
966 return $ isJust faculty
1019 return $ isJust faculty
967
1020
1021+-- |Обновляет факультет.
968updateFaculty :: Faculty -> StaticPQ ()
1022updateFaculty :: Faculty -> StaticPQ ()
969updateFaculty fac = void $ manipulateParams updateFacultyQ fac
1023updateFaculty fac = void $ manipulateParams updateFacultyQ fac
970
1024
1025+-- |Возвращает посты в канале.
971getChannelPosts
1026getChannelPosts
972 :: UserId
1027 :: UserId
973 -> Maybe PostId
1028 -> Maybe PostId
@@ -986,6 +1041,7 @@ getChannelPosts uId pId lim dir cId = do
986 >>= getRows
1041 >>= getRows
987 fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
1042 fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
988
1043
1044+-- |Возвращает почты в анонимном кнаале.
989getAnonymousChannelPosts
1045getAnonymousChannelPosts
990 :: Maybe PostId
1046 :: Maybe PostId
991 -> Limit
1047 -> Limit
@@ -996,19 +1052,23 @@ getAnonymousChannelPosts pId lim dir (AnonymousChannel tags people) = do
996 postRows <- runQueryParams (getChannelPostsQ lim dir people tags) (Only pId) >>= getRows
1052 postRows <- runQueryParams (getChannelPostsQ lim dir people tags) (Only pId) >>= getRows
997 fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
1053 fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
998
1054
1055+-- |Возвращает все каналы.
999getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
1056getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
1000getAllChannels uId = fmap (map removeUserFromChannel) $
1057getAllChannels uId = fmap (map removeUserFromChannel) $
1001 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
1058 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
1002
1059
1060+-- |Удаляет именованный канал.
1003deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
1061deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
1004deleteNamedChannel uId cId = do
1062deleteNamedChannel uId cId = do
1005 _ <- getChannelForUser uId cId
1063 _ <- getChannelForUser uId cId
1006 _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
1064 _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
1007 return ()
1065 return ()
1008
1066
1067+-- |Возвращает теги.
1009getTags :: Limit -> StaticPQ [String]
1068getTags :: Limit -> StaticPQ [String]
1010getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
1069getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
1011
1070
1071+-- |Возвращает диалоги.
1012getDialogs
1072getDialogs
1013 :: UserId
1073 :: UserId
1014 -> Maybe MessageId
1074 -> Maybe MessageId
@@ -1019,6 +1079,7 @@ getDialogs uId mId lim dir = do
1019 resp <- runQueryParams (getChatsQ lim dir) (uId, Just $ show uId, mId) >>= getRows
1079 resp <- runQueryParams (getChatsQ lim dir) (uId, Just $ show uId, mId) >>= getRows
1020 (>>= fromMaybe500) $ (responseToDialogs uId resp `liftMaybe` wrapIntoResponse)
1080 (>>= fromMaybe500) $ (responseToDialogs uId resp `liftMaybe` wrapIntoResponse)
1021
1081
1082+-- |Возвращает сообщения в диалоге.
1022getMessagesInUserChat
1083getMessagesInUserChat
1023 :: UserId
1084 :: UserId
1024 -> UserId
1085 -> UserId
@@ -1030,6 +1091,7 @@ getMessagesInUserChat selfId uId mId lim dir = do
1030 resp <- runQueryParams (getMessagesQ lim dir) (selfId, uId, mId) >>= getRows
1091 resp <- runQueryParams (getMessagesQ lim dir) (selfId, uId, mId) >>= getRows
1031 fromMaybe500 . sequence . map restoreMessage $ resp
1092 fromMaybe500 . sequence . map restoreMessage $ resp
1032
1093
1094+-- |Возвращает сообщения в групповой беседе.
1033getMessagesInGroupChat
1095getMessagesInGroupChat
1034 :: UserId
1096 :: UserId
1035 -> GroupChatId
1097 -> GroupChatId
@@ -1042,6 +1104,7 @@ getMessagesInGroupChat selfId gId mId lim dir = do
1042 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
1104 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
1043 return . catMaybes . map restoreMessage $ resp
1105 return . catMaybes . map restoreMessage $ resp
1044
1106
1107+-- |Отправляет сообщение.
1045sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
1108sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
1046sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
1109sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
1047 _ <- getGroupChatForUser selfId gId
1110 _ <- getGroupChatForUser selfId gId
@@ -1055,6 +1118,7 @@ sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do
1055 return mId
1118 return mId
1056sendMessage _ _ = lift $ S.throwError S.err400
1119sendMessage _ _ = lift $ S.throwError S.err400
1057
1120
1121+-- |Создает групповую беседу.
1058createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
1122createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
1059createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
1123createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
1060 verifyUsers . M.keys $ chatUsers
1124 verifyUsers . M.keys $ chatUsers
@@ -1065,6 +1129,7 @@ createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
1065 _ <- manipulateParams createPhantomMessageQ (Only chatId)
1129 _ <- manipulateParams createPhantomMessageQ (Only chatId)
1066 return chatId
1130 return chatId
1067
1131
1132+-- |Обновляет групповую беседу.
1068updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
1133updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
1069updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
1134updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
1070 verifyUsers . M.keys $ perms
1135 verifyUsers . M.keys $ perms
@@ -1075,6 +1140,7 @@ updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
1075 let newPerms = M.insert uId userPerm perms
1140 let newPerms = M.insert uId userPerm perms
1076 void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
1141 void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
1077
1142
1143+-- |Удаляет пользователя из беседы.
1078leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
1144leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
1079leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
1145leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
1080 gChat@(GroupChat _ (Jsonb perms) _) <- getGroupChatForUser uId gId
1146 gChat@(GroupChat _ (Jsonb perms) _) <- getGroupChatForUser uId gId
@@ -1083,6 +1149,7 @@ leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
1083 then deleteGroupChat gId
1149 then deleteGroupChat gId
1084 else void $ manipulateParams updateGroupChatQ gChat{groupChatUsers = Jsonb newPerms}
1150 else void $ manipulateParams updateGroupChatQ gChat{groupChatUsers = Jsonb newPerms}
1085
1151
1152+-- |Возвращает беседу для пользователя.
1086getGroupChatForUser :: UserId -> GroupChatId -> StaticPQ GroupChat
1153getGroupChatForUser :: UserId -> GroupChatId -> StaticPQ GroupChat
1087getGroupChatForUser uId gId = do
1154getGroupChatForUser uId gId = do
1088 chat <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
1155 chat <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
@@ -1090,15 +1157,18 @@ getGroupChatForUser uId gId = do
1090 (Just c) -> return c
1157 (Just c) -> return c
1091 Nothing -> lift $ S.throwError S.err404
1158 Nothing -> lift $ S.throwError S.err404
1092
1159
1160+-- |Проверяет, является ли данная беседа валидной для данного пользователя.
1093groupChatIsValidForUser :: UserId -> GroupChatId -> StaticPQ Bool
1161groupChatIsValidForUser :: UserId -> GroupChatId -> StaticPQ Bool
1094groupChatIsValidForUser uId gId = do
1162groupChatIsValidForUser uId gId = do
1095 (chat :: Maybe GroupChat) <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
1163 (chat :: Maybe GroupChat) <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
1096 return $ isJust chat
1164 return $ isJust chat
1097
1165
1166+-- |Возвращает каналы по поисковой строке.
1098getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
1167getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
1099getFacultyFromQuery query =
1168getFacultyFromQuery query =
1100 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
1169 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
1101
1170
1171+-- |Ищет пользователей по строке.
1102searchUsers :: T.Text -> StaticPQ [User Faculty]
1172searchUsers :: T.Text -> StaticPQ [User Faculty]
1103searchUsers query = do
1173searchUsers query = do
1104 unless (validateText query) $ lift $ throwError lengthExceeded
1174 unless (validateText query) $ lift $ throwError lengthExceeded
@@ -1106,37 +1176,45 @@ searchUsers query = do
1106 then return []
1176 then return []
1107 else map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
1177 else map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
1108
1178
1179+-- |Ищет теги по запосу.
1109searchTags :: T.Text -> StaticPQ [Text]
1180searchTags :: T.Text -> StaticPQ [Text]
1110searchTags "" = return []
1181searchTags "" = return []
1111searchTags query = map fromOnly <$>
1182searchTags query = map fromOnly <$>
1112 (runQueryParams searchTagsQ
1183 (runQueryParams searchTagsQ
1113 (Only . (<> ":*") . T.strip $ query) >>= getRows)
1184 (Only . (<> ":*") . T.strip $ query) >>= getRows)
1114
1185
1186+-- |Создает токен.
1115createToken :: Token -> StaticPQ ()
1187createToken :: Token -> StaticPQ ()
1116createToken token = void $ manipulateParams createTokenQ token
1188createToken token = void $ manipulateParams createTokenQ token
1117
1189
1190+-- |Деактивирует все токены для пользователя.
1118killAllTokens :: UserId -> StaticPQ ()
1191killAllTokens :: UserId -> StaticPQ ()
1119killAllTokens = void . manipulateParams killAllTokensQ . Only
1192killAllTokens = void . manipulateParams killAllTokensQ . Only
1120
1193
1194+-- |Удаляет устаревшую информацию про авторизацию.
1121pruneAuth :: StaticPQ ()
1195pruneAuth :: StaticPQ ()
1122pruneAuth = do
1196pruneAuth = do
1123 _ <- commitedTransactionallyUpdate . manipulate $ pruneDeadTokensQ
1197 _ <- commitedTransactionallyUpdate . manipulate $ pruneDeadTokensQ
1124 _ <- commitedTransactionallyUpdate . manipulate $ pruneGhostUsersQ
1198 _ <- commitedTransactionallyUpdate . manipulate $ pruneGhostUsersQ
1125 return ()
1199 return ()
1126
1200
1201+-- |Осуществляет поиск по каналам.
1127searchChannels :: UserId -> Text -> StaticPQ [NamedChannel UserId]
1202searchChannels :: UserId -> Text -> StaticPQ [NamedChannel UserId]
1128searchChannels uId query = fmap (map removeUserFromChannel) $
1203searchChannels uId query = fmap (map removeUserFromChannel) $
1129 runQueryParams searchChannelsForUserQ (uId, queryFromText query) >>= getRows
1204 runQueryParams searchChannelsForUserQ (uId, queryFromText query) >>= getRows
1130
1205
1131-- NOTE: Not transactional
1206-- NOTE: Not transactional
1207+-- |Проверяет, является ли токен валидным.
1132validateToken :: Token -> StaticPQ ()
1208validateToken :: Token -> StaticPQ ()
1133validateToken token = do
1209validateToken token = do
1134 void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing, tokenActivationCode = Nothing}
1210 void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing, tokenActivationCode = Nothing}
1135 void $ manipulateParams validateUserQ $ Only $ tokenUserId token
1211 void $ manipulateParams validateUserQ $ Only $ tokenUserId token
1136
1212
1213+-- |Даективирует токен.
1137invalidateToken :: UserId -> ByteString -> StaticPQ ()
1214invalidateToken :: UserId -> ByteString -> StaticPQ ()
1138invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
1215invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
1139
1216
1217+-- |Пытается активировать токен с помощью кода.
1140tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)
1218tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)
1141tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
1219tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
1142 token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow
1220 token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow
@@ -1154,6 +1232,7 @@ tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
1154 _ <- manipulateParams updateTokenQ newToken
1232 _ <- manipulateParams updateTokenQ newToken
1155 return Nothing
1233 return Nothing
1156
1234
1235+-- |Пытается активировать с помощью ключа активации.
1157tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1236tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1158tryActivateToken uId activationData = do
1237tryActivateToken uId activationData = do
1159 let hData = hash activationData
1238 let hData = hash activationData
@@ -1165,17 +1244,21 @@ tryActivateToken uId activationData = do
1165 then commitedTransactionallyUpdate (validateToken token) >> (return $ Just token)
1244 then commitedTransactionallyUpdate (validateToken token) >> (return $ Just token)
1166 else return Nothing
1245 else return Nothing
1167
1246
1247+-- |Деактивирует токен.
1168deactivateToken :: UserId -> ByteString -> StaticPQ (Maybe Text)
1248deactivateToken :: UserId -> ByteString -> StaticPQ (Maybe Text)
1169deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow)
1249deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow)
1170
1250
1251+-- |Возвращает активированный токен.
1171getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1252getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
1172getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
1253getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
1173
1254
1255+-- |Обновляет пользователя.
1174updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
1256updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
1175updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
1257updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
1176
1258
1177-- MARK: Utils
1259-- MARK: Utils
1178
1260
1261+-- |Нормализует поля пользователя.
1179normalizeUser :: UserUpdateRow -> UserUpdateRow
1262normalizeUser :: UserUpdateRow -> UserUpdateRow
1180normalizeUser UserUpdateRow{..} = UserUpdateRow {
1263normalizeUser UserUpdateRow{..} = UserUpdateRow {
1181 userUpdateRowId = userUpdateRowId,
1264 userUpdateRowId = userUpdateRowId,
@@ -1185,23 +1268,39 @@ normalizeUser UserUpdateRow{..} = UserUpdateRow {
1185 userUpdateRowUserFaculty = T.toLower . T.strip $ userUpdateRowUserFaculty
1268 userUpdateRowUserFaculty = T.toLower . T.strip $ userUpdateRowUserFaculty
1186}
1269}
1187
1270
1271+-- |Объект пользователя для ответов с базы данных.
1188data UserRow = UserRow {
1272data UserRow = UserRow {
1273+ -- |Идентификатор пользователя.
1189 userRowId :: UserId,
1274 userRowId :: UserId,
1275+ -- |Имя.
1190 userRowFirstName :: Text,
1276 userRowFirstName :: Text,
1277+ -- |Отчество.
1191 userRowMiddleName :: Text,
1278 userRowMiddleName :: Text,
1279+ -- |Фамилия.
1192 userRowLastName :: Text,
1280 userRowLastName :: Text,
1281+ -- |Факультет.
1193 userRowFacultyUrl :: FacultyUrl,
1282 userRowFacultyUrl :: FacultyUrl,
1283+ -- |Почта.
1194 userRowEmail :: Text,
1284 userRowEmail :: Text,
1285+ -- |Был ли профиль подтвержден через почту.
1195 userRowIsValidated :: Bool,
1286 userRowIsValidated :: Bool,
1287+ -- |Название факультета.
1196 userRowFacultyName :: T.Text,
1288 userRowFacultyName :: T.Text,
1289+ -- |Адрес сайта факультета.
1197 userRowFacultyURL :: FacultyUrl,
1290 userRowFacultyURL :: FacultyUrl,
1291+ -- |Вспомогательная информация о факультете.
1198 userRowFacultyPath :: T.Text,
1292 userRowFacultyPath :: T.Text,
1293+ -- |Кампус.
1199 userRowFacultyCampusName :: T.Text,
1294 userRowFacultyCampusName :: T.Text,
1295+ -- |Код Кампуса.
1200 userRowFacultyCampusCode :: T.Text,
1296 userRowFacultyCampusCode :: T.Text,
1297+ -- |Теги департамента.
1201 userRowFacultyTags :: V.Vector T.Text,
1298 userRowFacultyTags :: V.Vector T.Text,
1299+ -- |АДрес департамента.
1202 userRowFacultyAddress :: T.Text
1300 userRowFacultyAddress :: T.Text
1203} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
1301} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
1204
1302
1303+-- |Функция, переводящая ответ с базы данных в пользователя.
1205rowToUser :: UserRow -> User Faculty
1304rowToUser :: UserRow -> User Faculty
1206rowToUser UserRow{..} = User {
1305rowToUser UserRow{..} = User {
1207 userId = userRowId,
1306 userId = userRowId,
@@ -1220,6 +1319,7 @@ rowToUser UserRow{..} = User {
1220 userEmail = userRowEmail
1319 userEmail = userRowEmail
1221 }
1320 }
1222
1321
1322+-- |Переводит строку в запрос с учетом аббревиатур.
1223queryFromTextAbbr :: Text -> Text
1323queryFromTextAbbr :: Text -> Text
1224queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
1324queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
1225 where
1325 where
@@ -1230,12 +1330,14 @@ queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (no
1230 else mempty
1330 else mempty
1231 ) <> ")"
1331 ) <> ")"
1232
1332
1333+-- |Переводит строку в запорс.
1233queryFromText :: Text -> Text
1334queryFromText :: Text -> Text
1234queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)
1335queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)
1235 where
1336 where
1236 processTerm :: Text -> Text
1337 processTerm :: Text -> Text
1237 processTerm t = t <> ":*"
1338 processTerm t = t <> ":*"
1238
1339
1340+-- |Перевод направление в оператор.
1239directionToOperator
1341directionToOperator
1240 :: P.PaginationDirection
1342 :: P.PaginationDirection
1241 -> (ConditionOp schema0 from0 grouping0 params0 nullity0 nullity1 (ty :: PGType),
1343 -> (ConditionOp schema0 from0 grouping0 params0 nullity0 nullity1 (ty :: PGType),
@@ -1248,6 +1350,7 @@ foldMaybe [] = Just []
1248foldMaybe (Nothing : _) = Nothing
1350foldMaybe (Nothing : _) = Nothing
1249foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
1351foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
1250
1352
1353+-- |переводит элементы поста с базы данных в объект поста.
1251rowsToPosts :: [PostRowResponse] -> Maybe [Post]
1354rowsToPosts :: [PostRowResponse] -> Maybe [Post]
1252rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)
1355rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)
1253
1356
@@ -1261,11 +1364,15 @@ idsToColumn :: [Int64] -> Maybe (Query schema params '["id" ::: 'NotNull 'PGint8
1261idsToColumn [] = Nothing
1364idsToColumn [] = Nothing
1262idsToColumn (i:ii) = Just $ values (unsafeIntToExpr i `as` #id) $ map ((`as` #id) . unsafeIntToExpr) ii
1365idsToColumn (i:ii) = Just $ values (unsafeIntToExpr i `as` #id) $ map ((`as` #id) . unsafeIntToExpr) ii
1263
1366
1367+-- |Небезопасное переведение числа в SQL выражение.
1264unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty
1368unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty
1265unsafeIntToExpr = UnsafeExpression . pack . show
1369unsafeIntToExpr = UnsafeExpression . pack . show
1266
1370
1371+-- |Ответ сервера с пользователями.
1267data ResponseWithUsers r = ResponseWithUsers {
1372data ResponseWithUsers r = ResponseWithUsers {
1373+ -- |Тело ответа.
1268 response :: r,
1374 response :: r,
1375+ -- |Пользователи.
1269 users :: M.Map UserId (User Faculty)
1376 users :: M.Map UserId (User Faculty)
1270} deriving (Generic)
1377} deriving (Generic)
1271
1378
@@ -1296,6 +1403,7 @@ instance (Foldable t, HasUsers r) => HasUsers (t r) where
1296instance HasUsers Post where
1403instance HasUsers Post where
1297 userSet = Set.singleton . postAuthorId
1404 userSet = Set.singleton . postAuthorId
1298
1405
1406+-- |Оборачивает ответ в пользователей.
1299wrapIntoUsers :: r -> Set.Set UserId -> StaticPQ (Maybe (ResponseWithUsers r))
1407wrapIntoUsers :: r -> Set.Set UserId -> StaticPQ (Maybe (ResponseWithUsers r))
1300wrapIntoUsers r us
1408wrapIntoUsers r us
1301 | Set.null us = return . Just $ ResponseWithUsers r M.empty
1409 | Set.null us = return . Just $ ResponseWithUsers r M.empty
denis/src/Data/Schema.hs+3−5
@@ -9,16 +9,14 @@
9 KindSignatures #-}
9 KindSignatures #-}
10
10
11
11
12−module Data.Schema (
12+module Data.Schema where
13− Schema,
14− createTables
15−) where
16
13
17import Squeal.PostgreSQL
14import Squeal.PostgreSQL
18import Data.GroupChat
15import Data.GroupChat
19import Data.PostElement
16import Data.PostElement
20import Data.Message
17import Data.Message
21
18
19+-- |Таблицы базы данных
22type Schema =
20type Schema =
23 '[
21 '[
24 "faculties" ::: 'Table ('[
22 "faculties" ::: 'Table ('[
@@ -188,7 +186,7 @@ type Schema =
188
186
189 ]
187 ]
190
188
191−
189+-- |Создает таблицы базы данных.
192createTables :: Definition '[] Schema
190createTables :: Definition '[] Schema
193createTables = createTable #faculties (
191createTables = createTable #faculties (
194 notNullable text `as` #facultyName :*
192 notNullable text `as` #facultyName :*
denis/src/Data/Tags/Completions.hs+3−4
@@ -4,10 +4,7 @@
4 FlexibleInstances #-}
4 FlexibleInstances #-}
5{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
5{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
6
6
7−module Data.Tags.Completions (
7+module Data.Tags.Completions where
8− CompletionTree(..),
9− mkCompletionTree
10− ) where
11
8
12import qualified Data.Map as M
9import qualified Data.Map as M
13import Data.Aeson
10import Data.Aeson
@@ -24,6 +21,7 @@ instance ToSample CompletionTree where
24 toSamples _ = singleSample . mkCompletionTree $
21 toSamples _ = singleSample . mkCompletionTree $
25 ["aa", "aaab", "ba", "b", "bab"]
22 ["aa", "aaab", "ba", "b", "bab"]
26
23
24+-- |Объект дерева подсказок тегов.
27data CompletionTree = CompletionTreeNode {
25data CompletionTree = CompletionTreeNode {
28 value :: Maybe String,
26 value :: Maybe String,
29 subtree :: M.Map Char CompletionTree
27 subtree :: M.Map Char CompletionTree
@@ -31,6 +29,7 @@ data CompletionTree = CompletionTreeNode {
31
29
32instance ToJSON CompletionTree where
30instance ToJSON CompletionTree where
33
31
32+-- |Функция, ктороая строит дерево подсказок по данному списку строк.
34mkCompletionTree :: [String] -> CompletionTree
33mkCompletionTree :: [String] -> CompletionTree
35mkCompletionTree = mkCompletionTree' . map (\ a -> (map toLower a, a)) . sort
34mkCompletionTree = mkCompletionTree' . map (\ a -> (map toLower a, a)) . sort
36 where
35 where
denis/src/Data/Tags/Validation.hs+4−4
@@ -1,11 +1,9 @@
1−module Data.Tags.Validation (
1+module Data.Tags.Validation where
2− validateTag,
3− validateTag'
4− ) where
5
2
6import Data.Text as T
3import Data.Text as T
7import Data.Char
4import Data.Char
8
5
6+-- |Функция, валилирующая хэштег, возвращающая тег в монаде `Maybe`
9validateTag :: T.Text -> Maybe T.Text
7validateTag :: T.Text -> Maybe T.Text
10validateTag tag =
8validateTag tag =
11 let
9 let
@@ -14,9 +12,11 @@ validateTag tag =
14 then Just normalised
12 then Just normalised
15 else Nothing
13 else Nothing
16
14
15+-- |Функция, проверяющая, является ли данный тег валидным.
17validateTag' :: T.Text -> Bool
16validateTag' :: T.Text -> Bool
18validateTag' = T.all validChar
17validateTag' = T.all validChar
19
18
19+-- |Функция, проверяющая, является ли данный символ валидным внутри тега.
20validChar :: Char -> Bool
20validChar :: Char -> Bool
21validChar '-' = True
21validChar '-' = True
22validChar c = isAlphaNum c
22validChar c = isAlphaNum c
denis/src/Data/Text/Validator.hs+8−9
@@ -1,30 +1,26 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2
2
3−module Data.Text.Validator (
3+module Data.Text.Validator where
4− HasValidatableText(..),
5− isValidChar,
6− ExtraPredicate(..),
7− (~=),
8− (~<),
9− (<~>),
10− RangeableText(..)
11− ) where
12
4
13import qualified Data.Text as T
5import qualified Data.Text as T
14import Data.Char
6import Data.Char
15import Data.Limits
7import Data.Limits
16
8
9+-- |Функция, проверяющая, является ли данный символ валидным символом текста.
17isValidChar :: Char -> Bool
10isValidChar :: Char -> Bool
18isValidChar '\n' = True
11isValidChar '\n' = True
19isValidChar '\r' = True
12isValidChar '\r' = True
20isValidChar c = isPrint c || generalCategory c == ModifierLetter
13isValidChar c = isPrint c || generalCategory c == ModifierLetter
21
14
15+-- |Класс объектов, имеющих возможность проверить содержащийся в них текст на валидность.
22class HasValidatableText t where
16class HasValidatableText t where
23 validateText :: t -> Bool
17 validateText :: t -> Bool
24
18
19+-- |Текст с предикат.
25data ExtraPredicate t = ExtraPredicate t (t -> Bool)
20data ExtraPredicate t = ExtraPredicate t (t -> Bool)
26
21
27infixl 5 ~=
22infixl 5 ~=
23+-- |Опертор для добавления предиката к тексту.
28(~=) :: t -> (t -> Bool) -> ExtraPredicate t
24(~=) :: t -> (t -> Bool) -> ExtraPredicate t
29(~=) = ExtraPredicate
25(~=) = ExtraPredicate
30
26
@@ -33,13 +29,16 @@ instance (HasValidatableText t) => HasValidatableText (ExtraPredicate t) where
33
29
34
30
35infixl 5 ~<
31infixl 5 ~<
32+-- |Опертор для добавления ограничений на длину сверху к тексту.
36(~<) :: t -> Int -> RangeableText t
33(~<) :: t -> Int -> RangeableText t
37t ~< n = t <~> (0, n)
34t ~< n = t <~> (0, n)
38
35
39infixl 5 <~>
36infixl 5 <~>
37+-- |Оператор для добавления ограничения на длину текста.
40(<~>) :: t -> (Int, Int) -> RangeableText t
38(<~>) :: t -> (Int, Int) -> RangeableText t
41(<~>) = RangeableText
39(<~>) = RangeableText
42
40
41+-- |Текст с ограничением по длине.
43data RangeableText t = RangeableText t (Int, Int)
42data RangeableText t = RangeableText t (Int, Int)
44
43
45instance HasValidatableText (RangeableText String) where
44instance HasValidatableText (RangeableText String) where
denis/src/Data/User.hs+18−8
@@ -9,12 +9,7 @@
9 DeriveAnyClass,
9 DeriveAnyClass,
10 RecordWildCards #-}
10 RecordWildCards #-}
11
11
12−module Data.User (
12+module Data.User where
13− User(..),
14− UserId,
15− UserEmail,
16− UserUpdate(..)
17−) where
18
13
19import Data.Int (Int64)
14import Data.Int (Int64)
20import qualified Generics.SOP as SOP
15import qualified Generics.SOP as SOP
@@ -30,25 +25,35 @@ import Data.Text.Validator
30-- MARK: Documentation
25-- MARK: Documentation
31
26
32instance (ToSample f) => ToSample (User f) where
27instance (ToSample f) => ToSample (User f) where
33− toSamples _ = samples $ [User 8 "Vasya" "Pupkinovuch" "Pupkin", User 69 "Seva" "Algebrovich" "Leonidov"] <*> (map snd $ toSamples Proxy) <*> ["foo@hse.ru"]
28+ toSamples _ = samples $ [User 8 "Vasya" "Pupkinovuch" "Pupkin"] <*> (map snd $ toSamples Proxy) <*> ["foo@hse.ru"]
34
29
35instance ToSample (UserUpdate) where
30instance ToSample (UserUpdate) where
36− toSamples _ = samples $ [UserUpdate "Vasya" "Pupkinovuch" "Pupkin", UserUpdate "Seva" "Algebrovich" "Leonidov"] <*> ["cs.hse.ru/dse/"]
31+ toSamples _ = samples $ [UserUpdate "Vasya" "Pupkinovuch" "Pupkin"] <*> ["cs.hse.ru/dse/"]
37
32
38instance HasValidatableText UserUpdate where
33instance HasValidatableText UserUpdate where
39 validateText UserUpdate{..} = all (validateText . (~< userFieldLengthLimit)) [userUpdateFirstName, userUpdateMiddleName, userUpdateLastName, userUpdateUserFaculty]
34 validateText UserUpdate{..} = all (validateText . (~< userFieldLengthLimit)) [userUpdateFirstName, userUpdateMiddleName, userUpdateLastName, userUpdateUserFaculty]
40
35
41-- MARK: Implementation
36-- MARK: Implementation
42
37
38+-- |Идентификатор пользователя.
43type UserId = Int64
39type UserId = Int64
40+
41+-- |Адрес почты пользователя.
44type UserEmail = Text
42type UserEmail = Text
45
43
44+-- |Пользователь.
46data User f = User {
45data User f = User {
46+ -- |Идентификатор.
47 userId :: UserId,
47 userId :: UserId,
48+ -- |Имя.
48 firstName :: Text,
49 firstName :: Text,
50+ -- |Фамилия.
49 middleName :: Text,
51 middleName :: Text,
52+ -- |Отчество.
50 lastName :: Text,
53 lastName :: Text,
54+ -- |Факультет.
51 userFaculty :: f,
55 userFaculty :: f,
56+ -- |Адрес почты.
52 userEmail :: UserEmail
57 userEmail :: UserEmail
53} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
58} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
54
59
@@ -66,10 +71,15 @@ instance (FromJSON f) => FromJSON (User f) where
66 parseJSON = withObject "named channel" $ \e ->
71 parseJSON = withObject "named channel" $ \e ->
67 User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
72 User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
68
73
74+-- |Объект для обновления пользователя.
69data UserUpdate = UserUpdate {
75data UserUpdate = UserUpdate {
76+ -- |Имя.
70 userUpdateFirstName :: Text,
77 userUpdateFirstName :: Text,
78+ -- |Отчество.
71 userUpdateMiddleName :: Text,
79 userUpdateMiddleName :: Text,
80+ -- |Фамилия.
72 userUpdateLastName :: Text,
81 userUpdateLastName :: Text,
82+ -- |Факультет.
73 userUpdateUserFaculty :: FacultyUrl
83 userUpdateUserFaculty :: FacultyUrl
74} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
84} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
75
85
denis/src/Server/API.hs+14−13
@@ -7,12 +7,7 @@
7 RecordWildCards #-}
7 RecordWildCards #-}
8{-# OPTIONS_GHC -Wno-orphans #-}
8{-# OPTIONS_GHC -Wno-orphans #-}
9
9
10−module Server.API (
10+module Server.API where
11− API,
12− serverProxy,
13− mkServerAPI,
14− Authentication
15−) where
16
11
17import Data.Proxy
12import Data.Proxy
18import Servant.API
13import Servant.API
@@ -42,13 +37,19 @@ import Data.Text.Validator
42
37
43instance HasDocs api => HasDocs (Authentication :> api) where
38instance HasDocs api => HasDocs (Authentication :> api) where
44 docsFor Proxy (endpoint, action) =
39 docsFor Proxy (endpoint, action) =
45− docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `498 Invalid Token` if the token is invalid or the token header is missing. Returns `401 Unathorized` if the token doesn't permit access to the requested data."]])
40+ docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["Этот метод требует токен, который можно получить через запрос `POST /authenticate/login`.\n\nВозвращает `498 Invalid Token` если токен не валидный или отсутствует. Возвращает `401 Unathorized` если токен не дает доступа к запрашиваемому ресурсу."]])
46
41
47−type UserSearchDescription = Description "Searches for users with the given string.\n\nFeed in the raw user input string."
42+type UserSearchDescription = Description "Ищет пользователей по данной строке."
48
43
49−type UpdateUserDescription = Description "Updates the current user.\n\nThrow 401 if you try to change email or something like that."
44+type UpdateUserDescription = Description "Обновляет профиль текущего пользователя."
50
45
51−type DeactivateAllDescription = Description "Deactivates all tokens for the logged in user including the one used to authenticate this request."
46+type DeactivateAllDescription = Description "Деактивирует все токены для текущего пользователя."
47+
48+type MeDescription = Description "Возвращает идентификатор текущего пользователя."
49+
50+type UsersDescription = Description "Возвращает пользователей для данных идентификаторов."
51+
52+type UsersAllDescription = Description "Возвращает всех пользователей."
52
53
53-- MARK: Implementation
54-- MARK: Implementation
54
55
@@ -58,11 +59,11 @@ type API =
58 LoggerAPI :<|>
59 LoggerAPI :<|>
59 "authentication" :> AuthenticationHandler :<|>
60 "authentication" :> AuthenticationHandler :<|>
60 Authentication :> ComplexQuery :> (
61 Authentication :> ComplexQuery :> (
61− "authentication" :> "me" :> Post '[JSON] UserId :<|>
62+ "authentication" :> "me" :> MeDescription :> Post '[JSON] UserId :<|>
62 "deactivateAll" :> DeactivateAllDescription
63 "deactivateAll" :> DeactivateAllDescription
63 :> DeleteNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
64 :> DeleteNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
64− "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>
65+ "users" :> UsersDescription :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>
65− "users" :> "all" :> Post '[JSON] [User Faculty] :<|>
66+ "users" :> "all" :> UsersAllDescription :> Post '[JSON] [User Faculty] :<|>
66 "users" :> "search" :> UserSearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [User Faculty] :<|>
67 "users" :> "search" :> UserSearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [User Faculty] :<|>
67 "users" :> "update" :> UpdateUserDescription :> ReqBody '[JSON] UserUpdate :> PostNoContent '[JSON, PlainText] NoContent :<|>
68 "users" :> "update" :> UpdateUserDescription :> ReqBody '[JSON] UserUpdate :> PostNoContent '[JSON, PlainText] NoContent :<|>
68 "posts" :> PostApi :<|>
69 "posts" :> PostApi :<|>
denis/src/Server/API/Channels.hs+20−12
@@ -7,10 +7,7 @@
7 TypeOperators,
7 TypeOperators,
8 RecordWildCards #-}
8 RecordWildCards #-}
9
9
10−module Server.API.Channels (
10+module Server.API.Channels where
11− ChannelsApi,
12− channelsApi
13−) where
14
11
15import Servant.API
12import Servant.API
16import Server.App
13import Server.App
@@ -29,20 +26,31 @@ import Control.Monad
29import Data.Limits
26import Data.Limits
30import qualified Data.Text as T
27import qualified Data.Text as T
31import Data.Char
28import Data.Char
29+import Control.Monad.Except
32
30
33−type CreateDescription = Description "Creates a new channel\n\nReturns 406 if the channel limit has been exceeded."
31+type CreateDescription = Description "Создает канал.\n\nВозвращает 406 если лимит каналов для пользователя был исчерпан."
34
32
35−type SearchDescription = Description "Search for user channels."
33+type SearchDescription = Description "Осуществляет поиск по каналам."
34+
35+type GetDescription = Description "Запрашивает посты в данном канале."
36+
37+type GetAnonDescription = Description "Запрашивает посты в анонимном канале."
38+
39+type UpdateDescription = Description "Обновляет именнованный канал."
40+
41+type DeleteDescription = Description "Удаляет именнованный канал."
42+
43+type GetAllDescription = Description "Запрашивает все каналы пользователя."
36
44
37-- MARK: Implementation
45-- MARK: Implementation
38
46
39−type ChannelsApi = Post '[JSON] [NamedChannel UserId] :<|>
47+type ChannelsApi = GetAllDescription :> Post '[JSON] [NamedChannel UserId] :<|>
40− "get" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe NamedChannelId)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
48+ "get" :> GetDescription :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe NamedChannelId)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
41− "getAnonymous" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe AnonymousChannel)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
49+ "getAnonymous" :> GetAnonDescription :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe AnonymousChannel)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
42 "create" :> CreateDescription :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
50 "create" :> CreateDescription :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
43− "update" :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
51+ "update" :> UpdateDescription :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
44− "delete" :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
52+ "delete" :> DeleteDescription :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
45− "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [NamedChannel UserId]
53+ "search" :> SearchDescription :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [NamedChannel UserId]
46
54
47channelsApi :: UserId -> ServerT ChannelsApi App
55channelsApi :: UserId -> ServerT ChannelsApi App
48channelsApi uId = getChannelsApi uId :<|> getChannel uId :<|> getAnonymousChannelsApi :<|> createChannelApi uId :<|> updateChannelApi uId :<|> deleteChannelApi uId :<|> searchChannelsApi uId
56channelsApi uId = getChannelsApi uId :<|> getChannel uId :<|> getAnonymousChannelsApi :<|> createChannelApi uId :<|> updateChannelApi uId :<|> deleteChannelApi uId :<|> searchChannelsApi uId
denis/src/Server/API/Completions.hs+4−7
@@ -7,10 +7,7 @@
7 TypeOperators,
7 TypeOperators,
8 LambdaCase #-}
8 LambdaCase #-}
9
9
10−module Server.API.Completions (
10+module Server.API.Completions where
11− TagsAPI,
12− tagsServer
13− ) where
14
11
15import Servant.Server
12import Servant.Server
16import Servant
13import Servant
@@ -25,14 +22,14 @@ import qualified Data.Text as T
25import Data.Char
22import Data.Char
26
23
27type CompletionsDescription = Description "\
24type CompletionsDescription = Description "\
28− \Gets tag completion tree\n\n\
25+ \Возвращает дерево тегов.\n\n\
29 \```haskell\n\
26 \```haskell\n\
30 \data CompletionTree = CompletionTreeNode {\n\
27 \data CompletionTree = CompletionTreeNode {\n\
31 \ value :: Maybe String,\n\
28 \ value :: Maybe String,\n\
32 \ subtree :: Map Char CompletionTree\n\
29 \ subtree :: Map Char CompletionTree\n\
33 \}\n\
30 \}\n\
34 \```\n\n\
31 \```\n\n\
35− \The psuedocode for retrieving all completions from the tree:\n\n\
32+ \Псевдокод для получения всех подсказок:\n\n\
36 \```swift\n\
33 \```swift\n\
37 \func getCompletion(tree: CompletionTree, word: String) -> [String] {\n\
34 \func getCompletion(tree: CompletionTree, word: String) -> [String] {\n\
38 \ if word == \"\" {\n\
35 \ if word == \"\" {\n\
@@ -63,7 +60,7 @@ type CompletionsDescription = Description "\
63 \}\n\
60 \}\n\
64 \```"
61 \```"
65
62
66−type SearchDescription = Description "Returns top 1000 tag completions for given user input."
63+type SearchDescription = Description "Возвращает 1000 самых популярных тегов для запроса пользователя."
67
64
68type TagsAPI = "completions" :> CompletionsDescription :> Get '[JSON] CompletionTree :<|>
65type TagsAPI = "completions" :> CompletionsDescription :> Get '[JSON] CompletionTree :<|>
69 "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [Text]
66 "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [Text]
denis/src/Server/API/Faculty.hs+2−5
@@ -7,10 +7,7 @@
7 TypeOperators,
7 TypeOperators,
8 LambdaCase #-}
8 LambdaCase #-}
9
9
10−module Server.API.Faculty (
10+module Server.API.Faculty where
11− FacultyAPI,
12− facultyServer
13− ) where
14
11
15import Servant.Server
12import Servant.Server
16import Servant
13import Servant
@@ -25,7 +22,7 @@ import Control.Monad
25import Server.Error
22import Server.Error
26import Data.Char
23import Data.Char
27
24
28−type SearchDescription = Description "Returns faculties for given string"
25+type SearchDescription = Description "Возвращает факультет по данному запросу."
29
26
30type FacultyAPI =
27type FacultyAPI =
31 "search" :> SearchDescription :> ReqBody '[PlainText, JSON] Text :> Post '[JSON] [Faculty]
28 "search" :> SearchDescription :> ReqBody '[PlainText, JSON] Text :> Post '[JSON] [Faculty]
denis/src/Server/API/Messages.hs+10−12
@@ -7,10 +7,7 @@
7 TypeOperators,
7 TypeOperators,
8 RecordWildCards #-}
8 RecordWildCards #-}
9
9
10−module Server.API.Messages (
10+module Server.API.Messages where
11− MessagesApi,
12− messagesServer
13−) where
14
11
15import Servant.API
12import Servant.API
16import Server.App
13import Server.App
@@ -28,15 +25,16 @@ import Server.Error
28import qualified Data.Map as M
25import qualified Data.Map as M
29import Squeal.PostgreSQL.Schema
26import Squeal.PostgreSQL.Schema
30import Data.Limits
27import Data.Limits
28+import Control.Monad.Except
31
29
32−type GetAllChatsDescription = Description "Gets chats starting from/ending with the given message id."
30+type GetAllChatsDescription = Description "Возвращает чаты с данного идентификатора сообщения."
33−type GetGroupChatDescription = Description "Gets information about a given group chat."
31+type GetGroupChatDescription = Description "Возвращает информацию о групповой беседе."
34−type GetUpdateGroupChatDescription = Description "Updates given group chat.\n\nReturns 404 if you are not part of the group chat.\n\nReturn 401 if you do not have sufficient permissions to edit the chat."
32+type GetUpdateGroupChatDescription = Description "Обновляет групповой чат.\n\nВозвращает 404 если пользователь не является участником беседы.\n\nВозвращает 401 Если у пользователя не достаточно прав на редактирование беседы."
35−type CreateGroupChatDescription = Description "Creates a group chat with the given user permission.\n\nThe calling user gets add and promoted to maximum permissions automatically. You do not have to include him.\n\nReturns the id of the created group chat"
33+type CreateGroupChatDescription = Description "Создает групповую беседу с данными правами.\n\nВызывающий пользовтаель автоматически приобретает максимальные права. Его не надо добавлять.\n\nВозвращает идентификатор созданного чата."
36−type LeaveGroupChatDescription = Description "Removes the user from the given group chat."
34+type LeaveGroupChatDescription = Description "Убирает пользователя из беседы."
37−type MessagesGetGroupChatDesctiption = Description "Gets the messages from the supplied group chat starting from/ending with the given message id."
35+type MessagesGetGroupChatDesctiption = Description "Возвращает сообщения в групповой бесед начиная с данного идентификатора сообщения."
38−type MessagesGetUserChatDesctiption = Description "Gets the messages from the supplied user chat (two people) starting from/ending with the given message id."
36+type MessagesGetUserChatDesctiption = Description "Возвращает сообщения в диалоге начиная с данного идентификатора сообщения."
39−type MessagesSend = Description "Sends the given message.\n\nReturns the id of the sent message."
37+type MessagesSend = Description "Отправляет сообщения.\n\nВозвращает идентификато отправленного сообщения."
40
38
41type MessagesApi =
39type MessagesApi =
42 "chats" :> (
40 "chats" :> (
denis/src/Server/API/Posts.hs+8−4
@@ -6,10 +6,7 @@
6 TypeApplications ,
6 TypeApplications ,
7 TypeOperators #-}
7 TypeOperators #-}
8
8
9−module Server.API.Posts (
9+module Server.API.Posts where
10− PostApi,
11− postApi
12−) where
13
10
14import Servant.API
11import Servant.API
15import qualified Data.Post as P
12import qualified Data.Post as P
@@ -23,6 +20,13 @@ import Data.Limits
23import Server.Error
20import Server.Error
24import Control.Monad
21import Control.Monad
25import Data.Text.Validator
22import Data.Text.Validator
23+import Servant.Docs
24+import Control.Monad.Except
25+
26+type PostDescription = Description "Возвращает пост по идентификатору."
27+type LastPostDescription = Description "Возвращает несколько последних постов, начиная с данного."
28+type ForUserPostDescription = Description "Возвращает несколько последних постов для пользователя, начиная с данного."
29+type PublishPostDescription = Description "Публикует пост."
26
30
27-- MARK: Implementation
31-- MARK: Implementation
28
32
denis/src/Server/App.hs+2−10
@@ -8,16 +8,7 @@
8 TypeSynonymInstances,
8 TypeSynonymInstances,
9 FlexibleInstances #-}
9 FlexibleInstances #-}
10
10
11−module Server.App (
11+module Server.App where
12− App,
13− DBConnection,
14− Config(..),
15− ask,
16− asks,
17− liftIO,
18− MailConfig(..),
19− fromMaybeThrow
20−) where
21
12
22import Servant.Server
13import Servant.Server
23import Control.Monad.Reader
14import Control.Monad.Reader
@@ -27,6 +18,7 @@ import Generics.SOP (K)
27import Squeal.PostgreSQL.PQ (Connection)
18import Squeal.PostgreSQL.PQ (Connection)
28import Crypto.RNG
19import Crypto.RNG
29import Server.Error
20import Server.Error
21+import Control.Monad.Except
30
22
31type App = ReaderT Config Handler
23type App = ReaderT Config Handler
32
24
denis/src/Server/Auth.hs+14−20
@@ -12,17 +12,7 @@
12 RecordWildCards #-}
12 RecordWildCards #-}
13{-# OPTIONS_GHC -Wno-orphans #-}
13{-# OPTIONS_GHC -Wno-orphans #-}
14
14
15−module Server.Auth (
15+module Server.Auth where
16− checkToken,
17− cookieTokenKey,
18− genAuthServerContext,
19− AuthenticationHandler,
20− logIn,
21− contextProxy,
22− AuthenticationCredits(..),
23− authenticationAPI,
24− TokenActivationData
25−) where
26
16
27import Server.App
17import Server.App
28import Data.User
18import Data.User
@@ -58,11 +48,15 @@ import qualified Data.Text.Lazy as TL
58import Server.Auth.HTML
48import Server.Auth.HTML
59import Data.Char
49import Data.Char
60import Data.Text.Validator
50import Data.Text.Validator
51+import Servant.HTML.Blaze
52+import Text.Blaze
53+import Crypto.Hash.SHA512
54+
61
55
62-- MARK: Documentation
56-- MARK: Documentation
63
57
64instance ToSample AuthenticationCredits where
58instance ToSample AuthenticationCredits where
65− toSamples _ = samples $ map AuthenticationCredits ["vchernyshev@hse.ru", "iikostyuchenko@hse.ru"]
59+ toSamples _ = samples $ map AuthenticationCredits ["example@hse.ru", "iikostyuchenko@hse.ru"]
66
60
67instance ToSample UserLoginResponse where
61instance ToSample UserLoginResponse where
68 toSamples _ = samples $ map UserLoginResponse [UserIsRegistered, UserCanRegister, InvalidUser]
62 toSamples _ = samples $ map UserLoginResponse [UserIsRegistered, UserCanRegister, InvalidUser]
@@ -71,7 +65,7 @@ instance ToSample Int where
71 toSamples _ = samples [382934, 103845, 294905]
65 toSamples _ = samples [382934, 103845, 294905]
72
66
73instance ToSample UserCreation where
67instance ToSample UserCreation where
74− toSamples _ = samples $ [UserCreation "Seva" "Algebrovich" "Leonidov" "cs.hse.ru/dse/" "vchernyshev@hse.ru"]
68+ toSamples _ = samples $ [UserCreation "Василий" "Иванов" "Романович" "cs.hse.ru/dse/" "example@hse.ru"]
75
69
76instance ToSample TokenActivationData where
70instance ToSample TokenActivationData where
77 toSamples _ = singleSample $ TokenActivationData 69 "ABCDE"
71 toSamples _ = singleSample $ TokenActivationData 69 "ABCDE"
@@ -96,19 +90,19 @@ instance ToParam (QueryParam' mods "id" UserId) where
96instance ToSample Markup where
90instance ToSample Markup where
97 toSamples _ = noSamples
91 toSamples _ = noSamples
98
92
99−type LoginDescription = Description "Try to log in with the given email\n\nResponse fields:\n\n- `registered` -- User is registered and the cookie has been set. You now need to get a verification code from the user and pass it to `/verify`.\n- `canRegister` -- the email is valid, but the user needs to register. Prompt him for information and pass it to `/register`.\n- `invalid` -- the email is invalid."
93+type LoginDescription = Description "Попытка зайти с указанной почты.\n\nЗначения возвращаемого поля:\n\n- `registered` -- Пользователь уже зарегестрирован и токен был поставлен в HTTP Cookie. Теперь можно запросить у пользователя код активации и передать его в `/verify`.\n- `canRegister` -- почта валидная, но пользователь не зарегестрирован. У пользователя необходимо запросить данные для передачи в `/register`.\n- `invalid` -- почта не валидная."
100
94
101−type LogoutDescription = Description "Log out with the given cookie"
95+type LogoutDescription = Description "Деактивировать текущий токен."
102
96
103−type VerifyDescription = Description "Verify token with the verification code from the user.\n\nReturns 400 if the token was not supplied.\n\nReturns 498 if the token was parsed but is invalid.\n\nReturns 403 if the token/code compination is invalid."
97+type VerifyDescription = Description "Активировать текущий токен через код, отправленный на почту.\n\nВозвращает 400 если не был передан валидный токен.\n\nВозвращает 498 если токен был обраотан успешно, но не является валидным.\n\nВозвращает 403 если комбинация токена и код не валидная."
104
98
105−type RegisterDescription = Description "Register the user for a new account.\n\nReturns 409 if a user can not be created. (Most likely the email is already registered).\n\nSets the token if creation was successful.\n\nYou should prompt user for code and verify the token with `/verify`."
99+type RegisterDescription = Description "Зарегестрировать пользователя.\n\nВозвращает 409 если пользователь не может быть создан. (Скорее всего он уже зарегестрирован).\n\nСтавит токен в HTTP Cookie, если пользователь был успещно создан.\n\nПосле успех необходимо запросить у пользователя код активации, который он получил на почту и передать его в `/verify`."
106
100
107−type CheckCookieDescription = Description "Checks if a parseable cookie is present in the request.\n\nDoes not check if the cookie itself contains valid credentials.\n\nReturns 204 NoContent if cookie is present.\n\nReturns 401 Unauthorized if the cookie is not present."
101+type CheckCookieDescription = Description "Проверяет, есть ли в запросе валидный токен.\n\nВалидность содержимого не проверяется.\n\nВозвращает 204 NoContent если токен присутствует.\n\nВозвращает 401 Unauthorized если токена нет."
108
102
109−type ActivateDescription = Description "Activates a token using data from email"
103+type ActivateDescription = Description "Активирует токен по ключу из письма."
110
104
111−type DeactivateDescription = Description "Deactivates a token using data from email"
105+type DeactivateDescription = Description "Деактивирует токен по ключу из письма."
112
106
113-- MARK: Implementation
107-- MARK: Implementation
114
108
denis/src/Server/Auth/HTML.hs+1−7
@@ -11,13 +11,7 @@
11 DeriveAnyClass,
11 DeriveAnyClass,
12 RecordWildCards #-}
12 RecordWildCards #-}
13
13
14−module Server.Auth.HTML (
14+module Server.Auth.HTML where
15− HTML,
16− genActivationPage,
17− Markup,
18− errorPage,
19− page
20− ) where
21
15
22import Servant.HTML.Blaze
16import Servant.HTML.Blaze
23import Text.Blaze.Html5 as H
17import Text.Blaze.Html5 as H
denis/src/Server/Auth/Mail.hs+2−3
@@ -12,9 +12,7 @@
12 RecordWildCards #-}
12 RecordWildCards #-}
13{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
13{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
14
14
15−module Server.Auth.Mail (
15+module Server.Auth.Mail where
16− sendTokenVerificationEmail
17− ) where
18
16
19import Network.Mail.SMTP
17import Network.Mail.SMTP
20import Server.App
18import Server.App
@@ -29,6 +27,7 @@ import Text.Blaze.Html.Renderer.Text
29import Data.ByteString (ByteString)
27import Data.ByteString (ByteString)
30import Data.User
28import Data.User
31import Data.ByteString.Char8 (unpack)
29import Data.ByteString.Char8 (unpack)
30+import Control.Monad.Reader
32
31
33sendTokenVerificationEmail :: TokenVerificationCode -> UserId -> ByteString -> ByteString -> TL.Text -> Text -> App ()
32sendTokenVerificationEmail :: TokenVerificationCode -> UserId -> ByteString -> ByteString -> TL.Text -> Text -> App ()
34sendTokenVerificationEmail userCode uId activation deactivation ua email = do
33sendTokenVerificationEmail userCode uId activation deactivation ua email = do
denis/src/Server/Auth/Token.hs+1−9
@@ -9,15 +9,7 @@
9 TypeOperators,
9 TypeOperators,
10 DeriveAnyClass #-}
10 DeriveAnyClass #-}
11
11
12−module Server.Auth.Token (
12+module Server.Auth.Token where
13− Token(..),
14− generateToken,
15− TokenVerificationCode,
16− generateTokenM,
17− hashVerificationCode,
18− GeneratedToken(..),
19− hash
20− ) where
21
13
22import Data.Time.Clock
14import Data.Time.Clock
23import Data.ByteString
15import Data.ByteString
denis/src/Server/Error.hs+1−8
@@ -1,13 +1,6 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2
2
3−module Server.Error (
3+module Server.Error where
4− invalidToken,
5− amountExceeded,
6− lengthExceeded,
7− formatError,
8− impossibleContent,
9− throwError
10−) where
11
4
12import Servant.Server
5import Servant.Server
13import Control.Monad.Except
6import Control.Monad.Except
denis/src/Server/Logger.hs+2−6
@@ -6,12 +6,7 @@
6 FlexibleInstances #-}
6 FlexibleInstances #-}
7{-# OPTIONS_GHC -Wno-orphans #-}
7{-# OPTIONS_GHC -Wno-orphans #-}
8
8
9−module Server.Logger (
9+module Server.Logger where
10− Logger,
11− LoggerAPI,
12− mkLogger,
13− Log
14−) where
15
10
16import Network.Wai
11import Network.Wai
17import Control.Concurrent.STM
12import Control.Concurrent.STM
@@ -26,6 +21,7 @@ import Network.Wai.Middleware.RequestLogger
26import Data.Default.Class
21import Data.Default.Class
27import qualified System.Log.FastLogger as FL
22import qualified System.Log.FastLogger as FL
28import Servant.Docs
23import Servant.Docs
24+import Control.Monad.IO.Class
29
25
30instance HasDocs "log" where
26instance HasDocs "log" where
31 docsFor _ _ _ = emptyAPI
27 docsFor _ _ _ = emptyAPI
denis/src/Server/Periodic.hs+1−6
@@ -1,9 +1,4 @@
1−module Server.Periodic (
1+module Server.Periodic where
2− periodically,
3− seconds,
4− minutes,
5− hours
6− ) where
7
2
8import Control.Monad.IO.Class
3import Control.Monad.IO.Class
9import Control.Concurrent
4import Control.Concurrent
denis/src/Server/Query/ComplexQuery.hs+2−4
@@ -15,9 +15,7 @@
15{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
15{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
16{-# OPTIONS_GHC -Wno-orphans #-}
16{-# OPTIONS_GHC -Wno-orphans #-}
17
17
18−module Server.Query.ComplexQuery (
18+module Server.Query.ComplexQuery where
19− ComplexQuery
20−) where
21
19
22import Data.ByteString.Lazy (ByteString)
20import Data.ByteString.Lazy (ByteString)
23import Data.ByteString.Builder (toLazyByteString)
21import Data.ByteString.Builder (toLazyByteString)
@@ -51,7 +49,7 @@ instance {-# Overlapping #-} ToSample [ComplexQueryRequest] where
51 toSamples _ = singleSample $ [ComplexQueryRequest "channels/" "", ComplexQueryRequest "posts/last" "3"]
49 toSamples _ = singleSample $ [ComplexQueryRequest "channels/" "", ComplexQueryRequest "posts/last" "3"]
52
50
53instance {-# Overlapping #-} ToSample [ComplexQueryRepsonse] where
51instance {-# Overlapping #-} ToSample [ComplexQueryRepsonse] where
54− toSamples _ = singleSample $ map ComplexQueryRepsonse ["[{\"people\":[1],\"name\":\"newChannelName\",\"id\":7,\"tags\":[]},{\"people\":[1],\"name\":\"newChannelName\",\"id\":6,\"tags\":[]},{\"people\":[1],\"name\":\"newChannelName\",\"id\":5,\"tags\":[]},{\"people\":[1,1,2,2,2],\"name\":\"sssss\",\"id\":4,\"tags\":[\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsAlsoHashTag\",\"cs\"]},{\"people\":[1,7,2,19],\"name\":\"соытвототтоциология\",\"id\":1,\"tags\":[\"sos\"]}]","{\"users\":{\"1\":{\"middleName\":\"FirstUser\",\"lastName\":\"FirstUser\",\"firstName\":\"FirstUser\",\"id\":1}},\"response\":[{\"body\":[{\"markdown\":\"hello\"}],\"authorId\":1,\"id\":28,\"updated\":\"2019-04-13T16:14:38.495832Z\",\"tags\":[]},{\"body\":[{\"markdown\":\"Hello, blyat\"}],\"authorId\":1,\"id\":27,\"updated\":\"2005-01-03T12:34:56Z\",\"tags\":[]}]}"]
52+ toSamples _ = singleSample $ map ComplexQueryRepsonse ["[{\"people\":[1],\"name\":\"newChannelName\",\"id\":7,\"tags\":[]},{\"people\":[1],\"name\":\"newChannelName\",\"id\":6,\"tags\":[]},{\"people\":[1],\"name\":\"newChannelName\",\"id\":5,\"tags\":[]},{\"people\":[1,1,2,2,2],\"name\":\"sssss\",\"id\":4,\"tags\":[\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsAlsoHashTag\",\"cs\"]},{\"people\":[1,7,2,19],\"name\":\"соытвототтоциология\",\"id\":1,\"tags\":[\"sos\"]}]","{\"users\":{\"1\":{\"middleName\":\"FirstUser\",\"lastName\":\"FirstUser\",\"firstName\":\"FirstUser\",\"id\":1}},\"response\":[{\"body\":[{\"markdown\":\"hello\"}],\"authorId\":1,\"id\":28,\"updated\":\"2019-04-13T16:14:38.495832Z\",\"tags\":[]},{\"body\":[{\"markdown\":\"Hello\"}],\"authorId\":1,\"id\":27,\"updated\":\"2005-01-03T12:34:56Z\",\"tags\":[]}]}"]
55
53
56-- MARK: Implementation
54-- MARK: Implementation
57
55
denis/src/Server/Query/Dialog.hs+9−7
@@ -2,11 +2,7 @@
2 OverloadedStrings,
2 OverloadedStrings,
3 DeriveGeneric #-}
3 DeriveGeneric #-}
4
4
5−module Server.Query.Dialog (
5+module Server.Query.Dialog where
6− ChatsResponse(..),
7− responseToDialogs,
8− Dialog(..)
9− ) where
10
6
11import Data.Aeson
7import Data.Aeson
12import Data.Message
8import Data.Message
@@ -25,7 +21,12 @@ instance ToSample Dialog where
25 toSamples _ = samples (take 1 (UserDialog <$> [69] <*> map snd (toSamples Proxy)) <>
21 toSamples _ = samples (take 1 (UserDialog <$> [69] <*> map snd (toSamples Proxy)) <>
26 (GroupDialog <$> map snd (toSamples Proxy) <*> map snd (toSamples Proxy)))
22 (GroupDialog <$> map snd (toSamples Proxy) <*> map snd (toSamples Proxy)))
27
23
24+-- |Объект диалога
25+data Dialog =
26+ -- |Thing
28−data Dialog = GroupDialog GroupChat (Maybe Message) | UserDialog UserId Message
27+ GroupDialog GroupChat (Maybe Message) |
28+ -- |Also a thing
29+ UserDialog UserId Message
29 deriving Show
30 deriving Show
30
31
31instance ToJSON Dialog where
32instance ToJSON Dialog where
@@ -42,7 +43,8 @@ instance ToJSON Dialog where
42 ]
43 ]
43 ]
44 ]
44
45
45−data ChatsResponse = ChatsResponse {
46+data ChatsResponse =
47+ ChatsResponse {
46 chatResponseMessageId :: MessageId,
48 chatResponseMessageId :: MessageId,
47 chatResponseMessageAuthorId :: Maybe UserId,
49 chatResponseMessageAuthorId :: Maybe UserId,
48 chatResponseMessageDestinationGroupId :: Maybe GroupChatId,
50 chatResponseMessageDestinationGroupId :: Maybe GroupChatId,
denis/src/Server/Query/Pagination.hs+1−5
@@ -11,11 +11,7 @@
11 UndecidableInstances,
11 UndecidableInstances,
12 UndecidableSuperClasses #-}
12 UndecidableSuperClasses #-}
13
13
14−module Server.Query.Pagination (
14+module Server.Query.Pagination where
15− PaginatingRequest(..),
16− PaginationDirection(..),
17− validatePaginationRequest
18− ) where
19
15
20import GHC.Generics
16import GHC.Generics
21import Data.Aeson as A
17import Data.Aeson as A
denis/src/Server/Server.hs+1−5
@@ -3,11 +3,7 @@
3 TypeOperators,
3 TypeOperators,
4 DataKinds #-}
4 DataKinds #-}
5
5
6−module Server.Server (
6+module Server.Server where
7− runServer,
8− hoistedServer,
9− getConfig
10−) where
11
7
12import Server.API
8import Server.API
13import Server.Auth
9import Server.Auth
denis/src/test/Orphans.hs−4
@@ -71,10 +71,6 @@ instance Arbitrary (PostElement p) where
71 arbitrary = genericArbitrary
71 arbitrary = genericArbitrary
72 shrink = genericShrink
72 shrink = genericShrink
73
73
74−instance Arbitrary PostQuote where
75− arbitrary = genericArbitrary
76− shrink = genericShrink
77−
78instance Arbitrary AnonymousChannel where
74instance Arbitrary AnonymousChannel where
79 arbitrary = genericArbitrary
75 arbitrary = genericArbitrary
80 shrink = genericShrink
76 shrink = genericShrink
sql/indexes.sqlnew file+20
@@ -0,0 +1,20 @@
1+CREATE OR REPLACE FUNCTION my_array_to_text(text[])
2+ RETURNS text LANGUAGE sql IMMUTABLE AS $$SELECT array_to_string($1, ' ')$$;
3+CREATE INDEX "faculty_text" ON "faculties" USING GIN (to_tsvector('russian', "facultyName" || ' ' || "facultyPath" || ' ' || "facultyCampusName" || ' ' || my_array_to_text("facultyTags")));
4+CREATE INDEX "faculty_name_path" ON "faculties" USING GIN (to_tsvector('russian', "facultyName" || ' ' || "facultyPath"));
5+CREATE INDEX "faculty_name" ON "faculties" USING GIN (to_tsvector('russian', "facultyName"));
6+CREATE INDEX group_chat_users ON "groupChats" USING gin ("groupChatUsers");
7+CREATE INDEX message_author ON messages USING btree ("messageStorageAuthorId");
8+CREATE INDEX message_group ON messages USING btree ("messageStorageDestinationGroupId");
9+CREATE INDEX message_user ON messages USING btree ("messageStorageDestinationUserId");
10+CREATE INDEX named_channel_owner ON channels USING btree ("namedChannelFullOwner");
11+CREATE INDEX post_author ON posts USING btree ("postRowAuthorId");
12+CREATE INDEX post_element_ord ON "postElements" USING btree ("rowElementId", "rowElementOrd");
13+CREATE INDEX post_tags ON posts USING gin ("postRowTags");
14+CREATE INDEX message_time on messages ("messageStorageTime");
15+CREATE INDEX post_time on posts ("postRowUpdateTime");
16+CREATE INDEX token_user on tokens ("tokenUserId");
17+CREATE INDEX token_time on tokens ("tokenExpiryDate");
18+CREATE INDEX token_value on tokens using hash ("tokenValue");
19+CREATE INDEX token_activation on tokens using hash ("tokenActivationCode");
20+CREATE INDEX token_deactivation on tokens using hash ("tokenDeactivationCode");