534f1b5...master · denis

git.iko.soy/denis

7 files changed+48−27

since splitsnapshots

unifiedsplit

denis/src/Data/Limits.hs+4−1 denis/src/Data/PostElement.hs+8−2 denis/src/Data/Query.hs+21−18 denis/src/Data/Tags/Validation.hs+6−3 denis/src/Data/Text/Validator.hs+1−1 denis/src/Server/API/Messages.hs+7−2 denis/src/Server/Server.hs+1

denis/src/Data/Limits.hs+4−1

@@ -29,4 +29,7 @@ listLimit :: Int

2929listLimit = 100

3030

3131globalTextLimit :: Int

32−globalTextLimit = 50000

32+globalTextLimit = 50000

33+

34+groupChatSizeLimit :: Int

35+groupChatSizeLimit = 256

denis/src/Data/PostElement.hs+8−2

@@ -16,13 +16,14 @@ module Data.PostElement (

1616 PostElementRow(..),

1717 PostElement(..),

1818 elementsToRows,

19− PostQuote(..)

19+ PostQuote(..),

20+ stripPostElement

2021) where

2122

2223import Data.Int (Int64)

2324import qualified Generics.SOP as SOP

2425import qualified GHC.Generics as GHC

25−import Data.Text (Text)

26+import Data.Text (Text, strip)

2627import Data.Aeson

2728import Control.Applicative ((<|>))

2829import Servant.Docs (ToSample, toSamples, samples)

@@ -54,6 +55,11 @@ data PostElement a = Markdown Text

5455 | Attachment Text

5556 deriving (Show, GHC.Generic)

5657

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+

5763instance ToJSON (PostElement t) where

5864 toJSON (Markdown m) = object ["markdown" .= m]

5965 toJSON (Latex l) = object ["latex" .= l]

denis/src/Data/Query.hs+21−18

@@ -935,7 +935,7 @@ publishPost uId pc = commitedTransactionallyUpdate $ do

935935 pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow

936936 case pId' of

937937 (Just (Only pId)) -> do

938− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)

938+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)

939939 return pId

940940 _ -> lift $ S.throwError S.err404

941941

@@ -1006,7 +1006,6 @@ deleteNamedChannel uId cId = do

10061006 _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)

10071007 return ()

10081008

1009−-- Returns n most popular

10101009getTags :: Limit -> StaticPQ [String]

10111010getTags lim = map fromOnly <$> (runQuery (getNpopularTagsQ lim) >>= getRows)

10121011

@@ -1044,33 +1043,37 @@ getMessagesInGroupChat selfId gId mId lim dir = do

10441043 return . catMaybes . map restoreMessage $ resp

10451044

10461045sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId

1047−sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do

1046+sendMessage selfId (MessageCreation (Just gId) uId@Nothing (Jsonb body)) = do

10481047 _ <- getGroupChatForUser selfId gId

1049− (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, body)

1048+ (Only mId) <- manipulateParams createMessageQ (selfId, Just gId, uId, Jsonb $ stripPostElement body)

10501049 >>= firstRow >>= fromMaybe500

10511050 return mId

1052−sendMessage selfId (MessageCreation gId@Nothing (Just uId) body) = do

1051+sendMessage selfId (MessageCreation gId@Nothing (Just uId) (Jsonb body)) = do

10531052 verifyUsers [uId]

1054− (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, body)

1053+ (Only mId) <- manipulateParams createMessageQ (selfId, gId, Just uId, Jsonb $ stripPostElement body)

10551054 >>= firstRow >>= fromMaybe500

10561055 return mId

10571056sendMessage _ _ = lift $ S.throwError S.err400

10581057

10591058createGroupChat :: UserId -> GroupChatCreation -> StaticPQ GroupChatId

1060−createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = commitedTransactionallyUpdate $ do

1061− let chatUsers' = M.insert uId maxChatPermissions chatUsers

1062− (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)

1063− >>= firstRow >>= fromMaybe500

1064− _ <- manipulateParams createPhantomMessageQ (Only chatId)

1065− return chatId

1059+createGroupChat uId (GroupChatCreation (Jsonb chatUsers) name) = do

1060+ verifyUsers . M.keys $ chatUsers

