master..534f1b5 · denis

git.iko.soy/denis

7 files changed+27−48

unifiedsplit

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

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

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

2929listLimit = 100

3030

3131globalTextLimit :: Int

32−globalTextLimit = 50000

33−

34−groupChatSizeLimit :: Int

35−groupChatSizeLimit = 256

32+globalTextLimit = 50000

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

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

1616 PostElementRow(..),

1717 PostElement(..),

1818 elementsToRows,

19− PostQuote(..),

20− stripPostElement

19+ PostQuote(..)

2120) where

2221

2322import Data.Int (Int64)

2423import qualified Generics.SOP as SOP

2524import qualified GHC.Generics as GHC

26−import Data.Text (Text, strip)

25+import Data.Text (Text)

2726import Data.Aeson

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

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

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

5554 | Attachment Text

5655 deriving (Show, GHC.Generic)

5756

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−

6357instance ToJSON (PostElement t) where

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

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

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

@@ -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 (map stripPostElement $ postCreationBody pc)

938+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)

939939 return pId

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

941941

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

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

10071007 return ()

10081008

1009+-- Returns n most popular

10091010getTags :: Limit -> StaticPQ [String]

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

10111012

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

10431044 return . catMaybes . map restoreMessage $ resp

10441045

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

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

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

10471048 _ <- getGroupChatForUser selfId gId

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

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

10491050 >>= firstRow >>= fromMaybe500

10501051 return mId

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

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

10521053 verifyUsers [uId]

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

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

10541055 >>= firstRow >>= fromMaybe500

10551056 return mId

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

10571058

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

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

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

10671066

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

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

1070− verifyUsers . M.keys $ perms

1071− commitedTransactionallyUpdate $ do

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

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

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

1075− let newPerms = M.insert uId userPerm perms

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

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)

10771074

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

10791076leaveGroupChat uId gId = commitedTransactionallyUpdate $ do

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

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

44 ) where

66import Data.Text as T

7−import Data.Char as C

8−import qualified Data.Set as S

7+import Data.Char

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

1110validateTag tag =

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

1817validateTag' :: T.Text -> Bool

1918validateTag' = T.all validChar

2019

21−validChars :: S.Set Char

22−validChars = S.fromList "йцукенгшщзхъфывапролджэёячсмитьбюqwertyuiopasdfghjklzxcvbnm1234567890_"

23−

2420validChar :: Char -> Bool

25−validChar c = S.member (C.toLower c) validChars

21+validChar '-' = True

22+validChar c = isAlphaNum c

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 || generalCategory c == ModifierLetter

20+isValidChar c = isPrint c

2121

2222class HasValidatableText t where

2323 validateText :: t -> Bool

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

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

44 OverloadedLabels,

55 OverloadedStrings ,

66 TypeApplications ,

7− TypeOperators,

8− RecordWildCards #-}

7+ TypeOperators #-}

109module Server.API.Messages (

1110 MessagesApi,

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

2524import Data.Text.Validator

2625import Control.Monad

2726import Server.Error

28−import qualified Data.Map as M

29−import Squeal.PostgreSQL.Schema

30−import Data.Limits

3127

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

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

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

9894 runQerror $ sendMessage uId mes

9995

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

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

97+createGroupChatApi uId group = do

10298 unless (validateText group) $ throwError lengthExceeded

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

10499 runQerror $ createGroupChat uId group

105100

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

denis/src/Server/Server.hs−1

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

6363runServer = do

6464 port <- getServerPort

6565 cfg <- getConfig

66− updateFaculties cfg

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

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

6968 let ctx = genAuthServerContext $ getPool cfg