git.iko.soy/denis
on master help sign in
Added docs (?)
commit727d9cac6508f8c7e7a06b6386c1e7f95614bbaa authoriko <ilyakooo0@gmail.com> dateThu 16 May 2019, 05:45 (7 years ago) parent0771fc6
39 files changed+475−327
compare with master
unifiedsplit
denis/package.yaml+1 denis/sql/indexes.sql−5 denis/src/Data/Channel/AnonymousChannel.hs+4−3 denis/src/Data/Channel/NamedChannel.hs+11−5 denis/src/Data/Connection.hs+11−12 denis/src/Data/CyclicBuffer.hs+6−5 denis/src/Data/Faculty.hs+10−4 denis/src/Data/Faculty/Parser.hs+9−4 denis/src/Data/GroupChat.hs+12−9 denis/src/Data/Limits.hs+9−3 denis/src/Data/Message.hs+29−11 denis/src/Data/Post.hs+25−10 denis/src/Data/PostElement.hs+32−22 denis/src/Data/Query.hs+165−57 denis/src/Data/Schema.hs+3−5 denis/src/Data/Tags/Completions.hs+3−4 denis/src/Data/Tags/Validation.hs+4−4 denis/src/Data/Text/Validator.hs+8−9 denis/src/Data/User.hs+18−8 denis/src/Server/API.hs+14−13 denis/src/Server/API/Channels.hs+20−12 denis/src/Server/API/Completions.hs+4−7 denis/src/Server/API/Faculty.hs+2−5 denis/src/Server/API/Messages.hs+10−12 denis/src/Server/API/Posts.hs+8−4 denis/src/Server/App.hs+2−10 denis/src/Server/Auth.hs+14−20 denis/src/Server/Auth/HTML.hs+1−7 denis/src/Server/Auth/Mail.hs+2−3 denis/src/Server/Auth/Token.hs+1−9 denis/src/Server/Error.hs+1−8 denis/src/Server/Logger.hs+2−6 denis/src/Server/Periodic.hs+1−6 denis/src/Server/Query/ComplexQuery.hs+2−4 denis/src/Server/Query/Dialog.hs+9−7 denis/src/Server/Query/Pagination.hs+1−5 denis/src/Server/Server.hs+1−5 denis/src/test/Orphans.hs−4 sql/indexes.sql+20
denis/package.yaml+1
@@ -67,6 +67,7 @@ dependencies:
6767- generic-arbitrary
6868- quickcheck-instances
6969- http-client
70+- blaze-markup
7071
7172library:
7273 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 @@
88 OverloadedStrings,
99 RecordWildCards #-}
1010
11−module Data.Channel.AnonymousChannel (
12− AnonymousChannel(..)
13−) where
11+module Data.Channel.AnonymousChannel where
1412
1513import qualified Generics.SOP as SOP
1614import qualified GHC.Generics as GHC
@@ -34,8 +32,11 @@ instance HasValidatableText AnonymousChannel where
3432
3533-- MARK: Implementation
3634
35+-- |Анонимные канал -- канал, который не хрнится на сервере.
3736data AnonymousChannel = AnonymousChannel {
37+ -- |Список тегов в канале
3838 anonymousChannelTags :: V.Vector Text,
39+ -- |Список людей в анонимном канале
3940 anonymousChannelPeopleIds :: [UserId]
4041} deriving GHC.Generic
4142
denis/src/Data/Channel/NamedChannel.hs+11−5
@@ -8,11 +8,7 @@ TypeOperators,
88OverloadedStrings,
99RecordWildCards #-}
1010
11−module Data.Channel.NamedChannel (
12− NamedChannelId,
13− NamedChannel(..),
14− NamedChannelCreationRequest(..)
15−) where
11+module Data.Channel.NamedChannel where
1612
1713import Data.Int (Int64)
1814import qualified Generics.SOP as SOP
@@ -44,13 +40,19 @@ instance HasValidatableText (NamedChannelCreationRequest) where
4440
4541-- MARK: Implementation
4642
43+-- |Тип -- идентификатор именнованного канала.
4744type NamedChannelId = Int64
4845
4946-- Note: Channel owner only exists in sql
47+-- |Структура данных именованного канала.
5048data NamedChannel u = NamedChannel {
49+ -- |Идентификатор именованного канала.
5150 namedChannelId :: NamedChannelId,
51+ -- |Имя именнованного канала.
5252 namedChannelName :: Text,
53+ -- |Список тегов в именованном канале.
5354 namedChannelTags :: V.Vector Text,
55+ -- |Список идентификаторов пользователей в именованном канале.
5456 namedChannelPeopleIds :: V.Vector u
5557} deriving GHC.Generic
5658
@@ -70,9 +72,13 @@ instance (FromJSON u, Ord u) => FromJSON (NamedChannel u) where
7072
7173-- MARK: NamedChannelCreationRequest
7274
75+-- |Объект-запрос на создание именованного канала.
7376data NamedChannelCreationRequest = NamedChannelCreationRequest {
77+ -- |Название канала.
7478 namedChannelCreationRequestName :: Text,
79+ -- |Список тегов в канале.
7580 namedChannelCreationRequestTags :: V.Vector Text,
81+ -- |Список идентификаторов пользователей в канале.
7682 namedChannelCreationRequestPeopleIds :: V.Vector UserId
7783} deriving GHC.Generic
7884
denis/src/Data/Connection.hs+11−12
@@ -7,18 +7,7 @@
77 TypeOperators,
88 FlexibleContexts #-}
99
10−module Data.Connection (
11− Connection,
12− StaticPQ,
13− runQ,
14− runQ',
15− runQnotFound,
16− runQerror,
17− maybeNotFound,
18− maybeInvalidToken,
19− commitedTransactionallyUpdate,
20− runQsilent
21−) where
10+module Data.Connection where
2211
2312import Squeal.PostgreSQL
2413import Squeal.PostgreSQL.Pool
@@ -30,39 +19,49 @@ import Servant.Server
3019import Server.Error
3120import Control.Monad.Trans.Control
3221
22+-- |Монада для совершения запросов и манимпуляций с базой данных в рамках сервера.
3323type StaticPQ = PoolPQ Schema Handler
3424
25+-- |Функция, печатающая текст красным цветом в консоль.
3526printRed :: (Show a) => a -> IO ()
3627printRed a = do
3728 putStr "\a\x001b[31m"
3829 print a
3930 putStr "\x001b[0m"
4031
32+-- |Функция, выполняющая запрос к бае данных.
4133runQ :: ServantErr -> StaticPQ a -> App a
4234runQ err req = handleSqueal ((>> throwError err) . liftIO . printRed) $ asks getPool >>= lift . runPoolPQ req
4335
36+-- |Функция, выполняющая запрос к бае данных.
4437runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a
4538runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn
4639
40+-- |Функция, выполняющая запрос к бае данных.
4741runQnotFound :: StaticPQ a -> App a
4842runQnotFound = runQ err404
4943
44+-- |Функция, выполняющая запрос к бае данных.
5045runQerror :: StaticPQ a -> App a
5146runQerror = runQ err500
5247
48+-- |Функция, выполняющая запрос к бае данных.
5349runQsilent :: StaticPQ a -> App ()
5450runQsilent req = handleSqueal (liftIO . print) $ asks getPool >>= lift . runPoolPQ req
5551 >> return ()
5652
53+-- |Функция, выкидывающая исключение при отсутсвии значения.
5754maybeNotFound :: App (Maybe a) -> App a
5855maybeNotFound = (>>= (\t -> case t of
5956 Just y -> return y
6057 Nothing -> throwError err404))
6158
59+-- |Функция, выкидывающая исключение при отсутсвии значения.
6260maybeInvalidToken :: App (Maybe a) -> App a
6361maybeInvalidToken = (>>= (\t -> case t of
6462 Just y -> return y
6563 Nothing -> throwError invalidToken))
6664
65+-- |Функция, совершающая операцию внутри транакции базы данных.
6766commitedTransactionallyUpdate :: (MonadBaseControl IO tx, MonadPQ schema tx) => tx x -> tx x
6867commitedTransactionallyUpdate = transactionally $ TransactionMode ReadCommitted ReadWrite NotDeferrable
denis/src/Data/CyclicBuffer.hs+6−5
@@ -1,18 +1,19 @@
11{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
22
3−module Data.CyclicBuffer (
4− CyclicBuffer(elems),
5− mkCyclicBuffer,
6− insertIntoCyclicBuffer
7−) where
3+module Data.CyclicBuffer where
84
5+-- |Объект циклического буфера
96data CyclicBuffer a = CyclicBuffer {
7+ -- |Элементы в циклическом буфере
108 elems :: [a],
9+ -- |Количество элементов в циклическом буфере
1110 limit :: Int
1211}
1312
13+-- |Функция, создающая циклический буфер с данным размером
1414mkCyclicBuffer :: Int -> CyclicBuffer a
1515mkCyclicBuffer lim = CyclicBuffer [] lim
1616
17+-- |Функция, добавлющая эоемент в циклический буфер
1718insertIntoCyclicBuffer :: CyclicBuffer a -> a -> CyclicBuffer a
1819insertIntoCyclicBuffer (CyclicBuffer els lim) el = CyclicBuffer (take lim $ el:els) lim
denis/src/Data/Faculty.hs+10−4
@@ -8,10 +8,7 @@
88 OverloadedStrings,
99 DeriveAnyClass #-}
1010
11−module Data.Faculty (
12− Faculty(..),
13− FacultyUrl
14− ) where
11+module Data.Faculty where
1512
1613import qualified Generics.SOP as SOP
1714import qualified GHC.Generics as GHC
@@ -24,15 +21,24 @@ instance ToSample Faculty where
2421 toSamples _ = singleSample $ Faculty "ПИ" "cs.hse.ru/bse" "ФКН -> ПИ" "Москва" "193729"
2522 (V.fromList ["Программирование", "Естсественные науки"]) "Настоящий адрес факультета"
2623
24+-- |Адрес сайта департамента
2725type FacultyUrl = T.Text
2826
27+-- |Объект департамента
2928data Faculty = Faculty {
29+ -- |Название департамента
3030 facultyName :: T.Text,
31+ -- |Адрес сайта департамента
3132 facultyUrl :: FacultyUrl,
33+ -- |Вспомогательный текст дапартамента с сайта
3234 facultyPath :: T.Text,
35+ -- |Название кампуса
3336 facultyCampusName :: T.Text,
37+ -- |Код кампуса департамента
3438 facultyCampusCode :: T.Text,
39+ -- |Теги департамента
3540 facultyTags :: V.Vector T.Text,
41+ -- |Адрес департамента
3642 facultyAddress :: T.Text
3743} deriving (GHC.Generic, Show, SOP.Generic, SOP.HasDatatypeInfo)
3844
denis/src/Data/Faculty/Parser.hs+9−4
@@ -2,9 +2,7 @@
22 OverloadedStrings,
33 TupleSections #-}
44
5−module Data.Faculty.Parser (
6− getFaculties
7− ) where
5+module Data.Faculty.Parser where
86
97import Network.HTTP.Req
108import qualified Data.Text as T
@@ -18,17 +16,20 @@ import Control.Monad.IO.Class
1816import Data.Default
1917import qualified Data.Vector as V
2018
19+-- |Функция, возвращающая список факультетов с сайта ВШЭ.
2120getFaculties :: MonadIO m => m [Faculty]
2221getFaculties = runReq def $ do
2322 campuses <- getCampuses
2423 concat <$> mapM (\c -> getFacultiesForCampus c) campuses
2524
25+-- |Функция для отправки HTTP запроса.
2626sendReq
2727 :: MonadHttp f
2828 => Url scheme
2929 -> f LT.Text
3030sendReq url = decodeUtf8 . responseBody <$> req GET url NoReqBody lbsResponse mempty
3131
32+-- |Функция, возвращающая список кампусов с сайта ВШЭ.
3233getCampuses :: Req [Campus]
3334getCampuses = do
3435 let url = https "www.hse.ru" /: "org" /: "units"
@@ -45,7 +46,7 @@ getCampuses = do
4546 code <- HM.lookup "hse-value" hm
4647 return $ Campus (T.strip name) code
4748
48−
49+-- |Функция, возвращающая список подразделений для данного кампуса.
4950getFacultiesForCampus :: Campus -> Req [Faculty]
5051getFacultiesForCampus (Campus cName cCode) = do
5152 let url = https "www.hse.ru" /: "org" /: "units" /: "campus" /: cCode
@@ -67,18 +68,22 @@ getFacultiesForCampus (Campus cName cCode) = do
6768 let address = T.unwords . map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "link link_dark i") $ els
6869 return $ Faculty name url path cName cCode (V.fromList tags) address
6970
71+-- |Функция, проверяющая, имеет ли данный HTML тег атрибут принадлежности к данному классу.
7072classIs :: T.Text -> Element -> Bool
7173classIs c = (== (Just c)) . HM.lookup "class" . eltAttrs
7274
75+-- |Фозвращает список всех подэлементов данного HTML тега при поиске в глубину.
7376elements :: [Node] -> [Element]
7477elements ((NodeElement el):nn) = el : ((elements . eltChildren) el ++ elements nn)
7578elements _ = []
7679
80+-- |Функция, возвращающая список всего текстового содержания HTML тегов.
7781texts' :: HM.HashMap T.Text T.Text -> [Node] -> [(HM.HashMap T.Text T.Text, T.Text)]
7882texts' hm (NodeContent t: nn) = (hm, t) : texts' hm nn
7983texts' hm ((NodeElement el):nn) = ((texts' (HM.union (eltAttrs el) hm) (eltChildren el)) ++ texts' hm nn)
8084texts' _ _ = []
8185
86+-- |Объкт кампуса.
8287data Campus = Campus {
8388 campusName :: T.Text,
8489 campusCode :: T.Text
denis/src/Data/GroupChat.hs+12−9
@@ -12,15 +12,7 @@
1212{-# OPTIONS_GHC -Wno-orphans #-}
1313
1414
15−module Data.GroupChat (
16− GroupChat(..),
17− GroupChatPermissions(..),
18− GroupChatId,
19− UserPermissions,
20− GroupChatCreation(..),
21− maxChatPermissions,
22− minChatPermissions
23− ) where
15+module Data.GroupChat where
2416
2517import Data.Aeson
2618import Data.Int (Int64)
@@ -56,12 +48,18 @@ instance HasValidatableText GroupChatCreation where
5648instance ToSample UserPermissions where
5749 toSamples _ = singleSample $ M.fromList [(69, GroupChatPermissions True), (5051, GroupChatPermissions False)]
5850
51+-- |Идентификатор групповой беседы.
5952type GroupChatId = Int64
53+-- |Права участников групповой беседы.
6054type UserPermissions = M.Map UserId GroupChatPermissions
6155
56+-- |Объект групповой беседы.
6257data GroupChat = GroupChat {
58+ -- |Идентификатор групповой беседы.
6359 groupChatId :: GroupChatId,
60+ -- |Права участников беседы.
6461 groupChatUsers :: Jsonb UserPermissions,
62+ -- |Имя групповой беседы.
6563 groupChatName :: Text
6664} deriving (Show, GHC.Generic)
6765
@@ -78,14 +76,18 @@ instance FromJSON GroupChat where
7876 parseJSON = withObject "group chat" $ \e ->
7977 GroupChat <$> e .: "id" <*> (Jsonb <$> e .: "users") <*> e .: "name"
8078
79+-- |Права участника беседы
8180data GroupChatPermissions = GroupChatPermissions {
8281 -- canInvite :: Bool,
8382 -- canKick :: Bool,
83+ -- |Является ли данный участник администратором
8484 isAdmin :: Bool
8585} deriving (Show, GHC.Generic)
8686
87+-- |Максимально возможные права в групповой беседе.
8788maxChatPermissions :: GroupChatPermissions
8889maxChatPermissions = GroupChatPermissions True -- True True
90+-- |Минимально возможные права в групповой беседе.
8991minChatPermissions :: GroupChatPermissions
9092minChatPermissions = GroupChatPermissions False
9193
@@ -100,6 +102,7 @@ instance SOP.HasDatatypeInfo GroupChatPermissions
100102instance ToJSON GroupChatPermissions
101103instance FromJSON GroupChatPermissions
102104
105+-- |Объект для создания групповой беседы
103106data GroupChatCreation = GroupChatCreation {
104107 groupChatCreationUsers :: Jsonb UserPermissions,
105108 groupChatCreationName :: Text
denis/src/Data/Limits.hs+9−3
@@ -4,32 +4,38 @@ module Data.Limits where
44
55import Data.Int (Int64)
66
7+-- |Максимально возможное количество количество символов в нвазвании канала.
78maxChannelName :: Int
89maxChannelName = 60
910
11+-- |Максимально возможное количество количество символов в нвазвании групповой беседы.
1012maxGroupChatName :: Int
1113maxGroupChatName = 60
1214
13−maxMessageLimitName :: Int
14−maxMessageLimitName = 60
15−
15+-- |Максимальное количество элементов в элементе поста
1616postElementLengthLimit :: Int
1717postElementLengthLimit = 35000
1818
19+-- |Максимальное число символов в поле пользователя
1920userFieldLengthLimit :: Int
2021userFieldLengthLimit = 50
2122
23+-- |максимальное число тегов
2224maxNumberOfTags :: Int
2325maxNumberOfTags = 20
2426
27+-- |максимальное число именнованных каналов у пользователя
2528channelCountLimit :: Int64
2629channelCountLimit = 128
2730
31+-- |Максимальное число элементов, возвращаемых в списке запроса
2832listLimit :: Int
2933listLimit = 100
3034
35+-- |глобальное ограничение на количество символов в пользовательском тексте.
3136globalTextLimit :: Int
3237globalTextLimit = 50000
3338
39+-- |Максимальное число пользователей в групповой беседе
3440groupChatSizeLimit :: Int
3541groupChatSizeLimit = 256
denis/src/Data/Message.hs+29−11
@@ -11,15 +11,7 @@
1111{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
1212
1313
14−module Data.Message (
15− MessageStorage(..),
16− Message(..),
17− MessageDetination(..),
18− MessageId,
19− restoreMessage,
20− storeMessage,
21− MessageCreation(..)
22− ) where
14+module Data.Message where
2315
2416import Data.Aeson
2517import Data.PostElement
@@ -51,18 +43,31 @@ instance HasValidatableText Message where
5143instance HasValidatableText MessageCreation where
5244 validateText (MessageCreation _ _ (Jsonb mb)) = validateText mb
5345
46+-- |Идентификатор сообщения в групповой беседе.
5447type GroupChatMessageId = Int64
5548
56−data MessageDetination = GroupChatDestination GroupChatId | UserChatDestination UserId
49+-- |Адресат сообщения.
50+data MessageDetination
51+ -- |Групповая беседа.
52+ = GroupChatDestination GroupChatId
53+ -- |Пользоваель.
54+ | UserChatDestination UserId
5755 deriving (Show)
5856
57+-- |Идентификатор сообщения
5958type MessageId = Int64
6059
60+-- |Объект обычного представления сообщения.
6161data Message = Message {
62+ -- |Идентификатор сообщения.
6263 messageId :: MessageId,
64+ -- |Идентификатор автора сообщения.
6365 messageAuthorId :: UserId,
66+ -- |Адресат сообщения.
6467 messageDestinationId :: MessageDetination,
68+ -- |Содержание сообщения.
6569 messageBody :: PostElement Message,
70+ -- |Время отправки сообщения.
6671 messageTime :: UTCTime
6772} deriving (Show)
6873
@@ -86,13 +91,19 @@ instance FromJSON Message where
8691 <*> e .: "body"
8792 <*> e .: "time"
8893
89−
94+-- |Объект для представления сообщения в базе данных.
9095data MessageStorage = MessageStorage {
96+ -- |Идентификатор сообщения.
9197 messageStorageId :: MessageId,
98+ -- |Идентификатор автора сообщения.
9299 messageStorageAuthorId :: Maybe UserId,
100+ -- |Идентификатор групповой беседы как адресата сообщения.
93101 messageStorageDestinationGroupId :: Maybe GroupChatId,
102+ -- |Идентификатор пользователя как адресата сообщения.
94103 messageStorageDestinationUserId :: Maybe UserId,
104+ -- |Содержание сообщения.
95105 messageStorageBody :: Maybe (Jsonb (PostElement Message)),
106+ -- |Время отправки сообщения.
96107 messageStorageTime :: UTCTime
97108} deriving GHC.Generic
98109
@@ -101,9 +112,11 @@ instance SOP.HasDatatypeInfo (MessageStorage)
101112
102113infixl 4 <>>
103114
115+-- |Оператор, применяющий функция в функторе к объекту вне функтора.
104116(<>>) :: Applicative f => f (a -> b) -> a -> f b
105117f <>> a = f <*> pure a
106118
119+-- |Функция, переводящая представление сообщения из базы данных в обычное.
107120restoreMessage :: MessageStorage -> Maybe Message
108121restoreMessage (MessageStorage mId (Just aId) gId uId (Just (Jsonb pb)) mt) =
109122 Message mId aId <$> case (gId, uId) of
@@ -113,6 +126,7 @@ restoreMessage (MessageStorage mId (Just aId) gId uId (Just (Jsonb pb)) mt) =
113126 <>> pb <>> mt
114127restoreMessage _ = Nothing
115128
129+-- |Функция переводящая обычное представление сообщения в представление для базы данных.
116130storeMessage :: Message -> MessageStorage
117131storeMessage (Message mId aId dId pb mt) = case dId of
118132 GroupChatDestination gId -> MessageStorage mId (Just aId) (Just gId) Nothing (Just (Jsonb pb)) mt
@@ -124,9 +138,13 @@ instance ToSample MessageCreation where
124138 (MessageCreation (Just 5) Nothing <$>
125139 map (Jsonb . snd) (toSamples Proxy))
126140
141+-- |Объект для создания сообщения.
127142data MessageCreation = MessageCreation {
143+ -- |Идентификатор групповой беседы - адресата сообщения.
128144 messageCreationDestinationGroupId :: Maybe GroupChatId,
145+ -- |Идентификатор пользователя - адресата сообщения.
129146 messageCreationDestinationUserId :: Maybe UserId,
147+ -- |Содержание сообщения.
130148 messageCreationBody :: Jsonb (PostElement (MessageCreation))
131149} deriving (Show, GHC.Generic)
132150
denis/src/Data/Post.hs+25−10
@@ -7,15 +7,7 @@
77 TypeOperators,
88 OverloadedStrings #-}
99
10−module Data.Post (
11− Post(..),
12− PostElement,
13− rowsToPost,
14− PostId,
15− QuoteId,
16− PostRowResponse(..),
17− PostCreation(..)
18−) where
10+module Data.Post where
1911
2012import Data.Int (Int64)
2113import qualified Generics.SOP as SOP
@@ -46,14 +38,22 @@ instance HasValidatableText PostCreation where
4638
4739-- MARK: Actual type
4840
41+-- |Идентификатор поста.
4942type PostId = Int64
43+-- |Идентификатор цитаты.
5044type QuoteId = Int64
5145
46+-- |Объект поста
5247data Post = Post {
48+ -- |Идентификатор поста.
5349 postId :: Int64,
50+ -- |Идентификатор автора поста.
5451 postAuthorId :: Int64,
52+ -- |Время последнего обновления поста.
5553 updated :: UTCTime,
54+ -- |Теги поста.
5655 postTags :: V.Vector Text,
56+ -- |Содержание поста.
5757 postBody :: [PostElement Post]
5858} deriving (Show)
5959
@@ -65,8 +65,11 @@ instance ToJSON Post where
6565 "tags" .= tags,
6666 "body" .= pb ]
6767
68+-- |Объект для создания поста
6869data PostCreation = PostCreation {
70+ -- |Содержание поста.
6971 postCreationBody :: [PostElement Post],
72+ -- |Теги поста.
7073 postCreationTags :: V.Vector Text
7174} deriving GHC.Generic
7275
@@ -86,29 +89,41 @@ instance FromJSON PostCreation where
8689-- MARK: Rows
8790
8891-- Need to manually maintain. Future: https://github.com/morphismtech/squeal/issues/96
89−
92+-- |Объект поста при ответе с базы данных.
9093data PostRowResponse = PostRowResponse {
9194 -- PostRow
95+ -- |Идентификатор поста.
9296 postRowId :: Int64,
97+ -- |Идентификатор автора поста.
9398 postRowAuthorId :: Int64,
99+ -- |Время последнего обновления поста.
94100 postRowUpdateTime :: UTCTime,
101+ -- |Теги поста.
95102 postRowTags :: V.Vector Text,
96103
97104 -- ElementRow
105+ -- |Порядковый номер элемента поста.
98106 rowElementOrd :: Int64,
107+ -- |Markdown элемент поста.
99108 rowElementMarkdown :: Maybe Text,
109+ -- |Latex элемент поста.
100110 rowElementLatex :: Maybe Text,
111+ -- |Изображение.
101112 rowElementImage :: Maybe Text,
113+ -- |Цитата.
102114 rowElementQuote :: Maybe Int64,
115+ -- |Файл.
103116 rowElementAttachment :: Maybe Text
104117} deriving (GHC.Generic)
105118
106119instance SOP.Generic PostRowResponse
107120instance SOP.HasDatatypeInfo PostRowResponse
108121
122+-- |Функция, переводящая объект поста при ответе с базы данных в какой-то поста при помощи данного отображения.
109123unRow :: MkElementRow x -> PostRowResponse -> x
110124unRow f' (PostRowResponse _ _ _ _ _ a b c d e) = f' a b c d e
111125
126+-- |Функция, переводящая объект поста при ответе с базы данных в обычный объект поста.
112127rowsToPost :: [PostRowResponse] -> Maybe Post
113128rowsToPost [] = Nothing
114129rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
denis/src/Data/PostElement.hs+32−22
@@ -9,15 +9,7 @@
99{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
1010
1111
12−module Data.PostElement (
13− elemenToRow,
14− rowsToElement,
15− MkElementRow,
16− PostElementRow(..),
17− PostElement(..),
18− elementsToRows,
19− PostQuote(..)
20−) where
12+module Data.PostElement where
2113
2214import Data.Int (Int64)
2315import qualified Generics.SOP as SOP
@@ -47,10 +39,17 @@ instance HasValidatableText (PostElement p) where
4739
4840-- MARK: PostElement
4941
50−data PostElement a = Markdown Text
42+-- |Обычный элемент поста.
43+data PostElement a
44+ -- |Markdown элемент поста.
45+ = Markdown Text
46+ -- |Latex элемент поста.
5147 | Latex Text
48+ -- |Изорбражение.
5249 | Image Text
50+ -- |Цитата.
5351 | Quote ()
52+ -- |Документ.
5453 | Attachment Text
5554 deriving (Show, GHC.Generic)
5655
@@ -72,8 +71,10 @@ instance FromJSON (PostElement t) where
7271
7372-- -- MARK: PostElementRows
7473
74+-- |Тип отображения из элемента поста с базы данных в другой объект.
7575type MkElementRow x = Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> x
7676
77+-- |Функция, переводящая обычный элемент поста в другой объект.
7778elemenToRow :: MkElementRow x -> PostElement p -> x
7879elemenToRow f el = case el of
7980 Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
@@ -83,6 +84,7 @@ elemenToRow f el = case el of
8384 Quote _ -> f Nothing Nothing Nothing Nothing Nothing
8485 Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
8586
87+-- |Отображение элемента поста с базы данных в обычный элемент поста.
8688rowsToElement :: MkElementRow (Maybe (PostElement p))
8789rowsToElement (Just m) Nothing Nothing Nothing Nothing = Just $ Markdown m
8890rowsToElement Nothing (Just l) Nothing Nothing Nothing = Just $ Latex l
@@ -92,37 +94,45 @@ rowsToElement Nothing Nothing (Just i) Nothing Nothing = Just $ Image i
9294rowsToElement Nothing Nothing Nothing Nothing (Just a) = Just $ Attachment a
9395rowsToElement _ _ _ _ _ = Nothing
9496
97+-- |Объект поста с базы данных
9598data PostElementRow a = PostElementRow {
99+ -- |Идентификатор элемента поста
96100 rowElementId :: Int64,
101+ -- |Порядковый номер элемента поста.
97102 rowElementOrd :: Int64,
103+ -- |Markdown элемент.
98104 rowElementMarkdown :: Maybe Text,
105+ -- |LaTeX элемент.
99106 rowElementLatex :: Maybe Text,
107+ -- |Изорбражение.
100108 rowElementImage :: Maybe Text,
109+ -- |Цитата.
101110 rowElementQuote :: Maybe Int64,
111+ -- |Приложение.
102112 rowElementAttachment :: Maybe Text
103113} deriving (GHC.Generic)
104114
105115instance SOP.Generic (PostElementRow a)
106116instance SOP.HasDatatypeInfo (PostElementRow a)
107117
108−
118+-- |Функция, переводящая обычные элементы постоа в их представления для базы данных.
109119elementsToRows :: Int64 -> [PostElement a] -> [PostElementRow a]
110120elementsToRows pId els = map (\(el, f) -> elemenToRow f el) . zip els . map (PostElementRow pId) $ [0..]
111121
112122
113123-- -- MARK: Quote
114124
115−data PostQuote = PostQuote {
116− quoteId :: Int64,
117− quoteBody :: [PostElement PostQuote],
118− quotePostId :: Int64
119−} deriving (Show, GHC.Generic)
120−
121−instance ToJSON PostQuote where
122− toJSON (PostQuote qId pb pId) = object [
123− "id" .= qId,
124− "postId" .= pId,
125− "quoteBody" .= pb ]
125+-- data PostQuote = PostQuote {
126+-- quoteId :: Int64,
127+-- quoteBody :: [PostElement PostQuote],
128+-- quotePostId :: Int64
129+-- } deriving (Show, GHC.Generic)
130+
131+-- instance ToJSON PostQuote where
132+-- toJSON (PostQuote qId pb pId) = object [
133+-- "id" .= qId,
134+-- "postId" .= pId,
135+-- "quoteBody" .= pb ]
126136
127137
128138-- -- MARK: PostQuoteRow
denis/src/Data/Query.hs+165−57
@@ -15,59 +15,7 @@
1515{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
1616
1717
18−module Data.Query (
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
18+module Data.Query where
7119
7220import Squeal.PostgreSQL
7321import Data.User
@@ -110,6 +58,9 @@ import qualified Data.Vector as V
11058import Server.Auth.Token
11159import Server.Error
11260import Data.Text.Validator
61+import Control.Monad.Except
62+import Control.Monad.IO.Class
63+import Crypto.Hash.SHA512 (hash)
11364
11465-- MARK: Documentation
11566
@@ -122,14 +73,17 @@ instance (ToSample r) => ToSample (ResponseWithUsers r) where
12273type TableEndo schema params from grouping = TableExpression schema params from grouping ->
12374 TableExpression schema params from grouping
12475
76+-- |Функция, возвращаяющая запрос на посты, прменяя к нему данный ндоморфизм.
12577postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
12678postsQ te = selectStar $ te (from $ table #posts)
12779
80+-- |Функция, возвращающая посты
12881postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped
12982postViewT te = from $ subquery (postsQ te `As` #posts) &
13083 innerJoin (table #postElements)
13184 (#posts ! #postRowId .== #postElements ! #rowElementId)
13285
86+-- |Функция, возвращающая запрос на поста, примення два промежуточных эндоморфизма к таблице.
13387getPostQ
13488 :: TableEndo Schema params _ 'Ungrouped
13589 -- ^ PostRowResponse endo
@@ -172,6 +126,7 @@ getPostQ oTe te = select (
172126-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
173127-- return $ M.lookup qId rows >>= rowsToQuote rows
174128
129+-- |Запрос, возвращающий пользователя по адресу почты.
175130getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))
176131getUserWithEmailQ = select (
177132 #userRowId `as` #userId :*
@@ -184,6 +139,7 @@ getUserWithEmailQ = select (
184139 where_ (#userRowEmail .== param @1) &
185140 where_ (notNull #userRowIsValidated))
186141
142+-- |Запрос, возвращающий подтвержденных пользователей.
187143verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
188144verifiedUserIdsQ uIds = case idsToColumn uIds of
189145 Just idQ -> Just $ select (#users ! #userRowId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
@@ -191,6 +147,7 @@ verifiedUserIdsQ uIds = case idsToColumn uIds of
191147 (#ids ! #id .== #users ! #userRowId))
192148 Nothing -> Nothing
193149
150+-- |Запрос, возвращающий пользователей с данными идентификаторами.
194151getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))
195152getUsersQ uIds = case idsToColumn uIds of
196153 Just idQ -> Just $ select (
@@ -216,6 +173,7 @@ getUsersQ uIds = case idsToColumn uIds of
216173 where_ (notNull $ #users ! #userRowIsValidated))
217174 Nothing -> Nothing
218175
176+-- |Запорс, возвращающий всех пользователей.
219177getAllUsersQ :: Query Schema '[] (RowPG UserRow)
220178getAllUsersQ = select (
221179 #users ! #userRowId :*
@@ -237,6 +195,7 @@ getAllUsersQ = select (
237195 (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&
238196 where_ (notNull $ #users ! #userRowIsValidated))
239197
198+-- |Запрос, возвращающий все посты по идентификатору.
240199getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
241200getPostsByIdQ pIds = case idsToColumn pIds of
242201 Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
@@ -245,14 +204,17 @@ getPostsByIdQ pIds = case idsToColumn pIds of
245204 (#ids ! #id .== #posts ! #postRowId))
246205 Nothing -> Nothing
247206
207+-- |Ограничение
248208type Limit = Word64
249209
210+-- |SQL оператор IS NOT FALSE
250211isNotFalse
251212 :: Expression schema from grouping params ('Null ty)
252213 -- ^ possibly @NULL@
253214 -> Condition schema from grouping params
254215isNotFalse x = UnsafeExpression $ renderExpression x <+> "IS NOT FALSE"
255216
217+-- |Запрос, возвращающий последние посты.
256218getLastPostsQ
257219 :: TableEndo _ _ _ _
258220 -> Limit
@@ -267,12 +229,14 @@ getLastPostsQ te lim dir = getPostQ
267229 where
268230 ((.^), order) = directionToOperator dir
269231
232+-- |Запрос, возвращающий последние посты для данного пользователя.
270233getLastNPostsForUserQ
271234 :: Limit
272235 -> P.PaginationDirection
273236 -> Query Schema (TuplePG (Maybe PostId, UserId)) (RowPG PostRowResponse)
274237getLastNPostsForUserQ = getLastPostsQ $ where_ (#posts ! #postRowAuthorId .== param @2)
275238
239+-- |Запрос на создание поста.
276240createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
277241createPostRowQ = insertRow #posts
278242 (Default `as` #postRowId :*
@@ -282,6 +246,7 @@ createPostRowQ = insertRow #posts
282246 OnConflictDoRaise
283247 (Returning $ #postRowId `as` #fromOnly)
284248
249+-- |Запрос на создание элементов постов.
285250createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
286251createPostElementRowsQ = insertRow_ #postElements
287252 (Set (param @1) `as` #rowElementId :*
@@ -292,11 +257,13 @@ createPostElementRowsQ = insertRow_ #postElements
292257 Set (param @6) `as` #rowElementQuote :*
293258 Set (param @7) `as` #rowElementAttachment)
294259
260+-- |Запрос, возвращающий канал для данного пользователя.
295261getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
296262getChannelForUserQ = selectStar $
297263 from (table #channels) &
298264 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
299265
266+-- |Запрос, обновляющий данные о пользователе.
300267updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))
301268updateUserQ = update #users (
302269 Same `as` #userRowId :*
@@ -309,12 +276,14 @@ updateUserQ = update #users (
309276 (#userRowId .== param @1)
310277 (Returning $ #userRowId `as` #fromOnly)
311278
279+-- |Запрос, возвращающий каналы пользователя.
312280getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
313281getAllChannelsForUserQ = selectStar $
314282 from (table #channels) &
315283 where_ (#namedChannelFullOwner .== param @1) &
316284 orderBy [#namedChannelFullId & Desc]
317285
286+-- |Запрос, осуществляющий поиск по каналам данного пользователя.
318287searchChannelsForUserQ :: Query Schema (TuplePG (UserId, Text)) (RowPG NamedChannelFull)
319288searchChannelsForUserQ = selectStar $
320289 from (table #channels) &
@@ -331,6 +300,7 @@ searchChannelsForUserQ = selectStar $
331300 vector1 = tsVector' #namedChannelFullName
332301 query = tsQuery' (param @2)
333302
303+-- |Запрос, обновляющий факультет.
334304updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
335305updateFacultyQ = insertRow #faculties
336306 (
@@ -345,10 +315,12 @@ updateFacultyQ = insertRow #faculties
345315 (OnConflictDoNothing)
346316 (Returning Nil)
347317
318+-- |Запрос, возвращающий факультет.
348319getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
349320getFacultyQ = selectStar (from (table #faculties) &
350321 where_ (#facultyUrl .== param @1))
351322
323+-- |Запрос на создание нового именованного канала.
352324createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
353325createNamedChannelQ = insertRow #channels
354326 (
@@ -361,14 +333,17 @@ createNamedChannelQ = insertRow #channels
361333 OnConflictDoRaise
362334 (Returning $ #namedChannelFullId `as` #fromOnly)
363335
336+-- |Запрос, возвращающий количество каналов у данного пользователя.
364337countChannelsQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only Int64))
365338countChannelsQ = select (countStar `as` #fromOnly) (from (table #channels) &
366339 where_ (#namedChannelFullOwner .== param @1) &
367340 groupBy #namedChannelFullOwner)
368341
342+-- |Запрос, удаляющий канал у данного пользователя.
369343deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
370344deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
371345
346+-- |Запрос, обновляющий именованный канал.
372347updateNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelFull) '[]
373348updateNamedChannelQ = update_ #channels
374349 (
@@ -380,6 +355,7 @@ updateNamedChannelQ = update_ #channels
380355 )
381356 (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)
382357
358+-- |Запрос на каналы пользователя.
383359getChannelPostsQ
384360 :: Limit
385361 -> P.PaginationDirection
@@ -398,10 +374,12 @@ getChannelPostsQ lim dir uIds tags = getLastPostsQ
398374 Just uIdsQ -> (`in_` uIdsQ)
399375 Nothing -> const $ false
400376
377+-- |Запрос на все хэштеги.
401378getTagsQ :: Query Schema params (RowPG (Only String))
402379getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
403380 from (table #posts)
404381
382+-- |Запорс на создание сообщения.
405383createMessageQ :: Manipulation
406384 Schema
407385 (TuplePG (UserId, Maybe GroupChatId, Maybe UserId, Jsonb (PostElement (MessageCreation))))
@@ -418,6 +396,7 @@ createMessageQ = insertRow #messages
418396 OnConflictDoRaise
419397 (Returning $ #messageStorageId `as` #fromOnly)
420398
399+-- |Запрос на создание фантомного сообщения.
421400createPhantomMessageQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]
422401createPhantomMessageQ = insertRow_ #messages
423402 (
@@ -429,6 +408,7 @@ createPhantomMessageQ = insertRow_ #messages
429408 Set currentTimestamp `as` #messageStorageTime
430409 )
431410
411+-- |Запрос на создание групповой беседы.
432412createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
433413createGroupChatQ = insertRow #groupChats
434414 (
@@ -439,6 +419,7 @@ createGroupChatQ = insertRow #groupChats
439419 OnConflictDoRaise
440420 (Returning $ #groupChatId `as` #fromOnly)
441421
422+-- |Запрос на обновление групповой беседы.
442423updateGroupChatQ :: Manipulation Schema (TuplePG GroupChat) '[]
443424updateGroupChatQ = update_ #groupChats
444425 (
@@ -448,23 +429,27 @@ updateGroupChatQ = update_ #groupChats
448429 )
449430 (#groupChatId .== param @1)
450431
432+-- |Тип строки, воозвращаемой в промежуточном запросе на все диалоги.
451433type ChatsQueryResponse = '[
452434 "messageId" ::: 'NotNull (PG UserId),
453435 "messageGroupId" ::: 'Null (PG UserId),
454436 "messageUserId" ::: 'Null (PG UserId)
455437 ]
456438
439+-- |Тип оператора сравнения.
457440type ConditionOp schema from grouping params nullity0 nullity1 (ty :: PGType)
458441 = Expression schema from grouping params (nullity0 ty)
459442 -> Expression schema from grouping params (nullity1 ty)
460443 -> Condition schema from grouping params
461444
445+-- |Тип параметров на запрос диалогов.
462446type ChatQueryParams = TuplePG
463447 ( UserId
464448 , Maybe String -- Just UserId as String
465449 , Maybe MessageId
466450 )
467451
452+-- |Запрос на все диалоги.
468453getChatsQ
469454 :: Limit
470455 -> P.PaginationDirection
@@ -525,6 +510,7 @@ getChatsQ lim dir = select (
525510 where_ (isNotNull #messageStorageDestinationGroupId) &
526511 groupBy #messageStorageDestinationGroupId
527512
513+-- |Запрос на сообщения.
528514getMessagesQ
529515 :: Limit
530516 -> P.PaginationDirection
@@ -544,6 +530,7 @@ getMessagesQ lim dir = selectStar (from (table #messages) &
544530 where
545531 ((.^), order) = directionToOperator dir
546532
533+-- |Запрос на сообщения в групповой беседе.
547534getGroupMessagesQ
548535 :: Limit
549536 -> P.PaginationDirection
@@ -562,12 +549,14 @@ getGroupMessagesQ lim dir = selectStar (from (table #messages) &
562549 ((.^), order) = directionToOperator dir
563550
564551-- String -- user id as String
552+-- |Запрос на групповую беседу для данного пользователя.
565553getGroupChatForUserQ :: Query Schema (TuplePG (String, GroupChatId)) (RowPG GroupChat)
566554getGroupChatForUserQ = selectStar $
567555 (from (table #groupChats)) &
568556 where_ (#groupChatId .== param @2) &
569557 where_ (#groupChatUsers .? param @1)
570558
559+-- |Запрос на поиск факультета.
571560getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
572561getFacultySearchResultQ = selectStar (from (table #faculties) &
573562 where_ (vector @@ query) &
@@ -588,6 +577,7 @@ getFacultySearchResultQ = selectStar (from (table #faculties) &
588577 #facultyPath])
589578 query = tsQuery "russian" (param @1)
590579
580+-- |Запрос на поиск пользователя.
591581searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
592582searchUsersQ = select (
593583 #users ! #userRowId :*
@@ -619,19 +609,21 @@ searchUsersQ = select (
619609 ])
620610 query = tsQuery' (param @1)
621611
612+-- |Запрос на теги по популярности.
622613tagsByFrquencyQ :: Query Schema params '["tag" ::: 'NotNull (PG Text), "count" ::: 'NotNull 'PGint8]
623614tagsByFrquencyQ = select
624615 (#fromOnly `as` #tag :* count #fromOnly `as` #count)
625616 (from (subquery $ getTagsQ `As` #tt) &
626617 groupBy #fromOnly)
627618
619+-- |Запрос на данной количество самых популярных тегов.
628620getNpopularTagsQ :: Limit -> Query Schema param (RowPG (Only Text))
629621getNpopularTagsQ lim = select (#tag `as` #fromOnly)
630622 (from (subquery $ tagsByFrquencyQ `As` #tt) &
631623 orderBy [#count & Desc] &
632624 limit lim)
633625
634−
626+-- |Запрос на поиск по тегам.
635627searchTagsQ :: Query Schema (TuplePG (Only Text)) (RowPG (Only Text))
636628searchTagsQ = select (#tag `as` #fromOnly) $
637629 from (subquery (tagsByFrquencyQ `As` #tt)) &
@@ -642,6 +634,7 @@ searchTagsQ = select (#tag `as` #fromOnly) $
642634 query = tsQuery' (param @1)
643635 vector = tsVector' #tag
644636
637+-- |PostgreSQL функция ts_rank_cd
645638tsRankCd
646639 :: Expression schema from grouping params ('NotNull 'PGtext)
647640 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -649,6 +642,7 @@ tsRankCd
649642tsRankCd vector query = UnsafeExpression $
650643 "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])
651644
645+-- |PostgreSQL функция ts_vector
652646tsVector
653647 :: ByteString -- ^ Language
654648 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -656,12 +650,14 @@ tsVector
656650tsVector lang x = UnsafeExpression $
657651 "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
658652
653+-- |PostgreSQL функция ts_vector без языка.
659654tsVector'
660655 :: Expression schema from grouping params ('NotNull 'PGtext)
661656 -> Expression schema from grouping params ('NotNull 'PGtext)
662657tsVector' x = UnsafeExpression $
663658 "to_tsvector" <> parenthesized (renderExpression x)
664659
660+-- |PostgreSQL функция ts_query.
665661tsQuery
666662 :: ByteString -- ^ Language
667663 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -669,32 +665,38 @@ tsQuery
669665tsQuery lang x = UnsafeExpression $
670666 "to_tsquery" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
671667
668+-- |PostgreSQL функция ts_query без языка.
672669tsQuery'
673670 :: Expression schema from grouping params ('NotNull 'PGtext)
674671 -> Expression schema from grouping params ('NotNull 'PGtext)
675672tsQuery' x = UnsafeExpression $
676673 "to_tsquery" <> parenthesized (renderExpression x)
677674
675+-- |PostgreSQL функция array_to_string
678676arrayToText
679677 :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
680678 -> Expression schema from grouping params ('NotNull 'PGtext)
681679arrayToText x = UnsafeExpression $
682680 "array_to_string" <> parenthesized (commaSeparated [renderExpression x, "' '"])
683681
682+-- |PostgreSQL оператор @@
684683(@@)
685684 :: Expression schema from grouping params (nullity0 'PGtext)
686685 -> Expression schema from grouping params (nullity1 'PGtext)
687686 -> Expression schema from grouping params (nullity2 'PGbool)
688687(@@) = unsafeBinaryOp "@@"
689688
689+-- |Пробел.
690690space :: Expression schema from grouping params ('NotNull 'PGtext)
691691space = UnsafeExpression "' '"
692692
693+-- |Функция, переводящая список варажений текста в одно выражение текста через пробел.
693694textArrayToText
694695 :: [Expression schema from grouping params ('NotNull 'PGtext)]
695696 -> Expression schema from grouping params ('NotNull 'PGtext)
696697textArrayToText = fold . L.intersperse space
697698
699+-- |Запрос, создающий пользователя.
698700createUserQ :: Manipulation Schema (TuplePG UserCreation) (RowPG (Only UserId))
699701createUserQ = insertRow #users (
700702 Default `as` #userRowId :*
@@ -707,12 +709,13 @@ createUserQ = insertRow #users (
707709 OnConflictDoRaise
708710 (Returning (#userRowId `as` #fromOnly))
709711
712+-- |Запрос, удалющий пользователей, которые не подтвердили свой профиль.
710713removeUnverifiedUserQ :: Manipulation Schema (TuplePG (Only UserEmail)) '[]
711714removeUnverifiedUserQ = deleteFrom_ #users
712715 (#userRowEmail .== param @1 .&&
713716 (not_ . notNull $ #userRowIsValidated))
714717
715−
718+-- |Запрос, создающий токен.
716719createTokenQ :: Manipulation Schema (TuplePG Token) '[]
717720createTokenQ = insertRow_ #tokens (
718721 Set (param @1) `as` #tokenUserId :*
@@ -725,6 +728,7 @@ createTokenQ = insertRow_ #tokens (
725728 Set (param @8) `as` #tokenDeactivationCode
726729 )
727730
731+-- |Запрос, обновляющий токен.
728732updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
729733updateTokenQ = update_ #tokens (
730734 Same `as` #tokenUserId :*
@@ -737,10 +741,12 @@ updateTokenQ = update_ #tokens (
737741 Set (param @8) `as` #tokenDeactivationCode)
738742 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
739743
744+-- |Запрос, удалющий токен.
740745deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
741746deleteTokenQ = deleteFrom_ #tokens
742747 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
743748
749+-- |Запрос, подтверждающий профиль пользователя.
744750validateUserQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
745751validateUserQ = update_ #users (
746752 Same `as` #userRowId :*
@@ -752,22 +758,26 @@ validateUserQ = update_ #users (
752758 Set true `as` #userRowIsValidated)
753759 (#userRowId .== param @1)
754760
761+-- |Запрос, возвращающий токен.
755762getTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
756763getTokenQ = selectStar (from (table #tokens) &
757764 where_ (#tokenUserId .== param @1 .&&
758765 #tokenValue .== param @2))
759766
767+-- |Запрос, возвращающий токен по хэшу кода активации.
760768getTokenActivationQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
761769getTokenActivationQ = selectStar (from (table #tokens) &
762770 where_ (#tokenUserId .== param @1 .&&
763771 #tokenActivationCode .== param @2))
764772
773+-- |Запрос, даективирующий токен.
765774deactivateTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) (RowPG (Only Text))
766775deactivateTokenQ = deleteFrom #tokens
767776 (#tokenUserId .== param @1 .&&
768777 #tokenDeactivationCode .== param @2)
769778 (Returning (#tokenUserAgent `as` #fromOnly))
770779
780+-- |Запрос, возвращающий подтвержденный токен.
771781getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
772782getVerifiedTokenQ = selectStar (from (table #tokens) &
773783 where_ (#tokenUserId .== param @1 .&&
@@ -775,14 +785,17 @@ getVerifiedTokenQ = selectStar (from (table #tokens) &
775785 isNull #tokenVerificationCode .&&
776786 currentTimestamp .< #tokenExpiryDate))
777787
788+-- |Запрос, даективирующий все токены для данного пользователя.
778789killAllTokensQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
779790killAllTokensQ = deleteFrom_ #tokens
780791 (#tokenUserId .== param @1)
781792
793+-- |Запрос, удаляющий недействительные токены.
782794pruneDeadTokensQ :: Manipulation Schema '[] '[]
783795pruneDeadTokensQ = deleteFrom_ #tokens
784796 (#tokenExpiryDate .< currentTimestamp)
785797
798+-- |Запрос, удаляющий неактивированных пользователей.
786799pruneGhostUsersQ :: Manipulation Schema '[] '[]
787800pruneGhostUsersQ = deleteFrom_ #users
788801 ((not_ . in_ #userRowId $ select (#tokens ! #tokenUserId `as` #id) (from $ table #tokens)) .&&
@@ -798,11 +811,17 @@ instance HasValidatableText UserCreation where
798811 userCreationUserFaculty,
799812 userCreationUserEmail]
800813
814+-- |Объект для создания пользователя.
801815data UserCreation = UserCreation {
816+ -- |Имя.
802817 userCreationFirstName :: Text,
818+ -- |Отчество.
803819 userCreationMiddleName :: Text,
820+ -- |Фамилия.
804821 userCreationLastName :: Text,
822+ -- |Факультет.
805823 userCreationUserFaculty :: FacultyUrl,
824+ -- |Адрес почты.
806825 userCreationUserEmail :: Text
807826} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
808827
@@ -819,42 +838,62 @@ instance FromJSON UserCreation where
819838 parseJSON = withObject "user creation" $ \e ->
820839 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
821840
841+-- |Объект для обновления пользователя.
822842data UserUpdateRow = UserUpdateRow {
843+ -- |Идентификатор пользователя.
823844 userUpdateRowId :: UserId,
845+ -- |Имя.
824846 userUpdateRowFirstName :: Text,
847+ -- |Отчество.
825848 userUpdateRowMiddleName :: Text,
849+ -- |Фамилия.
826850 userUpdateRowLastName :: Text,
851+ -- |Факультет.
827852 userUpdateRowUserFaculty :: FacultyUrl
828853} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
829854
830−
855+-- |Объект для создания канала.
831856data NamedChannelCreation = NamedChannelCreation {
857+ -- |Владелец канала.
832858 namedChannelCreationOwner :: UserId,
859+ -- |Название канала.
833860 namedChannelCreationName :: Text,
861+ -- |Теги в канале.
834862 namedChannelCreationTags :: Vector Text,
863+ -- |Люди в канале.
835864 namedChannelCreationPeopleIds :: Vector UserId
836865} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
837866
867+-- |Функция, добавлющая в структуру пользователя.
838868addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
839869addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
840870
871+-- |Полный объект канала.
841872data NamedChannelFull = NamedChannelFull {
873+ -- |Идентификатор.
842874 namedChannelFullId :: NamedChannelId,
875+ -- |Владелец.
843876 namedChannelFullOwner :: UserId,
877+ -- |Название.
844878 namedChannelFullName :: Text,
879+ -- |Теги.
845880 namedChannelFullTags :: Vector Text,
881+ -- |пользователи.
846882 namedChannelFullPeopleIds :: Vector UserId
847883} deriving GHC.Generic
848884
849885instance SOP.Generic NamedChannelFull
850886instance SOP.HasDatatypeInfo NamedChannelFull
851887
888+-- |Добавляет в структуру пользователя.
852889addUserToChannelUpdate :: UserId -> NamedChannel UserId -> NamedChannelFull
853890addUserToChannelUpdate uId (NamedChannel cId cName cTags cPeople) = NamedChannelFull cId uId cName cTags cPeople
854891
892+-- |Убирает пользователя из структуры.
855893removeUserFromChannel :: NamedChannelFull -> NamedChannel UserId
856894removeUserFromChannel (NamedChannelFull cId _ cName cTags cPeople) = NamedChannel cId cName cTags cPeople
857895
896+-- |Возвращаает канал для данного человека.
858897getChannelForUser :: UserId -> NamedChannelId -> StaticPQ NamedChannelFull
859898getChannelForUser uId cId = do
860899 channel <- runQueryParams getChannelForUserQ (uId, cId) >>= firstRow
@@ -862,7 +901,7 @@ getChannelForUser uId cId = do
862901 (Just c) -> return c
863902 Nothing -> lift $ S.throwError S.err404
864903
865−-- TODO: Reject bad requests. Should be binary.
904+-- |Проверяет, существует ли пользователь.
866905verifyUsers :: [UserId] -> StaticPQ ()
867906verifyUsers uIds =
868907 case verifiedUserIdsQ uIds of
@@ -871,6 +910,7 @@ verifyUsers uIds =
871910 when (length us /= length uIds) $ lift $ S.throwError impossibleContent
872911 Nothing -> return ()
873912
913+-- |Удаляет групповую беседу.
874914deleteGroupChat :: GroupChatId -> StaticPQ ()
875915deleteGroupChat gId = do
876916 _ <- manipulateParams deleteGroupChatQ (Only gId)
@@ -885,6 +925,7 @@ deleteGroupChat gId = do
885925 (#messageStorageDestinationGroupId .== param @1)
886926
887927-- NOTE: Not transactional
928+-- |Создает пользователя.
888929createUser :: UserCreation -> StaticPQ UserId
889930createUser creation = do
890931 _ <- manipulateParams removeUnverifiedUserQ (Only $ userCreationUserEmail creation)
@@ -894,6 +935,7 @@ createUser creation = do
894935-- MARK: FrontEnd functions
895936
896937-- Nothing <=> no user
938+-- |Возвращаает посты от данного пользователя.
897939getPostsForUser
898940 :: Maybe PostId
899941 -> Limit
@@ -904,6 +946,7 @@ getPostsForUser pId lim dir uId = do
904946 postRows <- runQueryParams (getLastNPostsForUserQ lim dir) (pId, uId) >>= getRows
905947 wrapIntoResponse (fromMaybe [] . rowsToPosts $ postRows)
906948
949+-- |Возвращаает посты по идентификатором.
907950getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))
908951getPosts pId =
909952 case getPostsByIdQ pId of
@@ -912,6 +955,7 @@ getPosts pId =
912955 rowsToPosts postRows `liftMaybe` wrapIntoResponse
913956 Nothing -> return Nothing
914957
958+-- |Возвращает последние посты.
915959getLastPosts
916960 :: Maybe PostId
917961 -> Limit
@@ -921,15 +965,19 @@ getLastPosts pId lim dir = do
921965 postRows <- runQueryParams (getLastPostsQ id lim dir) (Only pId) >>= getRows
922966 rowsToPosts postRows `liftMaybe` wrapIntoResponse
923967
968+-- |Возвращает пользователя по адресу почты.
924969getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))
925970getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow
926971
972+-- |возвращает пользователей по идентификаторам.
927973getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])
928974getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))
929975
976+-- |Возвращает всех пользователей.
930977getAllUsers :: StaticPQ [User Faculty]
931978getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
932979
980+-- |Публичует пост.
933981publishPost :: UserId -> PostCreation -> StaticPQ PostId
934982publishPost uId pc = commitedTransactionallyUpdate $ do
935983 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
@@ -939,6 +987,7 @@ publishPost uId pc = commitedTransactionallyUpdate $ do
939987 return pId
940988 _ -> lift $ S.throwError S.err404
941989
990+-- |Создает канал.
942991createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
943992createNewChannel uId req = commitedTransactionallyUpdate $ do
944993 let uIds = toList $ namedChannelCreationRequestPeopleIds req
@@ -946,9 +995,11 @@ createNewChannel uId req = commitedTransactionallyUpdate $ do
946995 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
947996 return $ fmap fromOnly cId
948997
998+-- |Возвращает канал для данного пользователя.
949999channelCountForUser :: UserId -> StaticPQ Int64
9501000channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
9511001
1002+-- |Обновляет канал.
9521003updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
9531004updateChannel uId req = do
9541005 let uIds = namedChannelPeopleIds req
@@ -957,17 +1008,21 @@ updateChannel uId req = do
9571008 _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
9581009 return ()
9591010
1011+-- |Возвращает факультет.
9601012getFaculty :: Text -> StaticPQ Faculty
9611013getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
9621014
1015+-- |Проверяет, является ли данный факультет валидным.
9631016isValidFaculty :: FacultyUrl -> StaticPQ Bool
9641017isValidFaculty url = do
9651018 (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
9661019 return $ isJust faculty
9671020
1021+-- |Обновляет факультет.
9681022updateFaculty :: Faculty -> StaticPQ ()
9691023updateFaculty fac = void $ manipulateParams updateFacultyQ fac
9701024
1025+-- |Возвращает посты в канале.
9711026getChannelPosts
9721027 :: UserId
9731028 -> Maybe PostId
@@ -986,6 +1041,7 @@ getChannelPosts uId pId lim dir cId = do
9861041 >>= getRows
9871042 fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
9881043
1044+-- |Возвращает почты в анонимном кнаале.
9891045getAnonymousChannelPosts
9901046 :: Maybe PostId
9911047 -> Limit
@@ -996,19 +1052,23 @@ getAnonymousChannelPosts pId lim dir (AnonymousChannel tags people) = do
9961052 postRows <- runQueryParams (getChannelPostsQ lim dir people tags) (Only pId) >>= getRows
9971053 fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
9981054
1055+-- |Возвращает все каналы.
9991056getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
10001057getAllChannels uId = fmap (map removeUserFromChannel) $
10011058 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
10021059
1060+-- |Удаляет именованный канал.
10031061deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
10041062deleteNamedChannel uId cId = do
10051063 _ <- getChannelForUser uId cId
10061064 _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
10071065 return ()
10081066
1067+-- |Возвращает теги.
10091068getTags :: Limit -> StaticPQ [String]
10101069getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
10111070
1071+-- |Возвращает диалоги.
10121072getDialogs
10131073 :: UserId
10141074 -> Maybe MessageId
@@ -1019,6 +1079,7 @@ getDialogs uId mId lim dir = do
10191079 resp <- runQueryParams (getChatsQ lim dir) (uId, Just $ show uId, mId) >>= getRows
10201080 (>>= fromMaybe500) $ (responseToDialogs uId resp `liftMaybe` wrapIntoResponse)
10211081
1082+-- |Возвращает сообщения в диалоге.
10221083getMessagesInUserChat
10231084 :: UserId
10241085 -> UserId
@@ -1030,6 +1091,7 @@ getMessagesInUserChat selfId uId mId lim dir = do
10301091 resp <- runQueryParams (getMessagesQ lim dir) (selfId, uId, mId) >>= getRows
10311092 fromMaybe500 . sequence . map restoreMessage $ resp
10321093
1094+-- |Возвращает сообщения в групповой беседе.
10331095getMessagesInGroupChat
10341096 :: UserId
10351097 -> GroupChatId
@@ -1042,6 +1104,7 @@ getMessagesInGroupChat selfId gId mId lim dir = do
10421104 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
10431105 return . catMaybes . map restoreMessage $ resp
10441106
1107+-- |Отправляет сообщение.
10451108sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
10461109sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
10471110 _ <- getGroupChatForUser selfId gId
@@ -1055,6 +1118,7 @@ sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do
10551118 return mId
10561119sendMessage _ _ = lift $ S.throwError S.err400
10571120
1121+-- |Создает групповую беседу.
10581122createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
10591123createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
10601124 verifyUsers . M.keys $ chatUsers
@@ -1065,6 +1129,7 @@ createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
10651129 _ <- manipulateParams createPhantomMessageQ (Only chatId)
10661130 return chatId
10671131
1132+-- |Обновляет групповую беседу.
10681133updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
10691134updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
10701135 verifyUsers . M.keys $ perms
@@ -1075,6 +1140,7 @@ updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
10751140 let newPerms = M.insert uId userPerm perms
10761141 void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
10771142
1143+-- |Удаляет пользователя из беседы.
10781144leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
10791145leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
10801146 gChat@(GroupChat _ (Jsonb perms) _) <- getGroupChatForUser uId gId
@@ -1083,6 +1149,7 @@ leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
10831149 then deleteGroupChat gId
10841150 else void $ manipulateParams updateGroupChatQ gChat{groupChatUsers = Jsonb newPerms}
10851151
1152+-- |Возвращает беседу для пользователя.
10861153getGroupChatForUser :: UserId -> GroupChatId -> StaticPQ GroupChat
10871154getGroupChatForUser uId gId = do
10881155 chat <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
@@ -1090,15 +1157,18 @@ getGroupChatForUser uId gId = do
10901157 (Just c) -> return c
10911158 Nothing -> lift $ S.throwError S.err404
10921159
1160+-- |Проверяет, является ли данная беседа валидной для данного пользователя.
10931161groupChatIsValidForUser :: UserId -> GroupChatId -> StaticPQ Bool
10941162groupChatIsValidForUser uId gId = do
10951163 (chat :: Maybe GroupChat) <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
10961164 return $ isJust chat
10971165
1166+-- |Возвращает каналы по поисковой строке.
10981167getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
10991168getFacultyFromQuery query =
11001169 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
11011170
1171+-- |Ищет пользователей по строке.
11021172searchUsers :: T.Text -> StaticPQ [User Faculty]
11031173searchUsers query = do
11041174 unless (validateText query) $ lift $ throwError lengthExceeded
@@ -1106,37 +1176,45 @@ searchUsers query = do
11061176 then return []
11071177 else map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
11081178
1179+-- |Ищет теги по запосу.
11091180searchTags :: T.Text -> StaticPQ [Text]
11101181searchTags "" = return []
11111182searchTags query = map fromOnly <$>
11121183 (runQueryParams searchTagsQ
11131184 (Only . (<> ":*") . T.strip $ query) >>= getRows)
11141185
1186+-- |Создает токен.
11151187createToken :: Token -> StaticPQ ()
11161188createToken token = void $ manipulateParams createTokenQ token
11171189
1190+-- |Деактивирует все токены для пользователя.
11181191killAllTokens :: UserId -> StaticPQ ()
11191192killAllTokens = void . manipulateParams killAllTokensQ . Only
11201193
1194+-- |Удаляет устаревшую информацию про авторизацию.
11211195pruneAuth :: StaticPQ ()
11221196pruneAuth = do
11231197 _ <- commitedTransactionallyUpdate . manipulate $ pruneDeadTokensQ
11241198 _ <- commitedTransactionallyUpdate . manipulate $ pruneGhostUsersQ
11251199 return ()
11261200
1201+-- |Осуществляет поиск по каналам.
11271202searchChannels :: UserId -> Text -> StaticPQ [NamedChannel UserId]
11281203searchChannels uId query = fmap (map removeUserFromChannel) $
11291204 runQueryParams searchChannelsForUserQ (uId, queryFromText query) >>= getRows
11301205
11311206-- NOTE: Not transactional
1207+-- |Проверяет, является ли токен валидным.
11321208validateToken :: Token -> StaticPQ ()
11331209validateToken token = do
11341210 void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing, tokenActivationCode = Nothing}
11351211 void $ manipulateParams validateUserQ $ Only $ tokenUserId token
11361212
1213+-- |Даективирует токен.
11371214invalidateToken :: UserId -> ByteString -> StaticPQ ()
11381215invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
11391216
1217+-- |Пытается активировать токен с помощью кода.
11401218tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)
11411219tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
11421220 token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow
@@ -1154,6 +1232,7 @@ tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
11541232 _ <- manipulateParams updateTokenQ newToken
11551233 return Nothing
11561234
1235+-- |Пытается активировать с помощью ключа активации.
11571236tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
11581237tryActivateToken uId activationData = do
11591238 let hData = hash activationData
@@ -1165,17 +1244,21 @@ tryActivateToken uId activationData = do
11651244 then commitedTransactionallyUpdate (validateToken token) >> (return $ Just token)
11661245 else return Nothing
11671246
1247+-- |Деактивирует токен.
11681248deactivateToken :: UserId -> ByteString -> StaticPQ (Maybe Text)
11691249deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow)
11701250
1251+-- |Возвращает активированный токен.
11711252getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
11721253getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
11731254
1255+-- |Обновляет пользователя.
11741256updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
11751257updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
11761258
11771259-- MARK: Utils
11781260
1261+-- |Нормализует поля пользователя.
11791262normalizeUser :: UserUpdateRow -> UserUpdateRow
11801263normalizeUser UserUpdateRow{..} = UserUpdateRow {
11811264 userUpdateRowId = userUpdateRowId,
@@ -1185,23 +1268,39 @@ normalizeUser UserUpdateRow{..} = UserUpdateRow {
11851268 userUpdateRowUserFaculty = T.toLower . T.strip $ userUpdateRowUserFaculty
11861269}
11871270
1271+-- |Объект пользователя для ответов с базы данных.
11881272data UserRow = UserRow {
1273+ -- |Идентификатор пользователя.
11891274 userRowId :: UserId,
1275+ -- |Имя.
11901276 userRowFirstName :: Text,
1277+ -- |Отчество.
11911278 userRowMiddleName :: Text,
1279+ -- |Фамилия.
11921280 userRowLastName :: Text,
1281+ -- |Факультет.
11931282 userRowFacultyUrl :: FacultyUrl,
1283+ -- |Почта.
11941284 userRowEmail :: Text,
1285+ -- |Был ли профиль подтвержден через почту.
11951286 userRowIsValidated :: Bool,
1287+ -- |Название факультета.
11961288 userRowFacultyName :: T.Text,
1289+ -- |Адрес сайта факультета.
11971290 userRowFacultyURL :: FacultyUrl,
1291+ -- |Вспомогательная информация о факультете.
11981292 userRowFacultyPath :: T.Text,
1293+ -- |Кампус.
11991294 userRowFacultyCampusName :: T.Text,
1295+ -- |Код Кампуса.
12001296 userRowFacultyCampusCode :: T.Text,
1297+ -- |Теги департамента.
12011298 userRowFacultyTags :: V.Vector T.Text,
1299+ -- |АДрес департамента.
12021300 userRowFacultyAddress :: T.Text
12031301} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
12041302
1303+-- |Функция, переводящая ответ с базы данных в пользователя.
12051304rowToUser :: UserRow -> User Faculty
12061305rowToUser UserRow{..} = User {
12071306 userId = userRowId,
@@ -1220,6 +1319,7 @@ rowToUser UserRow{..} = User {
12201319 userEmail = userRowEmail
12211320 }
12221321
1322+-- |Переводит строку в запрос с учетом аббревиатур.
12231323queryFromTextAbbr :: Text -> Text
12241324queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
12251325 where
@@ -1230,12 +1330,14 @@ queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (no
12301330 else mempty
12311331 ) <> ")"
12321332
1333+-- |Переводит строку в запорс.
12331334queryFromText :: Text -> Text
12341335queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)
12351336 where
12361337 processTerm :: Text -> Text
12371338 processTerm t = t <> ":*"
12381339
1340+-- |Перевод направление в оператор.
12391341directionToOperator
12401342 :: P.PaginationDirection
12411343 -> (ConditionOp schema0 from0 grouping0 params0 nullity0 nullity1 (ty :: PGType),
@@ -1248,6 +1350,7 @@ foldMaybe [] = Just []
12481350foldMaybe (Nothing : _) = Nothing
12491351foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
12501352
1353+-- |переводит элементы поста с базы данных в объект поста.
12511354rowsToPosts :: [PostRowResponse] -> Maybe [Post]
12521355rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)
12531356
@@ -1261,11 +1364,15 @@ idsToColumn :: [Int64] -> Maybe (Query schema params '["id" ::: 'NotNull 'PGint8
12611364idsToColumn [] = Nothing
12621365idsToColumn (i:ii) = Just $ values (unsafeIntToExpr i `as` #id) $ map ((`as` #id) . unsafeIntToExpr) ii
12631366
1367+-- |Небезопасное переведение числа в SQL выражение.
12641368unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty
12651369unsafeIntToExpr = UnsafeExpression . pack . show
12661370
1371+-- |Ответ сервера с пользователями.
12671372data ResponseWithUsers r = ResponseWithUsers {
1373+ -- |Тело ответа.
12681374 response :: r,
1375+ -- |Пользователи.
12691376 users :: M.Map UserId (User Faculty)
12701377} deriving (Generic)
12711378
@@ -1296,6 +1403,7 @@ instance (Foldable t, HasUsers r) => HasUsers (t r) where
12961403instance HasUsers Post where
12971404 userSet = Set.singleton . postAuthorId
12981405
1406+-- |Оборачивает ответ в пользователей.
12991407wrapIntoUsers :: r -> Set.Set UserId -> StaticPQ (Maybe (ResponseWithUsers r))
13001408wrapIntoUsers r us
13011409 | Set.null us = return . Just $ ResponseWithUsers r M.empty
denis/src/Data/Schema.hs+3−5
@@ -9,16 +9,14 @@
99 KindSignatures #-}
1010
1111
12−module Data.Schema (
13− Schema,
14− createTables
15−) where
12+module Data.Schema where
1613
1714import Squeal.PostgreSQL
1815import Data.GroupChat
1916import Data.PostElement
2017import Data.Message
2118
19+-- |Таблицы базы данных
2220type Schema =
2321 '[
2422 "faculties" ::: 'Table ('[
@@ -188,7 +186,7 @@ type Schema =
188186
189187 ]
190188
191−
189+-- |Создает таблицы базы данных.
192190createTables :: Definition '[] Schema
193191createTables = createTable #faculties (
194192 notNullable text `as` #facultyName :*
denis/src/Data/Tags/Completions.hs+3−4
@@ -4,10 +4,7 @@
44 FlexibleInstances #-}
55{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
66
7−module Data.Tags.Completions (
8− CompletionTree(..),
9− mkCompletionTree
10− ) where
7+module Data.Tags.Completions where
118
129import qualified Data.Map as M
1310import Data.Aeson
@@ -24,6 +21,7 @@ instance ToSample CompletionTree where
2421 toSamples _ = singleSample . mkCompletionTree $
2522 ["aa", "aaab", "ba", "b", "bab"]
2623
24+-- |Объект дерева подсказок тегов.
2725data CompletionTree = CompletionTreeNode {
2826 value :: Maybe String,
2927 subtree :: M.Map Char CompletionTree
@@ -31,6 +29,7 @@ data CompletionTree = CompletionTreeNode {
3129
3230instance ToJSON CompletionTree where
3331
32+-- |Функция, ктороая строит дерево подсказок по данному списку строк.
3433mkCompletionTree :: [String] -> CompletionTree
3534mkCompletionTree = mkCompletionTree' . map (\ a -> (map toLower a, a)) . sort
3635 where
denis/src/Data/Tags/Validation.hs+4−4
@@ -1,11 +1,9 @@
1−module Data.Tags.Validation (
2− validateTag,
3− validateTag'
4− ) where
1+module Data.Tags.Validation where
52
63import Data.Text as T
74import Data.Char
85
6+-- |Функция, валилирующая хэштег, возвращающая тег в монаде `Maybe`
97validateTag :: T.Text -> Maybe T.Text
108validateTag tag =
119 let
@@ -14,9 +12,11 @@ validateTag tag =
1412 then Just normalised
1513 else Nothing
1614
15+-- |Функция, проверяющая, является ли данный тег валидным.
1716validateTag' :: T.Text -> Bool
1817validateTag' = T.all validChar
1918
19+-- |Функция, проверяющая, является ли данный символ валидным внутри тега.
2020validChar :: Char -> Bool
2121validChar '-' = True
2222validChar c = isAlphaNum c
denis/src/Data/Text/Validator.hs+8−9
@@ -1,30 +1,26 @@
11{-# LANGUAGE FlexibleInstances #-}
22
3−module Data.Text.Validator (
4− HasValidatableText(..),
5− isValidChar,
6− ExtraPredicate(..),
7− (~=),
8− (~<),
9− (<~>),
10− RangeableText(..)
11− ) where
3+module Data.Text.Validator where
124
135import qualified Data.Text as T
146import Data.Char
157import Data.Limits
168
9+-- |Функция, проверяющая, является ли данный символ валидным символом текста.
1710isValidChar :: Char -> Bool
1811isValidChar '\n' = True
1912isValidChar '\r' = True
2013isValidChar c = isPrint c || generalCategory c == ModifierLetter
2114
15+-- |Класс объектов, имеющих возможность проверить содержащийся в них текст на валидность.
2216class HasValidatableText t where
2317 validateText :: t -> Bool
2418
19+-- |Текст с предикат.
2520data ExtraPredicate t = ExtraPredicate t (t -> Bool)
2621
2722infixl 5 ~=
23+-- |Опертор для добавления предиката к тексту.
2824(~=) :: t -> (t -> Bool) -> ExtraPredicate t
2925(~=) = ExtraPredicate
3026
@@ -33,13 +29,16 @@ instance (HasValidatableText t) => HasValidatableText (ExtraPredicate t) where
3329
3430
3531infixl 5 ~<
32+-- |Опертор для добавления ограничений на длину сверху к тексту.
3633(~<) :: t -> Int -> RangeableText t
3734t ~< n = t <~> (0, n)
3835
3936infixl 5 <~>
37+-- |Оператор для добавления ограничения на длину текста.
4038(<~>) :: t -> (Int, Int) -> RangeableText t
4139(<~>) = RangeableText
4240
41+-- |Текст с ограничением по длине.
4342data RangeableText t = RangeableText t (Int, Int)
4443
4544instance HasValidatableText (RangeableText String) where
denis/src/Data/User.hs+18−8
@@ -9,12 +9,7 @@
99 DeriveAnyClass,
1010 RecordWildCards #-}
1111
12−module Data.User (
13− User(..),
14− UserId,
15− UserEmail,
16− UserUpdate(..)
17−) where
12+module Data.User where
1813
1914import Data.Int (Int64)
2015import qualified Generics.SOP as SOP
@@ -30,25 +25,35 @@ import Data.Text.Validator
3025-- MARK: Documentation
3126
3227instance (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"]
3429
3530instance 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/"]
3732
3833instance HasValidatableText UserUpdate where
3934 validateText UserUpdate{..} = all (validateText . (~< userFieldLengthLimit)) [userUpdateFirstName, userUpdateMiddleName, userUpdateLastName, userUpdateUserFaculty]
4035
4136-- MARK: Implementation
4237
38+-- |Идентификатор пользователя.
4339type UserId = Int64
40+
41+-- |Адрес почты пользователя.
4442type UserEmail = Text
4543
44+-- |Пользователь.
4645data User f = User {
46+ -- |Идентификатор.
4747 userId :: UserId,
48+ -- |Имя.
4849 firstName :: Text,
50+ -- |Фамилия.
4951 middleName :: Text,
52+ -- |Отчество.
5053 lastName :: Text,
54+ -- |Факультет.
5155 userFaculty :: f,
56+ -- |Адрес почты.
5257 userEmail :: UserEmail
5358} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
5459
@@ -66,10 +71,15 @@ instance (FromJSON f) => FromJSON (User f) where
6671 parseJSON = withObject "named channel" $ \e ->
6772 User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
6873
74+-- |Объект для обновления пользователя.
6975data UserUpdate = UserUpdate {
76+ -- |Имя.
7077 userUpdateFirstName :: Text,
78+ -- |Отчество.
7179 userUpdateMiddleName :: Text,
80+ -- |Фамилия.
7281 userUpdateLastName :: Text,
82+ -- |Факультет.
7383 userUpdateUserFaculty :: FacultyUrl
7484} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
7585
denis/src/Server/API.hs+14−13
@@ -7,12 +7,7 @@
77 RecordWildCards #-}
88{-# OPTIONS_GHC -Wno-orphans #-}
99
10−module Server.API (
11− API,
12− serverProxy,
13− mkServerAPI,
14− Authentication
15−) where
10+module Server.API where
1611
1712import Data.Proxy
1813import Servant.API
@@ -42,13 +37,19 @@ import Data.Text.Validator
4237
4338instance HasDocs api => HasDocs (Authentication :> api) where
4439 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` если токен не дает доступа к запрашиваемому ресурсу."]])
4641
47−type UserSearchDescription = Description "Searches for users with the given string.\n\nFeed in the raw user input string."
42+type UserSearchDescription = Description "Ищет пользователей по данной строке."
4843
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 "Обновляет профиль текущего пользователя."
5045
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 "Возвращает всех пользователей."
5253
5354-- MARK: Implementation
5455
@@ -58,11 +59,11 @@ type API =
5859 LoggerAPI :<|>
5960 "authentication" :> AuthenticationHandler :<|>
6061 Authentication :> ComplexQuery :> (
61− "authentication" :> "me" :> Post '[JSON] UserId :<|>
62+ "authentication" :> "me" :> MeDescription :> Post '[JSON] UserId :<|>
6263 "deactivateAll" :> DeactivateAllDescription
6364 :> DeleteNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
64− "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>
65− "users" :> "all" :> Post '[JSON] [User Faculty] :<|>
65+ "users" :> UsersDescription :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>
66+ "users" :> "all" :> UsersAllDescription :> Post '[JSON] [User Faculty] :<|>
6667 "users" :> "search" :> UserSearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [User Faculty] :<|>
6768 "users" :> "update" :> UpdateUserDescription :> ReqBody '[JSON] UserUpdate :> PostNoContent '[JSON, PlainText] NoContent :<|>
6869 "posts" :> PostApi :<|>
denis/src/Server/API/Channels.hs+20−12
@@ -7,10 +7,7 @@
77 TypeOperators,
88 RecordWildCards #-}
99
10−module Server.API.Channels (
11− ChannelsApi,
12− channelsApi
13−) where
10+module Server.API.Channels where
1411
1512import Servant.API
1613import Server.App
@@ -29,20 +26,31 @@ import Control.Monad
2926import Data.Limits
3027import qualified Data.Text as T
3128import Data.Char
29+import Control.Monad.Except
3230
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 если лимит каналов для пользователя был исчерпан."
3432
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 "Запрашивает все каналы пользователя."
3644
3745-- MARK: Implementation
3846
39−type ChannelsApi = Post '[JSON] [NamedChannel UserId] :<|>
40− "get" :> 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]) :<|>
47+type ChannelsApi = GetAllDescription :> Post '[JSON] [NamedChannel UserId] :<|>
48+ "get" :> GetDescription :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe NamedChannelId)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
49+ "getAnonymous" :> GetAnonDescription :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe AnonymousChannel)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
4250 "create" :> CreateDescription :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
43− "update" :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
44− "delete" :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
45− "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [NamedChannel UserId]
51+ "update" :> UpdateDescription :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
52+ "delete" :> DeleteDescription :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
53+ "search" :> SearchDescription :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [NamedChannel UserId]
4654
4755channelsApi :: UserId -> ServerT ChannelsApi App
4856channelsApi 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 @@
77 TypeOperators,
88 LambdaCase #-}
99
10−module Server.API.Completions (
11− TagsAPI,
12− tagsServer
13− ) where
10+module Server.API.Completions where
1411
1512import Servant.Server
1613import Servant
@@ -25,14 +22,14 @@ import qualified Data.Text as T
2522import Data.Char
2623
2724type CompletionsDescription = Description "\
28− \Gets tag completion tree\n\n\
25+ \Возвращает дерево тегов.\n\n\
2926 \```haskell\n\
3027 \data CompletionTree = CompletionTreeNode {\n\
3128 \ value :: Maybe String,\n\
3229 \ subtree :: Map Char CompletionTree\n\
3330 \}\n\
3431 \```\n\n\
35− \The psuedocode for retrieving all completions from the tree:\n\n\
32+ \Псевдокод для получения всех подсказок:\n\n\
3633 \```swift\n\
3734 \func getCompletion(tree: CompletionTree, word: String) -> [String] {\n\
3835 \ if word == \"\" {\n\
@@ -63,7 +60,7 @@ type CompletionsDescription = Description "\
6360 \}\n\
6461 \```"
6562
66−type SearchDescription = Description "Returns top 1000 tag completions for given user input."
63+type SearchDescription = Description "Возвращает 1000 самых популярных тегов для запроса пользователя."
6764
6865type TagsAPI = "completions" :> CompletionsDescription :> Get '[JSON] CompletionTree :<|>
6966 "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [Text]
denis/src/Server/API/Faculty.hs+2−5
@@ -7,10 +7,7 @@
77 TypeOperators,
88 LambdaCase #-}
99
10−module Server.API.Faculty (
11− FacultyAPI,
12− facultyServer
13− ) where
10+module Server.API.Faculty where
1411
1512import Servant.Server
1613import Servant
@@ -25,7 +22,7 @@ import Control.Monad
2522import Server.Error
2623import Data.Char
2724
28−type SearchDescription = Description "Returns faculties for given string"
25+type SearchDescription = Description "Возвращает факультет по данному запросу."
2926
3027type FacultyAPI =
3128 "search" :> SearchDescription :> ReqBody '[PlainText, JSON] Text :> Post '[JSON] [Faculty]
denis/src/Server/API/Messages.hs+10−12
@@ -7,10 +7,7 @@
77 TypeOperators,
88 RecordWildCards #-}
99
10−module Server.API.Messages (
11− MessagesApi,
12− messagesServer
13−) where
10+module Server.API.Messages where
1411
1512import Servant.API
1613import Server.App
@@ -28,15 +25,16 @@ import Server.Error
2825import qualified Data.Map as M
2926import Squeal.PostgreSQL.Schema
3027import Data.Limits
28+import Control.Monad.Except
3129
32−type GetAllChatsDescription = Description "Gets chats starting from/ending with the given message id."
33−type GetGroupChatDescription = Description "Gets information about a given group chat."
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."
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"
36−type LeaveGroupChatDescription = Description "Removes the user from the given group chat."
37−type MessagesGetGroupChatDesctiption = Description "Gets the messages from the supplied group chat starting from/ending with the given message id."
38−type MessagesGetUserChatDesctiption = Description "Gets the messages from the supplied user chat (two people) starting from/ending with the given message id."
39−type MessagesSend = Description "Sends the given message.\n\nReturns the id of the sent message."
30+type GetAllChatsDescription = Description "Возвращает чаты с данного идентификатора сообщения."
31+type GetGroupChatDescription = Description "Возвращает информацию о групповой беседе."
32+type GetUpdateGroupChatDescription = Description "Обновляет групповой чат.\n\nВозвращает 404 если пользователь не является участником беседы.\n\nВозвращает 401 Если у пользователя не достаточно прав на редактирование беседы."
33+type CreateGroupChatDescription = Description "Создает групповую беседу с данными правами.\n\nВызывающий пользовтаель автоматически приобретает максимальные права. Его не надо добавлять.\n\nВозвращает идентификатор созданного чата."
34+type LeaveGroupChatDescription = Description "Убирает пользователя из беседы."
35+type MessagesGetGroupChatDesctiption = Description "Возвращает сообщения в групповой бесед начиная с данного идентификатора сообщения."
36+type MessagesGetUserChatDesctiption = Description "Возвращает сообщения в диалоге начиная с данного идентификатора сообщения."
37+type MessagesSend = Description "Отправляет сообщения.\n\nВозвращает идентификато отправленного сообщения."
4038
4139type MessagesApi =
4240 "chats" :> (
denis/src/Server/API/Posts.hs+8−4
@@ -6,10 +6,7 @@
66 TypeApplications ,
77 TypeOperators #-}
88
9−module Server.API.Posts (
10− PostApi,
11− postApi
12−) where
9+module Server.API.Posts where
1310
1411import Servant.API
1512import qualified Data.Post as P
@@ -23,6 +20,13 @@ import Data.Limits
2320import Server.Error
2421import Control.Monad
2522import 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 "Публикует пост."
2630
2731-- MARK: Implementation
2832
denis/src/Server/App.hs+2−10
@@ -8,16 +8,7 @@
88 TypeSynonymInstances,
99 FlexibleInstances #-}
1010
11−module Server.App (
12− App,
13− DBConnection,
14− Config(..),
15− ask,
16− asks,
17− liftIO,
18− MailConfig(..),
19− fromMaybeThrow
20−) where
11+module Server.App where
2112
2213import Servant.Server
2314import Control.Monad.Reader
@@ -27,6 +18,7 @@ import Generics.SOP (K)
2718import Squeal.PostgreSQL.PQ (Connection)
2819import Crypto.RNG
2920import Server.Error
21+import Control.Monad.Except
3022
3123type App = ReaderT Config Handler
3224
denis/src/Server/Auth.hs+14−20
@@ -12,17 +12,7 @@
1212 RecordWildCards #-}
1313{-# OPTIONS_GHC -Wno-orphans #-}
1414
15−module Server.Auth (
16− checkToken,
17− cookieTokenKey,
18− genAuthServerContext,
19− AuthenticationHandler,
20− logIn,
21− contextProxy,
22− AuthenticationCredits(..),
23− authenticationAPI,
24− TokenActivationData
25−) where
15+module Server.Auth where
2616
2717import Server.App
2818import Data.User
@@ -58,11 +48,15 @@ import qualified Data.Text.Lazy as TL
5848import Server.Auth.HTML
5949import Data.Char
6050import Data.Text.Validator
51+import Servant.HTML.Blaze
52+import Text.Blaze
53+import Crypto.Hash.SHA512
54+
6155
6256-- MARK: Documentation
6357
6458instance 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"]
6660
6761instance ToSample UserLoginResponse where
6862 toSamples _ = samples $ map UserLoginResponse [UserIsRegistered, UserCanRegister, InvalidUser]
@@ -71,7 +65,7 @@ instance ToSample Int where
7165 toSamples _ = samples [382934, 103845, 294905]
7266
7367instance 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"]
7569
7670instance ToSample TokenActivationData where
7771 toSamples _ = singleSample $ TokenActivationData 69 "ABCDE"
@@ -96,19 +90,19 @@ instance ToParam (QueryParam' mods "id" UserId) where
9690instance ToSample Markup where
9791 toSamples _ = noSamples
9892
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` -- почта не валидная."
10094
101−type LogoutDescription = Description "Log out with the given cookie"
95+type LogoutDescription = Description "Деактивировать текущий токен."
10296
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 если комбинация токена и код не валидная."
10498
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`."
106100
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 если токена нет."
108102
109−type ActivateDescription = Description "Activates a token using data from email"
103+type ActivateDescription = Description "Активирует токен по ключу из письма."
110104
111−type DeactivateDescription = Description "Deactivates a token using data from email"
105+type DeactivateDescription = Description "Деактивирует токен по ключу из письма."
112106
113107-- MARK: Implementation
114108
denis/src/Server/Auth/HTML.hs+1−7
@@ -11,13 +11,7 @@
1111 DeriveAnyClass,
1212 RecordWildCards #-}
1313
14−module Server.Auth.HTML (
15− HTML,
16− genActivationPage,
17− Markup,
18− errorPage,
19− page
20− ) where
14+module Server.Auth.HTML where
2115
2216import Servant.HTML.Blaze
2317import Text.Blaze.Html5 as H
denis/src/Server/Auth/Mail.hs+2−3
@@ -12,9 +12,7 @@
1212 RecordWildCards #-}
1313{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
1414
15−module Server.Auth.Mail (
16− sendTokenVerificationEmail
17− ) where
15+module Server.Auth.Mail where
1816
1917import Network.Mail.SMTP
2018import Server.App
@@ -29,6 +27,7 @@ import Text.Blaze.Html.Renderer.Text
2927import Data.ByteString (ByteString)
3028import Data.User
3129import Data.ByteString.Char8 (unpack)
30+import Control.Monad.Reader
3231
3332sendTokenVerificationEmail :: TokenVerificationCode -> UserId -> ByteString -> ByteString -> TL.Text -> Text -> App ()
3433sendTokenVerificationEmail userCode uId activation deactivation ua email = do
denis/src/Server/Auth/Token.hs+1−9
@@ -9,15 +9,7 @@
99 TypeOperators,
1010 DeriveAnyClass #-}
1111
12−module Server.Auth.Token (
13− Token(..),
14− generateToken,
15− TokenVerificationCode,
16− generateTokenM,
17− hashVerificationCode,
18− GeneratedToken(..),
19− hash
20− ) where
12+module Server.Auth.Token where
2113
2214import Data.Time.Clock
2315import Data.ByteString
denis/src/Server/Error.hs+1−8
@@ -1,13 +1,6 @@
11{-# LANGUAGE OverloadedStrings #-}
22
3−module Server.Error (
4− invalidToken,
5− amountExceeded,
6− lengthExceeded,
7− formatError,
8− impossibleContent,
9− throwError
10−) where
3+module Server.Error where
114
125import Servant.Server
136import Control.Monad.Except
denis/src/Server/Logger.hs+2−6
@@ -6,12 +6,7 @@
66 FlexibleInstances #-}
77{-# OPTIONS_GHC -Wno-orphans #-}
88
9−module Server.Logger (
10− Logger,
11− LoggerAPI,
12− mkLogger,
13− Log
14−) where
9+module Server.Logger where
1510
1611import Network.Wai
1712import Control.Concurrent.STM
@@ -26,6 +21,7 @@ import Network.Wai.Middleware.RequestLogger
2621import Data.Default.Class
2722import qualified System.Log.FastLogger as FL
2823import Servant.Docs
24+import Control.Monad.IO.Class
2925
3026instance HasDocs "log" where
3127 docsFor _ _ _ = emptyAPI
denis/src/Server/Periodic.hs+1−6
@@ -1,9 +1,4 @@
1−module Server.Periodic (
2− periodically,
3− seconds,
4− minutes,
5− hours
6− ) where
1+module Server.Periodic where
72
83import Control.Monad.IO.Class
94import Control.Concurrent
denis/src/Server/Query/ComplexQuery.hs+2−4
@@ -15,9 +15,7 @@
1515{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
1616{-# OPTIONS_GHC -Wno-orphans #-}
1717
18−module Server.Query.ComplexQuery (
19− ComplexQuery
20−) where
18+module Server.Query.ComplexQuery where
2119
2220import Data.ByteString.Lazy (ByteString)
2321import Data.ByteString.Builder (toLazyByteString)
@@ -51,7 +49,7 @@ instance {-# Overlapping #-} ToSample [ComplexQueryRequest] where
5149 toSamples _ = singleSample $ [ComplexQueryRequest "channels/" "", ComplexQueryRequest "posts/last" "3"]
5250
5351instance {-# 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\":[]}]}"]
5553
5654-- MARK: Implementation
5755
denis/src/Server/Query/Dialog.hs+9−7
@@ -2,11 +2,7 @@
22 OverloadedStrings,
33 DeriveGeneric #-}
44
5−module Server.Query.Dialog (
6− ChatsResponse(..),
7− responseToDialogs,
8− Dialog(..)
9− ) where
5+module Server.Query.Dialog where
106
117import Data.Aeson
128import Data.Message
@@ -25,7 +21,12 @@ instance ToSample Dialog where
2521 toSamples _ = samples (take 1 (UserDialog <$> [69] <*> map snd (toSamples Proxy)) <>
2622 (GroupDialog <$> map snd (toSamples Proxy) <*> map snd (toSamples Proxy)))
2723
28−data Dialog = GroupDialog GroupChat (Maybe Message) | UserDialog UserId Message
24+-- |Объект диалога
25+data Dialog =
26+ -- |Thing
27+ GroupDialog GroupChat (Maybe Message) |
28+ -- |Also a thing
29+ UserDialog UserId Message
2930 deriving Show
3031
3132instance ToJSON Dialog where
@@ -42,7 +43,8 @@ instance ToJSON Dialog where
4243 ]
4344 ]
4445
45−data ChatsResponse = ChatsResponse {
46+data ChatsResponse =
47+ ChatsResponse {
4648 chatResponseMessageId :: MessageId,
4749 chatResponseMessageAuthorId :: Maybe UserId,
4850 chatResponseMessageDestinationGroupId :: Maybe GroupChatId,
denis/src/Server/Query/Pagination.hs+1−5
@@ -11,11 +11,7 @@
1111 UndecidableInstances,
1212 UndecidableSuperClasses #-}
1313
14−module Server.Query.Pagination (
15− PaginatingRequest(..),
16− PaginationDirection(..),
17− validatePaginationRequest
18− ) where
14+module Server.Query.Pagination where
1915
2016import GHC.Generics
2117import Data.Aeson as A
denis/src/Server/Server.hs+1−5
@@ -3,11 +3,7 @@
33 TypeOperators,
44 DataKinds #-}
55
6−module Server.Server (
7− runServer,
8− hoistedServer,
9− getConfig
10−) where
6+module Server.Server where
117
128import Server.API
139import Server.Auth
denis/src/test/Orphans.hs−4
@@ -71,10 +71,6 @@ instance Arbitrary (PostElement p) where
7171 arbitrary = genericArbitrary
7272 shrink = genericShrink
7373
74−instance Arbitrary PostQuote where
75− arbitrary = genericArbitrary
76− shrink = genericShrink
77−
7874instance Arbitrary AnonymousChannel where
7975 arbitrary = genericArbitrary
8076 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");