dcb6e84 · denis · git.iko.soy

git.iko.soy/denis

Merge pull request #141 from ilyakooo0/develop

Added test

commitdcb6e84f06ed7920de94968a24a8644c37d070f2 authoriko <ilyakooo0@gmail.com> dateTue 14 May 2019, 00:11 (7 years ago) parent757fdf9 b875b80

24 files changed+418−79

compare with master

unifiedsplit

denis/src/Data/Channel/AnonymousChannel.hs+13−7

@@ -5,7 +5,8 @@

55 OverloadedStrings ,

66 TypeApplications ,

77 TypeOperators,

8− OverloadedStrings #-}

8+ OverloadedStrings,

9+ RecordWildCards #-}

910

1011module Data.Channel.AnonymousChannel (

1112 AnonymousChannelId,

@@ -19,15 +20,20 @@ import Data.Aeson

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

2021import Data.Text (Text)

2122import qualified Data.Vector as V

22−import Data.User

23+import Data.User

2324import qualified Data.Set as Set

24−

25+import Data.Tags.Validation

26+import Data.Text.Validator

2527

2628-- MARK: Documentation

2729

2830instance ToSample AnonymousChannel where

2931 toSamples _ = samples $ AnonymousChannel <$> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [[2, 7, 8]]

30−

32+

33+

34+instance HasValidatableText AnonymousChannel where

35+ validateText AnonymousChannel{..} = all (validateText . (~= validateTag')) anonymousChannelTags

36+

3137-- MARK: Implementation

3238

3339type AnonymousChannelId = Int64

@@ -46,10 +52,10 @@ instance ToJSON AnonymousChannel where

4652 "people" .= cPeople ]

4753

4854instance FromJSON AnonymousChannel where

49− parseJSON = withObject "anonymous channel" $ \e ->

55+ parseJSON = withObject "anonymous channel" $ \e ->

5056 AnonymousChannel <$> fmap (V.fromList . removeDuplicates) (e .: "tags") <*> fmap removeDuplicates (e .: "people")

51− where

57+ where

5258 removeDuplicates :: Ord a => [a] -> [a]

5359 removeDuplicates = Set.toList . Set.fromList

5460

55−

61+

denis/src/Data/Channel/NamedChannel.hs+20−11

@@ -5,7 +5,8 @@ OverloadedLabels,

55OverloadedStrings ,

66TypeApplications ,

77TypeOperators,

8−OverloadedStrings #-}

8+OverloadedStrings,

9+RecordWildCards #-}

910

1011module Data.Channel.NamedChannel (

1112 NamedChannelId,

@@ -21,18 +22,26 @@ import Servant.Docs (ToSample, toSamples, samples)

2122import Data.Proxy

2223import Data.Text (Text)

2324import qualified Data.Vector as V

24−import Data.User

25+import Data.User

2526import qualified Data.Set as Set

27+import Data.Text.Validator

28+import Data.Tags.Validation

29+import Data.Limits

2630

2731-- MARK: Documentation

2832

2933instance (ToSample u) => ToSample (NamedChannel u) where

3034 toSamples _ = samples $ NamedChannel <$> [8] <*> ["социология", "ФКН"] <*> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [V.fromList (map snd $ toSamples Proxy)]

3135

32−

3336instance ToSample NamedChannelCreationRequest where

3437 toSamples _ = samples $ NamedChannelCreationRequest <$> ["социология", "ФКН"] <*> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [V.fromList [2, 7, 8]]

35−

38+

39+instance HasValidatableText (NamedChannel u) where

40+ validateText NamedChannel{..} = validateText (namedChannelName ~< maxChannelName) && all (validateText . (~= validateTag')) namedChannelTags

41+

42+instance HasValidatableText (NamedChannelCreationRequest) where

43+ validateText NamedChannelCreationRequest{..} = validateText (namedChannelCreationRequestName ~< maxChannelName) && all validateText namedChannelCreationRequestTags

44+

3645-- MARK: Implementation

3746

3847type NamedChannelId = Int64

@@ -53,14 +62,14 @@ instance (ToJSON u) => ToJSON (NamedChannel u) where

5362 "people" .= cPeople ]

5463

5564instance (FromJSON u, Ord u) => FromJSON (NamedChannel u) where

56− parseJSON = withObject "named channel" $ \e ->

65+ parseJSON = withObject "named channel" $ \e ->

5766 NamedChannel <$> e .: "id" <*> e .: "name" <*> fmap removeDuplicates (e .: "tags") <*> fmap removeDuplicates (e .: "people")

58− where

67+ where

5968 removeDuplicates :: Ord a => [a] -> V.Vector a

6069 removeDuplicates = V.fromList . Set.toList . Set.fromList

61−

70+

6271-- MARK: NamedChannelCreationRequest

63−

72+

6473data NamedChannelCreationRequest = NamedChannelCreationRequest {

6574 namedChannelCreationRequestName :: Text,

6675 namedChannelCreationRequestTags :: V.Vector Text,

@@ -75,10 +84,10 @@ instance ToJSON NamedChannelCreationRequest where

7584 "name" .= cName,

7685 "tags" .= cTags,

7786 "people" .= cPeople ]

78−

87+

7988instance FromJSON NamedChannelCreationRequest where

80− parseJSON = withObject "named channel" $ \e ->

89+ parseJSON = withObject "named channel" $ \e ->

8190 NamedChannelCreationRequest <$> e .: "name" <*> fmap removeDuplicates (e .: "tags") <*> fmap removeDuplicates (e .: "people")

82− where

91+ where

8392 removeDuplicates :: Ord a => [a] -> V.Vector a

8493 removeDuplicates = V.fromList . Set.toList . Set.fromList

denis/src/Data/Connection.hs+6−1

@@ -32,9 +32,14 @@ import Control.Monad.Trans.Control

3232

3333type StaticPQ = PoolPQ Schema Handler

3434

35+printRed :: (Show a) => a -> IO ()

36+printRed a = do

37+ putStr "\a\x001b[31m"

38+ print a

39+ putStr "\x001b[0m"

3540

3641runQ :: ServantErr -> StaticPQ a -> App a

37−runQ err req = handleSqueal ((>> throwError err) . liftIO . print) $ asks getPool >>= lift . runPoolPQ req

42+runQ err req = handleSqueal ((>> throwError err) . liftIO . printRed) $ asks getPool >>= lift . runPoolPQ req

3843

3944runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a

4045runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn

denis/src/Data/GroupChat.hs+10−1

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

77 TypeOperators,

88 OverloadedStrings,

99 TypeSynonymInstances,

10− FlexibleInstances #-}

10+ FlexibleInstances,

11+ RecordWildCards #-}

1112{-# OPTIONS_GHC -Wno-orphans #-}

1213

1314

@@ -32,6 +33,8 @@ import Squeal.PostgreSQL.Schema

3233import Data.Function

3334import Data.Proxy

3435import Servant.Docs

36+import Data.Limits

37+import Data.Text.Validator

3538

3639instance ToSample GroupChat where

3740 toSamples _ = samples $ GroupChat <$>

@@ -44,6 +47,12 @@ instance ToSample GroupChatCreation where

4447 (Jsonb <$> map snd (toSamples Proxy)) <*>

4548 ["cocos", "kursach"]

4649

50+instance HasValidatableText GroupChat where

51+ validateText GroupChat{..} = validateText $ groupChatName ~< maxGroupChatName

52+

53+instance HasValidatableText GroupChatCreation where

54+ validateText GroupChatCreation{..} = validateText $ groupChatCreationName ~< maxGroupChatName

55+

4756instance ToSample UserPermissions where

4857 toSamples _ = singleSample $ M.fromList [(69, GroupChatPermissions True), (5051, GroupChatPermissions False)]

4958

denis/src/Data/Limits.hsnew file+29

@@ -0,0 +1,29 @@

1+{-# OPTIONS_GHC -Wno-missing-export-lists #-}

3+module Data.Limits where

5+import Data.Int (Int64)

7+maxChannelName :: Int

8+maxChannelName = 60

10+maxGroupChatName :: Int

11+maxGroupChatName = 60

12+

13+maxMessageLimitName :: Int

14+maxMessageLimitName = 60

15+

16+postElementLengthLimit :: Int

17+postElementLengthLimit = 10000

18+

19+userFieldLengthLimit :: Int

20+userFieldLengthLimit = 50

21+

22+maxNumberOfTags :: Int

23+maxNumberOfTags = 20

24+

25+channelCountLimit :: Int64

26+channelCountLimit = 128

27+

28+listLimit :: Int

29+listLimit = 100

denis/src/Data/Message.hs+9−1

@@ -6,7 +6,8 @@

66 TypeApplications ,

77 TypeOperators,

88 OverloadedStrings,

9− TupleSections #-}

9+ TupleSections,

10+ RecordWildCards #-}

1011{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

1112

1213

@@ -33,6 +34,7 @@ import Control.Applicative

3334import Data.Aeson.Types

3435import Data.Proxy

3536import Servant.Docs

37+import Data.Text.Validator

3638

3739instance ToSample Message where

3840 toSamples _ = samples $ Message 8 69 <$>

@@ -43,6 +45,12 @@ instance ToSample Message where

4345instance ToSample MessageDetination where

4446 toSamples _ = samples $ [GroupChatDestination 5, UserChatDestination 69]

4547

48+instance HasValidatableText Message where

49+ validateText Message{..} = validateText messageBody

50+

51+instance HasValidatableText MessageCreation where

52+ validateText (MessageCreation _ _ (Jsonb mb)) = validateText mb

53+

4654type GroupChatMessageId = Int64

4755

4856data MessageDetination = GroupChatDestination GroupChatId | UserChatDestination UserId

denis/src/Data/Post.hs+4

@@ -29,6 +29,8 @@ import Data.Function (on)

2929import Data.Time.Clock

3030import Data.Time.Calendar

3131import qualified Data.Vector as V

32+import Data.Tags.Validation

33+import Data.Text.Validator

3234

3335-- MARK: Documentation

3436

@@ -39,6 +41,8 @@ instance ToSample Post where

3941instance ToSample PostCreation where

4042 toSamples _ = samples $ PostCreation <$> (map snd $ toSamples Proxy) <*> [(V.fromList ["hse", "cs", "machineLearning"])]

4143

44+instance HasValidatableText PostCreation where

45+ validateText (PostCreation body tags) = all validateText body && all (validateText . (~= validateTag')) tags

4246

4347-- MARK: Actual type

4448

denis/src/Data/PostElement.hs+9

@@ -26,6 +26,8 @@ import Data.Text (Text)

2626import Data.Aeson

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

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

29+import Data.Text.Validator

30+import Data.Limits

2931

3032-- MARK: Documentation

3133

@@ -35,6 +37,13 @@ instance ToSample (PostElement p) where

3537 Markdown "## This is a subtitle\n_hello._"

3638 ]

3739

40+instance HasValidatableText (PostElement p) where

41+ validateText (Markdown t) = validateText $ t ~< postElementLengthLimit

42+ validateText (Latex t) = validateText $ t ~< postElementLengthLimit

43+ validateText (Image t) = validateText $ t ~< postElementLengthLimit

44+ validateText (Quote _) = False

45+ validateText (Attachment t) = validateText $ t ~< postElementLengthLimit

46+

3847

3948-- MARK: PostElement

4049

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

@@ -9,7 +9,8 @@

99 FlexibleInstances,

1010 KindSignatures,

1111 DeriveAnyClass,

12− RecordWildCards #-}

12+ RecordWildCards,

13+ ScopedTypeVariables #-}

1314

1415{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

1516

@@ -63,7 +64,9 @@ module Data.Query (

6364 killAllTokens,

6465 channelCountForUser,

6566 pruneAuth,

66− searchChannels

67+ searchChannels,

68+ isValidFaculty,

69+ groupChatIsValidForUser

6770 ) where

6871

6972import Squeal.PostgreSQL

@@ -93,7 +96,7 @@ import Data.Text (Text)

9396import qualified Data.Text as T

9497import Data.Channel.NamedChannel

9598import Data.Channel.AnonymousChannel

96−import Data.Maybe (fromMaybe, catMaybes)

99+import Data.Maybe (fromMaybe, catMaybes, isJust)

97100import Squeal.PostgreSQL.Render

98101import Data.GroupChat

99102import Data.Message

@@ -105,6 +108,8 @@ import Data.Foldable (fold)

105108import Data.Char

106109import qualified Data.Vector as V

107110import Server.Auth.Token

111+import Server.Error

112+import Data.Text.Validator

108113

109114-- MARK: Documentation

110115

@@ -313,8 +318,7 @@ getAllChannelsForUserQ = selectStar $

313318searchChannelsForUserQ :: Query Schema (TuplePG (UserId, Text)) (RowPG NamedChannelFull)

314319searchChannelsForUserQ = selectStar $

315320 from (table #channels) &

316− where_ (#namedChannelFullOwner .== param @1 .&&

317− vector @@ query) &

321+ where_ (#namedChannelFullOwner .== param @1) &

318322 orderBy [

319323 tsRankCd vector1 query & Desc,

320324 tsRankCd vector query & Desc

@@ -786,6 +790,14 @@ pruneGhostUsersQ = deleteFrom_ #users

786790

787791-- MARK: FrontEnd Data Structures

788792

793+instance HasValidatableText UserCreation where

794+ validateText UserCreation{..} = all validateText [

795+ userCreationFirstName,

796+ userCreationMiddleName,

797+ userCreationLastName,

798+ userCreationUserFaculty,

799+ userCreationUserEmail]

800+

789801data UserCreation = UserCreation {

790802 userCreationFirstName :: Text,

791803 userCreationMiddleName :: Text,

@@ -851,11 +863,13 @@ getChannelForUser uId cId = do

851863 Nothing -> lift $ S.throwError S.err404

852864

853865-- TODO: Reject bad requests. Should be binary.

854−verifiedUsers :: [UserId] -> StaticPQ [UserId]

855−verifiedUsers uIds =

866+verifyUsers :: [UserId] -> StaticPQ ()

867+verifyUsers uIds =

856868 case verifiedUserIdsQ uIds of

857− Just uIdsQ -> fmap fromOnly <$> (runQuery uIdsQ >>= getRows)

858− Nothing -> return []

869+ Just uIdsQ -> do

870+ (us :: [UserId]) <- fmap fromOnly <$> (runQuery uIdsQ >>= getRows)

871+ when (length us /= length uIds) $ lift $ S.throwError impossibleContent

872+ Nothing -> return ()

859873

860874deleteGroupChat :: GroupChatId -> StaticPQ ()

861875deleteGroupChat gId = do

@@ -917,7 +931,7 @@ getAllUsers :: StaticPQ [User Faculty]

917931getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)

918932

919933publishPost :: UserId -> PostCreation -> StaticPQ PostId

920−publishPost uId pc = commitedTransactionallyUpdate $ do

934+publishPost uId pc = commitedTransactionallyUpdate $ do

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

922936 case pId' of

923937 (Just (Only pId)) -> do

@@ -927,7 +941,8 @@ publishPost uId pc = commitedTransactionallyUpdate $ do

927941

928942createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)

929943createNewChannel uId req = commitedTransactionallyUpdate $ do

930− uIds <- verifiedUsers . toList $ namedChannelCreationRequestPeopleIds req

944+ let uIds = toList $ namedChannelCreationRequestPeopleIds req

945+ verifyUsers uIds

931946 cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow

932947 return $ fmap fromOnly cId

933948

@@ -935,15 +950,21 @@ channelCountForUser :: UserId -> StaticPQ Int64

935950channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)

936951

937952updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()

938−updateChannel uId req = commitedTransactionallyUpdate $ do

939− uIds <- fmap fromList . verifiedUsers . toList $ namedChannelPeopleIds req

953+updateChannel uId req = do

954+ let uIds = namedChannelPeopleIds req

955+ verifyUsers (toList uIds)

940956 _ <- getChannelForUser uId $ namedChannelId req

941− _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})

957+ _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})

942958 return ()

943959

944960getFaculty :: Text -> StaticPQ Faculty

945961getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404

946962

963+isValidFaculty :: FacultyUrl -> StaticPQ Bool

964+isValidFaculty url = do

965+ (faculty :: Maybe Faculty) <- runQueryParams getFacultyQ (Only url) >>= firstRow

966+ return $ isJust faculty

967+

947968updateFaculty :: Faculty -> StaticPQ ()

948969updateFaculty fac = void $ manipulateParams updateFacultyQ fac

949970

@@ -980,9 +1001,9 @@ getAllChannels uId = fmap (map removeUserFromChannel) $

9801001 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows

9811002

9821003deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()

983−deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do

1004+deleteNamedChannel uId cId = do

9841005 _ <- getChannelForUser uId cId

985− _ <- manipulateParams deleteNamedChannelQ (Only cId)

1006+ _ <- commitedTransactionallyUpdate $ manipulateParams deleteNamedChannelQ (Only cId)

9861007 return ()

9871008

9881009-- Returns n most popular

@@ -1029,6 +1050,7 @@ sendMessage selfId (MessageCreation (Just gId) uId@Nothing body) = do

10291050 >>= firstRow >>= fromMaybe500

10301051 return mId

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

1053+ verifyUsers [uId]

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

10331055 >>= firstRow >>= fromMaybe500

10341056 return mId

@@ -1065,15 +1087,24 @@ getGroupChatForUser uId gId = do

10651087 (Just c) -> return c

10661088 Nothing -> lift $ S.throwError S.err404

10671089

1090+groupChatIsValidForUser :: UserId -> GroupChatId -> StaticPQ Bool

1091+groupChatIsValidForUser uId gId = do

1092+ (chat :: Maybe GroupChat) <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow

1093+ return $ isJust chat

1094+

10681095getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]

10691096getFacultyFromQuery query =

10701097 runQueryParams getFacultySearchResultQ (Only . queryFromTextAbbr $ query) >>= getRows

10711098

10721099searchUsers :: T.Text -> StaticPQ [User Faculty]

1073−searchUsers query =

1074− map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)

1100+searchUsers query = do

1101+ unless (validateText query) $ lift $ throwError lengthExceeded

1102+ if (T.null . T.strip $ query)

1103+ then return []

1104+ else map rowToUser <$> (runQueryParams searchUsersQ (Only . queryFromText $ query) >>= getRows)

10751105

10761106searchTags :: T.Text -> StaticPQ [Text]

1107+searchTags "" = return []

10771108searchTags query = map fromOnly <$>

10781109 (runQueryParams searchTagsQ

10791110 (Only . (<> ":*") . T.strip $ query) >>= getRows)

denis/src/Data/Tags/Validation.hsnew file+22

@@ -0,0 +1,22 @@

1+module Data.Tags.Validation (

2+ validateTag,

3+ validateTag'

4+ ) where

6+import Data.Text as T

7+import Data.Char

9+validateTag :: T.Text -> Maybe T.Text

10+validateTag tag =

11+ let

12+ normalised = T.strip $ tag

13+ in if validateTag' normalised

14+ then Just normalised

15+ else Nothing

16+

17+validateTag' :: T.Text -> Bool

18+validateTag' = T.all validChar

19+

20+validChar :: Char -> Bool

21+validChar '-' = True

22+validChar c = isAlphaNum c

denis/src/Data/Text/Validator.hsnew file+74

@@ -0,0 +1,74 @@

1+{-# LANGUAGE FlexibleInstances #-}

3+module Data.Text.Validator (

4+ HasValidatableText(..),

5+ isValidChar,

6+ ExtraPredicate(..),

7+ (~=),

8+ (~<),

9+ (<~>),

10+ RangeableText(..)

11+ ) where

12+

13+import qualified Data.Text as T

14+import Data.Char

15+

16+isValidChar :: Char -> Bool

17+isValidChar = isPrint

18+

19+class HasValidatableText t where

20+ validateText :: t -> Bool

21+

22+data ExtraPredicate t = ExtraPredicate t (t -> Bool)

23+

24+infixl 5 ~=

25+(~=) :: t -> (t -> Bool) -> ExtraPredicate t

26+(~=) = ExtraPredicate

27+

28+instance (HasValidatableText t) => HasValidatableText (ExtraPredicate t) where

29+ validateText (t `ExtraPredicate` p) = validateText t && p t

30+

31+

32+

33+-- instance (Traversable f) => HasValidatableText (RangeableText (ExtraPredicate (f String))) where

34+-- validateText ((t `ExtraPredicate` p) `RangeableText` lims) = p t && validateText (t `RangeableText` lims)

35+

36+-- instance HasValidatableText (RangeableText (ExtraPredicate (f T.Text))) where

37+-- validateText ((t `ExtraPredicate` p) `RangeableText` lims) = p t && validateText (t `RangeableText` lims)

38+

39+-- instance (Foldable f) => HasValidatableText (RangeableText (ExtraPredicate (f T.Text))) where

40+-- validateText ((t `ExtraPredicate` p) `RangeableText` lims) = p t && validateText (t `RangeableText` lims)

41+

42+infixl 5 ~<

43+(~<) :: t -> Int -> RangeableText t

44+t ~< n = t <~> (0, n)

45+

46+infixl 5 <~>

47+(<~>) :: t -> (Int, Int) -> RangeableText t

48+(<~>) = RangeableText

49+

50+data RangeableText t = RangeableText t (Int, Int)

51+

52+instance HasValidatableText (RangeableText String) where

53+ validateText (t `RangeableText` (lower, upper)) = len >= lower && len <= upper && validateText t

54+ where

55+ len = length t

56+

57+instance HasValidatableText (RangeableText T.Text) where

58+ validateText (t `RangeableText` (lower, upper)) = len >= lower && len <= upper && validateText t

59+ where

60+ len = T.length t

61+

62+-- instance HasValidatableText (RangeableText T.Text) where

63+-- validateText (t `RangeableText` (lower, upper)) = len >= lower && len <= upper

64+-- where

65+-- len = T.length t

66+

67+-- instance (Traversable t, HasValidatableText v) => HasValidatableText (t v) where

68+-- validateText = all validateText

69+

70+instance HasValidatableText T.Text where

71+ validateText t = T.all isValidChar t && (not . T.null) t

72+

73+instance HasValidatableText String where

74+ validateText t = all isValidChar t && length t > 0

denis/src/Data/User.hs+7−1

@@ -6,7 +6,8 @@

66 TypeApplications ,

77 TypeOperators,

88 OverloadedStrings,

9− DeriveAnyClass #-}

9+ DeriveAnyClass,

10+ RecordWildCards #-}

1011

1112module Data.User (

1213 User(..),

@@ -23,6 +24,8 @@ import Data.Aeson

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

2425import Data.Proxy

2526import Data.Faculty

27+import Data.Limits

28+import Data.Text.Validator

2629

2730-- MARK: Documentation

2831

@@ -32,6 +35,9 @@ instance (ToSample f) => ToSample (User f) where

3235instance ToSample (UserUpdate) where

3336 toSamples _ = samples $ [UserUpdate "Vasya" "Pupkinovuch" "Pupkin", UserUpdate "Seva" "Algebrovich" "Leonidov"] <*> ["cs.hse.ru/dse/"]

3437

38+instance HasValidatableText UserUpdate where

39+ validateText UserUpdate{..} = all (validateText . (~< userFieldLengthLimit)) [userUpdateFirstName, userUpdateMiddleName, userUpdateLastName, userUpdateUserFaculty]

40+

3541-- MARK: Implementation

3642

3743type UserId = Int64

denis/src/Server/API.hs+6−1

@@ -35,6 +35,8 @@ import Server.API.Faculty

3535import Data.Text (Text)

3636import Data.Maybe (isJust)

3737import Control.Monad.Except

38+import Server.Error

39+import Data.Text.Validator

3840

3941-- MARK: Documentation

4042

@@ -92,7 +94,10 @@ mkServerAPI l =

9294

9395updateUserApi :: UserId -> UserUpdate -> App NoContent

9496updateUserApi uId UserUpdate{..} = do

95− res <- runQerror $ updateUser UserUpdateRow {

97+ unless (validateText $ userUpdateUserFaculty ~< 100) $ throwError lengthExceeded

98+ facultyIsValid <- runQerror $ isValidFaculty userUpdateUserFaculty

99+ unless (facultyIsValid) $ throwError impossibleContent

100+ res <- runQ impossibleContent $ updateUser UserUpdateRow {

96101 userUpdateRowId = uId,

97102 userUpdateRowFirstName = userUpdateFirstName,

98103 userUpdateRowMiddleName = userUpdateMiddleName,

denis/src/Server/API/Channels.hs+27−13

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

44 OverloadedLabels,

55 OverloadedStrings ,

66 TypeApplications ,

7− TypeOperators #-}

7+ TypeOperators,

8+ RecordWildCards #-}

910module Server.API.Channels (

1011 ChannelsApi,

@@ -21,9 +22,12 @@ import Data.Channel.NamedChannel

2122import Data.Channel.AnonymousChannel

2223import qualified Data.Post as P

2324import Server.Query.Pagination

24−import Data.Int

2525import Server.Error

2626import Data.Text (Text)

27+import Data.Text.Validator

28+import Control.Monad

29+import Data.Limits

30+import qualified Data.Text as T

2731

2832type CreateDescription = Description "Creates a new channel\n\nReturns 406 if the channel limit has been exceeded."

2933

@@ -47,22 +51,32 @@ getChannelsApi :: UserId -> App [NamedChannel UserId]

4751getChannelsApi uId = runQnotFound $ getAllChannels uId

4852

4953getAnonymousChannelsApi :: PaginatingRequest P.PostId (Maybe AnonymousChannel) -> App (ResponseWithUsers [P.Post])

50−getAnonymousChannelsApi (PaginatingRequest pId lim (Just req) dir) = runQnotFound $ getAnonymousChannelPosts pId lim dir req

51−getAnonymousChannelsApi (PaginatingRequest pId lim Nothing dir) = maybeNotFound . runQnotFound $ getLastPosts pId lim dir

54+getAnonymousChannelsApi req'@(PaginatingRequest pId lim (Just req) dir) = do

55+ unless (validateText req && validatePaginationRequest req') $ throwError lengthExceeded

56+ runQnotFound $ getAnonymousChannelPosts pId lim dir req

57+getAnonymousChannelsApi req@(PaginatingRequest pId lim Nothing dir) = do

58+ unless (validatePaginationRequest req) $ throwError lengthExceeded

59+ maybeNotFound . runQnotFound $ getLastPosts pId lim dir

5260

5361getChannel :: UserId -> PaginatingRequest P.PostId (Maybe NamedChannelId) -> App (ResponseWithUsers [P.Post])

54−getChannel uId (PaginatingRequest pId lim (Just cId) dir) = runQnotFound $ getChannelPosts uId pId lim dir cId

55−getChannel _ (PaginatingRequest pId lim Nothing dir) = maybeNotFound . runQnotFound $ getLastPosts pId lim dir

62+getChannel uId req@(PaginatingRequest pId lim (Just cId) dir) = do

63+ unless (validatePaginationRequest req) $ throwError lengthExceeded

64+ runQnotFound $ getChannelPosts uId pId lim dir cId

65+getChannel _ req@(PaginatingRequest pId lim Nothing dir) = do

66+ unless (validatePaginationRequest req) $ throwError lengthExceeded

67+ maybeNotFound . runQnotFound $ getLastPosts pId lim dir

5668

5769createChannelApi :: UserId -> NamedChannelCreationRequest -> App NamedChannelId

5870createChannelApi uId req = do

5971 cCount <- runQerror $ channelCountForUser uId

72+ unless (validateText req) $ throwError lengthExceeded

6073 if cCount >= channelCountLimit

61− then throwError $ limitExceeded "You have exceeded the number of channels you can create."

74+ then throwError $ amountExceeded

6275 else maybeNotFound . runQerror $ createNewChannel uId req

6376

6477updateChannelApi :: UserId -> NamedChannel UserId -> App NoContent

65−updateChannelApi uId req = do

78+updateChannelApi uId req@NamedChannel{..} = do

79+ unless (validateText req) $ throwError lengthExceeded

6680 runQnotFound $ updateChannel uId req

6781 return NoContent

6882

@@ -72,8 +86,8 @@ deleteChannelApi uId cId = do

7286 return NoContent

7387

7488searchChannelsApi :: UserId -> Text -> App [NamedChannel UserId]

75−searchChannelsApi uId = runQerror . searchChannels uId

76−

77−-- TODO: Increase

78−channelCountLimit :: Int64

79−channelCountLimit = 5

89+searchChannelsApi uId query = do

90+ unless (validateText query) $ throwError lengthExceeded

91+ if (T.null . T.strip) query

92+ then return []

93+ else runQerror . searchChannels uId $ query

denis/src/Server/API/Completions.hs+6−1

@@ -19,6 +19,8 @@ import Server.App

1919import Data.Connection

2020import Data.Query

2121import Data.Text (Text)

22+import Data.Tags.Validation

23+import Server.Error

2224

2325type CompletionsDescription = Description "\

2426 \Gets tag completion tree\n\n\

@@ -71,4 +73,7 @@ completionHandler :: App CompletionTree

7173completionHandler = runQerror $ mkCompletionTree <$> getTags 1000

7274

7375tagSearch :: Text -> App [Text]

74−tagSearch = runQerror . searchTags

76+tagSearch "" = return []

77+tagSearch query' = do

78+ query <- fromMaybeThrow formatError . return $ validateTag query'

79+ runQerror . searchTags $ query

denis/src/Server/API/Faculty.hs+10−1

@@ -18,7 +18,11 @@ import Server.App

1818import Data.Connection

1919import Data.Query

2020import Data.Text (Text)

21+import qualified Data.Text as T

2122import Data.Faculty

23+import Data.Text.Validator

24+import Control.Monad

25+import Server.Error

2226

2327type SearchDescription = Description "Returns faculties for given string"

2428

@@ -29,4 +33,9 @@ facultyServer :: ServerT FacultyAPI App

2933facultyServer = search

3034

3135search :: Text -> App [Faculty]

32−search = runQerror . getFacultyFromQuery

36+search query = do

37+ if T.null . T.strip $ query

38+ then return []

39+ else do

40+ unless (validateText query) $ throwError lengthExceeded

41+ runQerror . getFacultyFromQuery $ query

denis/src/Server/API/Messages.hs+29−8

@@ -21,6 +21,9 @@ import Server.Query.Pagination

2121import Data.Message

2222import Data.GroupChat

2323import Server.Query.Dialog

24+import Data.Text.Validator

25+import Control.Monad

26+import Server.Error

2427

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

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

@@ -58,27 +61,45 @@ messagesServer uId =

5861

5962

6063getChats :: UserId -> PaginatingRequest MessageId (Maybe ()) -> App (ResponseWithUsers [Dialog])

61−getChats uId (PaginatingRequest mId lim _ dir) = runQerror $ getDialogs uId mId lim dir

64+getChats uId req@(PaginatingRequest mId lim _ dir) = do

65+ unless (validatePaginationRequest req) $ throwError lengthExceeded

66+ runQerror $ getDialogs uId mId lim dir

6267

6368getGroupChat :: UserId -> PaginatingRequest MessageId GroupChatId -> App [Message]

64−getGroupChat uId (PaginatingRequest mId lim gId dir) =

69+getGroupChat uId req@(PaginatingRequest mId lim gId dir) = do

70+ unless (validatePaginationRequest req) $ throwError lengthExceeded

6571 runQerror $ getMessagesInGroupChat uId gId mId lim dir

6672

6773getUserChat :: UserId -> PaginatingRequest MessageId UserId -> App [Message]

68−getUserChat uId (PaginatingRequest mId lim dId dir) =

74+getUserChat uId req@(PaginatingRequest mId lim dId dir) = do

75+ unless (validatePaginationRequest req) $ throwError lengthExceeded

6976 runQerror $ getMessagesInUserChat uId dId mId lim dir

7077

7178getGroupChatInfo :: UserId -> GroupChatId -> App GroupChat

72−getGroupChatInfo uId gId = runQerror $ getGroupChatForUser uId gId

79+getGroupChatInfo uId gId = do

80+ groupIsValid <- runQerror $ groupChatIsValidForUser uId gId

81+ unless (groupIsValid) $ throwError impossibleContent

82+ runQerror $ getGroupChatForUser uId gId

7383

7484updateGroupChatApi :: UserId -> GroupChat -> App NoContent

75−updateGroupChatApi uId group = runQerror (updateGroupChat uId group) >> return NoContent

85+updateGroupChatApi uId group = do

86+ unless (validateText group) $ throwError lengthExceeded

87+ groupIsValid <- runQerror $ groupChatIsValidForUser uId (groupChatId group)

88+ unless (groupIsValid) $ throwError impossibleContent

89+ runQerror (updateGroupChat uId group) >> return NoContent

7690

7791sendMessageApi :: UserId -> MessageCreation -> App MessageId

78−sendMessageApi uId mes = runQerror $ sendMessage uId mes

92+sendMessageApi uId mes = do

93+ unless (validateText mes) $ throwError lengthExceeded

94+ runQerror $ sendMessage uId mes

7995

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

81−createGroupChatApi uId group = runQerror $ createGroupChat uId group

97+createGroupChatApi uId group = do

98+ unless (validateText group) $ throwError lengthExceeded

99+ runQerror $ createGroupChat uId group

82100

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

84−leaveChatAPI uId gIg = runQerror (leaveGroupChat uId gIg) >> return NoContent

102+leaveChatAPI uId gId = do

103+ groupIsValid <- runQerror $ groupChatIsValidForUser uId gId

104+ unless (groupIsValid) $ throwError impossibleContent

105+ runQerror (leaveGroupChat uId gId) >> return NoContent

denis/src/Server/API/Posts.hs+16−4

@@ -19,6 +19,10 @@ import Data.Query

1919import Data.User

2020import Data.Connection

2121import Server.Query.Pagination

22+import Data.Limits

23+import Server.Error

24+import Control.Monad

25+import Data.Text.Validator

2226

2327-- MARK: Implementation

2428

@@ -31,13 +35,21 @@ postApi :: UserId -> ServerT PostApi App

3135postApi uId = getPostsApi :<|> lastPosts :<|> getPostsForUserApi :<|> publishPostApi uId

3236

3337getPostsApi :: [P.PostId] -> App (ResponseWithUsers [P.Post])

34−getPostsApi = maybeNotFound . runQnotFound . getPosts

38+getPostsApi req = do

39+ unless (listLimit < length req) $ throwError lengthExceeded

40+ maybeNotFound . runQnotFound . getPosts $ req

3541

3642lastPosts :: PaginatingRequest P.PostId (Maybe ()) -> App (ResponseWithUsers [P.Post])

37−lastPosts (PaginatingRequest pId lim _ dir) = maybeNotFound . runQnotFound $ getLastPosts pId lim dir

43+lastPosts req@(PaginatingRequest pId lim _ dir) = do

44+ unless (validatePaginationRequest req) $ throwError lengthExceeded

45+ maybeNotFound . runQnotFound $ getLastPosts pId lim dir

3846

3947getPostsForUserApi :: PaginatingRequest P.PostId UserId -> App (ResponseWithUsers [P.Post])

40−getPostsForUserApi (PaginatingRequest pId lim uId dir) = maybeNotFound . runQnotFound $ getPostsForUser pId lim dir uId

48+getPostsForUserApi req@(PaginatingRequest pId lim uId dir) = do

49+ unless (validatePaginationRequest req) $ throwError lengthExceeded

50+ maybeNotFound . runQnotFound $ getPostsForUser pId lim dir uId

4151

4252publishPostApi :: UserId -> P.PostCreation -> App P.PostId

43−publishPostApi uId = runQerror . publishPost uId

53+publishPostApi uId creation = do

54+ unless (validateText creation) $ throwError lengthExceeded

55+ runQerror . publishPost uId $ creation

denis/src/Server/App.hs+11−2

@@ -15,7 +15,8 @@ module Server.App (

1515 ask,

1616 asks,

1717 liftIO,

18− MailConfig(..)

18+ MailConfig(..),

19+ fromMaybeThrow

1920) where

2021

2122import Servant.Server

@@ -25,6 +26,7 @@ import Data.Schema

2526import Generics.SOP (K)

2627import Squeal.PostgreSQL.PQ (Connection)

2728import Crypto.RNG

29+import Server.Error

2830

2931type App = ReaderT Config Handler

3032

@@ -45,4 +47,11 @@ data MailConfig = MailConfig {

4547}

4648

4749instance CryptoRNG App where

48− randomBytes n = join $ asks (liftIO . randomBytesIO n . cryptoState)

50+ randomBytes n = join $ asks (liftIO . randomBytesIO n . cryptoState)

51+

52+fromMaybeThrow :: ServantErr -> App (Maybe a) -> App a

53+fromMaybeThrow err mb = do

54+ a <- mb

55+ case a of

56+ Just b -> return b

57+ Nothing -> throwError err

denis/src/Server/Auth.hs+16−2

@@ -56,6 +56,8 @@ import Server.Auth.Mail

5656import Web.UAParser

5757import qualified Data.Text.Lazy as TL

5858import Server.Auth.HTML

59+import Data.Char

60+import Data.Text.Validator

5961

6062-- MARK: Documentation

6163

@@ -312,7 +314,9 @@ checkToken conn (AuthenticationCookieData uId tokenData) = do

312314register :: UserCreation -> Maybe String -> App (Headers '[Header "Set-Cookie" String] NoContent)

313315register creation' ua' = do

314316 let creation = normalizaUser creation'

315− unless (validateUser creation) $ throwError err400

317+ unless (validateUser creation && validateText creation) $ throwError err400

318+ validFaculty <- runQerror $ isValidFaculty (userCreationUserFaculty creation)

319+ unless validFaculty $ throwError impossibleContent

316320 genToken <- generateTokenM

317321 let ua = getUserAgent ua'

318322 GeneratedToken token value code activation deactivation <- runQ err409 . commitedTransactionallyUpdate $ do

@@ -382,8 +386,9 @@ validateEmail :: T.Text -> Bool

382386validateEmail "ilyakooo0@gmail.com" = True

383387validateEmail "rednikina.com@yandex.ru" = True

384388validateEmail "admikhaleva@edu.hse.ru" = True

385−validateEmail e = (isJust . matchRegex regex . T.unpack $ e) || (isJust . matchRegex falseRegex . T.unpack $ e)

389+validateEmail e = (all validChar email) && ((isJust . matchRegex regex $ email) || (isJust . matchRegex falseRegex $ email))

386390 where

391+ email = T.unpack $ e

387392 regex = mkRegexWithOpts

388393 "^[A-Z0-9a-z._%-]+@hse\\.ru$"

389394 False

@@ -392,3 +397,12 @@ validateEmail e = (isJust . matchRegex regex . T.unpack $ e) || (isJust . matchR

392397 "^[A-Z0-9a-z._%-+]+@edu.hse\\.ru$"

393398 False

394399 False

400+

401+validChar :: Char -> Bool

402+validChar = isPrint

403+

404+-- checkString :: String -> App String

405+-- checkString s =

406+-- if any invalidChar s

407+-- then throwError formatError

408+-- else return s

denis/src/Server/Error.hs+35−4

@@ -2,7 +2,10 @@

33module Server.Error (

44 invalidToken,

5− limitExceeded,

5+ amountExceeded,

6+ lengthExceeded,

7+ formatError,

8+ impossibleContent,

69 throwError

710) where

811

@@ -17,7 +20,35 @@ invalidToken = ServantErr {

1720 errHeaders = []

1821}

1922

20−limitExceeded :: String -> ServantErr

21−limitExceeded msg = err406 {

22− errReasonPhrase = msg

23+amountExceeded :: ServantErr

24+amountExceeded = ServantErr {

25+ errHTTPCode = 470,

26+ errReasonPhrase = "The amount of elements the user can have has been exceeded.",

27+ errBody = "",

28+ errHeaders = []

29+}

30+

31+lengthExceeded :: ServantErr

32+lengthExceeded = ServantErr {

33+ errHTTPCode = 471,

34+ errReasonPhrase = "The length of user content has been exceeded.",

35+ errBody = "",

36+ errHeaders = []

2337}

38+

39+formatError :: ServantErr

40+formatError = ServantErr {

41+ errHTTPCode = 472,

42+ errReasonPhrase = "The format of the supplied content is invalid.",

43+ errBody = "",

44+ errHeaders = []

45+}

46+

47+impossibleContent :: ServantErr

48+impossibleContent = ServantErr {

49+ errHTTPCode = 473,

50+ errReasonPhrase = "The content you have supplied is invalid and/or conflict with the rest of the existing content.",

51+ errBody = "",

52+ errHeaders = []

53+}

54+

denis/src/Server/Query/Pagination.hs+5−1

@@ -13,7 +13,8 @@

1313

1414module Server.Query.Pagination (

1515 PaginatingRequest(..),

16− PaginationDirection(..)

16+ PaginationDirection(..),

17+ validatePaginationRequest

1718 ) where

1819

1920import GHC.Generics

@@ -32,6 +33,9 @@ data PaginatingRequest i r = PaginatingRequest {

3233 direction :: PaginationDirection

3334} deriving (Generic)

3435

36+validatePaginationRequest :: (PaginatingRequest i r) -> Bool

37+validatePaginationRequest PaginatingRequest{limit=lim} = lim > 0 && lim < 100

38+

3539instance (ToJSON r, ToJSON i) => ToJSON (PaginatingRequest i r) where

3640instance (FromJSON r, FromJSON i) => FromJSON (PaginatingRequest i r) where

3741

denis/src/test/Spec.hs+5−1

@@ -23,6 +23,7 @@ import Orphans

2323import qualified Network.HTTP.Client as HTTP

2424import qualified Data.ByteString.Char8 as B

2525import qualified Data.ByteString.Lazy.Char8 as LB

26+import Network.HTTP.Types.Status (statusCode)

2627

2728main :: IO ()

2829main = hspec goodAPISpec

@@ -43,8 +44,11 @@ goodAPISpec = describe "my server" $ do

4344printPredicate = RequestPredicate $ \ req mgr -> do

4445 let url = HTTP.path req

4546 let (HTTP.RequestBodyLBS bs) = HTTP.requestBody req

47+ resp <- HTTP.httpLbs req mgr

48+ let code = statusCode $ HTTP.responseStatus resp

4649 putStrLn . ("\t\t" <>) $ B.unpack url

47− putStrLn $ LB.unpack bs

50+ putStrLn . filter (/= '\a') $ LB.unpack bs

51+ print code

4852 putStrLn ""

4953 return []

5054

stack.yaml−1

@@ -40,7 +40,6 @@ packages:

4040extra-deps:

4141- taggy-0.2.1

4242- crypto-rng-0.1.0.2

43−- periodic-0.1.0.0

4443# - servant-options-0.1.0.0

4544

4645