git.iko.soy/denis
on master help sign in
swap
864681351 ahead, 2 behind
39 files changed+350−485
since splitsnapshots
unifiedsplit
denis/package.yaml−1 denis/sql/indexes.sql+5 denis/src/Data/Channel/AnonymousChannel.hs+8−5 denis/src/Data/Channel/NamedChannel.hs+5−11 denis/src/Data/Connection.hs+12−11 denis/src/Data/CyclicBuffer.hs+5−6 denis/src/Data/Faculty.hs+4−10 denis/src/Data/Faculty/Parser.hs+4−9 denis/src/Data/GroupChat.hs+9−12 denis/src/Data/Limits.hs+3−9 denis/src/Data/Message.hs+11−29 denis/src/Data/Post.hs+10−25 denis/src/Data/PostElement.hs+29−33 denis/src/Data/Query.hs+62−170 denis/src/Data/Schema.hs+5−3 denis/src/Data/Tags/Completions.hs+4−3 denis/src/Data/Tags/Validation.hs+10−7 denis/src/Data/Text/Validator.hs+9−8 denis/src/Data/User.hs+8−18 denis/src/Server/API.hs+13−14 denis/src/Server/API/Channels.hs+12−20 denis/src/Server/API/Completions.hs+7−4 denis/src/Server/API/Faculty.hs+5−2 denis/src/Server/API/Messages.hs+12−10 denis/src/Server/API/Posts.hs+4−8 denis/src/Server/App.hs+10−2 denis/src/Server/Auth.hs+20−14 denis/src/Server/Auth/HTML.hs+7−1 denis/src/Server/Auth/Mail.hs+3−2 denis/src/Server/Auth/Token.hs+9−1 denis/src/Server/Error.hs+8−1 denis/src/Server/Logger.hs+6−2 denis/src/Server/Periodic.hs+6−1 denis/src/Server/Query/ComplexQuery.hs+4−2 denis/src/Server/Query/Dialog.hs+7−9 denis/src/Server/Query/Pagination.hs+5−1 denis/src/Server/Server.hs+5−1 denis/src/test/Orphans.hs+4 sql/indexes.sql−20
denis/package.yaml−1
@@ -67,7 +67,6 @@ dependencies:
6767- generic-arbitrary
6868- quickcheck-instances
6969- http-client
70−- blaze-markup
7170
7271library:
7372 source-dirs: src
denis/sql/indexes.sqlnew file+5
@@ -0,0 +1,5 @@
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+8−5
@@ -1,4 +1,4 @@
1− {-# LANGUAGE
1+{-# LANGUAGE
22 DataKinds ,
33 DeriveGeneric ,
44 OverloadedLabels,
@@ -8,8 +8,12 @@
88 OverloadedStrings,
99 RecordWildCards #-}
1010
11−module Data.Channel.AnonymousChannel where
11+module Data.Channel.AnonymousChannel (
12+ AnonymousChannelId,
13+ AnonymousChannel(..)
14+) where
1215
16+import Data.Int (Int64)
1317import qualified Generics.SOP as SOP
1418import qualified GHC.Generics as GHC
1519import Data.Aeson
@@ -32,11 +36,10 @@ instance HasValidatableText AnonymousChannel where
3236
3337-- MARK: Implementation
3438
35−-- |Анонимные канал -- канал, который не хрнится на сервере.
39+type AnonymousChannelId = Int64
40+
3641data AnonymousChannel = AnonymousChannel {
37− -- |Список тегов в канале
3842 anonymousChannelTags :: V.Vector Text,
39− -- |Список людей в анонимном канале
4043 anonymousChannelPeopleIds :: [UserId]
4144} deriving GHC.Generic
4245
denis/src/Data/Channel/NamedChannel.hs+5−11
@@ -8,7 +8,11 @@ TypeOperators,
88OverloadedStrings,
99RecordWildCards #-}
1010
11−module Data.Channel.NamedChannel where
11+module Data.Channel.NamedChannel (
12+ NamedChannelId,
13+ NamedChannel(..),
14+ NamedChannelCreationRequest(..)
15+) where
1216
1317import Data.Int (Int64)
1418import qualified Generics.SOP as SOP
@@ -40,19 +44,13 @@ instance HasValidatableText (NamedChannelCreationRequest) where
4044
4145-- MARK: Implementation
4246
43−-- |Тип -- идентификатор именнованного канала.
4447type NamedChannelId = Int64
4548
4649-- Note: Channel owner only exists in sql
47−-- |Структура данных именованного канала.
4850data NamedChannel u = NamedChannel {
49− -- |Идентификатор именованного канала.
5051 namedChannelId :: NamedChannelId,
51− -- |Имя именнованного канала.
5252 namedChannelName :: Text,
53− -- |Список тегов в именованном канале.
5453 namedChannelTags :: V.Vector Text,
55− -- |Список идентификаторов пользователей в именованном канале.
5654 namedChannelPeopleIds :: V.Vector u
5755} deriving GHC.Generic
5856
@@ -72,13 +70,9 @@ instance (FromJSON u, Ord u) => FromJSON (NamedChannel u) where
7270
7371-- MARK: NamedChannelCreationRequest
7472
75−-- |Объект-запрос на создание именованного канала.
7673data NamedChannelCreationRequest = NamedChannelCreationRequest {
77− -- |Название канала.
7874 namedChannelCreationRequestName :: Text,
79− -- |Список тегов в канале.
8075 namedChannelCreationRequestTags :: V.Vector Text,
81− -- |Список идентификаторов пользователей в канале.
8276 namedChannelCreationRequestPeopleIds :: V.Vector UserId
8377} deriving GHC.Generic
8478
denis/src/Data/Connection.hs+12−11
@@ -7,7 +7,18 @@
77 TypeOperators,
88 FlexibleContexts #-}
99
10−module Data.Connection where
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
1122
1223import Squeal.PostgreSQL
1324import Squeal.PostgreSQL.Pool
@@ -19,49 +30,39 @@ import Servant.Server
1930import Server.Error
2031import Control.Monad.Trans.Control
2132
22−-- |Монада для совершения запросов и манимпуляций с базой данных в рамках сервера.
2333type StaticPQ = PoolPQ Schema Handler
2434
25−-- |Функция, печатающая текст красным цветом в консоль.
2635printRed :: (Show a) => a -> IO ()
2736printRed a = do
2837 putStr "\a\x001b[31m"
2938 print a
3039 putStr "\x001b[0m"
3140
32−-- |Функция, выполняющая запрос к бае данных.
3341runQ :: ServantErr -> StaticPQ a -> App a
3442runQ err req = handleSqueal ((>> throwError err) . liftIO . printRed) $ asks getPool >>= lift . runPoolPQ req
3543
36−-- |Функция, выполняющая запрос к бае данных.
3744runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a
3845runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn
3946
40−-- |Функция, выполняющая запрос к бае данных.
4147runQnotFound :: StaticPQ a -> App a
4248runQnotFound = runQ err404
4349
44−-- |Функция, выполняющая запрос к бае данных.
4550runQerror :: StaticPQ a -> App a
4651runQerror = runQ err500
4752
48−-- |Функция, выполняющая запрос к бае данных.
4953runQsilent :: StaticPQ a -> App ()
5054runQsilent req = handleSqueal (liftIO . print) $ asks getPool >>= lift . runPoolPQ req
5155 >> return ()
5256
53−-- |Функция, выкидывающая исключение при отсутсвии значения.
5457maybeNotFound :: App (Maybe a) -> App a
5558maybeNotFound = (>>= (\t -> case t of
5659 Just y -> return y
5760 Nothing -> throwError err404))
5861
59−-- |Функция, выкидывающая исключение при отсутсвии значения.
6062maybeInvalidToken :: App (Maybe a) -> App a
6163maybeInvalidToken = (>>= (\t -> case t of
6264 Just y -> return y
6365 Nothing -> throwError invalidToken))
6466
65−-- |Функция, совершающая операцию внутри транакции базы данных.
6667commitedTransactionallyUpdate :: (MonadBaseControl IO tx, MonadPQ schema tx) => tx x -> tx x
6768commitedTransactionallyUpdate = transactionally $ TransactionMode ReadCommitted ReadWrite NotDeferrable
denis/src/Data/CyclicBuffer.hs+5−6
@@ -1,19 +1,18 @@
11{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
22
3−module Data.CyclicBuffer where
3+module Data.CyclicBuffer (
4+ CyclicBuffer(elems),
5+ mkCyclicBuffer,
6+ insertIntoCyclicBuffer
7+) where
48
5−-- |Объект циклического буфера
69data CyclicBuffer a = CyclicBuffer {
7− -- |Элементы в циклическом буфере
810 elems :: [a],
9− -- |Количество элементов в циклическом буфере
1011 limit :: Int
1112}
1213
13−-- |Функция, создающая циклический буфер с данным размером
1414mkCyclicBuffer :: Int -> CyclicBuffer a
1515mkCyclicBuffer lim = CyclicBuffer [] lim
1616
17−-- |Функция, добавлющая эоемент в циклический буфер
1817insertIntoCyclicBuffer :: CyclicBuffer a -> a -> CyclicBuffer a
1918insertIntoCyclicBuffer (CyclicBuffer els lim) el = CyclicBuffer (take lim $ el:els) lim
denis/src/Data/Faculty.hs+4−10
@@ -8,7 +8,10 @@
88 OverloadedStrings,
99 DeriveAnyClass #-}
1010
11−module Data.Faculty where
11+module Data.Faculty (
12+ Faculty(..),
13+ FacultyUrl
14+ ) where
1215
1316import qualified Generics.SOP as SOP
1417import qualified GHC.Generics as GHC
@@ -21,24 +24,15 @@ instance ToSample Faculty where
2124 toSamples _ = singleSample $ Faculty "ПИ" "cs.hse.ru/bse" "ФКН -> ПИ" "Москва" "193729"
2225 (V.fromList ["Программирование", "Естсественные науки"]) "Настоящий адрес факультета"
2326
24−-- |Адрес сайта департамента
2527type FacultyUrl = T.Text
2628
27−-- |Объект департамента
2829data Faculty = Faculty {
29− -- |Название департамента
3030 facultyName :: T.Text,
31− -- |Адрес сайта департамента
3231 facultyUrl :: FacultyUrl,
33− -- |Вспомогательный текст дапартамента с сайта
3432 facultyPath :: T.Text,
35− -- |Название кампуса
3633 facultyCampusName :: T.Text,
37− -- |Код кампуса департамента
3834 facultyCampusCode :: T.Text,
39− -- |Теги департамента
4035 facultyTags :: V.Vector T.Text,
41− -- |Адрес департамента
4236 facultyAddress :: T.Text
4337} deriving (GHC.Generic, Show, SOP.Generic, SOP.HasDatatypeInfo)
4438
denis/src/Data/Faculty/Parser.hs+4−9
@@ -2,7 +2,9 @@
22 OverloadedStrings,
33 TupleSections #-}
44
5−module Data.Faculty.Parser where
5+module Data.Faculty.Parser (
6+ getFaculties
7+ ) where
68
79import Network.HTTP.Req
810import qualified Data.Text as T
@@ -16,20 +18,17 @@ import Control.Monad.IO.Class
1618import Data.Default
1719import qualified Data.Vector as V
1820
19−-- |Функция, возвращающая список факультетов с сайта ВШЭ.
2021getFaculties :: MonadIO m => m [Faculty]
2122getFaculties = runReq def $ do
2223 campuses <- getCampuses
2324 concat <$> mapM (\c -> getFacultiesForCampus c) campuses
2425
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−-- |Функция, возвращающая список кампусов с сайта ВШЭ.
3332getCampuses :: Req [Campus]
3433getCampuses = do
3534 let url = https "www.hse.ru" /: "org" /: "units"
@@ -46,7 +45,7 @@ getCampuses = do
4645 code <- HM.lookup "hse-value" hm
4746 return $ Campus (T.strip name) code
4847
49−-- |Функция, возвращающая список подразделений для данного кампуса.
48+
5049getFacultiesForCampus :: Campus -> Req [Faculty]
5150getFacultiesForCampus (Campus cName cCode) = do
5251 let url = https "www.hse.ru" /: "org" /: "units" /: "campus" /: cCode
@@ -68,22 +67,18 @@ getFacultiesForCampus (Campus cName cCode) = do
6867 let address = T.unwords . map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "link link_dark i") $ els
6968 return $ Faculty name url path cName cCode (V.fromList tags) address
7069
71−-- |Функция, проверяющая, имеет ли данный HTML тег атрибут принадлежности к данному классу.
7270classIs :: T.Text -> Element -> Bool
7371classIs c = (== (Just c)) . HM.lookup "class" . eltAttrs
7472
75−-- |Фозвращает список всех подэлементов данного HTML тега при поиске в глубину.
7673elements :: [Node] -> [Element]
7774elements ((NodeElement el):nn) = el : ((elements . eltChildren) el ++ elements nn)
7875elements _ = []
7976
80−-- |Функция, возвращающая список всего текстового содержания HTML тегов.
8177texts' :: HM.HashMap T.Text T.Text -> [Node] -> [(HM.HashMap T.Text T.Text, T.Text)]
8278texts' hm (NodeContent t: nn) = (hm, t) : texts' hm nn
8379texts' hm ((NodeElement el):nn) = ((texts' (HM.union (eltAttrs el) hm) (eltChildren el)) ++ texts' hm nn)
8480texts' _ _ = []
8581
86−-- |Объкт кампуса.
8782data Campus = Campus {
8883 campusName :: T.Text,
8984 campusCode :: T.Text
denis/src/Data/GroupChat.hs+9−12
@@ -12,7 +12,15 @@
1212{-# OPTIONS_GHC -Wno-orphans #-}
1313
1414
15−module Data.GroupChat where
15+module Data.GroupChat (
16+ GroupChat(..),
17+ GroupChatPermissions(..),
18+ GroupChatId,
19+ UserPermissions,
20+ GroupChatCreation(..),
21+ maxChatPermissions,
22+ minChatPermissions
23+ ) where
1624
1725import Data.Aeson
1826import Data.Int (Int64)
@@ -48,18 +56,12 @@ instance HasValidatableText GroupChatCreation where
4856instance ToSample UserPermissions where
4957 toSamples _ = singleSample $ M.fromList [(69, GroupChatPermissions True), (5051, GroupChatPermissions False)]
5058
51−-- |Идентификатор групповой беседы.
5259type GroupChatId = Int64
53−-- |Права участников групповой беседы.
5460type UserPermissions = M.Map UserId GroupChatPermissions
5561
56−-- |Объект групповой беседы.
5762data GroupChat = GroupChat {
58− -- |Идентификатор групповой беседы.
5963 groupChatId :: GroupChatId,
60− -- |Права участников беседы.
6164 groupChatUsers :: Jsonb UserPermissions,
62− -- |Имя групповой беседы.
6365 groupChatName :: Text
6466} deriving (Show, GHC.Generic)
6567
@@ -76,18 +78,14 @@ instance FromJSON GroupChat where
7678 parseJSON = withObject "group chat" $ \e ->
7779 GroupChat <$> e .: "id" <*> (Jsonb <$> e .: "users") <*> e .: "name"
7880
79−-- |Права участника беседы
8081data GroupChatPermissions = GroupChatPermissions {
8182 -- canInvite :: Bool,
8283 -- canKick :: Bool,
83− -- |Является ли данный участник администратором
8484 isAdmin :: Bool
8585} deriving (Show, GHC.Generic)
8686
87−-- |Максимально возможные права в групповой беседе.
8887maxChatPermissions :: GroupChatPermissions
8988maxChatPermissions = GroupChatPermissions True -- True True
90−-- |Минимально возможные права в групповой беседе.
9189minChatPermissions :: GroupChatPermissions
9290minChatPermissions = GroupChatPermissions False
9391
@@ -102,7 +100,6 @@ instance SOP.HasDatatypeInfo GroupChatPermissions
102100instance ToJSON GroupChatPermissions
103101instance FromJSON GroupChatPermissions
104102
105−-- |Объект для создания групповой беседы
106103data GroupChatCreation = GroupChatCreation {
107104 groupChatCreationUsers :: Jsonb UserPermissions,
108105 groupChatCreationName :: Text
denis/src/Data/Limits.hs+3−9
@@ -4,38 +4,32 @@ module Data.Limits where
44
55import Data.Int (Int64)
66
7−-- |Максимально возможное количество количество символов в нвазвании канала.
87maxChannelName :: Int
98maxChannelName = 60
109
11−-- |Максимально возможное количество количество символов в нвазвании групповой беседы.
1210maxGroupChatName :: Int
1311maxGroupChatName = 60
1412
15−-- |Максимальное количество элементов в элементе поста
13+maxMessageLimitName :: Int
14+maxMessageLimitName = 60
15+
1616postElementLengthLimit :: Int
1717postElementLengthLimit = 35000
1818
19−-- |Максимальное число символов в поле пользователя
2019userFieldLengthLimit :: Int
2120userFieldLengthLimit = 50
2221
23−-- |максимальное число тегов
2422maxNumberOfTags :: Int
2523maxNumberOfTags = 20
2624
27−-- |максимальное число именнованных каналов у пользователя
2825channelCountLimit :: Int64
2926channelCountLimit = 128
3027
31−-- |Максимальное число элементов, возвращаемых в списке запроса
3228listLimit :: Int
3329listLimit = 100
3430
35−-- |глобальное ограничение на количество символов в пользовательском тексте.
3631globalTextLimit :: Int
3732globalTextLimit = 50000
3833
39−-- |Максимальное число пользователей в групповой беседе
4034groupChatSizeLimit :: Int
4135groupChatSizeLimit = 256
denis/src/Data/Message.hs+11−29
@@ -11,7 +11,15 @@
1111{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
1212
1313
14−module Data.Message where
14+module Data.Message (
15+ MessageStorage(..),
16+ Message(..),
17+ MessageDetination(..),
18+ MessageId,
19+ restoreMessage,
20+ storeMessage,
21+ MessageCreation(..)
22+ ) where
1523
1624import Data.Aeson
1725import Data.PostElement
@@ -43,31 +51,18 @@ instance HasValidatableText Message where
4351instance HasValidatableText MessageCreation where
4452 validateText (MessageCreation _ _ (Jsonb mb)) = validateText mb
4553
46−-- |Идентификатор сообщения в групповой беседе.
4754type GroupChatMessageId = Int64
4855
49−-- |Адресат сообщения.
50−data MessageDetination
51− -- |Групповая беседа.
52− = GroupChatDestination GroupChatId
53− -- |Пользоваель.
54− | UserChatDestination UserId
56+data MessageDetination = GroupChatDestination GroupChatId | UserChatDestination UserId
5557 deriving (Show)
5658
57−-- |Идентификатор сообщения
5859type MessageId = Int64
5960
60−-- |Объект обычного представления сообщения.
6161data Message = Message {
62− -- |Идентификатор сообщения.
6362 messageId :: MessageId,
64− -- |Идентификатор автора сообщения.
6563 messageAuthorId :: UserId,
66− -- |Адресат сообщения.
6764 messageDestinationId :: MessageDetination,
68− -- |Содержание сообщения.
6965 messageBody :: PostElement Message,
70− -- |Время отправки сообщения.
7166 messageTime :: UTCTime
7267} deriving (Show)
7368
@@ -91,19 +86,13 @@ instance FromJSON Message where
9186 <*> e .: "body"
9287 <*> e .: "time"
9388
94−-- |Объект для представления сообщения в базе данных.
89+
9590data MessageStorage = MessageStorage {
96− -- |Идентификатор сообщения.
9791 messageStorageId :: MessageId,
98− -- |Идентификатор автора сообщения.
9992 messageStorageAuthorId :: Maybe UserId,
100− -- |Идентификатор групповой беседы как адресата сообщения.
10193 messageStorageDestinationGroupId :: Maybe GroupChatId,
102− -- |Идентификатор пользователя как адресата сообщения.
10394 messageStorageDestinationUserId :: Maybe UserId,
104− -- |Содержание сообщения.
10595 messageStorageBody :: Maybe (Jsonb (PostElement Message)),
106− -- |Время отправки сообщения.
10796 messageStorageTime :: UTCTime
10897} deriving GHC.Generic
10998
@@ -112,11 +101,9 @@ instance SOP.HasDatatypeInfo (MessageStorage)
112101
113102infixl 4 <>>
114103
115−-- |Оператор, применяющий функция в функторе к объекту вне функтора.
116104(<>>) :: Applicative f => f (a -> b) -> a -> f b
117105f <>> a = f <*> pure a
118106
119−-- |Функция, переводящая представление сообщения из базы данных в обычное.
120107restoreMessage :: MessageStorage -> Maybe Message
121108restoreMessage (MessageStorage mId (Just aId) gId uId (Just (Jsonb pb)) mt) =
122109 Message mId aId <$> case (gId, uId) of
@@ -126,7 +113,6 @@ restoreMessage (MessageStorage mId (Just aId) gId uId (Just (Jsonb pb)) mt) =
126113 <>> pb <>> mt
127114restoreMessage _ = Nothing
128115
129−-- |Функция переводящая обычное представление сообщения в представление для базы данных.
130116storeMessage :: Message -> MessageStorage
131117storeMessage (Message mId aId dId pb mt) = case dId of
132118 GroupChatDestination gId -> MessageStorage mId (Just aId) (Just gId) Nothing (Just (Jsonb pb)) mt
@@ -138,13 +124,9 @@ instance ToSample MessageCreation where
138124 (MessageCreation (Just 5) Nothing <$>
139125 map (Jsonb . snd) (toSamples Proxy))
140126
141−-- |Объект для создания сообщения.
142127data MessageCreation = MessageCreation {
143− -- |Идентификатор групповой беседы - адресата сообщения.
144128 messageCreationDestinationGroupId :: Maybe GroupChatId,
145− -- |Идентификатор пользователя - адресата сообщения.
146129 messageCreationDestinationUserId :: Maybe UserId,
147− -- |Содержание сообщения.
148130 messageCreationBody :: Jsonb (PostElement (MessageCreation))
149131} deriving (Show, GHC.Generic)
150132
denis/src/Data/Post.hs+10−25
@@ -7,7 +7,15 @@
77 TypeOperators,
88 OverloadedStrings #-}
99
10−module Data.Post where
10+module Data.Post (
11+ Post(..),
12+ PostElement,
13+ rowsToPost,
14+ PostId,
15+ QuoteId,
16+ PostRowResponse(..),
17+ PostCreation(..)
18+) where
1119
1220import Data.Int (Int64)
1321import qualified Generics.SOP as SOP
@@ -38,22 +46,14 @@ instance HasValidatableText PostCreation where
3846
3947-- MARK: Actual type
4048
41−-- |Идентификатор поста.
4249type PostId = Int64
43−-- |Идентификатор цитаты.
4450type QuoteId = Int64
4551
46−-- |Объект поста
4752data Post = Post {
48− -- |Идентификатор поста.
4953 postId :: Int64,
50− -- |Идентификатор автора поста.
5154 postAuthorId :: Int64,
52− -- |Время последнего обновления поста.
5355 updated :: UTCTime,
54− -- |Теги поста.
5556 postTags :: V.Vector Text,
56− -- |Содержание поста.
5757 postBody :: [PostElement Post]
5858} deriving (Show)
5959
@@ -65,11 +65,8 @@ instance ToJSON Post where
6565 "tags" .= tags,
6666 "body" .= pb ]
6767
68−-- |Объект для создания поста
6968data PostCreation = PostCreation {
70− -- |Содержание поста.
7169 postCreationBody :: [PostElement Post],
72− -- |Теги поста.
7370 postCreationTags :: V.Vector Text
7471} deriving GHC.Generic
7572
@@ -89,41 +86,29 @@ instance FromJSON PostCreation where
8986-- MARK: Rows
9087
9188-- Need to manually maintain. Future: https://github.com/morphismtech/squeal/issues/96
92−-- |Объект поста при ответе с базы данных.
89+
9390data PostRowResponse = PostRowResponse {
9491 -- PostRow
95− -- |Идентификатор поста.
9692 postRowId :: Int64,
97− -- |Идентификатор автора поста.
9893 postRowAuthorId :: Int64,
99− -- |Время последнего обновления поста.
10094 postRowUpdateTime :: UTCTime,
101− -- |Теги поста.
10295 postRowTags :: V.Vector Text,
10396
10497 -- ElementRow
105− -- |Порядковый номер элемента поста.
10698 rowElementOrd :: Int64,
107− -- |Markdown элемент поста.
10899 rowElementMarkdown :: Maybe Text,
109− -- |Latex элемент поста.
110100 rowElementLatex :: Maybe Text,
111− -- |Изображение.
112101 rowElementImage :: Maybe Text,
113− -- |Цитата.
114102 rowElementQuote :: Maybe Int64,
115− -- |Файл.
116103 rowElementAttachment :: Maybe Text
117104} deriving (GHC.Generic)
118105
119106instance SOP.Generic PostRowResponse
120107instance SOP.HasDatatypeInfo PostRowResponse
121108
122−-- |Функция, переводящая объект поста при ответе с базы данных в какой-то поста при помощи данного отображения.
123109unRow :: MkElementRow x -> PostRowResponse -> x
124110unRow f' (PostRowResponse _ _ _ _ _ a b c d e) = f' a b c d e
125111
126−-- |Функция, переводящая объект поста при ответе с базы данных в обычный объект поста.
127112rowsToPost :: [PostRowResponse] -> Maybe Post
128113rowsToPost [] = Nothing
129114rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
denis/src/Data/PostElement.hs+29−33
@@ -9,12 +9,21 @@
99{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
1010
1111
12−module Data.PostElement where
12+module Data.PostElement (
13+ elemenToRow,
14+ rowsToElement,
15+ MkElementRow,
16+ PostElementRow(..),
17+ PostElement(..),
18+ elementsToRows,
19+ PostQuote(..),
20+ stripPostElement
21+) where
1322
1423import Data.Int (Int64)
1524import qualified Generics.SOP as SOP
1625import qualified GHC.Generics as GHC
17−import Data.Text (Text)
26+import Data.Text (Text, strip)
1827import Data.Aeson
1928import Control.Applicative ((<|>))
2029import Servant.Docs (ToSample, toSamples, samples)
@@ -39,20 +48,18 @@ instance HasValidatableText (PostElement p) where
3948
4049-- MARK: PostElement
4150
42−-- |Обычный элемент поста.
43−data PostElement a
44− -- |Markdown элемент поста.
45− = Markdown Text
46− -- |Latex элемент поста.
51+data PostElement a = Markdown Text
4752 | Latex Text
48− -- |Изорбражение.
4953 | Image Text
50− -- |Цитата.
5154 | Quote ()
52− -- |Документ.
5355 | Attachment Text
5456 deriving (Show, GHC.Generic)
5557
58+stripPostElement :: (PostElement a) -> (PostElement a)
59+stripPostElement (Markdown t) = Markdown (strip t)
60+stripPostElement (Latex t) = Latex (strip t)
61+stripPostElement u = u
62+
5663instance ToJSON (PostElement t) where
5764 toJSON (Markdown m) = object ["markdown" .= m]
5865 toJSON (Latex l) = object ["latex" .= l]
@@ -71,10 +78,8 @@ instance FromJSON (PostElement t) where
7178
7279-- -- MARK: PostElementRows
7380
74−-- |Тип отображения из элемента поста с базы данных в другой объект.
7581type MkElementRow x = Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> x
7682
77−-- |Функция, переводящая обычный элемент поста в другой объект.
7883elemenToRow :: MkElementRow x -> PostElement p -> x
7984elemenToRow f el = case el of
8085 Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
@@ -84,7 +89,6 @@ elemenToRow f el = case el of
8489 Quote _ -> f Nothing Nothing Nothing Nothing Nothing
8590 Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
8691
87−-- |Отображение элемента поста с базы данных в обычный элемент поста.
8892rowsToElement :: MkElementRow (Maybe (PostElement p))
8993rowsToElement (Just m) Nothing Nothing Nothing Nothing = Just $ Markdown m
9094rowsToElement Nothing (Just l) Nothing Nothing Nothing = Just $ Latex l
@@ -94,45 +98,37 @@ rowsToElement Nothing Nothing (Just i) Nothing Nothing = Just $ Image i
9498rowsToElement Nothing Nothing Nothing Nothing (Just a) = Just $ Attachment a
9599rowsToElement _ _ _ _ _ = Nothing
96100
97−-- |Объект поста с базы данных
98101data PostElementRow a = PostElementRow {
99− -- |Идентификатор элемента поста
100102 rowElementId :: Int64,
101− -- |Порядковый номер элемента поста.
102103 rowElementOrd :: Int64,
103− -- |Markdown элемент.
104104 rowElementMarkdown :: Maybe Text,
105− -- |LaTeX элемент.
106105 rowElementLatex :: Maybe Text,
107− -- |Изорбражение.
108106 rowElementImage :: Maybe Text,
109− -- |Цитата.
110107 rowElementQuote :: Maybe Int64,
111− -- |Приложение.
112108 rowElementAttachment :: Maybe Text
113109} deriving (GHC.Generic)
114110
115111instance SOP.Generic (PostElementRow a)
116112instance SOP.HasDatatypeInfo (PostElementRow a)
117113
118−-- |Функция, переводящая обычные элементы постоа в их представления для базы данных.
114+
119115elementsToRows :: Int64 -> [PostElement a] -> [PostElementRow a]
120116elementsToRows pId els = map (\(el, f) -> elemenToRow f el) . zip els . map (PostElementRow pId) $ [0..]
121117
122118
123119-- -- MARK: Quote
124120
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 ]
121+data PostQuote = PostQuote {
122+ quoteId :: Int64,
123+ quoteBody :: [PostElement PostQuote],
124+ quotePostId :: Int64
125+} deriving (Show, GHC.Generic)
126+
127+instance ToJSON PostQuote where
128+ toJSON (PostQuote qId pb pId) = object [
129+ "id" .= qId,
130+ "postId" .= pId,
131+ "quoteBody" .= pb ]
136132
137133
138134-- -- MARK: PostQuoteRow
denis/src/Data/Query.hs+62−170
@@ -15,7 +15,59 @@
1515{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
1616
1717
18−module Data.Query where
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
1971
2072import Squeal.PostgreSQL
2173import Data.User
@@ -58,9 +110,6 @@ import qualified Data.Vector as V
58110import Server.Auth.Token
59111import Server.Error
60112import Data.Text.Validator
61−import Control.Monad.Except
62−import Control.Monad.IO.Class
63−import Crypto.Hash.SHA512 (hash)
64113
65114-- MARK: Documentation
66115
@@ -73,17 +122,14 @@ instance (ToSample r) => ToSample (ResponseWithUsers r) where
73122type TableEndo schema params from grouping = TableExpression schema params from grouping ->
74123 TableExpression schema params from grouping
75124
76−-- |Функция, возвращаяющая запрос на посты, прменяя к нему данный ндоморфизм.
77125postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
78126postsQ te = selectStar $ te (from $ table #posts)
79127
80−-- |Функция, возвращающая посты
81128postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped
82129postViewT te = from $ subquery (postsQ te `As` #posts) &
83130 innerJoin (table #postElements)
84131 (#posts ! #postRowId .== #postElements ! #rowElementId)
85132
86−-- |Функция, возвращающая запрос на поста, примення два промежуточных эндоморфизма к таблице.
87133getPostQ
88134 :: TableEndo Schema params _ 'Ungrouped
89135 -- ^ PostRowResponse endo
@@ -126,7 +172,6 @@ getPostQ oTe te = select (
126172-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
127173-- return $ M.lookup qId rows >>= rowsToQuote rows
128174
129−-- |Запрос, возвращающий пользователя по адресу почты.
130175getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))
131176getUserWithEmailQ = select (
132177 #userRowId `as` #userId :*
@@ -139,7 +184,6 @@ getUserWithEmailQ = select (
139184 where_ (#userRowEmail .== param @1) &
140185 where_ (notNull #userRowIsValidated))
141186
142−-- |Запрос, возвращающий подтвержденных пользователей.
143187verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
144188verifiedUserIdsQ uIds = case idsToColumn uIds of
145189 Just idQ -> Just $ select (#users ! #userRowId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
@@ -147,7 +191,6 @@ verifiedUserIdsQ uIds = case idsToColumn uIds of
147191 (#ids ! #id .== #users ! #userRowId))
148192 Nothing -> Nothing
149193
150−-- |Запрос, возвращающий пользователей с данными идентификаторами.
151194getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))
152195getUsersQ uIds = case idsToColumn uIds of
153196 Just idQ -> Just $ select (
@@ -173,7 +216,6 @@ getUsersQ uIds = case idsToColumn uIds of
173216 where_ (notNull $ #users ! #userRowIsValidated))
174217 Nothing -> Nothing
175218
176−-- |Запорс, возвращающий всех пользователей.
177219getAllUsersQ :: Query Schema '[] (RowPG UserRow)
178220getAllUsersQ = select (
179221 #users ! #userRowId :*
@@ -195,7 +237,6 @@ getAllUsersQ = select (
195237 (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&
196238 where_ (notNull $ #users ! #userRowIsValidated))
197239
198−-- |Запрос, возвращающий все посты по идентификатору.
199240getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
200241getPostsByIdQ pIds = case idsToColumn pIds of
201242 Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
@@ -204,17 +245,14 @@ getPostsByIdQ pIds = case idsToColumn pIds of
204245 (#ids ! #id .== #posts ! #postRowId))
205246 Nothing -> Nothing
206247
207−-- |Ограничение
208248type Limit = Word64
209249
210−-- |SQL оператор IS NOT FALSE
211250isNotFalse
212251 :: Expression schema from grouping params ('Null ty)
213252 -- ^ possibly @NULL@
214253 -> Condition schema from grouping params
215254isNotFalse x = UnsafeExpression $ renderExpression x <+> "IS NOT FALSE"
216255
217−-- |Запрос, возвращающий последние посты.
218256getLastPostsQ
219257 :: TableEndo _ _ _ _
220258 -> Limit
@@ -229,14 +267,12 @@ getLastPostsQ te lim dir = getPostQ
229267 where
230268 ((.^), order) = directionToOperator dir
231269
232−-- |Запрос, возвращающий последние посты для данного пользователя.
233270getLastNPostsForUserQ
234271 :: Limit
235272 -> P.PaginationDirection
236273 -> Query Schema (TuplePG (Maybe PostId, UserId)) (RowPG PostRowResponse)
237274getLastNPostsForUserQ = getLastPostsQ $ where_ (#posts ! #postRowAuthorId .== param @2)
238275
239−-- |Запрос на создание поста.
240276createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
241277createPostRowQ = insertRow #posts
242278 (Default `as` #postRowId :*
@@ -246,7 +282,6 @@ createPostRowQ = insertRow #posts
246282 OnConflictDoRaise
247283 (Returning $ #postRowId `as` #fromOnly)
248284
249−-- |Запрос на создание элементов постов.
250285createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
251286createPostElementRowsQ = insertRow_ #postElements
252287 (Set (param @1) `as` #rowElementId :*
@@ -257,13 +292,11 @@ createPostElementRowsQ = insertRow_ #postElements
257292 Set (param @6) `as` #rowElementQuote :*
258293 Set (param @7) `as` #rowElementAttachment)
259294
260−-- |Запрос, возвращающий канал для данного пользователя.
261295getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
262296getChannelForUserQ = selectStar $
263297 from (table #channels) &
264298 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
265299
266−-- |Запрос, обновляющий данные о пользователе.
267300updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))
268301updateUserQ = update #users (
269302 Same `as` #userRowId :*
@@ -276,14 +309,12 @@ updateUserQ = update #users (
276309 (#userRowId .== param @1)
277310 (Returning $ #userRowId `as` #fromOnly)
278311
279−-- |Запрос, возвращающий каналы пользователя.
280312getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
281313getAllChannelsForUserQ = selectStar $
282314 from (table #channels) &
283315 where_ (#namedChannelFullOwner .== param @1) &
284316 orderBy [#namedChannelFullId & Desc]
285317
286−-- |Запрос, осуществляющий поиск по каналам данного пользователя.
287318searchChannelsForUserQ :: Query Schema (TuplePG (UserId, Text)) (RowPG NamedChannelFull)
288319searchChannelsForUserQ = selectStar $
289320 from (table #channels) &
@@ -300,7 +331,6 @@ searchChannelsForUserQ = selectStar $
300331 vector1 = tsVector' #namedChannelFullName
301332 query = tsQuery' (param @2)
302333
303−-- |Запрос, обновляющий факультет.
304334updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
305335updateFacultyQ = insertRow #faculties
306336 (
@@ -315,12 +345,10 @@ updateFacultyQ = insertRow #faculties
315345 (OnConflictDoNothing)
316346 (Returning Nil)
317347
318−-- |Запрос, возвращающий факультет.
319348getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
320349getFacultyQ = selectStar (from (table #faculties) &
321350 where_ (#facultyUrl .== param @1))
322351
323−-- |Запрос на создание нового именованного канала.
324352createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
325353createNamedChannelQ = insertRow #channels
326354 (
@@ -333,17 +361,14 @@ createNamedChannelQ = insertRow #channels
333361 OnConflictDoRaise
334362 (Returning $ #namedChannelFullId `as` #fromOnly)
335363
336−-- |Запрос, возвращающий количество каналов у данного пользователя.
337364countChannelsQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only Int64))
338365countChannelsQ = select (countStar `as` #fromOnly) (from (table #channels) &
339366 where_ (#namedChannelFullOwner .== param @1) &
340367 groupBy #namedChannelFullOwner)
341368
342−-- |Запрос, удаляющий канал у данного пользователя.
343369deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
344370deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
345371
346−-- |Запрос, обновляющий именованный канал.
347372updateNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelFull) '[]
348373updateNamedChannelQ = update_ #channels
349374 (
@@ -355,7 +380,6 @@ updateNamedChannelQ = update_ #channels
355380 )
356381 (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)
357382
358−-- |Запрос на каналы пользователя.
359383getChannelPostsQ
360384 :: Limit
361385 -> P.PaginationDirection
@@ -374,12 +398,10 @@ getChannelPostsQ lim dir uIds tags = getLastPostsQ
374398 Just uIdsQ -> (`in_` uIdsQ)
375399 Nothing -> const $ false
376400
377−-- |Запрос на все хэштеги.
378401getTagsQ :: Query Schema params (RowPG (Only String))
379402getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $
380403 from (table #posts)
381404
382−-- |Запорс на создание сообщения.
383405createMessageQ :: Manipulation
384406 Schema
385407 (TuplePG (UserId, Maybe GroupChatId, Maybe UserId, Jsonb (PostElement (MessageCreation))))
@@ -396,7 +418,6 @@ createMessageQ = insertRow #messages
396418 OnConflictDoRaise
397419 (Returning $ #messageStorageId `as` #fromOnly)
398420
399−-- |Запрос на создание фантомного сообщения.
400421createPhantomMessageQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]
401422createPhantomMessageQ = insertRow_ #messages
402423 (
@@ -408,7 +429,6 @@ createPhantomMessageQ = insertRow_ #messages
408429 Set currentTimestamp `as` #messageStorageTime
409430 )
410431
411−-- |Запрос на создание групповой беседы.
412432createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))
413433createGroupChatQ = insertRow #groupChats
414434 (
@@ -419,7 +439,6 @@ createGroupChatQ = insertRow #groupChats
419439 OnConflictDoRaise
420440 (Returning $ #groupChatId `as` #fromOnly)
421441
422−-- |Запрос на обновление групповой беседы.
423442updateGroupChatQ :: Manipulation Schema (TuplePG GroupChat) '[]
424443updateGroupChatQ = update_ #groupChats
425444 (
@@ -429,27 +448,23 @@ updateGroupChatQ = update_ #groupChats
429448 )
430449 (#groupChatId .== param @1)
431450
432−-- |Тип строки, воозвращаемой в промежуточном запросе на все диалоги.
433451type ChatsQueryResponse = '[
434452 "messageId" ::: 'NotNull (PG UserId),
435453 "messageGroupId" ::: 'Null (PG UserId),
436454 "messageUserId" ::: 'Null (PG UserId)
437455 ]
438456
439−-- |Тип оператора сравнения.
440457type ConditionOp schema from grouping params nullity0 nullity1 (ty :: PGType)
441458 = Expression schema from grouping params (nullity0 ty)
442459 -> Expression schema from grouping params (nullity1 ty)
443460 -> Condition schema from grouping params
444461
445−-- |Тип параметров на запрос диалогов.
446462type ChatQueryParams = TuplePG
447463 ( UserId
448464 , Maybe String -- Just UserId as String
449465 , Maybe MessageId
450466 )
451467
452−-- |Запрос на все диалоги.
453468getChatsQ
454469 :: Limit
455470 -> P.PaginationDirection
@@ -510,7 +525,6 @@ getChatsQ lim dir = select (
510525 where_ (isNotNull #messageStorageDestinationGroupId) &
511526 groupBy #messageStorageDestinationGroupId
512527
513−-- |Запрос на сообщения.
514528getMessagesQ
515529 :: Limit
516530 -> P.PaginationDirection
@@ -530,7 +544,6 @@ getMessagesQ lim dir = selectStar (from (table #messages) &
530544 where
531545 ((.^), order) = directionToOperator dir
532546
533−-- |Запрос на сообщения в групповой беседе.
534547getGroupMessagesQ
535548 :: Limit
536549 -> P.PaginationDirection
@@ -549,14 +562,12 @@ getGroupMessagesQ lim dir = selectStar (from (table #messages) &
549562 ((.^), order) = directionToOperator dir
550563
551564-- String -- user id as String
552−-- |Запрос на групповую беседу для данного пользователя.
553565getGroupChatForUserQ :: Query Schema (TuplePG (String, GroupChatId)) (RowPG GroupChat)
554566getGroupChatForUserQ = selectStar $
555567 (from (table #groupChats)) &
556568 where_ (#groupChatId .== param @2) &
557569 where_ (#groupChatUsers .? param @1)
558570
559−-- |Запрос на поиск факультета.
560571getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
561572getFacultySearchResultQ = selectStar (from (table #faculties) &
562573 where_ (vector @@ query) &
@@ -577,7 +588,6 @@ getFacultySearchResultQ = selectStar (from (table #faculties) &
577588 #facultyPath])
578589 query = tsQuery "russian" (param @1)
579590
580−-- |Запрос на поиск пользователя.
581591searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)
582592searchUsersQ = select (
583593 #users ! #userRowId :*
@@ -609,21 +619,19 @@ searchUsersQ = select (
609619 ])
610620 query = tsQuery' (param @1)
611621
612−-- |Запрос на теги по популярности.
613622tagsByFrquencyQ :: Query Schema params '["tag" ::: 'NotNull (PG Text), "count" ::: 'NotNull 'PGint8]
614623tagsByFrquencyQ = select
615624 (#fromOnly `as` #tag :* count #fromOnly `as` #count)
616625 (from (subquery $ getTagsQ `As` #tt) &
617626 groupBy #fromOnly)
618627
619−-- |Запрос на данной количество самых популярных тегов.
620628getNpopularTagsQ :: Limit -> Query Schema param (RowPG (Only Text))
621629getNpopularTagsQ lim = select (#tag `as` #fromOnly)
622630 (from (subquery $ tagsByFrquencyQ `As` #tt) &
623631 orderBy [#count & Desc] &
624632 limit lim)
625633
626−-- |Запрос на поиск по тегам.
634+
627635searchTagsQ :: Query Schema (TuplePG (Only Text)) (RowPG (Only Text))
628636searchTagsQ = select (#tag `as` #fromOnly) $
629637 from (subquery (tagsByFrquencyQ `As` #tt)) &
@@ -634,7 +642,6 @@ searchTagsQ = select (#tag `as` #fromOnly) $
634642 query = tsQuery' (param @1)
635643 vector = tsVector' #tag
636644
637−-- |PostgreSQL функция ts_rank_cd
638645tsRankCd
639646 :: Expression schema from grouping params ('NotNull 'PGtext)
640647 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -642,7 +649,6 @@ tsRankCd
642649tsRankCd vector query = UnsafeExpression $
643650 "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])
644651
645−-- |PostgreSQL функция ts_vector
646652tsVector
647653 :: ByteString -- ^ Language
648654 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -650,14 +656,12 @@ tsVector
650656tsVector lang x = UnsafeExpression $
651657 "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
652658
653−-- |PostgreSQL функция ts_vector без языка.
654659tsVector'
655660 :: Expression schema from grouping params ('NotNull 'PGtext)
656661 -> Expression schema from grouping params ('NotNull 'PGtext)
657662tsVector' x = UnsafeExpression $
658663 "to_tsvector" <> parenthesized (renderExpression x)
659664
660−-- |PostgreSQL функция ts_query.
661665tsQuery
662666 :: ByteString -- ^ Language
663667 -> Expression schema from grouping params ('NotNull 'PGtext)
@@ -665,38 +669,32 @@ tsQuery
665669tsQuery lang x = UnsafeExpression $
666670 "to_tsquery" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
667671
668−-- |PostgreSQL функция ts_query без языка.
669672tsQuery'
670673 :: Expression schema from grouping params ('NotNull 'PGtext)
671674 -> Expression schema from grouping params ('NotNull 'PGtext)
672675tsQuery' x = UnsafeExpression $
673676 "to_tsquery" <> parenthesized (renderExpression x)
674677
675−-- |PostgreSQL функция array_to_string
676678arrayToText
677679 :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
678680 -> Expression schema from grouping params ('NotNull 'PGtext)
679681arrayToText x = UnsafeExpression $
680682 "array_to_string" <> parenthesized (commaSeparated [renderExpression x, "' '"])
681683
682−-- |PostgreSQL оператор @@
683684(@@)
684685 :: Expression schema from grouping params (nullity0 'PGtext)
685686 -> Expression schema from grouping params (nullity1 'PGtext)
686687 -> Expression schema from grouping params (nullity2 'PGbool)
687688(@@) = unsafeBinaryOp "@@"
688689
689−-- |Пробел.
690690space :: Expression schema from grouping params ('NotNull 'PGtext)
691691space = UnsafeExpression "' '"
692692
693−-- |Функция, переводящая список варажений текста в одно выражение текста через пробел.
694693textArrayToText
695694 :: [Expression schema from grouping params ('NotNull 'PGtext)]
696695 -> Expression schema from grouping params ('NotNull 'PGtext)
697696textArrayToText = fold . L.intersperse space
698697
699−-- |Запрос, создающий пользователя.
700698createUserQ :: Manipulation Schema (TuplePG UserCreation) (RowPG (Only UserId))
701699createUserQ = insertRow #users (
702700 Default `as` #userRowId :*
@@ -709,13 +707,12 @@ createUserQ = insertRow #users (
709707 OnConflictDoRaise
710708 (Returning (#userRowId `as` #fromOnly))
711709
712−-- |Запрос, удалющий пользователей, которые не подтвердили свой профиль.
713710removeUnverifiedUserQ :: Manipulation Schema (TuplePG (Only UserEmail)) '[]
714711removeUnverifiedUserQ = deleteFrom_ #users
715712 (#userRowEmail .== param @1 .&&
716713 (not_ . notNull $ #userRowIsValidated))
717714
718−-- |Запрос, создающий токен.
715+
719716createTokenQ :: Manipulation Schema (TuplePG Token) '[]
720717createTokenQ = insertRow_ #tokens (
721718 Set (param @1) `as` #tokenUserId :*
@@ -728,7 +725,6 @@ createTokenQ = insertRow_ #tokens (
728725 Set (param @8) `as` #tokenDeactivationCode
729726 )
730727
731−-- |Запрос, обновляющий токен.
732728updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
733729updateTokenQ = update_ #tokens (
734730 Same `as` #tokenUserId :*
@@ -741,12 +737,10 @@ updateTokenQ = update_ #tokens (
741737 Set (param @8) `as` #tokenDeactivationCode)
742738 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
743739
744−-- |Запрос, удалющий токен.
745740deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
746741deleteTokenQ = deleteFrom_ #tokens
747742 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
748743
749−-- |Запрос, подтверждающий профиль пользователя.
750744validateUserQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
751745validateUserQ = update_ #users (
752746 Same `as` #userRowId :*
@@ -758,26 +752,22 @@ validateUserQ = update_ #users (
758752 Set true `as` #userRowIsValidated)
759753 (#userRowId .== param @1)
760754
761−-- |Запрос, возвращающий токен.
762755getTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
763756getTokenQ = selectStar (from (table #tokens) &
764757 where_ (#tokenUserId .== param @1 .&&
765758 #tokenValue .== param @2))
766759
767−-- |Запрос, возвращающий токен по хэшу кода активации.
768760getTokenActivationQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
769761getTokenActivationQ = selectStar (from (table #tokens) &
770762 where_ (#tokenUserId .== param @1 .&&
771763 #tokenActivationCode .== param @2))
772764
773−-- |Запрос, даективирующий токен.
774765deactivateTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) (RowPG (Only Text))
775766deactivateTokenQ = deleteFrom #tokens
776767 (#tokenUserId .== param @1 .&&
777768 #tokenDeactivationCode .== param @2)
778769 (Returning (#tokenUserAgent `as` #fromOnly))
779770
780−-- |Запрос, возвращающий подтвержденный токен.
781771getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
782772getVerifiedTokenQ = selectStar (from (table #tokens) &
783773 where_ (#tokenUserId .== param @1 .&&
@@ -785,17 +775,14 @@ getVerifiedTokenQ = selectStar (from (table #tokens) &
785775 isNull #tokenVerificationCode .&&
786776 currentTimestamp .< #tokenExpiryDate))
787777
788−-- |Запрос, даективирующий все токены для данного пользователя.
789778killAllTokensQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
790779killAllTokensQ = deleteFrom_ #tokens
791780 (#tokenUserId .== param @1)
792781
793−-- |Запрос, удаляющий недействительные токены.
794782pruneDeadTokensQ :: Manipulation Schema '[] '[]
795783pruneDeadTokensQ = deleteFrom_ #tokens
796784 (#tokenExpiryDate .< currentTimestamp)
797785
798−-- |Запрос, удаляющий неактивированных пользователей.
799786pruneGhostUsersQ :: Manipulation Schema '[] '[]
800787pruneGhostUsersQ = deleteFrom_ #users
801788 ((not_ . in_ #userRowId $ select (#tokens ! #tokenUserId `as` #id) (from $ table #tokens)) .&&
@@ -811,17 +798,11 @@ instance HasValidatableText UserCreation where
811798 userCreationUserFaculty,
812799 userCreationUserEmail]
813800
814−-- |Объект для создания пользователя.
815801data UserCreation = UserCreation {
816− -- |Имя.
817802 userCreationFirstName :: Text,
818− -- |Отчество.
819803 userCreationMiddleName :: Text,
820− -- |Фамилия.
821804 userCreationLastName :: Text,
822− -- |Факультет.
823805 userCreationUserFaculty :: FacultyUrl,
824− -- |Адрес почты.
825806 userCreationUserEmail :: Text
826807} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
827808
@@ -838,62 +819,42 @@ instance FromJSON UserCreation where
838819 parseJSON = withObject "user creation" $ \e ->
839820 UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
840821
841−-- |Объект для обновления пользователя.
842822data UserUpdateRow = UserUpdateRow {
843− -- |Идентификатор пользователя.
844823 userUpdateRowId :: UserId,
845− -- |Имя.
846824 userUpdateRowFirstName :: Text,
847− -- |Отчество.
848825 userUpdateRowMiddleName :: Text,
849− -- |Фамилия.
850826 userUpdateRowLastName :: Text,
851− -- |Факультет.
852827 userUpdateRowUserFaculty :: FacultyUrl
853828} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
854829
855−-- |Объект для создания канала.
830+
856831data NamedChannelCreation = NamedChannelCreation {
857− -- |Владелец канала.
858832 namedChannelCreationOwner :: UserId,
859− -- |Название канала.
860833 namedChannelCreationName :: Text,
861− -- |Теги в канале.
862834 namedChannelCreationTags :: Vector Text,
863− -- |Люди в канале.
864835 namedChannelCreationPeopleIds :: Vector UserId
865836} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
866837
867−-- |Функция, добавлющая в структуру пользователя.
868838addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
869839addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
870840
871−-- |Полный объект канала.
872841data NamedChannelFull = NamedChannelFull {
873− -- |Идентификатор.
874842 namedChannelFullId :: NamedChannelId,
875− -- |Владелец.
876843 namedChannelFullOwner :: UserId,
877− -- |Название.
878844 namedChannelFullName :: Text,
879− -- |Теги.
880845 namedChannelFullTags :: Vector Text,
881− -- |пользователи.
882846 namedChannelFullPeopleIds :: Vector UserId
883847} deriving GHC.Generic
884848
885849instance SOP.Generic NamedChannelFull
886850instance SOP.HasDatatypeInfo NamedChannelFull
887851
888−-- |Добавляет в структуру пользователя.
889852addUserToChannelUpdate :: UserId -> NamedChannel UserId -> NamedChannelFull
890853addUserToChannelUpdate uId (NamedChannel cId cName cTags cPeople) = NamedChannelFull cId uId cName cTags cPeople
891854
892−-- |Убирает пользователя из структуры.
893855removeUserFromChannel :: NamedChannelFull -> NamedChannel UserId
894856removeUserFromChannel (NamedChannelFull cId _ cName cTags cPeople) = NamedChannel cId cName cTags cPeople
895857
896−-- |Возвращаает канал для данного человека.
897858getChannelForUser :: UserId -> NamedChannelId -> StaticPQ NamedChannelFull
898859getChannelForUser uId cId = do
899860 channel <- runQueryParams getChannelForUserQ (uId, cId) >>= firstRow
@@ -901,7 +862,7 @@ getChannelForUser uId cId = do
901862 (Just c) -> return c
902863 Nothing -> lift $ S.throwError S.err404
903864
904−-- |Проверяет, существует ли пользователь.
865+-- TODO: Reject bad requests. Should be binary.
905866verifyUsers :: [UserId] -> StaticPQ ()
906867verifyUsers uIds =
907868 case verifiedUserIdsQ uIds of
@@ -910,7 +871,6 @@ verifyUsers uIds =
910871 when (length us /= length uIds) $ lift $ S.throwError impossibleContent
911872 Nothing -> return ()
912873
913−-- |Удаляет групповую беседу.
914874deleteGroupChat :: GroupChatId -> StaticPQ ()
915875deleteGroupChat gId = do
916876 _ <- manipulateParams deleteGroupChatQ (Only gId)
@@ -925,7 +885,6 @@ deleteGroupChat gId = do
925885 (#messageStorageDestinationGroupId .== param @1)
926886
927887-- NOTE: Not transactional
928−-- |Создает пользователя.
929888createUser :: UserCreation -> StaticPQ UserId
930889createUser creation = do
931890 _ <- manipulateParams removeUnverifiedUserQ (Only $ userCreationUserEmail creation)
@@ -935,7 +894,6 @@ createUser creation = do
935894-- MARK: FrontEnd functions
936895
937896-- Nothing <=> no user
938−-- |Возвращаает посты от данного пользователя.
939897getPostsForUser
940898 :: Maybe PostId
941899 -> Limit
@@ -946,7 +904,6 @@ getPostsForUser pId lim dir uId = do
946904 postRows <- runQueryParams (getLastNPostsForUserQ lim dir) (pId, uId) >>= getRows
947905 wrapIntoResponse (fromMaybe [] . rowsToPosts $ postRows)
948906
949−-- |Возвращаает посты по идентификатором.
950907getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))
951908getPosts pId =
952909 case getPostsByIdQ pId of
@@ -955,7 +912,6 @@ getPosts pId =
955912 rowsToPosts postRows `liftMaybe` wrapIntoResponse
956913 Nothing -> return Nothing
957914
958−-- |Возвращает последние посты.
959915getLastPosts
960916 :: Maybe PostId
961917 -> Limit
@@ -965,29 +921,24 @@ getLastPosts pId lim dir = do
965921 postRows <- runQueryParams (getLastPostsQ id lim dir) (Only pId) >>= getRows
966922 rowsToPosts postRows `liftMaybe` wrapIntoResponse
967923
968−-- |Возвращает пользователя по адресу почты.
969924getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))
970925getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow
971926
972−-- |возвращает пользователей по идентификаторам.
973927getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])
974928getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))
975929
976−-- |Возвращает всех пользователей.
977930getAllUsers :: StaticPQ [User Faculty]
978931getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
979932
980−-- |Публичует пост.
981933publishPost :: UserId -> PostCreation -> StaticPQ PostId
982934publishPost uId pc = commitedTransactionallyUpdate $ do
983935 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
984936 case pId' of
985937 (Just (Only pId)) -> do
986− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)
938+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
987939 return pId
988940 _ -> lift $ S.throwError S.err404
989941
990−-- |Создает канал.
991942createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
992943createNewChannel uId req = commitedTransactionallyUpdate $ do
993944 let uIds = toList $ namedChannelCreationRequestPeopleIds req
@@ -995,11 +946,9 @@ createNewChannel uId req = commitedTransactionallyUpdate $ do
995946 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
996947 return $ fmap fromOnly cId
997948
998−-- |Возвращает канал для данного пользователя.
999949channelCountForUser :: UserId -> StaticPQ Int64
1000950channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
1001951
1002−-- |Обновляет канал.
1003952updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
1004953updateChannel uId req = do
1005954 let uIds = namedChannelPeopleIds req
@@ -1008,21 +957,17 @@ updateChannel uId req = do
1008957 _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
1009958 return ()
1010959
1011−-- |Возвращает факультет.
1012960getFaculty :: Text -> StaticPQ Faculty
1013961getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
1014962
1015−-- |Проверяет, является ли данный факультет валидным.
1016963isValidFaculty :: FacultyUrl -> StaticPQ Bool
1017964isValidFaculty url = do
1018965 (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow
1019966 return $ isJust faculty
1020967
1021−-- |Обновляет факультет.
1022968updateFaculty :: Faculty -> StaticPQ ()
1023969updateFaculty fac = void $ manipulateParams updateFacultyQ fac
1024970
1025−-- |Возвращает посты в канале.
1026971getChannelPosts
1027972 :: UserId
1028973 -> Maybe PostId
@@ -1041,7 +986,6 @@ getChannelPosts uId pId lim dir cId = do
1041986 >>= getRows
1042987 fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
1043988
1044−-- |Возвращает почты в анонимном кнаале.
1045989getAnonymousChannelPosts
1046990 :: Maybe PostId
1047991 -> Limit
@@ -1052,23 +996,19 @@ getAnonymousChannelPosts pId lim dir (AnonymousChannel tags people) = do
1052996 postRows <- runQueryParams (getChannelPostsQ lim dir people tags) (Only pId) >>= getRows
1053997 fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
1054998
1055−-- |Возвращает все каналы.
1056999getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
10571000getAllChannels uId = fmap (map removeUserFromChannel) $
10581001 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
10591002
1060−-- |Удаляет именованный канал.
10611003deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
10621004deleteNamedChannel uId cId = do
10631005 _ <- getChannelForUser uId cId
10641006 _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)
10651007 return ()
10661008
1067−-- |Возвращает теги.
10681009getTags :: Limit -> StaticPQ [String]
10691010getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)
10701011
1071−-- |Возвращает диалоги.
10721012getDialogs
10731013 :: UserId
10741014 -> Maybe MessageId
@@ -1079,7 +1019,6 @@ getDialogs uId mId lim dir = do
10791019 resp <- runQueryParams (getChatsQ lim dir) (uId, Just $ show uId, mId) >>= getRows
10801020 (>>= fromMaybe500) $ (responseToDialogs uId resp `liftMaybe` wrapIntoResponse)
10811021
1082−-- |Возвращает сообщения в диалоге.
10831022getMessagesInUserChat
10841023 :: UserId
10851024 -> UserId
@@ -1091,7 +1030,6 @@ getMessagesInUserChat selfId uId mId lim dir = do
10911030 resp <- runQueryParams (getMessagesQ lim dir) (selfId, uId, mId) >>= getRows
10921031 fromMaybe500 . sequence . map restoreMessage $ resp
10931032
1094−-- |Возвращает сообщения в групповой беседе.
10951033getMessagesInGroupChat
10961034 :: UserId
10971035 -> GroupChatId
@@ -1104,21 +1042,19 @@ getMessagesInGroupChat selfId gId mId lim dir = do
11041042 resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows
11051043 return . catMaybes . map restoreMessage $ resp
11061044
1107−-- |Отправляет сообщение.
11081045sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId
1109−sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do
1046+sendMessage selfId (MessageCreation (Just gId) uId@Nothing (Jsonb body)) = do
11101047 _ <- getGroupChatForUser selfId gId
1111− (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, body)
1048+ (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, Jsonb $ stripPostElement body)
11121049 >>= firstRow >>= fromMaybe500
11131050 return mId
1114−sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do
1051+sendMessage selfId (MessageCreation gId@Nothing (Just uId) (Jsonb body)) = do
11151052 verifyUsers [uId]
1116− (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, body)
1053+ (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, Jsonb $ stripPostElement body)
11171054 >>= firstRow >>= fromMaybe500
11181055 return mId
11191056sendMessage _ _ = lift $ S.throwError S.err400
11201057
1121−-- |Создает групповую беседу.
11221058createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId
11231059createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
11241060 verifyUsers . M.keys $ chatUsers
@@ -1129,7 +1065,6 @@ createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do
11291065 _ <- manipulateParams createPhantomMessageQ (Only chatId)
11301066 return chatId
11311067
1132−-- |Обновляет групповую беседу.
11331068updateGroupChat :: UserId -> GroupChat -> StaticPQ ()
11341069updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
11351070 verifyUsers . M.keys $ perms
@@ -1140,7 +1075,6 @@ updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do
11401075 let newPerms = M.insert uId userPerm perms
11411076 void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)
11421077
1143−-- |Удаляет пользователя из беседы.
11441078leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()
11451079leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
11461080 gChat@(GroupChat _ (Jsonb perms) _) <- getGroupChatForUser uId gId
@@ -1149,7 +1083,6 @@ leaveGroupChat uId gId = commitedTransactionallyUpdate $ do
11491083 then deleteGroupChat gId
11501084 else void $ manipulateParams updateGroupChatQ gChat{groupChatUsers = Jsonb newPerms}
11511085
1152−-- |Возвращает беседу для пользователя.
11531086getGroupChatForUser :: UserId -> GroupChatId -> StaticPQ GroupChat
11541087getGroupChatForUser uId gId = do
11551088 chat <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
@@ -1157,18 +1090,15 @@ getGroupChatForUser uId gId = do
11571090 (Just c) -> return c
11581091 Nothing -> lift $ S.throwError S.err404
11591092
1160−-- |Проверяет, является ли данная беседа валидной для данного пользователя.
11611093groupChatIsValidForUser :: UserId -> GroupChatId -> StaticPQ Bool
11621094groupChatIsValidForUser uId gId = do
11631095 (chat :: Maybe GroupChat) <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow
11641096 return $ isJust chat
11651097
1166−-- |Возвращает каналы по поисковой строке.
11671098getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
11681099getFacultyFromQuery query =
11691100 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows
11701101
1171−-- |Ищет пользователей по строке.
11721102searchUsers :: T.Text -> StaticPQ [User Faculty]
11731103searchUsers query = do
11741104 unless (validateText query) $ lift $ throwError lengthExceeded
@@ -1176,45 +1106,37 @@ searchUsers query = do
11761106 then return []
11771107 else map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)
11781108
1179−-- |Ищет теги по запосу.
11801109searchTags :: T.Text -> StaticPQ [Text]
11811110searchTags "" = return []
11821111searchTags query = map fromOnly <$>
11831112 (runQueryParams searchTagsQ
11841113 (Only . (<> ":*") . T.strip $ query) >>= getRows)
11851114
1186−-- |Создает токен.
11871115createToken :: Token -> StaticPQ ()
11881116createToken token = void $ manipulateParams createTokenQ token
11891117
1190−-- |Деактивирует все токены для пользователя.
11911118killAllTokens :: UserId -> StaticPQ ()
11921119killAllTokens = void . manipulateParams killAllTokensQ . Only
11931120
1194−-- |Удаляет устаревшую информацию про авторизацию.
11951121pruneAuth :: StaticPQ ()
11961122pruneAuth = do
11971123 _ <- commitedTransactionallyUpdate . manipulate $ pruneDeadTokensQ
11981124 _ <- commitedTransactionallyUpdate . manipulate $ pruneGhostUsersQ
11991125 return ()
12001126
1201−-- |Осуществляет поиск по каналам.
12021127searchChannels :: UserId -> Text -> StaticPQ [NamedChannel UserId]
12031128searchChannels uId query = fmap (map removeUserFromChannel) $
12041129 runQueryParams searchChannelsForUserQ (uId, queryFromText query) >>= getRows
12051130
12061131-- NOTE: Not transactional
1207−-- |Проверяет, является ли токен валидным.
12081132validateToken :: Token -> StaticPQ ()
12091133validateToken token = do
12101134 void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing, tokenActivationCode = Nothing}
12111135 void $ manipulateParams validateUserQ $ Only $ tokenUserId token
12121136
1213−-- |Даективирует токен.
12141137invalidateToken :: UserId -> ByteString -> StaticPQ ()
12151138invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
12161139
1217−-- |Пытается активировать токен с помощью кода.
12181140tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)
12191141tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
12201142 token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow
@@ -1232,7 +1154,6 @@ tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
12321154 _ <- manipulateParams updateTokenQ newToken
12331155 return Nothing
12341156
1235−-- |Пытается активировать с помощью ключа активации.
12361157tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
12371158tryActivateToken uId activationData = do
12381159 let hData = hash activationData
@@ -1244,21 +1165,17 @@ tryActivateToken uId activationData = do
12441165 then commitedTransactionallyUpdate (validateToken token) >> (return $ Just token)
12451166 else return Nothing
12461167
1247−-- |Деактивирует токен.
12481168deactivateToken :: UserId -> ByteString -> StaticPQ (Maybe Text)
12491169deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow)
12501170
1251−-- |Возвращает активированный токен.
12521171getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
12531172getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow
12541173
1255−-- |Обновляет пользователя.
12561174updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)
12571175updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)
12581176
12591177-- MARK: Utils
12601178
1261−-- |Нормализует поля пользователя.
12621179normalizeUser :: UserUpdateRow -> UserUpdateRow
12631180normalizeUser UserUpdateRow{..} = UserUpdateRow {
12641181 userUpdateRowId = userUpdateRowId,
@@ -1268,39 +1185,23 @@ normalizeUser UserUpdateRow{..} = UserUpdateRow {
12681185 userUpdateRowUserFaculty = T.toLower . T.strip $ userUpdateRowUserFaculty
12691186}
12701187
1271−-- |Объект пользователя для ответов с базы данных.
12721188data UserRow = UserRow {
1273− -- |Идентификатор пользователя.
12741189 userRowId :: UserId,
1275− -- |Имя.
12761190 userRowFirstName :: Text,
1277− -- |Отчество.
12781191 userRowMiddleName :: Text,
1279− -- |Фамилия.
12801192 userRowLastName :: Text,
1281− -- |Факультет.
12821193 userRowFacultyUrl :: FacultyUrl,
1283− -- |Почта.
12841194 userRowEmail :: Text,
1285− -- |Был ли профиль подтвержден через почту.
12861195 userRowIsValidated :: Bool,
1287− -- |Название факультета.
12881196 userRowFacultyName :: T.Text,
1289− -- |Адрес сайта факультета.
12901197 userRowFacultyURL :: FacultyUrl,
1291− -- |Вспомогательная информация о факультете.
12921198 userRowFacultyPath :: T.Text,
1293− -- |Кампус.
12941199 userRowFacultyCampusName :: T.Text,
1295− -- |Код Кампуса.
12961200 userRowFacultyCampusCode :: T.Text,
1297− -- |Теги департамента.
12981201 userRowFacultyTags :: V.Vector T.Text,
1299− -- |АДрес департамента.
13001202 userRowFacultyAddress :: T.Text
13011203} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
13021204
1303−-- |Функция, переводящая ответ с базы данных в пользователя.
13041205rowToUser :: UserRow -> User Faculty
13051206rowToUser UserRow{..} = User {
13061207 userId = userRowId,
@@ -1319,7 +1220,6 @@ rowToUser UserRow{..} = User {
13191220 userEmail = userRowEmail
13201221 }
13211222
1322−-- |Переводит строку в запрос с учетом аббревиатур.
13231223queryFromTextAbbr :: Text -> Text
13241224queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)
13251225 where
@@ -1330,14 +1230,12 @@ queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (no
13301230 else mempty
13311231 ) <> ")"
13321232
1333−-- |Переводит строку в запорс.
13341233queryFromText :: Text -> Text
13351234queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)
13361235 where
13371236 processTerm :: Text -> Text
13381237 processTerm t = t <> ":*"
13391238
1340−-- |Перевод направление в оператор.
13411239directionToOperator
13421240 :: P.PaginationDirection
13431241 -> (ConditionOp schema0 from0 grouping0 params0 nullity0 nullity1 (ty :: PGType),
@@ -1350,7 +1248,6 @@ foldMaybe [] = Just []
13501248foldMaybe (Nothing : _) = Nothing
13511249foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
13521250
1353−-- |переводит элементы поста с базы данных в объект поста.
13541251rowsToPosts :: [PostRowResponse] -> Maybe [Post]
13551252rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)
13561253
@@ -1364,15 +1261,11 @@ idsToColumn :: [Int64] -> Maybe (Query schema params '["id" ::: 'NotNull 'PGint8
13641261idsToColumn [] = Nothing
13651262idsToColumn (i:ii) = Just $ values (unsafeIntToExpr i `as` #id) $ map ((`as` #id) . unsafeIntToExpr) ii
13661263
1367−-- |Небезопасное переведение числа в SQL выражение.
13681264unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty
13691265unsafeIntToExpr = UnsafeExpression . pack . show
13701266
1371−-- |Ответ сервера с пользователями.
13721267data ResponseWithUsers r = ResponseWithUsers {
1373− -- |Тело ответа.
13741268 response :: r,
1375− -- |Пользователи.
13761269 users :: M.Map UserId (User Faculty)
13771270} deriving (Generic)
13781271
@@ -1403,7 +1296,6 @@ instance (Foldable t, HasUsers r) => HasUsers (t r) where
14031296instance HasUsers Post where
14041297 userSet = Set.singleton . postAuthorId
14051298
1406−-- |Оборачивает ответ в пользователей.
14071299wrapIntoUsers :: r -> Set.Set UserId -> StaticPQ (Maybe (ResponseWithUsers r))
14081300wrapIntoUsers r us
14091301 | Set.null us = return . Just $ ResponseWithUsers r M.empty
denis/src/Data/Schema.hs+5−3
@@ -9,14 +9,16 @@
99 KindSignatures #-}
1010
1111
12−module Data.Schema where
12+module Data.Schema (
13+ Schema,
14+ createTables
15+) where
1316
1417import Squeal.PostgreSQL
1518import Data.GroupChat
1619import Data.PostElement
1720import Data.Message
1821
19−-- |Таблицы базы данных
2022type Schema =
2123 '[
2224 "faculties" ::: 'Table ('[
@@ -186,7 +188,7 @@ type Schema =
186188
187189 ]
188190
189−-- |Создает таблицы базы данных.
191+
190192createTables :: Definition '[] Schema
191193createTables = createTable #faculties (
192194 notNullable text `as` #facultyName :*
denis/src/Data/Tags/Completions.hs+4−3
@@ -4,7 +4,10 @@
44 FlexibleInstances #-}
55{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
66
7−module Data.Tags.Completions where
7+module Data.Tags.Completions (
8+ CompletionTree(..),
9+ mkCompletionTree
10+ ) where
811
912import qualified Data.Map as M
1013import Data.Aeson
@@ -21,7 +24,6 @@ instance ToSample CompletionTree where
2124 toSamples _ = singleSample . mkCompletionTree $
2225 ["aa", "aaab", "ba", "b", "bab"]
2326
24−-- |Объект дерева подсказок тегов.
2527data CompletionTree = CompletionTreeNode {
2628 value :: Maybe String,
2729 subtree :: M.Map Char CompletionTree
@@ -29,7 +31,6 @@ data CompletionTree = CompletionTreeNode {
2931
3032instance ToJSON CompletionTree where
3133
32−-- |Функция, ктороая строит дерево подсказок по данному списку строк.
3334mkCompletionTree :: [String] -> CompletionTree
3435mkCompletionTree = mkCompletionTree' . map (\ a -> (map toLower a, a)) . sort
3536 where
denis/src/Data/Tags/Validation.hs+10−7
@@ -1,9 +1,12 @@
1−module Data.Tags.Validation where
1+module Data.Tags.Validation (
2+ validateTag,
3+ validateTag'
4+ ) where
25
36import Data.Text as T
4−import Data.Char
7+import Data.Char as C
8+import qualified Data.Set as S
59
6−-- |Функция, валилирующая хэштег, возвращающая тег в монаде `Maybe`
710validateTag :: T.Text -> Maybe T.Text
811validateTag tag =
912 let
@@ -12,11 +15,11 @@ validateTag tag =
1215 then Just normalised
1316 else Nothing
1417
15−-- |Функция, проверяющая, является ли данный тег валидным.
1618validateTag' :: T.Text -> Bool
1719validateTag' = T.all validChar
1820
19−-- |Функция, проверяющая, является ли данный символ валидным внутри тега.
21+validChars :: S.Set Char
22+validChars = S.fromList "йцукенгшщзхъфывапролджэёячсмитьбюqwertyuiopasdfghjklzxcvbnm1234567890_"
23+
2024validChar :: Char -> Bool
21−validChar '-' = True
22−validChar c = isAlphaNum c
25+validChar c = S.member (C.toLower c) validChars
denis/src/Data/Text/Validator.hs+9−8
@@ -1,26 +1,30 @@
11{-# LANGUAGE FlexibleInstances #-}
22
3−module Data.Text.Validator where
3+module Data.Text.Validator (
4+ HasValidatableText(..),
5+ isValidChar,
6+ ExtraPredicate(..),
7+ (~=),
8+ (~<),
9+ (<~>),
10+ RangeableText(..)
11+ ) where
412
513import qualified Data.Text as T
614import Data.Char
715import Data.Limits
816
9−-- |Функция, проверяющая, является ли данный символ валидным символом текста.
1017isValidChar :: Char -> Bool
1118isValidChar '\n' = True
1219isValidChar '\r' = True
1320isValidChar c = isPrint c || generalCategory c == ModifierLetter
1421
15−-- |Класс объектов, имеющих возможность проверить содержащийся в них текст на валидность.
1622class HasValidatableText t where
1723 validateText :: t -> Bool
1824
19−-- |Текст с предикат.
2025data ExtraPredicate t = ExtraPredicate t (t -> Bool)
2126
2227infixl 5 ~=
23−-- |Опертор для добавления предиката к тексту.
2428(~=) :: t -> (t -> Bool) -> ExtraPredicate t
2529(~=) = ExtraPredicate
2630
@@ -29,16 +33,13 @@ instance (HasValidatableText t) => HasValidatableText (ExtraPredicate t) where
2933
3034
3135infixl 5 ~<
32−-- |Опертор для добавления ограничений на длину сверху к тексту.
3336(~<) :: t -> Int -> RangeableText t
3437t ~< n = t <~> (0, n)
3538
3639infixl 5 <~>
37−-- |Оператор для добавления ограничения на длину текста.
3840(<~>) :: t -> (Int, Int) -> RangeableText t
3941(<~>) = RangeableText
4042
41−-- |Текст с ограничением по длине.
4243data RangeableText t = RangeableText t (Int, Int)
4344
4445instance HasValidatableText (RangeableText String) where
denis/src/Data/User.hs+8−18
@@ -9,7 +9,12 @@
99 DeriveAnyClass,
1010 RecordWildCards #-}
1111
12−module Data.User where
12+module Data.User (
13+ User(..),
14+ UserId,
15+ UserEmail,
16+ UserUpdate(..)
17+) where
1318
1419import Data.Int (Int64)
1520import qualified Generics.SOP as SOP
@@ -25,35 +30,25 @@ import Data.Text.Validator
2530-- MARK: Documentation
2631
2732instance (ToSample f) => ToSample (User f) where
28− toSamples _ = samples $ [User 8 "Vasya" "Pupkinovuch" "Pupkin"] <*> (map snd $ toSamples Proxy) <*> ["foo@hse.ru"]
33+ toSamples _ = samples $ [User 8 "Vasya" "Pupkinovuch" "Pupkin", User 69 "Seva" "Algebrovich" "Leonidov"] <*> (map snd $ toSamples Proxy) <*> ["foo@hse.ru"]
2934
3035instance ToSample (UserUpdate) where
31− toSamples _ = samples $ [UserUpdate "Vasya" "Pupkinovuch" "Pupkin"] <*> ["cs.hse.ru/dse/"]
36+ toSamples _ = samples $ [UserUpdate "Vasya" "Pupkinovuch" "Pupkin", UserUpdate "Seva" "Algebrovich" "Leonidov"] <*> ["cs.hse.ru/dse/"]
3237
3338instance HasValidatableText UserUpdate where
3439 validateText UserUpdate{..} = all (validateText . (~< userFieldLengthLimit)) [userUpdateFirstName, userUpdateMiddleName, userUpdateLastName, userUpdateUserFaculty]
3540
3641-- MARK: Implementation
3742
38−-- |Идентификатор пользователя.
3943type UserId = Int64
40−
41−-- |Адрес почты пользователя.
4244type UserEmail = Text
4345
44−-- |Пользователь.
4546data User f = User {
46− -- |Идентификатор.
4747 userId :: UserId,
48− -- |Имя.
4948 firstName :: Text,
50− -- |Фамилия.
5149 middleName :: Text,
52− -- |Отчество.
5350 lastName :: Text,
54− -- |Факультет.
5551 userFaculty :: f,
56− -- |Адрес почты.
5752 userEmail :: UserEmail
5853} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
5954
@@ -71,15 +66,10 @@ instance (FromJSON f) => FromJSON (User f) where
7166 parseJSON = withObject "named channel" $ \e ->
7267 User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
7368
74−-- |Объект для обновления пользователя.
7569data UserUpdate = UserUpdate {
76− -- |Имя.
7770 userUpdateFirstName :: Text,
78− -- |Отчество.
7971 userUpdateMiddleName :: Text,
80− -- |Фамилия.
8172 userUpdateLastName :: Text,
82− -- |Факультет.
8373 userUpdateUserFaculty :: FacultyUrl
8474} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
8575
denis/src/Server/API.hs+13−14
@@ -7,7 +7,12 @@
77 RecordWildCards #-}
88{-# OPTIONS_GHC -Wno-orphans #-}
99
10−module Server.API where
10+module Server.API (
11+ API,
12+ serverProxy,
13+ mkServerAPI,
14+ Authentication
15+) where
1116
1217import Data.Proxy
1318import Servant.API
@@ -37,19 +42,13 @@ import Data.Text.Validator
3742
3843instance HasDocs api => HasDocs (Authentication :> api) where
3944 docsFor Proxy (endpoint, action) =
40− docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["Этот метод требует токен, который можно получить через запрос `POST /authenticate/login`.\n\nВозвращает `498 Invalid Token` если токен не валидный или отсутствует. Возвращает `401 Unathorized` если токен не дает доступа к запрашиваемому ресурсу."]])
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."]])
4146
42−type UserSearchDescription = Description "Ищет пользователей по данной строке."
47+type UserSearchDescription = Description "Searches for users with the given string.\n\nFeed in the raw user input string."
4348
44−type UpdateUserDescription = Description "Обновляет профиль текущего пользователя."
49+type UpdateUserDescription = Description "Updates the current user.\n\nThrow 401 if you try to change email or something like that."
4550
46−type DeactivateAllDescription = Description "Деактивирует все токены для текущего пользователя."
47−
48−type MeDescription = Description "Возвращает идентификатор текущего пользователя."
49−
50−type UsersDescription = Description "Возвращает пользователей для данных идентификаторов."
51−
52−type UsersAllDescription = Description "Возвращает всех пользователей."
51+type DeactivateAllDescription = Description "Deactivates all tokens for the logged in user including the one used to authenticate this request."
5352
5453-- MARK: Implementation
5554
@@ -59,11 +58,11 @@ type API =
5958 LoggerAPI :<|>
6059 "authentication" :> AuthenticationHandler :<|>
6160 Authentication :> ComplexQuery :> (
62− "authentication" :> "me" :> MeDescription :> Post '[JSON] UserId :<|>
61+ "authentication" :> "me" :> Post '[JSON] UserId :<|>
6362 "deactivateAll" :> DeactivateAllDescription
6463 :> DeleteNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
65− "users" :> UsersDescription :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>
66− "users" :> "all" :> UsersAllDescription :> Post '[JSON] [User Faculty] :<|>
64+ "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>
65+ "users" :> "all" :> Post '[JSON] [User Faculty] :<|>
6766 "users" :> "search" :> UserSearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [User Faculty] :<|>
6867 "users" :> "update" :> UpdateUserDescription :> ReqBody '[JSON] UserUpdate :> PostNoContent '[JSON, PlainText] NoContent :<|>
6968 "posts" :> PostApi :<|>
denis/src/Server/API/Channels.hs+12−20
@@ -7,7 +7,10 @@
77 TypeOperators,
88 RecordWildCards #-}
99
10−module Server.API.Channels where
10+module Server.API.Channels (
11+ ChannelsApi,
12+ channelsApi
13+) where
1114
1215import Servant.API
1316import Server.App
@@ -26,31 +29,20 @@ import Control.Monad
2629import Data.Limits
2730import qualified Data.Text as T
2831import Data.Char
29−import Control.Monad.Except
3032
31−type CreateDescription = Description "Создает канал.\n\nВозвращает 406 если лимит каналов для пользователя был исчерпан."
33+type CreateDescription = Description "Creates a new channel\n\nReturns 406 if the channel limit has been exceeded."
3234
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 "Запрашивает все каналы пользователя."
35+type SearchDescription = Description "Search for user channels."
4436
4537-- MARK: Implementation
4638
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]) :<|>
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]) :<|>
5042 "create" :> CreateDescription :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
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]
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]
5446
5547channelsApi :: UserId -> ServerT ChannelsApi App
5648channelsApi uId = getChannelsApi uId :<|> getChannel uId :<|> getAnonymousChannelsApi :<|> createChannelApi uId :<|> updateChannelApi uId :<|> deleteChannelApi uId :<|> searchChannelsApi uId
denis/src/Server/API/Completions.hs+7−4
@@ -7,7 +7,10 @@
77 TypeOperators,
88 LambdaCase #-}
99
10−module Server.API.Completions where
10+module Server.API.Completions (
11+ TagsAPI,
12+ tagsServer
13+ ) where
1114
1215import Servant.Server
1316import Servant
@@ -22,14 +25,14 @@ import qualified Data.Text as T
2225import Data.Char
2326
2427type CompletionsDescription = Description "\
25− \Возвращает дерево тегов.\n\n\
28+ \Gets tag completion tree\n\n\
2629 \```haskell\n\
2730 \data CompletionTree = CompletionTreeNode {\n\
2831 \ value :: Maybe String,\n\
2932 \ subtree :: Map Char CompletionTree\n\
3033 \}\n\
3134 \```\n\n\
32− \Псевдокод для получения всех подсказок:\n\n\
35+ \The psuedocode for retrieving all completions from the tree:\n\n\
3336 \```swift\n\
3437 \func getCompletion(tree: CompletionTree, word: String) -> [String] {\n\
3538 \ if word == \"\" {\n\
@@ -60,7 +63,7 @@ type CompletionsDescription = Description "\
6063 \}\n\
6164 \```"
6265
63−type SearchDescription = Description "Возвращает 1000 самых популярных тегов для запроса пользователя."
66+type SearchDescription = Description "Returns top 1000 tag completions for given user input."
6467
6568type TagsAPI = "completions" :> CompletionsDescription :> Get '[JSON] CompletionTree :<|>
6669 "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [Text]
denis/src/Server/API/Faculty.hs+5−2
@@ -7,7 +7,10 @@
77 TypeOperators,
88 LambdaCase #-}
99
10−module Server.API.Faculty where
10+module Server.API.Faculty (
11+ FacultyAPI,
12+ facultyServer
13+ ) where
1114
1215import Servant.Server
1316import Servant
@@ -22,7 +25,7 @@ import Control.Monad
2225import Server.Error
2326import Data.Char
2427
25−type SearchDescription = Description "Возвращает факультет по данному запросу."
28+type SearchDescription = Description "Returns faculties for given string"
2629
2730type FacultyAPI =
2831 "search" :> SearchDescription :> ReqBody '[PlainText, JSON] Text :> Post '[JSON] [Faculty]
denis/src/Server/API/Messages.hs+12−10
@@ -7,7 +7,10 @@
77 TypeOperators,
88 RecordWildCards #-}
99
10−module Server.API.Messages where
10+module Server.API.Messages (
11+ MessagesApi,
12+ messagesServer
13+) where
1114
1215import Servant.API
1316import Server.App
@@ -25,16 +28,15 @@ import Server.Error
2528import qualified Data.Map as M
2629import Squeal.PostgreSQL.Schema
2730import Data.Limits
28−import Control.Monad.Except
2931
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Возвращает идентификато отправленного сообщения."
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."
3840
3941type MessagesApi =
4042 "chats" :> (
denis/src/Server/API/Posts.hs+4−8
@@ -6,7 +6,10 @@
66 TypeApplications ,
77 TypeOperators #-}
88
9−module Server.API.Posts where
9+module Server.API.Posts (
10+ PostApi,
11+ postApi
12+) where
1013
1114import Servant.API
1215import qualified Data.Post as P
@@ -20,13 +23,6 @@ import Data.Limits
2023import Server.Error
2124import Control.Monad
2225import 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 "Публикует пост."
3026
3127-- MARK: Implementation
3228
denis/src/Server/App.hs+10−2
@@ -8,7 +8,16 @@
88 TypeSynonymInstances,
99 FlexibleInstances #-}
1010
11−module Server.App where
11+module Server.App (
12+ App,
13+ DBConnection,
14+ Config(..),
15+ ask,
16+ asks,
17+ liftIO,
18+ MailConfig(..),
19+ fromMaybeThrow
20+) where
1221
1322import Servant.Server
1423import Control.Monad.Reader
@@ -18,7 +27,6 @@ import Generics.SOP (K)
1827import Squeal.PostgreSQL.PQ (Connection)
1928import Crypto.RNG
2029import Server.Error
21−import Control.Monad.Except
2230
2331type App = ReaderT Config Handler
2432
denis/src/Server/Auth.hs+20−14
@@ -12,7 +12,17 @@
1212 RecordWildCards #-}
1313{-# OPTIONS_GHC -Wno-orphans #-}
1414
15−module Server.Auth where
15+module Server.Auth (
16+ checkToken,
17+ cookieTokenKey,
18+ genAuthServerContext,
19+ AuthenticationHandler,
20+ logIn,
21+ contextProxy,
22+ AuthenticationCredits(..),
23+ authenticationAPI,
24+ TokenActivationData
25+) where
1626
1727import Server.App
1828import Data.User
@@ -48,15 +58,11 @@ import qualified Data.Text.Lazy as TL
4858import Server.Auth.HTML
4959import Data.Char
5060import Data.Text.Validator
51−import Servant.HTML.Blaze
52−import Text.Blaze
53−import Crypto.Hash.SHA512
54−
5561
5662-- MARK: Documentation
5763
5864instance ToSample AuthenticationCredits where
59− toSamples _ = samples $ map AuthenticationCredits ["example@hse.ru", "iikostyuchenko@hse.ru"]
65+ toSamples _ = samples $ map AuthenticationCredits ["vchernyshev@hse.ru", "iikostyuchenko@hse.ru"]
6066
6167instance ToSample UserLoginResponse where
6268 toSamples _ = samples $ map UserLoginResponse [UserIsRegistered, UserCanRegister, InvalidUser]
@@ -65,7 +71,7 @@ instance ToSample Int where
6571 toSamples _ = samples [382934, 103845, 294905]
6672
6773instance ToSample UserCreation where
68− toSamples _ = samples $ [UserCreation "Василий" "Иванов" "Романович" "cs.hse.ru/dse/" "example@hse.ru"]
74+ toSamples _ = samples $ [UserCreation "Seva" "Algebrovich" "Leonidov" "cs.hse.ru/dse/" "vchernyshev@hse.ru"]
6975
7076instance ToSample TokenActivationData where
7177 toSamples _ = singleSample $ TokenActivationData 69 "ABCDE"
@@ -90,19 +96,19 @@ instance ToParam (QueryParam' mods "id" UserId) where
9096instance ToSample Markup where
9197 toSamples _ = noSamples
9298
93−type LoginDescription = Description "Попытка зайти с указанной почты.\n\nЗначения возвращаемого поля:\n\n- `registered` -- Пользователь уже зарегестрирован и токен был поставлен в HTTP Cookie. Теперь можно запросить у пользователя код активации и передать его в `/verify`.\n- `canRegister` -- почта валидная, но пользователь не зарегестрирован. У пользователя необходимо запросить данные для передачи в `/register`.\n- `invalid` -- почта не валидная."
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."
94100
95−type LogoutDescription = Description "Деактивировать текущий токен."
101+type LogoutDescription = Description "Log out with the given cookie"
96102
97−type VerifyDescription = Description "Активировать текущий токен через код, отправленный на почту.\n\nВозвращает 400 если не был передан валидный токен.\n\nВозвращает 498 если токен был обраотан успешно, но не является валидным.\n\nВозвращает 403 если комбинация токена и код не валидная."
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."
98104
99−type RegisterDescription = Description "Зарегестрировать пользователя.\n\nВозвращает 409 если пользователь не может быть создан. (Скорее всего он уже зарегестрирован).\n\nСтавит токен в HTTP Cookie, если пользователь был успещно создан.\n\nПосле успех необходимо запросить у пользователя код активации, который он получил на почту и передать его в `/verify`."
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`."
100106
101−type CheckCookieDescription = Description "Проверяет, есть ли в запросе валидный токен.\n\nВалидность содержимого не проверяется.\n\nВозвращает 204 NoContent если токен присутствует.\n\nВозвращает 401 Unauthorized если токена нет."
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."
102108
103−type ActivateDescription = Description "Активирует токен по ключу из письма."
109+type ActivateDescription = Description "Activates a token using data from email"
104110
105−type DeactivateDescription = Description "Деактивирует токен по ключу из письма."
111+type DeactivateDescription = Description "Deactivates a token using data from email"
106112
107113-- MARK: Implementation
108114
denis/src/Server/Auth/HTML.hs+7−1
@@ -11,7 +11,13 @@
1111 DeriveAnyClass,
1212 RecordWildCards #-}
1313
14−module Server.Auth.HTML where
14+module Server.Auth.HTML (
15+ HTML,
16+ genActivationPage,
17+ Markup,
18+ errorPage,
19+ page
20+ ) where
1521
1622import Servant.HTML.Blaze
1723import Text.Blaze.Html5 as H
denis/src/Server/Auth/Mail.hs+3−2
@@ -12,7 +12,9 @@
1212 RecordWildCards #-}
1313{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
1414
15−module Server.Auth.Mail where
15+module Server.Auth.Mail (
16+ sendTokenVerificationEmail
17+ ) where
1618
1719import Network.Mail.SMTP
1820import Server.App
@@ -27,7 +29,6 @@ import Text.Blaze.Html.Renderer.Text
2729import Data.ByteString (ByteString)
2830import Data.User
2931import Data.ByteString.Char8 (unpack)
30−import Control.Monad.Reader
3132
3233sendTokenVerificationEmail :: TokenVerificationCode -> UserId -> ByteString -> ByteString -> TL.Text -> Text -> App ()
3334sendTokenVerificationEmail userCode uId activation deactivation ua email = do
denis/src/Server/Auth/Token.hs+9−1
@@ -9,7 +9,15 @@
99 TypeOperators,
1010 DeriveAnyClass #-}
1111
12−module Server.Auth.Token where
12+module Server.Auth.Token (
13+ Token(..),
14+ generateToken,
15+ TokenVerificationCode,
16+ generateTokenM,
17+ hashVerificationCode,
18+ GeneratedToken(..),
19+ hash
20+ ) where
1321
1422import Data.Time.Clock
1523import Data.ByteString
denis/src/Server/Error.hs+8−1
@@ -1,6 +1,13 @@
11{-# LANGUAGE OverloadedStrings #-}
22
3−module Server.Error where
3+module Server.Error (
4+ invalidToken,
5+ amountExceeded,
6+ lengthExceeded,
7+ formatError,
8+ impossibleContent,
9+ throwError
10+) where
411
512import Servant.Server
613import Control.Monad.Except
denis/src/Server/Logger.hs+6−2
@@ -6,7 +6,12 @@
66 FlexibleInstances #-}
77{-# OPTIONS_GHC -Wno-orphans #-}
88
9−module Server.Logger where
9+module Server.Logger (
10+ Logger,
11+ LoggerAPI,
12+ mkLogger,
13+ Log
14+) where
1015
1116import Network.Wai
1217import Control.Concurrent.STM
@@ -21,7 +26,6 @@ import Network.Wai.Middleware.RequestLogger
2126import Data.Default.Class
2227import qualified System.Log.FastLogger as FL
2328import Servant.Docs
24−import Control.Monad.IO.Class
2529
2630instance HasDocs "log" where
2731 docsFor _ _ _ = emptyAPI
denis/src/Server/Periodic.hs+6−1
@@ -1,4 +1,9 @@
1−module Server.Periodic where
1+module Server.Periodic (
2+ periodically,
3+ seconds,
4+ minutes,
5+ hours
6+ ) where
27
38import Control.Monad.IO.Class
49import Control.Concurrent
denis/src/Server/Query/ComplexQuery.hs+4−2
@@ -15,7 +15,9 @@
1515{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
1616{-# OPTIONS_GHC -Wno-orphans #-}
1717
18−module Server.Query.ComplexQuery where
18+module Server.Query.ComplexQuery (
19+ ComplexQuery
20+) where
1921
2022import Data.ByteString.Lazy (ByteString)
2123import Data.ByteString.Builder (toLazyByteString)
@@ -49,7 +51,7 @@ instance {-# Overlapping #-} ToSample [ComplexQueryRequest] where
4951 toSamples _ = singleSample $ [ComplexQueryRequest "channels/" "", ComplexQueryRequest "posts/last" "3"]
5052
5153instance {-# Overlapping #-} ToSample [ComplexQueryRepsonse] where
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\":[]}]}"]
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\":[]}]}"]
5355
5456-- MARK: Implementation
5557
denis/src/Server/Query/Dialog.hs+7−9
@@ -2,7 +2,11 @@
22 OverloadedStrings,
33 DeriveGeneric #-}
44
5−module Server.Query.Dialog where
5+module Server.Query.Dialog (
6+ ChatsResponse(..),
7+ responseToDialogs,
8+ Dialog(..)
9+ ) where
610
711import Data.Aeson
812import Data.Message
@@ -21,12 +25,7 @@ instance ToSample Dialog where
2125 toSamples _ = samples (take 1 (UserDialog <$> [69] <*> map snd (toSamples Proxy)) <>
2226 (GroupDialog <$> map snd (toSamples Proxy) <*> map snd (toSamples Proxy)))
2327
24−-- |Объект диалога
25−data Dialog =
26− -- |Thing
27− GroupDialog GroupChat (Maybe Message) |
28− -- |Also a thing
29− UserDialog UserId Message
28+data Dialog = GroupDialog GroupChat (Maybe Message) | UserDialog UserId Message
3029 deriving Show
3130
3231instance ToJSON Dialog where
@@ -43,8 +42,7 @@ instance ToJSON Dialog where
4342 ]
4443 ]
4544
46−data ChatsResponse =
47− ChatsResponse {
45+data ChatsResponse = ChatsResponse {
4846 chatResponseMessageId :: MessageId,
4947 chatResponseMessageAuthorId :: Maybe UserId,
5048 chatResponseMessageDestinationGroupId :: Maybe GroupChatId,
denis/src/Server/Query/Pagination.hs+5−1
@@ -11,7 +11,11 @@
1111 UndecidableInstances,
1212 UndecidableSuperClasses #-}
1313
14−module Server.Query.Pagination where
14+module Server.Query.Pagination (
15+ PaginatingRequest(..),
16+ PaginationDirection(..),
17+ validatePaginationRequest
18+ ) where
1519
1620import GHC.Generics
1721import Data.Aeson as A
denis/src/Server/Server.hs+5−1
@@ -3,7 +3,11 @@
33 TypeOperators,
44 DataKinds #-}
55
6−module Server.Server where
6+module Server.Server (
7+ runServer,
8+ hoistedServer,
9+ getConfig
10+) where
711
812import Server.API
913import Server.Auth
denis/src/test/Orphans.hs+4
@@ -71,6 +71,10 @@ instance Arbitrary (PostElement p) where
7171 arbitrary = genericArbitrary
7272 shrink = genericShrink
7373
74+instance Arbitrary PostQuote where
75+ arbitrary = genericArbitrary
76+ shrink = genericShrink
77+
7478instance Arbitrary AnonymousChannel where
7579 arbitrary = genericArbitrary
7680 shrink = genericShrink
sql/indexes.sqldeleted−20
@@ -1,20 +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−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");