1061+ commitedTransactionallyUpdate $ do

1062+ let chatUsers' = M.insert uId maxChatPermissions chatUsers

1063+ (Only chatId) <- manipulateParams createGroupChatQ (GroupChatCreation (Jsonb chatUsers') name)

1064+ >>= firstRow >>= fromMaybe500

1065+ _ <- manipulateParams createPhantomMessageQ (Only chatId)

1066+ return chatId

10661067

10671068updateGroupChat :: UserId -> GroupChat -> StaticPQ ()

1068−updateGroupChat uId (GroupChat gId (Jsonb perms) name) = commitedTransactionallyUpdate $ do

1069− (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId

1070− let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'

1071− unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401

1072− let newPerms = M.insert uId userPerm perms

1073− void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)

1069+updateGroupChat uId (GroupChat gId (Jsonb perms) name) = do

1070+ verifyUsers . M.keys $ perms

1071+ commitedTransactionallyUpdate $ do

1072+ (GroupChat _ (Jsonb perms') _) <- getGroupChatForUser uId gId

1073+ let userPerm = fromMaybe minChatPermissions $ M.lookup uId perms'

1074+ unless (isAdmin userPerm) $ lift $ S.throwError $ S.err401

1075+ let newPerms = M.insert uId userPerm perms

1076+ void $ manipulateParams updateGroupChatQ (GroupChat gId (Jsonb newPerms) name)

10741077

10751078leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()

10761079leaveGroupChat uId gId = commitedTransactionallyUpdate $ do

denis/src/Data/Tags/Validation.hs+6−3

@@ -4,7 +4,8 @@ module Data.Tags.Validation (

44 ) where

66import Data.Text as T

7−import Data.Char

7+import Data.Char as C

8+import qualified Data.Set as S

910validateTag :: T.Text -> Maybe T.Text

1011validateTag tag =

@@ -17,6 +18,8 @@ validateTag tag =

1718validateTag' :: T.Text -> Bool

1819validateTag' = T.all validChar

1920

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+1−1

@@ -17,7 +17,7 @@ import Data.Limits

1717isValidChar :: Char -> Bool

1818isValidChar '\n' = True

1919isValidChar '\r' = True

20−isValidChar c = isPrint c

20+isValidChar c = isPrint c || generalCategory c == ModifierLetter

2121

2222class HasValidatableText t where

2323 validateText :: t -> Bool

denis/src/Server/API/Messages.hs+7−2

@@ -4,7 +4,8 @@

44 OverloadedLabels,

55 OverloadedStrings ,

66 TypeApplications ,

7− TypeOperators #-}

7+ TypeOperators,

8+ RecordWildCards #-}

910module Server.API.Messages (

1011 MessagesApi,

@@ -24,6 +25,9 @@ import Server.Query.Dialog

2425import Data.Text.Validator

2526import Control.Monad

2627import Server.Error

28+import qualified Data.Map as M

29+import Squeal.PostgreSQL.Schema

30+import Data.Limits

2731

2832type GetAllChatsDescription = Description "Gets chats starting from/ending with the given message id."

2933type GetGroupChatDescription = Description "Gets information about a given group chat."

@@ -94,8 +98,9 @@ sendMessageApi uId mes = do

9498 runQerror $ sendMessage uId mes

9599

96100createGroupChatApi :: UserId -> GroupChatCreation -> App GroupChatId

97−createGroupChatApi uId group = do

101+createGroupChatApi uId group@GroupChatCreation{..} = do

98102 unless (validateText group) $ throwError lengthExceeded

103+ unless ((M.size $ getJsonb groupChatCreationUsers) < groupChatSizeLimit) $ throwError amountExceeded

99104 runQerror $ createGroupChat uId group

100105

101106leaveChatAPI :: UserId -> GroupChatId -> App NoContent

denis/src/Server/Server.hs+1

@@ -63,6 +63,7 @@ runServer :: IO ()

6363runServer = do

6464 port <- getServerPort

6565 cfg <- getConfig

66+ updateFaculties cfg

6667 _ <- periodically (1 * hours) $ updateFaculties cfg

6768 _ <- periodically (20 * minutes) $ runDbTask cfg pruneAuth

6869 let ctx = genAuthServerContext $ getPool cfg