master..f618fed · denis

git.iko.soy/denis

on f618fed help sign in

Procfile+1−1

since splitsnapshots

unifiedsplit

@@ -1 +1 @@

1−web: denis-exe +RTS -N

1+web: denis-exe

denis/docs/Docs.hs+4−15

@@ -21,41 +21,30 @@ import Server.Logger

21import Server.Auth

22import Server.API.Channels

23import Data.Aeson

24−import qualified Data.Text.IO as T

25−import Servant.Server.Experimental.Auth

26−import Network.Wai

27−import Server.API.Messages

28−import Server.API.Faculty

30docsWriter :: HasDocs api => String -> Proxy api -> IO ()

25docsWriter :: HasDocs api => String -> Proxy api -> IO ()

31−docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs

26+docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs

33main = do

28main = do

34 docsWriter "posts" $ pretty (Proxy :: Proxy ("posts" :> PostApi))

29 docsWriter "posts" $ pretty (Proxy :: Proxy ("posts" :> PostApi))

35− docsWriter "messages" $ pretty (Proxy :: Proxy (MessagesApi))

36 docsWriter "all" $ pretty serverProxy

30 docsWriter "all" $ pretty serverProxy

37 docsWriter "authentication" $ pretty (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>

31 docsWriter "authentication" $ pretty (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>

38− Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))

32+ Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))

39 docsWriter "channels" $ pretty (Proxy :: Proxy ("channels" :> ChannelsApi))

33 docsWriter "channels" $ pretty (Proxy :: Proxy ("channels" :> ChannelsApi))

40− T.writeFile ("docs/Home.md") . (\t -> "```\n" <> t <> "```\n") $ layoutWithContext serverProxy (undefined :: Context (AuthHandler Request UserId ': '[]))

41− docsWriter "faculty" $ pretty (Proxy :: Proxy ("faculty" :> FacultyAPI))

44instance ToSample Char where

36instance ToSample Char where

45 toSamples _ = singleSample 'c'

37 toSamples _ = singleSample 'c'

46−

38+

47instance ToSample Int64 where

39instance ToSample Int64 where

48 toSamples _ = samples [1, 7, 2, 19]

40 toSamples _ = samples [1, 7, 2, 19]

50instance ToSample Word64 where

42instance ToSample Word64 where

51 toSamples _ = samples [1, 7, 2, 19]

43 toSamples _ = samples [1, 7, 2, 19]

52−

44+

53instance ToSample Log where

45instance ToSample Log where

54 toSamples _ = noSamples

46 toSamples _ = noSamples

56−instance ToSample () where

57− toSamples _ = singleSample ()

58−

59normalizer :: String -> String

48normalizer :: String -> String

60normalizer (' ':' ':' ':' ':'`':'`':'`':xs) = "```" ++ normalizer xs

49normalizer (' ':' ':' ':' ':'`':'`':'`':xs) = "```" ++ normalizer xs

61normalizer (x:xs) = x : normalizer xs

50normalizer (x:xs) = x : normalizer xs

denis/email.htmldeleted−22

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

1−<html>

2−

3−<body style="font-family: sans-serif;">

4− <div style="text-align: center; margin-top: 55px;">

5− <a href="#" style="font-size: 34px; font-weight: bold; display: inline-block; padding: 7px 13px 7px 13px; margin-bottom: 89px; text-decoration: underline; font-family: sans-serif; color: #555;">

6− Log in

7− </a>

8− <br />

9− <div style="font-size: 34px; font-weight: bold;">

10− <span style="color: #bbb; font-weight: bold;">from: </span>macOS

11− </div>

12− <br />

13− <div style="font-size: 55px; font-weight: bold; border-radius: 10px; background-color: #eee; display: inline-block; padding: 7px 13px 7px 13px; box-shadow: 0px 5px 21px #bbb; background-image: linear-gradient(#f9f9f9, #eee);">

14− 21<div style="display: inline-block; width: 13px;"></div>55<div style="display: inline-block; width: 13px;"></div>43

15− </div>

16− </div>

17− <div style="text-align: center; margin-top: 233px;">

18− <a href="#" style="text-decoration: underline; font-family: sans-serif; color: #555;font-size: 13px; margin-bottom: 21px;">Revoke access</a>

19− </div>

20−</body>

21−

22−</html>

denis/package.yaml+7−28

@@ -27,10 +27,12 @@ dependencies:

27- text

28- aeson

29- bytestring

30+# - http-client

31+# - http-client-tls

30- servant-websockets

32- servant-websockets

31- websockets

33- websockets

32- squeal-postgresql

34- squeal-postgresql

33−- monad-control

35+- transformers-base

34- generics-sop

36- generics-sop

35- containers

37- containers

36- mtl

38- mtl

@@ -47,26 +49,12 @@ dependencies:

47- data-default-class

49- data-default-class

48- fast-logger

50- fast-logger

49- vector

51- vector

50−- taggy

52+

51−- unordered-containers

52−- req

53−- data-default

54- lens

53- lens

55−- crypto-rng

54+

56- wai-cors

55- wai-cors

57−- base64-bytestring

56+

58−- regex-compat

57+

59−- smtp-mail

60−- mime-mail

61−- ua-parser

62−- cryptohash-sha512

63−- blaze-html

64−- servant-blaze

65−- random

66−- hspec

67−- generic-arbitrary

68−- quickcheck-instances

69−- http-client

71library:

59library:

72 source-dirs: src

60 source-dirs: src

@@ -109,13 +97,4 @@ executables:

109 - -rtsopts

97 - -rtsopts

110 - -with-rtsopts=-N

98 - -with-rtsopts=-N

111 dependencies:

99 dependencies:

112− - denis

113− test:

114− main: Spec.hs

115− source-dirs: src/test

116− ghc-options:

117− - -threaded

118− dependencies:

119− - QuickCheck

120− - servant-quickcheck

121 - denis

100 - denis

denis/sql/indexes.sqldeleted−5

@@ -1,5 +0,0 @@

1−CREATE OR REPLACE FUNCTION my_array_to_text(text[])

2− RETURNS text LANGUAGE sql IMMUTABLE AS $$SELECT array_to_string($1, ' ')$$;

3−

4−CREATE INDEX "faculty_text" ON "faculties" USING GIN (to_tsvector('russian', "facultyName" || ' ' || "facultyPath" || ' ' || "facultyCampusName" || ' ' || my_array_to_text("facultyTags")))

5−

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

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

5 OverloadedStrings ,

6 TypeApplications ,

7 TypeOperators,

8− OverloadedStrings,

8+ OverloadedStrings #-}

9− RecordWildCards #-}

11module Data.Channel.AnonymousChannel (

10module Data.Channel.AnonymousChannel (

12 AnonymousChannelId,

11 AnonymousChannelId,

@@ -18,22 +17,21 @@ import qualified Generics.SOP as SOP

18import qualified GHC.Generics as GHC

17import qualified GHC.Generics as GHC

19import Data.Aeson

18import Data.Aeson

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

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

20+import Data.Proxy

21import Data.Text (Text)

22+import Data.Function (on)

23+import Data.Time.Clock

24+import Data.Time.Calendar

22import qualified Data.Vector as V

25import qualified Data.Vector as V

23−import Data.User

26+import Data.User

24import qualified Data.Set as Set

27import qualified Data.Set as Set

25−import Data.Tags.Validation

28+

26−import Data.Text.Validator

28-- MARK: Documentation

30-- MARK: Documentation

30instance ToSample AnonymousChannel where

32instance ToSample AnonymousChannel where

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

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

32−

34+

33−

34−instance HasValidatableText AnonymousChannel where

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

36−

37-- MARK: Implementation

35-- MARK: Implementation

39type AnonymousChannelId = Int64

37type AnonymousChannelId = Int64

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

52 "people" .= cPeople ]

50 "people" .= cPeople ]

54instance FromJSON AnonymousChannel where

52instance FromJSON AnonymousChannel where

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

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

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

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

57− where

55+ where

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

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

59 removeDuplicates = Set.toList . Set.fromList

57 removeDuplicates = Set.toList . Set.fromList

61−

59+

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

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

5OverloadedStrings ,

6TypeApplications ,

7TypeOperators,

8−OverloadedStrings,

8+OverloadedStrings #-}

9−RecordWildCards #-}

11module Data.Channel.NamedChannel (

10module Data.Channel.NamedChannel (

12 NamedChannelId,

11 NamedChannelId,

@@ -21,27 +20,22 @@ import Data.Aeson

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

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

22import Data.Proxy

21import Data.Proxy

23import Data.Text (Text)

22import Data.Text (Text)

23+import Data.Function (on)

24+import Data.Time.Clock

25+import Data.Time.Calendar

24import qualified Data.Vector as V

26import qualified Data.Vector as V

25−import Data.User

27+import Data.User

26import qualified Data.Set as Set

28import qualified Data.Set as Set

27−import Data.Text.Validator

28−import Data.Tags.Validation

29−import Data.Limits

31-- MARK: Documentation

30-- MARK: Documentation

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

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

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

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

35+

36instance ToSample NamedChannelCreationRequest where

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

38−

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−

45-- MARK: Implementation

39-- MARK: Implementation

47type NamedChannelId = Int64

41type NamedChannelId = Int64

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

62 "people" .= cPeople ]

56 "people" .= cPeople ]

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

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

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

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

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

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

67− where

61+ where

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

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

69 removeDuplicates = V.fromList . Set.toList . Set.fromList

63 removeDuplicates = V.fromList . Set.toList . Set.fromList

70−

64+

71-- MARK: NamedChannelCreationRequest

65-- MARK: NamedChannelCreationRequest

72−

66+

73data NamedChannelCreationRequest = NamedChannelCreationRequest {

67data NamedChannelCreationRequest = NamedChannelCreationRequest {

74 namedChannelCreationRequestName :: Text,

68 namedChannelCreationRequestName :: Text,

75 namedChannelCreationRequestTags :: V.Vector Text,

69 namedChannelCreationRequestTags :: V.Vector Text,

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

84 "name" .= cName,

78 "name" .= cName,

85 "tags" .= cTags,

79 "tags" .= cTags,

86 "people" .= cPeople ]

80 "people" .= cPeople ]

87−

81+

88instance FromJSON NamedChannelCreationRequest where

82instance FromJSON NamedChannelCreationRequest where

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

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

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

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

91− where

85+ where

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

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

93 removeDuplicates = V.fromList . Set.toList . Set.fromList

87 removeDuplicates = V.fromList . Set.toList . Set.fromList

denis/src/Data/Connection.hs+4−19

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

4 OverloadedLabels,

5 OverloadedStrings ,

6 TypeApplications ,

7− TypeOperators,

7+ TypeOperators #-}

8− FlexibleContexts #-}

10module Data.Connection (

9module Data.Connection (

11 Connection,

10 Connection,

@@ -15,9 +14,7 @@ module Data.Connection (

15 runQnotFound,

14 runQnotFound,

16 runQerror,

15 runQerror,

17 maybeNotFound,

16 maybeNotFound,

18− maybeInvalidToken,

17+ maybeInvalidToken

19− commitedTransactionallyUpdate,

20− runQsilent

21) where

18) where

23import Squeal.PostgreSQL

20import Squeal.PostgreSQL

@@ -28,18 +25,12 @@ import Control.Monad.Reader

28import Control.Monad.Except

25import Control.Monad.Except

29import Servant.Server

26import Servant.Server

30import Server.Error

27import Server.Error

31−import Control.Monad.Trans.Control

33type StaticPQ = PoolPQ Schema Handler

29type StaticPQ = PoolPQ Schema Handler

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

36−printRed a = do

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

38− print a

39− putStr "\x001b[0m"

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

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

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

33+runQ err req = handleSqueal (const $ throwError err) $ asks getPool >>= lift . runPoolPQ req

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

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

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

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

@@ -50,10 +41,6 @@ runQnotFound = runQ err404

50runQerror :: StaticPQ a -> App a

41runQerror :: StaticPQ a -> App a

51runQerror = runQ err500

42runQerror = runQ err500

53−runQsilent :: StaticPQ a -> App ()

54−runQsilent req = handleSqueal (liftIO . print) $ asks getPool >>= lift . runPoolPQ req

55− >> return ()

56−

57maybeNotFound :: App (Maybe a) -> App a

44maybeNotFound :: App (Maybe a) -> App a

58maybeNotFound = (>>= (\t -> case t of

45maybeNotFound = (>>= (\t -> case t of

59 Just y -> return y

46 Just y -> return y

@@ -63,6 +50,4 @@ maybeInvalidToken :: App (Maybe a) -> App a

63maybeInvalidToken = (>>= (\t -> case t of

50maybeInvalidToken = (>>= (\t -> case t of

64 Just y -> return y

51 Just y -> return y

65 Nothing -> throwError invalidToken))

52 Nothing -> throwError invalidToken))

66−

53+

67−commitedTransactionallyUpdate :: (MonadBaseControl IO tx, MonadPQ schema tx) => tx x -> tx x

68−commitedTransactionallyUpdate = transactionally $ TransactionMode ReadCommitted ReadWrite NotDeferrable

denis/src/Data/CyclicBuffer.hs−2

@@ -1,5 +1,3 @@

1−{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

2−

3module Data.CyclicBuffer (

1module Data.CyclicBuffer (

4 CyclicBuffer(elems),

2 CyclicBuffer(elems),

5 mkCyclicBuffer,

3 mkCyclicBuffer,

denis/src/Data/Faculty.hsdeleted−59

@@ -1,59 +0,0 @@

1−{-# LANGUAGE

2− DataKinds ,

3− DeriveGeneric ,

4− OverloadedLabels,

5− OverloadedStrings ,

6− TypeApplications ,

7− TypeOperators,

8− OverloadedStrings,

9− DeriveAnyClass #-}

10−

11−module Data.Faculty (

12− Faculty(..),

13− FacultyUrl

14− ) where

15−

16−import qualified Generics.SOP as SOP

17−import qualified GHC.Generics as GHC

18−import Data.Aeson

19−import qualified Data.Text as T

20−import qualified Data.Vector as V

21−import Servant.Docs

22−

23−instance ToSample Faculty where

24− toSamples _ = singleSample $ Faculty "ПИ" "cs.hse.ru/bse" "ФКН -> ПИ" "Москва" "193729"

25− (V.fromList ["Программирование", "Естсественные науки"]) "Настоящий адрес факультета"

26−

27−type FacultyUrl = T.Text

28−

29−data Faculty = Faculty {

30− facultyName :: T.Text,

31− facultyUrl :: FacultyUrl,

32− facultyPath :: T.Text,

33− facultyCampusName :: T.Text,

34− facultyCampusCode :: T.Text,

35− facultyTags :: V.Vector T.Text,

36− facultyAddress :: T.Text

37−} deriving (GHC.Generic, Show, SOP.Generic, SOP.HasDatatypeInfo)

38−

39−instance ToJSON Faculty where

40− toJSON (Faculty name url p campusName campusCode tags address) = object [

41− "name" .= name,

42− "url" .= url,

43− "path" .= p,

44− "campusName" .= campusName,

45− "campusCode" .= campusCode,

46− "tags" .= tags,

47− "address" .= address

48− ]

49−

50−instance FromJSON Faculty where

51− parseJSON = withObject "faculty" $ \e ->

52− Faculty <$>

53− e .: "name" <*>

54− e .: "url" <*>

55− e .: "path" <*>

56− e .: "campusName" <*>

57− e .: "campusCode" <*>

58− e .: "tags" <*>

59− e .: "address"

denis/src/Data/Faculty/Parser.hsdeleted−85

@@ -1,85 +0,0 @@

1−{-# LANGUAGE

2− OverloadedStrings,

3− TupleSections #-}

4−

5−module Data.Faculty.Parser (

6− getFaculties

7− ) where

8−

9−import Network.HTTP.Req

10−import qualified Data.Text as T

11−import qualified Data.Text.Lazy as LT

12−import Data.Text.Lazy.Encoding

13−import Text.Taggy.DOM

14−import qualified Data.HashMap.Lazy as HM

15−import Data.Maybe

16−import Data.Faculty

17−import Control.Monad.IO.Class

18−import Data.Default

19−import qualified Data.Vector as V

20−

21−getFaculties :: MonadIO m => m [Faculty]

22−getFaculties = runReq def $ do

23− campuses <- getCampuses

24− concat <$> mapM (\c -> getFacultiesForCampus c) campuses

25−

26−sendReq

27− :: MonadHttp f

28− => Url scheme

29− -> f LT.Text

30−sendReq url = decodeUtf8 . responseBody <$> req GET url NoReqBody lbsResponse mempty

31−

32−getCampuses :: Req [Campus]

33−getCampuses = do

34− let url = https "www.hse.ru" /: "org" /: "units"

35− resp <- sendReq url

36− let dom = parseDOM True resp

37− return . fromMaybe [] $ do

38− let els = elements $ dom

39− campuses <- listToMaybe .

40− filter (classIs "js-side_filter_content side_filter_content filter_switcher") $ els

41− sequence . map processCampus . tail . texts' mempty . eltChildren $ campuses

42− where

43− processCampus :: (HM.HashMap T.Text T.Text, T.Text) -> Maybe Campus

44− processCampus (hm, name) = do

45− code <- HM.lookup "hse-value" hm

46− return $ Campus (T.strip name) code

47−

48−

49−getFacultiesForCampus :: Campus -> Req [Faculty]

50−getFacultiesForCampus (Campus cName cCode) = do

51− let url = https "www.hse.ru" /: "org" /: "units" /: "campus" /: cCode

52− resp <- decodeUtf8 . responseBody <$> req GET url NoReqBody lbsResponse ("ltr" =: (42 :: Int))

53− let dom = parseDOM True resp

54− return . catMaybes . map processFaculty . filter (classIs "post person") $ elements dom

55− where

56− processFaculty :: Element -> Maybe Faculty

57− processFaculty el = do

58− let els = elements [NodeElement el]

59− nameTag <- listToMaybe . texts' mempty . map (NodeElement) . filter (classIs "link large b") $ els

60− let name = T.strip . snd $ nameTag

61− url <- (T.strip . snd . T.breakOnEnd "://") <$> (HM.lookup "href" . fst $ nameTag)

62− _ <- if T.null url

63− then Nothing

64− else Just ()

65− let tags = map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "with-indent small tag-set") $ els

66− let path = T.unwords . map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "small") $ els

67− let address = T.unwords . map (T.strip . snd) . texts' mempty . map (NodeElement) . filter (classIs "link link_dark i") $ els

68− return $ Faculty name url path cName cCode (V.fromList tags) address

69−

70−classIs :: T.Text -> Element -> Bool

71−classIs c = (== (Just c)) . HM.lookup "class" . eltAttrs

72−

73−elements :: [Node] -> [Element]

74−elements ((NodeElement el):nn) = el : ((elements . eltChildren) el ++ elements nn)

75−elements _ = []

76−

77−texts' :: HM.HashMap T.Text T.Text -> [Node] -> [(HM.HashMap T.Text T.Text, T.Text)]

78−texts' hm (NodeContent t: nn) = (hm, t) : texts' hm nn

79−texts' hm ((NodeElement el):nn) = ((texts' (HM.union (eltAttrs el) hm) (eltChildren el)) ++ texts' hm nn)

80−texts' _ _ = []

81−

82−data Campus = Campus {

83− campusName :: T.Text,

84− campusCode :: T.Text

85−} deriving Show

denis/src/Data/GroupChat.hsdeleted−118

@@ -1,118 +0,0 @@

1−{-# LANGUAGE

2− DataKinds ,

3− DeriveGeneric ,

4− OverloadedLabels,

5− OverloadedStrings ,

6− TypeApplications ,

7− TypeOperators,

8− OverloadedStrings,

9− TypeSynonymInstances,

10− FlexibleInstances,

11− RecordWildCards #-}

12−{-# OPTIONS_GHC -Wno-orphans #-}

13−

14−

15−module Data.GroupChat (

16− GroupChat(..),

17− GroupChatPermissions(..),

18− GroupChatId,

19− UserPermissions,

20− GroupChatCreation(..),

21− maxChatPermissions,

22− minChatPermissions

23− ) where

24−

25−import Data.Aeson

26−import Data.Int (Int64)

27−import Data.User

28−import qualified Data.Map.Strict as M

29−import Data.Text (Text)

30−import qualified GHC.Generics as GHC

31−import qualified Generics.SOP as SOP

32−import Squeal.PostgreSQL.Schema

33−import Data.Function

34−import Data.Proxy

35−import Servant.Docs

36−import Data.Limits

37−import Data.Text.Validator

38−

39−instance ToSample GroupChat where

40− toSamples _ = samples $ GroupChat <$>

41− [5] <*>

42− (Jsonb <$> map snd (toSamples Proxy)) <*>

43− ["cocos", "kursach"]

44−

45−instance ToSample GroupChatCreation where

46− toSamples _ = samples $ GroupChatCreation <$>

47− (Jsonb <$> map snd (toSamples Proxy)) <*>

48− ["cocos", "kursach"]

49−

50−instance HasValidatableText GroupChat where

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

52−

53−instance HasValidatableText GroupChatCreation where

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

55−

56−instance ToSample UserPermissions where

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

58−

59−type GroupChatId = Int64

60−type UserPermissions = M.Map UserId GroupChatPermissions

61−

62−data GroupChat = GroupChat {

63− groupChatId :: GroupChatId,

64− groupChatUsers :: Jsonb UserPermissions,

65− groupChatName :: Text

66−} deriving (Show, GHC.Generic)

67−

68−instance SOP.Generic GroupChat

69−instance SOP.HasDatatypeInfo GroupChat

70−instance ToJSON GroupChat where

71− toJSON (GroupChat gId us n) = object [

72− "id" .= gId,

73− "users" .= getJsonb us,

74− "name" .= n

75− ]

76−

77−instance FromJSON GroupChat where

78− parseJSON = withObject "group chat" $ \e ->

79− GroupChat <$> e .: "id" <*> (Jsonb <$> e .: "users") <*> e .: "name"

80−

81−data GroupChatPermissions = GroupChatPermissions {

82− -- canInvite :: Bool,

83− -- canKick :: Bool,

84− isAdmin :: Bool

85−} deriving (Show, GHC.Generic)

86−

87−maxChatPermissions :: GroupChatPermissions

88−maxChatPermissions = GroupChatPermissions True -- True True

89−minChatPermissions :: GroupChatPermissions

90−minChatPermissions = GroupChatPermissions False

91−

92−instance Eq GroupChatPermissions where

93− (==) = (==) `on` isAdmin

94−

95−instance Ord GroupChatPermissions where

96− compare = compare `on` isAdmin

97−

98−instance SOP.Generic GroupChatPermissions

99−instance SOP.HasDatatypeInfo GroupChatPermissions

100−instance ToJSON GroupChatPermissions

101−instance FromJSON GroupChatPermissions

102−

103−data GroupChatCreation = GroupChatCreation {

104− groupChatCreationUsers :: Jsonb UserPermissions,

105− groupChatCreationName :: Text

106−} deriving (Show, GHC.Generic)

107−

108−instance SOP.Generic GroupChatCreation

109−instance SOP.HasDatatypeInfo GroupChatCreation

110−instance ToJSON GroupChatCreation where

111− toJSON (GroupChatCreation us n) = object [

112− "users" .= getJsonb us,

113− "name" .= n

114− ]

115−

116−instance FromJSON GroupChatCreation where

117− parseJSON = withObject "group chat creation" $ \e ->

118− GroupChatCreation <$> (Jsonb <$> e .: "users") <*> e .: "name"

denis/src/Data/Limits.hsdeleted−35

@@ -1,35 +0,0 @@

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

2−

3−module Data.Limits where

4−

5−import Data.Int (Int64)

6−

7−maxChannelName :: Int

8−maxChannelName = 60

9−

10−maxGroupChatName :: Int

11−maxGroupChatName = 60

12−

13−maxMessageLimitName :: Int

14−maxMessageLimitName = 60

15−

16−postElementLengthLimit :: Int

17−postElementLengthLimit = 35000

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

30−

31−globalTextLimit :: Int

32−globalTextLimit = 50000

33−

34−groupChatSizeLimit :: Int

35−groupChatSizeLimit = 256

denis/src/Data/Message.hsdeleted−152

@@ -1,152 +0,0 @@

1−{-# LANGUAGE

2− DataKinds ,

3− DeriveGeneric ,

4− OverloadedLabels,

5− OverloadedStrings ,

6− TypeApplications ,

7− TypeOperators,

8− OverloadedStrings,

9− TupleSections,

10− RecordWildCards #-}

11−{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

12−

13−

14−module Data.Message (

15− MessageStorage(..),

16− Message(..),

17− MessageDetination(..),

18− MessageId,

19− restoreMessage,

20− storeMessage,

21− MessageCreation(..)

22− ) where

23−

24−import Data.Aeson

25−import Data.PostElement

26−import Data.User

27−import Data.Int (Int64)

28−import Data.GroupChat

29−import Data.Time

30−import Squeal.PostgreSQL.Schema

31−import qualified GHC.Generics as GHC

32−import qualified Generics.SOP as SOP

33−import Control.Applicative

34−import Data.Aeson.Types

35−import Data.Proxy

36−import Servant.Docs

37−import Data.Text.Validator

38−

39−instance ToSample Message where

40− toSamples _ = samples $ Message 8 69 <$>

41− map snd (toSamples Proxy) <*>

42− map snd (toSamples Proxy) <*>

43− [UTCTime (ModifiedJulianDay 1000) 8]

44−

45−instance ToSample MessageDetination where

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

47−

48−instance HasValidatableText Message where

49− validateText Message{..} = validateText messageBody

50−

51−instance HasValidatableText MessageCreation where

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

53−

54−type GroupChatMessageId = Int64

55−

56−data MessageDetination = GroupChatDestination GroupChatId | UserChatDestination UserId

57− deriving (Show)

58−

59−type MessageId = Int64

60−

61−data Message = Message {

62− messageId :: MessageId,

63− messageAuthorId :: UserId,

64− messageDestinationId :: MessageDetination,

65− messageBody :: PostElement Message,

66− messageTime :: UTCTime

67−} deriving (Show)

68−

69−instance ToJSON Message where

70− toJSON (Message mId aId dId pb mt) = object [

71− "id" .= mId,

72− "author" .= aId,

73− case dId of

74− GroupChatDestination gId -> "group" .= gId

75− UserChatDestination uId -> "user" .= uId,

76− "body" .= pb,

77− "time" .= mt

78− ]

79−

80−instance FromJSON Message where

81− parseJSON = withObject "message" $ \e ->

82− Message

83− <$> e .: "id"

84− <*> e .: "author"

85− <*> ((GroupChatDestination <$> e .: "group") <|> (UserChatDestination <$> e .: "user"))

86− <*> e .: "body"

87− <*> e .: "time"

88−

89−

90−data MessageStorage = MessageStorage {

91− messageStorageId :: MessageId,

92− messageStorageAuthorId :: Maybe UserId,

93− messageStorageDestinationGroupId :: Maybe GroupChatId,

94− messageStorageDestinationUserId :: Maybe UserId,

95− messageStorageBody :: Maybe (Jsonb (PostElement Message)),

96− messageStorageTime :: UTCTime

97−} deriving GHC.Generic

98−

99−instance SOP.Generic (MessageStorage)

100−instance SOP.HasDatatypeInfo (MessageStorage)

101−

102−infixl 4 <>>

103−

104−(<>>) :: Applicative f => f (a -> b) -> a -> f b

105−f <>> a = f <*> pure a

106−

107−restoreMessage :: MessageStorage -> Maybe Message

108−restoreMessage (MessageStorage mId (Just aId) gId uId (Just (Jsonb pb)) mt) =

109− Message mId aId <$> case (gId, uId) of

110− (Just gId', Nothing) -> Just $ GroupChatDestination gId'

111− (Nothing, Just uId') -> Just $ UserChatDestination uId'

112− _ -> Nothing

113− <>> pb <>> mt

114−restoreMessage _ = Nothing

115−

116−storeMessage :: Message -> MessageStorage

117−storeMessage (Message mId aId dId pb mt) = case dId of

118− GroupChatDestination gId -> MessageStorage mId (Just aId) (Just gId) Nothing (Just (Jsonb pb)) mt

119− UserChatDestination uId -> MessageStorage mId (Just aId) Nothing (Just uId) (Just (Jsonb pb)) mt

120−

121−instance ToSample MessageCreation where

122− toSamples _ = samples $ (MessageCreation Nothing (Just 69) <$>

123− map (Jsonb . snd) (toSamples Proxy)) <>

124− (MessageCreation (Just 5) Nothing <$>

125− map (Jsonb . snd) (toSamples Proxy))

126−

127−data MessageCreation = MessageCreation {

128− messageCreationDestinationGroupId :: Maybe GroupChatId,

129− messageCreationDestinationUserId :: Maybe UserId,

130− messageCreationBody :: Jsonb (PostElement (MessageCreation))

131−} deriving (Show, GHC.Generic)

132−

133−instance SOP.Generic MessageCreation

134−instance SOP.HasDatatypeInfo MessageCreation

135−instance ToJSON MessageCreation where

136− toJSON (MessageCreation gId uId pb) = object $

137− case (gId, uId) of

138− (Just g, Nothing) -> pure $ "group" .= g

139− (Nothing, Just u) -> pure $ "user" .= u

140− _ -> mempty

141− <> ["body" .= getJsonb pb ]

142−

143−instance FromJSON MessageCreation where

144− parseJSON = withObject "message creation" $ \e ->

145− (MessageCreation

146− <$> (Just <$> e .: "group" :: Parser (Maybe GroupChatId))

147− <>> Nothing

148− <*> (Jsonb <$> e .: "body")) <|>

149− (MessageCreation

150− <$> (pure Nothing :: Parser (Maybe GroupChatId))

151− <*> (Just <$> e .: "user")

152− <*> (Jsonb <$> e .: "body"))

denis/src/Data/Post.hs+9−13

@@ -15,7 +15,7 @@ module Data.Post (

15 QuoteId,

16 PostRowResponse(..),

17 PostCreation(..)

18−) where

18+) where

20import Data.Int (Int64)

21import qualified Generics.SOP as SOP

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

29import Data.Time.Clock

30import Data.Time.Calendar

31import qualified Data.Vector as V

32−import Data.Tags.Validation

33−import Data.Text.Validator

35-- MARK: Documentation

33-- MARK: Documentation

@@ -39,12 +37,10 @@ instance ToSample Post where

39 where time = UTCTime (ModifiedJulianDay 1000) 8

37 where time = UTCTime (ModifiedJulianDay 1000) 8

41instance ToSample PostCreation where

39instance ToSample PostCreation where

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

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

41+

44−instance HasValidatableText PostCreation where

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

46−

47−-- MARK: Actual type

43+-- MARK: Actual type

49type PostId = Int64

45type PostId = Int64

50type QuoteId = Int64

46type QuoteId = Int64

@@ -55,7 +51,7 @@ data Post = Post {

55 updated :: UTCTime,

51 updated :: UTCTime,

56 postTags :: V.Vector Text,

52 postTags :: V.Vector Text,

57 postBody :: [PostElement Post]

53 postBody :: [PostElement Post]

58−} deriving (Show)

54+}

60instance ToJSON Post where

56instance ToJSON Post where

61 toJSON (Post pId aId tm tags pb) = object [

57 toJSON (Post pId aId tm tags pb) = object [

@@ -63,7 +59,7 @@ instance ToJSON Post where

63 "authorId" .= aId,

59 "authorId" .= aId,

64 "updated" .= tm,

60 "updated" .= tm,

65 "tags" .= tags,

61 "tags" .= tags,

66− "body" .= pb ]

62+ "body" .= pb ]

68data PostCreation = PostCreation {

64data PostCreation = PostCreation {

69 postCreationBody :: [PostElement Post],

65 postCreationBody :: [PostElement Post],

@@ -76,12 +72,12 @@ instance SOP.HasDatatypeInfo PostCreation

76instance ToJSON PostCreation where

72instance ToJSON PostCreation where

77 toJSON (PostCreation body tags) = object [

73 toJSON (PostCreation body tags) = object [

78 "tags" .= tags,

74 "tags" .= tags,

79− "body" .= body ]

75+ "body" .= body ]

81instance FromJSON PostCreation where

77instance FromJSON PostCreation where

82− parseJSON = withObject "post creation" $ \e ->

78+ parseJSON = withObject "post creation" $ \e ->

83 PostCreation <$> e .: "body" <*> e .: "tags"

79 PostCreation <$> e .: "body" <*> e .: "tags"

84−

80+

86-- MARK: Rows

82-- MARK: Rows

denis/src/Data/PostElement.hs+14−33

@@ -6,29 +6,24 @@

6 TypeApplications ,

7 TypeOperators,

8 OverloadedStrings #-}

9−{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

12module Data.PostElement (

11module Data.PostElement (

12+ PostElement,

13 elemenToRow,

14 rowsToElement,

15 MkElementRow,

16 PostElementRow(..),

17− PostElement(..),

18− elementsToRows,

17+ elementsToRows

19− PostQuote(..),

20− stripPostElement

21−) where

18+) where

23import Data.Int (Int64)

20import Data.Int (Int64)

24import qualified Generics.SOP as SOP

21import qualified Generics.SOP as SOP

25import qualified GHC.Generics as GHC

22import qualified GHC.Generics as GHC

26−import Data.Text (Text, strip)

23+import Data.Text (Text)

27import Data.Aeson

24import Data.Aeson

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

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

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

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

30−import Data.Text.Validator

31−import Data.Limits

33-- MARK: Documentation

28-- MARK: Documentation

@@ -38,29 +33,16 @@ instance ToSample (PostElement p) where

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

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

39 ]

34 ]

41−instance HasValidatableText (PostElement p) where

42− validateText (Markdown t) = validateText $ t ~< postElementLengthLimit

43− validateText (Latex t) = validateText $ t ~< postElementLengthLimit

44− validateText (Image t) = validateText $ t ~< postElementLengthLimit

45− validateText (Quote _) = False

46− validateText (Attachment t) = validateText $ t ~< postElementLengthLimit

47−

49-- MARK: PostElement

37-- MARK: PostElement

51data PostElement a = Markdown Text

39data PostElement a = Markdown Text

52 | Latex Text

40 | Latex Text

53 | Image Text

41 | Image Text

54− | Quote ()

42+ | Quote PostQuote

55 | Attachment Text

43 | Attachment Text

56− deriving (Show, GHC.Generic)

57−

58−stripPostElement :: (PostElement a) -> (PostElement a)

59−stripPostElement (Markdown t) = Markdown (strip t)

60−stripPostElement (Latex t) = Latex (strip t)

61−stripPostElement u = u

63−instance ToJSON (PostElement t) where

45+instance ToJSON (PostElement t) where

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

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

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

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

66 toJSON (Image i) = object ["image" .= i]

48 toJSON (Image i) = object ["image" .= i]

@@ -68,7 +50,7 @@ instance ToJSON (PostElement t) where

68 toJSON (Attachment a) = object ["attachment" .= a]

50 toJSON (Attachment a) = object ["attachment" .= a]

70instance FromJSON (PostElement t) where

52instance FromJSON (PostElement t) where

71− parseJSON = withObject "post element" $ \e ->

53+ parseJSON = withObject "post element" $ \e ->

72 Markdown <$> e .: "markdown" <|>

54 Markdown <$> e .: "markdown" <|>

73 Latex <$> e .: "latex" <|>

55 Latex <$> e .: "latex" <|>

74 Image <$> e .: "image" <|>

56 Image <$> e .: "image" <|>

@@ -85,15 +67,14 @@ elemenToRow f el = case el of

85 Markdown m -> f (Just m) Nothing Nothing Nothing Nothing

67 Markdown m -> f (Just m) Nothing Nothing Nothing Nothing

86 Latex l -> f Nothing (Just l) Nothing Nothing Nothing

68 Latex l -> f Nothing (Just l) Nothing Nothing Nothing

87 Image i -> f Nothing Nothing (Just i) Nothing Nothing

69 Image i -> f Nothing Nothing (Just i) Nothing Nothing

88− -- Quote q -> f Nothing Nothing Nothing (Just $ (quoteId q)) Nothing

70+ Quote q -> f Nothing Nothing Nothing (Just $ quoteId q) Nothing

89− Quote _ -> f Nothing Nothing Nothing Nothing Nothing

90 Attachment a -> f Nothing Nothing Nothing Nothing (Just a)

71 Attachment a -> f Nothing Nothing Nothing Nothing (Just a)

92rowsToElement :: MkElementRow (Maybe (PostElement p))

73rowsToElement :: MkElementRow (Maybe (PostElement p))

93rowsToElement (Just m) Nothing Nothing Nothing Nothing = Just $ Markdown m

74rowsToElement (Just m) Nothing Nothing Nothing Nothing = Just $ Markdown m

94rowsToElement Nothing (Just l) Nothing Nothing Nothing = Just $ Latex l

75rowsToElement Nothing (Just l) Nothing Nothing Nothing = Just $ Latex l

95rowsToElement Nothing Nothing (Just i) Nothing Nothing = Just $ Image i

76rowsToElement Nothing Nothing (Just i) Nothing Nothing = Just $ Image i

96−-- rowsToElement Nothing Nothing Nothing (Just q) Nothing =

77+-- rowsToElement Nothing Nothing Nothing (Just q) Nothing =

97-- fmap Quote $ M.lookup q pqrs >>= rowsToQuote erqs pqrs

78-- fmap Quote $ M.lookup q pqrs >>= rowsToQuote erqs pqrs

98rowsToElement Nothing Nothing Nothing Nothing (Just a) = Just $ Attachment a

79rowsToElement Nothing Nothing Nothing Nothing (Just a) = Just $ Attachment a

99rowsToElement _ _ _ _ _ = Nothing

80rowsToElement _ _ _ _ _ = Nothing

@@ -116,21 +97,21 @@ elementsToRows :: Int64 -> [PostElement a] -> [PostElementRow a]

116elementsToRows pId els = map (\(el, f) -> elemenToRow f el) . zip els . map (PostElementRow pId) $ [0..]

97elementsToRows pId els = map (\(el, f) -> elemenToRow f el) . zip els . map (PostElementRow pId) $ [0..]

117

118

119−-- -- MARK: Quote

100+-- -- MARK: Quote

120

101

121data PostQuote = PostQuote {

102data PostQuote = PostQuote {

122 quoteId :: Int64,

103 quoteId :: Int64,

123 quoteBody :: [PostElement PostQuote],

104 quoteBody :: [PostElement PostQuote],

124 quotePostId :: Int64

105 quotePostId :: Int64

125−} deriving (Show, GHC.Generic)

106+}

126

107

127instance ToJSON PostQuote where

108instance ToJSON PostQuote where

128 toJSON (PostQuote qId pb pId) = object [

109 toJSON (PostQuote qId pb pId) = object [

129− "id" .= qId,

110+ "id" .= qId,

130 "postId" .= pId,

111 "postId" .= pId,

131 "quoteBody" .= pb ]

112 "quoteBody" .= pb ]

132

113

133−

114+

134-- -- MARK: PostQuoteRow

115-- -- MARK: PostQuoteRow

135

116

136-- data PostQuoteRow = PostQuoteRow {

117-- data PostQuoteRow = PostQuoteRow {

@@ -140,7 +121,7 @@ instance ToJSON PostQuote where

140

121

141-- instance SOP.Generic PostQuoteRow

122-- instance SOP.Generic PostQuoteRow

142-- instance SOP.HasDatatypeInfo PostQuoteRow

123-- instance SOP.HasDatatypeInfo PostQuoteRow

143−

124+

144-- rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote

125-- rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote

145-- rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do

126-- rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do

146-- elementRows <- M.lookup qId erqs

127-- elementRows <- M.lookup qId erqs

denis/src/Data/Query.hs+126−1049

@@ -1,16 +1,11 @@

1{-# LANGUAGE

2− DataKinds,

2+ DataKinds ,

3− DeriveGeneric,

3+ DeriveGeneric ,

4 OverloadedLabels,

5− OverloadedStrings,

5+ OverloadedStrings ,

6− TypeApplications,

6+ TypeApplications ,

7 TypeOperators,

8− PartialTypeSignatures,

8+ PartialTypeSignatures #-}

9− FlexibleInstances,

10− KindSignatures,

11− DeriveAnyClass,

12− RecordWildCards,

13− ScopedTypeVariables #-}

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

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

@@ -19,55 +14,21 @@ module Data.Query (

19 Schema,

14 Schema,

20 createTables,

15 createTables,

21 getPosts,

16 getPosts,

22− -- getUser,

17+ getUser,

23 getUsers,

18 getUsers,

24 getAllUsers,

19 getAllUsers,

25 getLastPosts,

20 getLastPosts,

26 getPostsForUser,

21 getPostsForUser,

27 Limit,

22 Limit,

28 publishPost,

23 publishPost,

24+ PostResponse(..),

29 getChannelPosts,

25 getChannelPosts,

30 updateChannel,

26 updateChannel,

31 createNewChannel,

27 createNewChannel,

32 getAllChannels,

28 getAllChannels,

33 getAnonymousChannelPosts,

29 getAnonymousChannelPosts,

34− deleteNamedChannel,

30+ 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

31+) where

72import Squeal.PostgreSQL

33import Squeal.PostgreSQL

73import Data.User

34import Data.User

@@ -88,33 +49,20 @@ import qualified GHC.Generics as GHC

88import Data.Int (Int64)

49import Data.Int (Int64)

89import Data.ByteString.Char8 (pack)

50import Data.ByteString.Char8 (pack)

90import GHC.Generics (Generic)

51import GHC.Generics (Generic)

91−import Data.Aeson hiding (Null)

52+import Data.Aeson

92import Servant.Docs

53import Servant.Docs

93import Data.Proxy

54import Data.Proxy

94import Data.Vector (Vector, toList, fromList)

55import Data.Vector (Vector, toList, fromList)

95import Data.Text (Text)

56import Data.Text (Text)

96−import qualified Data.Text as T

97import Data.Channel.NamedChannel

57import Data.Channel.NamedChannel

98import Data.Channel.AnonymousChannel

58import Data.Channel.AnonymousChannel

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

59+import Data.Maybe (fromMaybe)

100−import Squeal.PostgreSQL.Render

101−import Data.GroupChat

60+import Data.Monoid (mempty)

102−import Data.Message

103−import Server.Query.Dialog

104−import qualified Server.Query.Pagination as P

105−import Data.Faculty

106−import Data.ByteString (ByteString)

107−import Data.Foldable (fold)

108−import Data.Char

109−import qualified Data.Vector as V

110−import Server.Auth.Token

111−import Server.Error

112−import Data.Text.Validator

113

114-- MARK: Documentation

62-- MARK: Documentation

115

116−instance (ToSample r) => ToSample (ResponseWithUsers r) where

64+instance ToSample PostResponse where

117− toSamples _ = samples $ ResponseWithUsers <$> (map snd $ toSamples Proxy) <*> [M.fromList $ map (tupleFirst userId . snd) (toSamples Proxy)]

65+ toSamples _ = samples $ PostResponse <$> (map snd $ toSamples Proxy) <*> [M.fromList $ map (tupleFirst userId . snd) (toSamples Proxy)]

118

119

120-- MARK: Generalized Post Queries

68-- MARK: Generalized Post Queries

@@ -126,16 +74,11 @@ postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _

126postsQ te = selectStar $ te (from $ table #posts)

74postsQ te = selectStar $ te (from $ table #posts)

127

128postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped

76postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped

129−postViewT te = from $ subquery (postsQ te `As` #posts) &

77+postViewT te = from $ subquery (postsQ te `As` #posts) &

130 innerJoin (table #postElements)

78 innerJoin (table #postElements)

131 (#posts ! #postRowId .== #postElements ! #rowElementId)

79 (#posts ! #postRowId .== #postElements ! #rowElementId)

132

133−getPostQ

134− :: TableEndo Schema params _ 'Ungrouped

135− -- ^ PostRowResponse endo

136− -> TableEndo Schema params _ 'Ungrouped

137− -- ^ PostRow endo

138− -> Query Schema params (RowPG PostRowResponse)

81+getPostQ :: TableEndo Schema params _ 'Ungrouped -> TableEndo Schema params _ 'Ungrouped -> Query Schema params (RowPG PostRowResponse)

139getPostQ oTe te = select (

82getPostQ oTe te = select (

140 #posts ! #postRowId :*

83 #posts ! #postRowId :*

141 #posts ! #postRowAuthorId :*

84 #posts ! #postRowAuthorId :*

@@ -147,7 +90,7 @@ getPostQ oTe te = select (

147 #postElements ! #rowElementLatex :*

90 #postElements ! #rowElementLatex :*

148 #postElements ! #rowElementImage :*

91 #postElements ! #rowElementImage :*

149 #postElements ! #rowElementQuote :*

92 #postElements ! #rowElementQuote :*

150− #postElements ! #rowElementAttachment)

93+ #postElements ! #rowElementAttachment)

151 (oTe $ postViewT te)

94 (oTe $ postViewT te)

152

153

@@ -170,120 +113,59 @@ getPostQ oTe te = select (

170-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows

113-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows

171-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0

114-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0

172-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'

115-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'

173−-- return $ M.lookup qId rows >>= rowsToQuote rows

116+-- return $ M.lookup qId rows >>= rowsToQuote rows

174−

117+

175−getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))

118+getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)

176−getUserWithEmailQ = select (

177− #userRowId `as` #userId :*

178− #userRowFirstName `as` #firstName :*

179− #userRowMiddleName `as` #middleName :*

180− #userRowLastName `as` #lastName :*

181− #userRowFacultyUrl `as` #userFaculty :*

182− #userRowEmail `as` #userEmail

183− ) (from (table #users) &

119+getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)

184− where_ (#userRowEmail .== param @1) &

185− where_ (notNull #userRowIsValidated))

186

120

187verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))

121verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))

188verifiedUserIdsQ uIds = case idsToColumn uIds of

122verifiedUserIdsQ uIds = case idsToColumn uIds of

189− Just idQ -> Just $ select (#users ! #userRowId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &

123+ Just idQ -> Just $ select (#users ! #userId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &

190 innerJoin (table #users)

124 innerJoin (table #users)

191− (#ids ! #id .== #users ! #userRowId))

125+ (#ids ! #id .== #users ! #userId))

192 Nothing -> Nothing

126 Nothing -> Nothing

193

127

128+

194−getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))

129+getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG User))

195getUsersQ uIds = case idsToColumn uIds of

130getUsersQ uIds = case idsToColumn uIds of

196− Just idQ -> Just $ select (

197− #users ! #userRowId :*

198− #users ! #userRowFirstName :*

199− #users ! #userRowMiddleName :*

200− #users ! #userRowLastName :*

201− #users ! #userRowFacultyUrl :*

202− #users ! #userRowEmail :*

203− #users ! #userRowIsValidated :*

204− #faculties ! #facultyName `as` #userRowFacultyName :*

205− #faculties ! #facultyUrl `as` #userRowFacultyURL :*

206− #faculties ! #facultyPath `as` #userRowFacultyPath :*

207− #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*

208− #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*

209− #faculties ! #facultyTags `as` #userRowFacultyTags :*

210− #faculties ! #facultyAddress `as` #userRowFacultyAddress

211− ) (from (subquery (idQ `As` #ids) &

131+ Just idQ -> Just $ selectDotStar #users $ from (subquery (idQ `As` #ids) &

212 innerJoin (table #users)

132 innerJoin (table #users)

213− (#ids ! #id .== #users ! #userRowId) &

133+ (#ids ! #id .== #users ! #userId))

214− innerJoin (table #faculties)

215− (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl)) &

216− where_ (notNull $ #users ! #userRowIsValidated))

217 Nothing -> Nothing

134 Nothing -> Nothing

218

135

219−getAllUsersQ :: Query Schema '[] (RowPG UserRow)

136+getAllUsersQ :: Query Schema '[] (RowPG User)

220−getAllUsersQ = select (

137+getAllUsersQ = selectStar $ from $ table #users

221− #users ! #userRowId :*

222− #users ! #userRowFirstName :*

223− #users ! #userRowMiddleName :*

224− #users ! #userRowLastName :*

225− #users ! #userRowFacultyUrl :*

226− #users ! #userRowEmail :*

227− #users ! #userRowIsValidated :*

228− #faculties ! #facultyName `as` #userRowFacultyName :*

229− #faculties ! #facultyUrl `as` #userRowFacultyURL :*

230− #faculties ! #facultyPath `as` #userRowFacultyPath :*

231− #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*

232− #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*

233− #faculties ! #facultyTags `as` #userRowFacultyTags :*

234− #faculties ! #facultyAddress `as` #userRowFacultyAddress

235− ) (from ((table #users) &

236− innerJoin (table #faculties)

237− (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&

238− where_ (notNull $ #users ! #userRowIsValidated))

239

138

240getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))

139getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))

241getPostsByIdQ pIds = case idsToColumn pIds of

140getPostsByIdQ pIds = case idsToColumn pIds of

242− Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &

141+ Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &

243− innerJoin (subquery $ getPostQ

142+ innerJoin (subquery $ getPostQ id id `As` #posts)

244− (orderBy [#postElements ! #rowElementId & Desc, #postElements ! #rowElementOrd & Asc]) id `As` #posts)

245 (#ids ! #id .== #posts ! #postRowId))

143 (#ids ! #id .== #posts ! #postRowId))

246 Nothing -> Nothing

144 Nothing -> Nothing

247

145

146+

248type Limit = Word64

147type Limit = Word64

249

148

250−isNotFalse

251− :: Expression schema from grouping params ('Null ty)

252− -- ^ possibly @NULL@

253− -> Condition schema from grouping params

254−isNotFalse x = UnsafeExpression $ renderExpression x <+> "IS NOT FALSE"

255−

256−getLastPostsQ

257− :: TableEndo _ _ _ _

258− -> Limit

259− -> P.PaginationDirection

260− -> Query Schema ('Null (PG Int64) ': params) (RowPG PostRowResponse)

149+getLastNPostsQ :: Limit -> Query Schema params (RowPG PostRowResponse)

261−getLastPostsQ te lim dir = getPostQ

150+getLastNPostsQ lim = getPostQ

262− (orderBy [#postElements ! #rowElementId & Desc, #postElements ! #rowElementOrd & Asc])

151+ (limit lim . orderBy [#posts ! #postRowUpdateTime & Desc]) id

263− (limit lim .

264− te .

265− where_ (ifThenElse (isNull $ param @1) true $ #posts ! #postRowId .^ param @1) .

266− orderBy [#posts ! #postRowId & order])

267− where

268− ((.^), order) = directionToOperator dir

269−

270−getLastNPostsForUserQ

271− :: Limit

272− -> P.PaginationDirection

273− -> Query Schema (TuplePG (Maybe PostId, UserId)) (RowPG PostRowResponse)

274−getLastNPostsForUserQ = getLastPostsQ $ where_ (#posts ! #postRowAuthorId .== param @2)

275

152

153+getLastNPostsForUserQ :: Limit -> Query Schema (TuplePG (Only UserId)) (RowPG PostRowResponse)

154+getLastNPostsForUserQ lim = getPostQ

155+ (limit lim . orderBy [#posts ! #postRowUpdateTime & Desc])

156+ (where_ $ #postRowAuthorId .== param @1)

157+

276createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))

158createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))

277−createPostRowQ = insertRow #posts

159+createPostRowQ = insertRow #posts

278 (Default `as` #postRowId :*

160 (Default `as` #postRowId :*

279 Set (param @1) `as` #postRowAuthorId :*

161 Set (param @1) `as` #postRowAuthorId :*

280 Set currentTimestamp `as` #postRowUpdateTime :*

162 Set currentTimestamp `as` #postRowUpdateTime :*

281− Set (param @2) `as` #postRowTags)

163+ Set (param @2) `as` #postRowTags)

282− OnConflictDoRaise

164+ OnConflictDoRaise

283 (Returning $ #postRowId `as` #fromOnly)

165 (Returning $ #postRowId `as` #fromOnly)

284

166

285createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]

167createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]

286−createPostElementRowsQ = insertRow_ #postElements

168+createPostElementRowsQ = insertRow_ #postElements

287 (Set (param @1) `as` #rowElementId :*

169 (Set (param @1) `as` #rowElementId :*

288 Set (param @2) `as` #rowElementOrd :*

170 Set (param @2) `as` #rowElementOrd :*

289 Set (param @3) `as` #rowElementMarkdown :*

171 Set (param @3) `as` #rowElementMarkdown :*

@@ -293,62 +175,16 @@ createPostElementRowsQ = insertRow_ #postElements

293 Set (param @7) `as` #rowElementAttachment)

175 Set (param @7) `as` #rowElementAttachment)

294

176

295getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)

177getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)

296−getChannelForUserQ = selectStar $

178+getChannelForUserQ = selectStar $

297 from (table #channels) &

179 from (table #channels) &

298 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)

180 where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)

299

181

300−updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))

301−updateUserQ = update #users (

302− Same `as` #userRowId :*

303− Set (param @2) `as` #userRowFirstName :*

304− Set (param @3) `as` #userRowMiddleName :*

305− Set (param @4) `as` #userRowLastName :*

306− Set (param @5) `as` #userRowFacultyUrl :*

307− Same `as` #userRowEmail :*

308− Same `as` #userRowIsValidated)

309− (#userRowId .== param @1)

310− (Returning $ #userRowId `as` #fromOnly)

311−

312getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)

182getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)

313getAllChannelsForUserQ = selectStar $

183getAllChannelsForUserQ = selectStar $

314 from (table #channels) &

184 from (table #channels) &

315 where_ (#namedChannelFullOwner .== param @1) &

185 where_ (#namedChannelFullOwner .== param @1) &

316 orderBy [#namedChannelFullId & Desc]

186 orderBy [#namedChannelFullId & Desc]

317

187

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

319−searchChannelsForUserQ = selectStar $

320− from (table #channels) &

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

322− orderBy [

323− tsRankCd vector1 query & Desc,

324− tsRankCd vector query & Desc

325− ]

326− where

327− vector = tsVector' (textArrayToText [

328− #namedChannelFullName,

329− unsafeFunction "unnest" #namedChannelFullTags

330− ])

331− vector1 = tsVector' #namedChannelFullName

332− query = tsQuery' (param @2)

333−

334−updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]

335−updateFacultyQ = insertRow #faculties

336− (

337− Set (param @1) `as` #facultyName :*

338− Set (param @2) `as` #facultyUrl :*

339− Set (param @3) `as` #facultyPath :*

340− Set (param @4) `as` #facultyCampusName :*

341− Set (param @5) `as` #facultyCampusCode :*

342− Set (param @6) `as` #facultyTags :*

343− Set (param @7) `as` #facultyAddress

344− )

345− (OnConflictDoNothing)

346− (Returning Nil)

347−

348−getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)

349−getFacultyQ = selectStar (from (table #faculties) &

350− where_ (#facultyUrl .== param @1))

351−

352createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))

188createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))

353createNamedChannelQ = insertRow #channels

189createNamedChannelQ = insertRow #channels

354 (

190 (

@@ -357,15 +193,10 @@ createNamedChannelQ = insertRow #channels

357 Set (param @2) `as` #namedChannelFullName :*

193 Set (param @2) `as` #namedChannelFullName :*

358 Set (param @3) `as` #namedChannelFullTags :*

194 Set (param @3) `as` #namedChannelFullTags :*

359 Set (param @4) `as` #namedChannelFullPeopleIds

195 Set (param @4) `as` #namedChannelFullPeopleIds

360− )

196+ )

361 OnConflictDoRaise

197 OnConflictDoRaise

362 (Returning $ #namedChannelFullId `as` #fromOnly)

198 (Returning $ #namedChannelFullId `as` #fromOnly)

363

199

364−countChannelsQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only Int64))

365−countChannelsQ = select (countStar `as` #fromOnly) (from (table #channels) &

366− where_ (#namedChannelFullOwner .== param @1) &

367− groupBy #namedChannelFullOwner)

368−

369deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]

200deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]

370deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)

201deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)

371

202

@@ -377,467 +208,46 @@ updateNamedChannelQ = update_ #channels

377 Set (param @3) `as` #namedChannelFullName :*

208 Set (param @3) `as` #namedChannelFullName :*

378 Set (param @4) `as` #namedChannelFullTags :*

209 Set (param @4) `as` #namedChannelFullTags :*

379 Set (param @5) `as` #namedChannelFullPeopleIds

210 Set (param @5) `as` #namedChannelFullPeopleIds

380− )

211+ )

381 (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)

212 (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)

382−

213+

383−getChannelPostsQ

214+

384− :: Limit

385− -> P.PaginationDirection

386− -> [UserId]

387− -> Vector Text

388− -> Query

389− Schema

390− (TuplePG (Only (Maybe PostId))) -- post id from which to start

391− (RowPG PostRowResponse)

215+getChannelPostsQ :: Limit -> [UserId] -> Vector Text -> Query Schema '[] (RowPG PostRowResponse)

392−getChannelPostsQ lim dir uIds tags = getLastPostsQ

216+getChannelPostsQ lim uIds tags = selectStar $ from (subquery $ postsQ' `As` #bar) &

393− (where_ $ jsonbLit tags .?| #postRowTags .|| isUser #postRowAuthorId)

217+ orderBy [#postRowUpdateTime & Desc] & limit lim

394− lim

395− dir

396− where

218+ where

397− isUser = case idsToColumn uIds of

219+ unionWithUsers = case idsToColumn uIds of

398− Just uIdsQ -> (`in_` uIdsQ)

220+ Just uIdsQ -> selectDotStar #posts' (from $ subquery (uIdsQ `As` #uIds) &

221+ innerJoin (subquery $ getPostQ id id `As` #posts')

222+ (#uIds ! #id .== #posts' ! #postRowAuthorId)) &

223+ union

399− Nothing -> const $ false

224+ Nothing -> id

400−

225+ postsQ' = unionWithUsers $ getPostQ id $ where_ $ jsonbLit tags .?| #postRowTags

401−getTagsQ :: Query Schema params (RowPG (Only String))

226+

402−getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $

403− from (table #posts)

404−

405−createMessageQ :: Manipulation

406− Schema

407− (TuplePG (UserId, Maybe GroupChatId, Maybe UserId, Jsonb (PostElement (MessageCreation))))

408− (RowPG (Only MessageId))

409−createMessageQ = insertRow #messages

410− (

411− Default `as` #messageStorageId :*

412− Set (notNull $ param @1) `as` #messageStorageAuthorId :*

413− Set (param @2) `as` #messageStorageDestinationGroupId :*

414− Set (param @3) `as` #messageStorageDestinationUserId :*

415− Set (notNull $ param @4) `as` #messageStorageBody :*

416− Set currentTimestamp `as` #messageStorageTime

417− )

418− OnConflictDoRaise

419− (Returning $ #messageStorageId `as` #fromOnly)

420−

421−createPhantomMessageQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]

422−createPhantomMessageQ = insertRow_ #messages

423− (

424− Default `as` #messageStorageId :*

425− Set null_ `as` #messageStorageAuthorId :*

426− Set (notNull $ param @1) `as` #messageStorageDestinationGroupId :*

427− Set null_ `as` #messageStorageDestinationUserId :*

428− Set null_ `as` #messageStorageBody :*

429− Set currentTimestamp `as` #messageStorageTime

430− )

431−

432−createGroupChatQ :: Manipulation Schema (TuplePG GroupChatCreation) (RowPG (Only GroupChatId))

433−createGroupChatQ = insertRow #groupChats

434− (

435− Default `as` #groupChatId :*

436− Set (param @1) `as` #groupChatUsers :*

437− Set (param @2) `as` #groupChatName

438− )

439− OnConflictDoRaise

440− (Returning $ #groupChatId `as` #fromOnly)

441−

442−updateGroupChatQ :: Manipulation Schema (TuplePG GroupChat) '[]

443−updateGroupChatQ = update_ #groupChats

444− (

445− Same `as` #groupChatId :*

446− Set (param @2) `as` #groupChatUsers :*

447− Set (param @3) `as` #groupChatName

448− )

449− (#groupChatId .== param @1)

450−

451−type ChatsQueryResponse = '[

452− "messageId" ::: 'NotNull (PG UserId),

453− "messageGroupId" ::: 'Null (PG UserId),

454− "messageUserId" ::: 'Null (PG UserId)

455− ]

456−

457−type ConditionOp schema from grouping params nullity0 nullity1 (ty :: PGType)

458− = Expression schema from grouping params (nullity0 ty)

459− -> Expression schema from grouping params (nullity1 ty)

460− -> Condition schema from grouping params

461−

462−type ChatQueryParams = TuplePG

463− ( UserId

464− , Maybe String -- Just UserId as String

465− , Maybe MessageId

466− )

467−

468−getChatsQ

469− :: Limit

470− -> P.PaginationDirection

471− -> Query Schema ChatQueryParams (RowPG ChatsResponse)

472−getChatsQ lim dir = select (

473− #chats ! #messageId `as` #chatResponseMessageId :*

474− #messages ! #messageStorageAuthorId `as` #chatResponseMessageAuthorId :*

475− #messages ! #messageStorageDestinationGroupId `as` #chatResponseMessageDestinationGroupId :*

476− #messages ! #messageStorageDestinationUserId `as` #chatResponseMessageDestinationUserId :*

477− #messages ! #messageStorageBody `as` #chatResponseMessageBody :*

478− #messages ! #messageStorageTime `as` #chatResponseMessageTime :*

479− #groupChats ! #groupChatUsers `as` #chatResponseGroupUsers :*

480− #groupChats ! #groupChatName `as` #chatResponseGroupName

481− ) $ from (

482− (subquery $ chatsQ `As` #chats) &

483− innerJoin

484− (table #messages)

485− (#chats ! #messageId .== #messages ! #messageStorageId) &

486− leftOuterJoin

487− (table #groupChats)

488− (#groupChats ! #groupChatId .== #chats ! #messageGroupId)) &

489− where_ (isNull (#groupChats ! #groupChatUsers) .||

490− (#groupChats ! #groupChatUsers .? param @2)) &

491− where_ (isNotFalse $ #chats ! #messageId .^ param @3) &

492− orderBy [#chats ! #messageId & order] &

493− limit lim &

494− orderBy [#chats ! #messageId & Desc]

495− where

496− ((.^), order) = directionToOperator dir

497− chatsQ :: Query Schema _ ChatsQueryResponse

498− chatsQ = unionAll groupChats userChats

499− where

500− allUserMessages :: Query Schema _ ChatsQueryResponse

501− allUserMessages = select (

502− #messageStorageId `as` #messageId :*

503− null_ `as` #messageGroupId :*

504− (ifThenElse

505− (#messageStorageAuthorId .== param @1)

506− #messageStorageDestinationUserId

507− #messageStorageAuthorId) `as` #messageUserId) $

508− from (table #messages) &

509− where_ (isNotNull #messageStorageDestinationUserId .&&

510− (#messageStorageAuthorId .== param @1 .||

511− #messageStorageDestinationUserId .== param @1))

512− userChats :: Query Schema _ ChatsQueryResponse

513− userChats = select (

514− max_ #messageId `as` #messageId :*

515− null_ `as` #messageGroupId :*

516− #messageUserId `as` #messageUserId) $

517− from (subquery $ allUserMessages `As` #allUserMessages) &

518− groupBy (#allUserMessages ! #messageUserId)

519− groupChats :: Query Schema _ ChatsQueryResponse

520− groupChats = select (

521− max_ #messageStorageId `as` #messageId :*

522− #messageStorageDestinationGroupId `as` #messageGroupId :*

523− null_ `as` #messageUserId) $

524− from (table #messages) &

525− where_ (isNotNull #messageStorageDestinationGroupId) &

526− groupBy #messageStorageDestinationGroupId

527−

528−getMessagesQ

529− :: Limit

530− -> P.PaginationDirection

531− -> Query Schema (TuplePG

532− ( UserId

533− , UserId

534− , Maybe MessageId

535− )) (RowPG MessageStorage)

536−getMessagesQ lim dir = selectStar (from (table #messages) &

537− where_ (isNotNull #messageStorageDestinationUserId .&&

538− ((#messageStorageAuthorId .== param @1 .&& #messageStorageDestinationUserId .== param @2) .||

539− (#messageStorageDestinationUserId .== param @1 .&& #messageStorageAuthorId .== param @2))) &

540− where_ (isNotFalse $ #messageStorageId .^ param @3) &

541− orderBy [#messageStorageId & order] &

542− limit lim &

543− orderBy [#messageStorageId & Desc])

544− where

545− ((.^), order) = directionToOperator dir

546−

547−getGroupMessagesQ

548− :: Limit

549− -> P.PaginationDirection

550− -> Query Schema (TuplePG

551− ( GroupChatId

552− , Maybe MessageId

553− )) (RowPG MessageStorage)

554−getGroupMessagesQ lim dir = selectStar (from (table #messages) &

555− where_ (isNotNull #messageStorageDestinationGroupId .&&

556− (#messageStorageDestinationGroupId .== param @1)) &

557− where_ (isNotFalse $ #messageStorageId .^ param @2) &

558− orderBy [#messageStorageId & order] &

559− limit lim &

560− orderBy [#messageStorageId & Desc])

561− where

562− ((.^), order) = directionToOperator dir

563−

564−-- String -- user id as String

565−getGroupChatForUserQ :: Query Schema (TuplePG (String, GroupChatId)) (RowPG GroupChat)

566−getGroupChatForUserQ = selectStar $

567− (from (table #groupChats)) &

568− where_ (#groupChatId .== param @2) &

569− where_ (#groupChatUsers .? param @1)

570−

571−getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)

572−getFacultySearchResultQ = selectStar (from (table #faculties) &

573− where_ (vector @@ query) &

574− orderBy [

575− tsRankCd vector1 query & Desc,

576− tsRankCd vector2 query & Desc,

577− tsRankCd vector query & Desc

578− ])

579− where

580− vector = tsVector "russian" (textArrayToText [

581− #facultyName,

582− #facultyPath,

583− #facultyCampusName,

584− (arrayToText #facultyTags)])

585− vector1 = tsVector "russian" #facultyName

586− vector2 = tsVector "russian" (textArrayToText [

587− #facultyName,

588− #facultyPath])

589− query = tsQuery "russian" (param @1)

590−

591−searchUsersQ :: Query Schema (TuplePG (Only Text)) (RowPG UserRow)

592−searchUsersQ = select (

593− #users ! #userRowId :*

594− #users ! #userRowFirstName :*

595− #users ! #userRowMiddleName :*

596− #users ! #userRowLastName :*

597− #users ! #userRowFacultyUrl :*

598− #users ! #userRowEmail :*

599− #users ! #userRowIsValidated :*

600− #faculties ! #facultyName `as` #userRowFacultyName :*

601− #faculties ! #facultyUrl `as` #userRowFacultyURL :*

602− #faculties ! #facultyPath `as` #userRowFacultyPath :*

603− #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*

604− #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*

605− #faculties ! #facultyTags `as` #userRowFacultyTags :*

606− #faculties ! #facultyAddress `as` #userRowFacultyAddress

607− ) (from ((table #users) &

608− innerJoin (table #faculties)

609− (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl)) &

610− where_ (notNull $ #users ! #userRowIsValidated) &

611− where_ (vector @@ query) &

612− orderBy [tsRankCd vector query & Desc] &

613− limit 100)

614− where

615− vector = tsVector' (textArrayToText [

616− #users ! #userRowFirstName,

617− #users ! #userRowMiddleName,

618− #users ! #userRowLastName

619− ])

620− query = tsQuery' (param @1)

621−

622−tagsByFrquencyQ :: Query Schema params '["tag" ::: 'NotNull (PG Text), "count" ::: 'NotNull 'PGint8]

623−tagsByFrquencyQ = select

624− (#fromOnly `as` #tag :* count #fromOnly `as` #count)

625− (from (subquery $ getTagsQ `As` #tt) &

626− groupBy #fromOnly)

627−

628−getNpopularTagsQ :: Limit -> Query Schema param (RowPG (Only Text))

629−getNpopularTagsQ lim = select (#tag `as` #fromOnly)

630− (from (subquery $ tagsByFrquencyQ `As` #tt) &

631− orderBy [#count & Desc] &

632− limit lim)

633−

634−

635−searchTagsQ :: Query Schema (TuplePG (Only Text)) (RowPG (Only Text))

636−searchTagsQ = select (#tag `as` #fromOnly) $

637− from (subquery (tagsByFrquencyQ `As` #tt)) &

638− where_ (vector @@ query) &

639− orderBy [#count & Desc] &

640− limit 100

641− where

642− query = tsQuery' (param @1)

643− vector = tsVector' #tag

644−

645−tsRankCd

646− :: Expression schema from grouping params ('NotNull 'PGtext)

647− -> Expression schema from grouping params ('NotNull 'PGtext)

648− -> Expression schema from grouping params ('NotNull 'PGfloat4)

649−tsRankCd vector query = UnsafeExpression $

650− "ts_rank_cd" <> parenthesized (commaSeparated ["ARRAY[1,1,1,1]", renderExpression vector, renderExpression query, "2|4|8|16|32"])

651−

652−tsVector

653− :: ByteString -- ^ Language

654− -> Expression schema from grouping params ('NotNull 'PGtext)

655− -> Expression schema from grouping params ('NotNull 'PGtext)

656−tsVector lang x = UnsafeExpression $

657− "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])

658−

659−tsVector'

660− :: Expression schema from grouping params ('NotNull 'PGtext)

661− -> Expression schema from grouping params ('NotNull 'PGtext)

662−tsVector' x = UnsafeExpression $

663− "to_tsvector" <> parenthesized (renderExpression x)

664−

665−tsQuery

666− :: ByteString -- ^ Language

667− -> Expression schema from grouping params ('NotNull 'PGtext)

668− -> Expression schema from grouping params ('NotNull 'PGtext)

669−tsQuery lang x = UnsafeExpression $

670− "to_tsquery" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])

671−

672−tsQuery'

673− :: Expression schema from grouping params ('NotNull 'PGtext)

674− -> Expression schema from grouping params ('NotNull 'PGtext)

675−tsQuery' x = UnsafeExpression $

676− "to_tsquery" <> parenthesized (renderExpression x)

677−

678−arrayToText

679− :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))

680− -> Expression schema from grouping params ('NotNull 'PGtext)

681−arrayToText x = UnsafeExpression $

682− "array_to_string" <> parenthesized (commaSeparated [renderExpression x, "' '"])

683−

684−(@@)

685− :: Expression schema from grouping params (nullity0 'PGtext)

686− -> Expression schema from grouping params (nullity1 'PGtext)

687− -> Expression schema from grouping params (nullity2 'PGbool)

688−(@@) = unsafeBinaryOp "@@"

689−

690−space :: Expression schema from grouping params ('NotNull 'PGtext)

691−space = UnsafeExpression "' '"

692−

693−textArrayToText

694− :: [Expression schema from grouping params ('NotNull 'PGtext)]

695− -> Expression schema from grouping params ('NotNull 'PGtext)

696−textArrayToText = fold . L.intersperse space

697−

698−createUserQ :: Manipulation Schema (TuplePG UserCreation) (RowPG (Only UserId))

699−createUserQ = insertRow #users (

700− Default `as` #userRowId :*

701− Set (param @1) `as` #userRowFirstName :*

702− Set (param @2) `as` #userRowMiddleName :*

703− Set (param @3) `as` #userRowLastName :*

704− Set (param @4) `as` #userRowFacultyUrl :*

705− Set (param @5) `as` #userRowEmail :*

706− Set false `as` #userRowIsValidated)

707− OnConflictDoRaise

708− (Returning (#userRowId `as` #fromOnly))

709−

710−removeUnverifiedUserQ :: Manipulation Schema (TuplePG (Only UserEmail)) '[]

711−removeUnverifiedUserQ = deleteFrom_ #users

712− (#userRowEmail .== param @1 .&&

713− (not_ . notNull $ #userRowIsValidated))

714−

715−

716−createTokenQ :: Manipulation Schema (TuplePG Token) '[]

717−createTokenQ = insertRow_ #tokens (

718− Set (param @1) `as` #tokenUserId :*

719− Set (param @2) `as` #tokenValue :*

720− Set (param @3) `as` #tokenExpiryDate :*

721− Set (param @4) `as` #tokenVerificationCode :*

722− Set (param @5) `as` #tokenActivationTriesLeft :*

723− Set (param @6) `as` #tokenUserAgent :*

724− Set (param @7) `as` #tokenActivationCode :*

725− Set (param @8) `as` #tokenDeactivationCode

726− )

727−

728−updateTokenQ :: Manipulation Schema (TuplePG Token) '[]

729−updateTokenQ = update_ #tokens (

730− Same `as` #tokenUserId :*

731− Same `as` #tokenValue :*

732− Set (param @3) `as` #tokenExpiryDate :*

733− Set (param @4) `as` #tokenVerificationCode :*

734− Set (param @5) `as` #tokenActivationTriesLeft :*

735− Set (param @6) `as` #tokenUserAgent :*

736− Set (param @7) `as` #tokenActivationCode :*

737− Set (param @8) `as` #tokenDeactivationCode)

738− (#tokenUserId .== param @1 .&& #tokenValue .== param @2)

739−

740−deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]

741−deleteTokenQ = deleteFrom_ #tokens

742− (#tokenUserId .== param @1 .&& #tokenValue .== param @2)

743−

744−validateUserQ :: Manipulation Schema (TuplePG (Only UserId)) '[]

745−validateUserQ = update_ #users (

746− Same `as` #userRowId :*

747− Same `as` #userRowFirstName :*

748− Same `as` #userRowMiddleName :*

749− Same `as` #userRowLastName :*

750− Same `as` #userRowFacultyUrl :*

751− Same `as` #userRowEmail :*

752− Set true `as` #userRowIsValidated)

753− (#userRowId .== param @1)

754−

755−getTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)

756−getTokenQ = selectStar (from (table #tokens) &

757− where_ (#tokenUserId .== param @1 .&&

758− #tokenValue .== param @2))

759−

760−getTokenActivationQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)

761−getTokenActivationQ = selectStar (from (table #tokens) &

762− where_ (#tokenUserId .== param @1 .&&

763− #tokenActivationCode .== param @2))

764−

765−deactivateTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) (RowPG (Only Text))

766−deactivateTokenQ = deleteFrom #tokens

767− (#tokenUserId .== param @1 .&&

768− #tokenDeactivationCode .== param @2)

769− (Returning (#tokenUserAgent `as` #fromOnly))

770−

771−getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)

772−getVerifiedTokenQ = selectStar (from (table #tokens) &

773− where_ (#tokenUserId .== param @1 .&&

774− #tokenValue .== param @2 .&&

775− isNull #tokenVerificationCode .&&

776− currentTimestamp .< #tokenExpiryDate))

777−

778−killAllTokensQ :: Manipulation Schema (TuplePG (Only UserId)) '[]

779−killAllTokensQ = deleteFrom_ #tokens

780− (#tokenUserId .== param @1)

781−

782−pruneDeadTokensQ :: Manipulation Schema '[] '[]

783−pruneDeadTokensQ = deleteFrom_ #tokens

784− (#tokenExpiryDate .< currentTimestamp)

785−

786−pruneGhostUsersQ :: Manipulation Schema '[] '[]

787−pruneGhostUsersQ = deleteFrom_ #users

788− ((not_ . in_ #userRowId $ select (#tokens ! #tokenUserId `as` #id) (from $ table #tokens)) .&&

789− (not_ . notNull $ #userRowIsValidated))

790

227

791-- MARK: FrontEnd Data Structures

228-- MARK: FrontEnd Data Structures

792

229

793−instance HasValidatableText UserCreation where

230+data PostResponse = PostResponse {

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

231+ posts :: [Post],

795− userCreationFirstName,

232+ users :: M.Map UserId User

796− userCreationMiddleName,

797− userCreationLastName,

798− userCreationUserFaculty,

799− userCreationUserEmail]

800−

801−data UserCreation = UserCreation {

802− userCreationFirstName :: Text,

803− userCreationMiddleName :: Text,

804− userCreationLastName :: Text,

805− userCreationUserFaculty :: FacultyUrl,

806− userCreationUserEmail :: Text

807−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

808−

809−instance ToJSON UserCreation where

810− toJSON (UserCreation fName mName lName faculty email) = object [

811− "firstName" .= fName,

812− "middleName" .= mName,

813− "lastName" .= lName,

814− "faculty" .= faculty,

815− "email" .= email

816− ]

817−

818−instance FromJSON UserCreation where

819− parseJSON = withObject "user creation" $ \e ->

820− UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"

821−

822−data UserUpdateRow = UserUpdateRow {

823− userUpdateRowId :: UserId,

824− userUpdateRowFirstName :: Text,

825− userUpdateRowMiddleName :: Text,

826− userUpdateRowLastName :: Text,

827− userUpdateRowUserFaculty :: FacultyUrl

828−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

233+} deriving (Generic)

829

234

235+instance ToJSON PostResponse

830

236

831data NamedChannelCreation = NamedChannelCreation {

237data NamedChannelCreation = NamedChannelCreation {

832 namedChannelCreationOwner :: UserId,

238 namedChannelCreationOwner :: UserId,

833 namedChannelCreationName :: Text,

239 namedChannelCreationName :: Text,

834 namedChannelCreationTags :: Vector Text,

240 namedChannelCreationTags :: Vector Text,

835 namedChannelCreationPeopleIds :: Vector UserId

241 namedChannelCreationPeopleIds :: Vector UserId

836−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

242+} deriving GHC.Generic

243+

244+instance SOP.Generic NamedChannelCreation

245+instance SOP.HasDatatypeInfo NamedChannelCreation

837

246

838addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation

247addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation

839addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople

248addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople

840

249

250+

841data NamedChannelFull = NamedChannelFull {

251data NamedChannelFull = NamedChannelFull {

842 namedChannelFullId :: NamedChannelId,

252 namedChannelFullId :: NamedChannelId,

843 namedChannelFullOwner :: UserId,

253 namedChannelFullOwner :: UserId,

@@ -863,391 +273,100 @@ getChannelForUser uId cId = do

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

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

864

274

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

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

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

276+verifiedUsers :: [UserId] -> StaticPQ [UserId]

867−verifyUsers uIds =

277+verifiedUsers uIds =

868 case verifiedUserIdsQ uIds of

278 case verifiedUserIdsQ uIds of

869− Just uIdsQ -> do

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

279+ Just uIdsQ -> fmap fromOnly <$> (runQuery uIdsQ >>= getRows)

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

872− Nothing -> return ()

280+ Nothing -> return []

873−

874−deleteGroupChat :: GroupChatId -> StaticPQ ()

875−deleteGroupChat gId = do

876− _ <- manipulateParams deleteGroupChatQ (Only gId)

877− _ <- manipulateParams deleteGroupChatMessagesQ (Only gId)

878− return ()

879− where

880− deleteGroupChatQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]

881− deleteGroupChatQ = deleteFrom_ #groupChats

882− (#groupChatId .== param @1)

883− deleteGroupChatMessagesQ :: Manipulation Schema (TuplePG (Only GroupChatId)) '[]

884− deleteGroupChatMessagesQ = deleteFrom_ #messages

885− (#messageStorageDestinationGroupId .== param @1)

886−

887−-- NOTE: Not transactional

888−createUser :: UserCreation -> StaticPQ UserId

889−createUser creation = do

890− _ <- manipulateParams removeUnverifiedUserQ (Only $ userCreationUserEmail creation)

891− rowThing <- manipulateParams createUserQ creation >>= firstRow >>= fromMaybe500

892− return (fromOnly rowThing)

893

281

894-- MARK: FrontEnd functions

282-- MARK: FrontEnd functions

895

283

896−-- Nothing <=> no user

897−getPostsForUser

284+getPostsForUser :: Word64 -> UserId -> StaticPQ (Maybe PostResponse)

898− :: Maybe PostId

899− -> Limit

900− -> P.PaginationDirection

901− -> UserId

902− -> StaticPQ (Maybe (ResponseWithUsers [Post]))

903−getPostsForUser pId lim dir uId = do

285+getPostsForUser lim uId = do

904− postRows <- runQueryParams (getLastNPostsForUserQ lim dir) (pId, uId) >>= getRows

286+ postRows <- runQueryParams (getLastNPostsForUserQ lim) (Only uId) >>= getRows

905− wrapIntoResponse (fromMaybe [] . rowsToPosts $ postRows)

287+ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse

906−

288+

907−getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))

289+getPosts :: [PostId] -> StaticPQ (Maybe PostResponse)

908−getPosts pId =

290+getPosts pId =

909 case getPostsByIdQ pId of

291 case getPostsByIdQ pId of

910 Just psQ -> do

292 Just psQ -> do

911 postRows <- runQuery psQ >>= getRows

293 postRows <- runQuery psQ >>= getRows

912− rowsToPosts postRows `liftMaybe` wrapIntoResponse

294+ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse

913 Nothing -> return Nothing

295 Nothing -> return Nothing

914

296

915−getLastPosts

297+getLastPosts :: Word64 -> StaticPQ (Maybe PostResponse)

916− :: Maybe PostId

917− -> Limit

918− -> P.PaginationDirection

919− -> StaticPQ (Maybe (ResponseWithUsers [Post]))

920−getLastPosts pId lim dir = do

298+getLastPosts n = do

921− postRows <- runQueryParams (getLastPostsQ id lim dir) (Only pId) >>= getRows

299+ postRows <- runQuery (getLastNPostsQ n) >>= getRows

922− rowsToPosts postRows `liftMaybe` wrapIntoResponse

300+ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse

301+

302+getUser :: UserId -> StaticPQ User

303+getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0

923

304

924−getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))

925−getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow

926−

927−getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])

305+getUsers :: [UserId] -> StaticPQ (Maybe [User])

928−getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))

306+getUsers ids = getUsersQ ids `liftMaybe` (fmap Just . (runQuery >=> getRows))

929−

930−getAllUsers :: StaticPQ [User Faculty]

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

932

307

308+getAllUsers :: StaticPQ [User]

309+getAllUsers = runQuery getAllUsersQ >>= getRows

310+

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

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

934−publishPost uId pc = commitedTransactionallyUpdate $ do

312+-- publishPost uId pc = transactionally_ $ do

313+publishPost uId pc = do

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

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

936 case pId' of

315 case pId' of

937 (Just (Only pId)) -> do

316 (Just (Only pId)) -> do

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

317+ traversePrepared_ createPostElementRowsQ $ elementsToRows pId (postCreationBody pc)

939 return pId

318 return pId

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

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

941

320

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

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

943−createNewChannel uId req = commitedTransactionallyUpdate $ do

322+-- createNewChannel uId req = transactionally_ $ do

323+createNewChannel uId req = do

944− let uIds = toList $ namedChannelCreationRequestPeopleIds req

324+ uIds <- verifiedUsers . toList $ namedChannelCreationRequestPeopleIds req

945− verifyUsers uIds

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

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

947 return $ fmap fromOnly cId

326 return $ fmap fromOnly cId

948

327

949−channelCountForUser :: UserId -> StaticPQ Int64

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

951−

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

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

329+-- updateChannel uId req = transactionally_ $ do

953updateChannel uId req = do

330updateChannel uId req = do

954− let uIds = namedChannelPeopleIds req

331+ uIds <- fmap fromList . verifiedUsers . toList $ namedChannelPeopleIds req

955− verifyUsers (toList uIds)

956 _ <- getChannelForUser uId $ namedChannelId req

332 _ <- getChannelForUser uId $ namedChannelId req

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

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

958 return ()

334 return ()

959

335

960−getFaculty :: Text -> StaticPQ Faculty

961−getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404

962−

963−isValidFaculty :: FacultyUrl -> StaticPQ Bool

964−isValidFaculty url = do

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

966− return $ isJust faculty

967−

968−updateFaculty :: Faculty -> StaticPQ ()

969−updateFaculty fac = void $ manipulateParams updateFacultyQ fac

970−

971−getChannelPosts

336+getChannelPosts :: UserId -> Limit -> NamedChannelId -> StaticPQ PostResponse

972− :: UserId

973− -> Maybe PostId

974− -> Limit

975− -> P.PaginationDirection

976− -> NamedChannelId

977− -> StaticPQ (ResponseWithUsers [Post])

978−getChannelPosts uId pId lim dir cId = do

337+getChannelPosts uId lim cId = do

979 channel <- getChannelForUser uId cId

338 channel <- getChannelForUser uId cId

980− postRows <- runQueryParams (getChannelPostsQ

981− lim

982− dir

983− (toList $ namedChannelFullPeopleIds channel)

339+ postRows <- runQuery (getChannelPostsQ lim (toList $ namedChannelFullPeopleIds channel) (namedChannelFullTags channel))

984− (namedChannelFullTags channel))

985− (Only pId)

986 >>= getRows

340 >>= getRows

987− fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse

341+ fmap (fromMaybe $ PostResponse mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse

988−

342+

989−getAnonymousChannelPosts

343+getAnonymousChannelPosts :: Limit -> AnonymousChannel -> StaticPQ PostResponse

990− :: Maybe PostId

991− -> Limit

992− -> P.PaginationDirection

993− -> AnonymousChannel

994− -> StaticPQ (ResponseWithUsers [Post])

995−getAnonymousChannelPosts pId lim dir (AnonymousChannel tags people) = do

344+getAnonymousChannelPosts lim (AnonymousChannel tags people) = do

996− postRows <- runQueryParams (getChannelPostsQ lim dir people tags) (Only pId) >>= getRows

345+ postRows <- runQuery (getChannelPostsQ lim people tags) >>= getRows

997− fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse

346+ fmap (fromMaybe $ PostResponse mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoPostResponse

998

347

999getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]

348getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]

1000−getAllChannels uId = fmap (map removeUserFromChannel) $

349+getAllChannels uId = fmap (map removeUserFromChannel) $

1001 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows

350 runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows

1002

351

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

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

353+-- deleteNamedChannel uId cId = transactionally_ $ do

1004deleteNamedChannel uId cId = do

354deleteNamedChannel uId cId = do

1005− _ <- getChannelForUser uId cId

355+ _ <- getChannelForUser uId cId

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

356+ _ <- manipulateParams deleteNamedChannelQ (Only cId)

1007− return ()

1008−

1009−getTags :: Limit -> StaticPQ [String]

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

1011−

1012−getDialogs

1013− :: UserId

1014− -> Maybe MessageId

1015− -> Limit

1016− -> P.PaginationDirection

1017− -> StaticPQ (ResponseWithUsers [Dialog])

1018−getDialogs uId mId lim dir = do

1019− resp <- runQueryParams (getChatsQ lim dir) (uId, Just $ show uId, mId) >>= getRows

1020− (>>= fromMaybe500) $ (responseToDialogs uId resp `liftMaybe` wrapIntoResponse)

1021−

1022−getMessagesInUserChat

1023− :: UserId

1024− -> UserId

1025− -> Maybe MessageId

1026− -> Limit

1027− -> P.PaginationDirection

1028− -> StaticPQ [Message]

1029−getMessagesInUserChat selfId uId mId lim dir = do

1030− resp <- runQueryParams (getMessagesQ lim dir) (selfId, uId, mId) >>= getRows

1031− fromMaybe500 . sequence . map restoreMessage $ resp

1032−

1033−getMessagesInGroupChat

1034− :: UserId

1035− -> GroupChatId

1036− -> Maybe MessageId

1037− -> Limit

1038− -> P.PaginationDirection

1039− -> StaticPQ [Message]

1040−getMessagesInGroupChat selfId gId mId lim dir = do

1041− _ <- getGroupChatForUser selfId gId

1042− resp <- runQueryParams (getGroupMessagesQ lim dir) (gId, mId) >>= getRows

1043− return . catMaybes . map restoreMessage $ resp

1044−

1045−sendMessage :: UserId -> MessageCreation -> StaticPQ MessageId

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

1047− _ <- getGroupChatForUser selfId gId

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

1049− >>= firstRow >>= fromMaybe500

1050− return mId

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

1052− verifyUsers [uId]

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

1054− >>= firstRow >>= fromMaybe500

1055− return mId

1056−sendMessage _ _ = lift $ S.throwError S.err400

1057−

1058−createGroupChat :: 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

1067−

1068−updateGroupChat :: 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)

1077−

1078−leaveGroupChat :: UserId -> GroupChatId -> StaticPQ ()

1079−leaveGroupChat uId gId = commitedTransactionallyUpdate $ do

1080− gChat@(GroupChat _ (Jsonb perms) _) <- getGroupChatForUser uId gId

1081− let newPerms = M.delete uId perms

1082− if M.null newPerms

1083− then deleteGroupChat gId

1084− else void $ manipulateParams updateGroupChatQ gChat{groupChatUsers = Jsonb newPerms}

1085−

1086−getGroupChatForUser :: UserId -> GroupChatId -> StaticPQ GroupChat

1087−getGroupChatForUser uId gId = do

1088− chat <- runQueryParams getGroupChatForUserQ (show uId, gId) >>= firstRow

1089− case (chat) of

1090− (Just c) -> return c

1091− Nothing -> lift $ S.throwError S.err404

1092−

1093−groupChatIsValidForUser :: UserId -> GroupChatId -> StaticPQ Bool

1094−groupChatIsValidForUser uId gId = do

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

1096− return $ isJust chat

1097−

1098−getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]

1099−getFacultyFromQuery query =

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

1101−

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

1103−searchUsers query = do

1104− unless (validateText query) $ lift $ throwError lengthExceeded

1105− if (T.null . T.filter isAlpha $ query)

1106− then return []

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

1108−

1109−searchTags :: T.Text -> StaticPQ [Text]

1110−searchTags "" = return []

1111−searchTags query = map fromOnly <$>

1112− (runQueryParams searchTagsQ

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

1114−

1115−createToken :: Token -> StaticPQ ()

1116−createToken token = void $ manipulateParams createTokenQ token

1117−

1118−killAllTokens :: UserId -> StaticPQ ()

1119−killAllTokens = void . manipulateParams killAllTokensQ . Only

1120−

1121−pruneAuth :: StaticPQ ()

1122−pruneAuth = do

1123− _ <- commitedTransactionallyUpdate . manipulate $ pruneDeadTokensQ

1124− _ <- commitedTransactionallyUpdate . manipulate $ pruneGhostUsersQ

1125 return ()

357 return ()

1126

358

1127−searchChannels :: UserId -> Text -> StaticPQ [NamedChannel UserId]

359+

1128−searchChannels uId query = fmap (map removeUserFromChannel) $

1129− runQueryParams searchChannelsForUserQ (uId, queryFromText query) >>= getRows

1130−

1131−-- NOTE: Not transactional

1132−validateToken :: Token -> StaticPQ ()

1133−validateToken token = do

1134− void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing, tokenActivationCode = Nothing}

1135− void $ manipulateParams validateUserQ $ Only $ tokenUserId token

1136−

1137−invalidateToken :: UserId -> ByteString -> StaticPQ ()

1138−invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)

1139−

1140−tryVerifyToken :: UserId -> ByteString -> Int -> StaticPQ (Maybe Token)

1141−tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do

1142− token' <- runQueryParams getTokenQ (uId, hash tokenData) >>= firstRow

1143− case token' of

1144− Nothing -> return Nothing

1145− Just token -> do

1146− if (tokenVerificationCode token == Just (hashVerificationCode code))

1147− then validateToken token >> (return $ Just token)

1148− else do

1149− let triesLeft = tokenActivationTriesLeft token - 1

1150− if triesLeft <= 0

1151− then invalidateToken (tokenUserId token) (tokenValue token) >> return Nothing

1152− else do

1153− let newToken = token{tokenActivationTriesLeft = triesLeft}

1154− _ <- manipulateParams updateTokenQ newToken

1155− return Nothing

1156−

1157−tryActivateToken :: UserId -> ByteString -> StaticPQ (Maybe Token)

1158−tryActivateToken uId activationData = do

1159− let hData = hash activationData

1160− token' <- runQueryParams getTokenActivationQ (uId, hData) >>= firstRow

1161− case token' of

1162− Nothing -> return Nothing

1163− Just token -> do

1164− if (tokenActivationCode token == Just hData)

1165− then commitedTransactionallyUpdate (validateToken token) >> (return $ Just token)

1166− else return Nothing

1167−

1168−deactivateToken :: UserId -> ByteString -> StaticPQ (Maybe Text)

1169−deactivateToken uId dData = fmap fromOnly <$> (manipulateParams deactivateTokenQ (uId, hash dData) >>= firstRow)

1170−

1171−getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)

1172−getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, hash tokenData) >>= firstRow

1173−

1174−updateUser :: (UserUpdateRow) -> StaticPQ (Maybe UserId)

1175−updateUser user = fmap fromOnly <$> (manipulateParams updateUserQ (normalizeUser user) >>= firstRow)

1176−

1177-- MARK: Utils

360-- MARK: Utils

1178

361

1179−normalizeUser :: UserUpdateRow -> UserUpdateRow

1180−normalizeUser UserUpdateRow{..} = UserUpdateRow {

1181− userUpdateRowId = userUpdateRowId,

1182− userUpdateRowFirstName = T.strip $ userUpdateRowFirstName,

1183− userUpdateRowMiddleName = T.strip $ userUpdateRowMiddleName,

1184− userUpdateRowLastName = T.strip $ userUpdateRowLastName,

1185− userUpdateRowUserFaculty = T.toLower . T.strip $ userUpdateRowUserFaculty

1186−}

1187−

1188−data UserRow = UserRow {

1189− userRowId :: UserId,

1190− userRowFirstName :: Text,

1191− userRowMiddleName :: Text,

1192− userRowLastName :: Text,

1193− userRowFacultyUrl :: FacultyUrl,

1194− userRowEmail :: Text,

1195− userRowIsValidated :: Bool,

1196− userRowFacultyName :: T.Text,

1197− userRowFacultyURL :: FacultyUrl,

1198− userRowFacultyPath :: T.Text,

1199− userRowFacultyCampusName :: T.Text,

1200− userRowFacultyCampusCode :: T.Text,

1201− userRowFacultyTags :: V.Vector T.Text,

1202− userRowFacultyAddress :: T.Text

1203−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

1204−

1205−rowToUser :: UserRow -> User Faculty

1206−rowToUser UserRow{..} = User {

1207− userId = userRowId,

1208− firstName = userRowFirstName,

1209− middleName = userRowMiddleName,

1210− lastName = userRowLastName,

1211− userFaculty = Faculty {

1212− facultyName = userRowFacultyName,

1213− facultyUrl = userRowFacultyURL,

1214− facultyPath = userRowFacultyPath,

1215− facultyCampusName = userRowFacultyCampusName,

1216− facultyCampusCode = userRowFacultyCampusCode,

1217− facultyTags = userRowFacultyTags,

1218− facultyAddress = userRowFacultyAddress

1219− },

1220− userEmail = userRowEmail

1221− }

1222−

1223−queryFromTextAbbr :: Text -> Text

1224−queryFromTextAbbr = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isAlphaNum)

1225− where

1226− processTerm :: Text -> Text

1227− processTerm t = "(" <> t <> ":*" <> (

1228− if T.length t <= 5

1229− then (" | (" <>) . (<> ")") . T.unwords . L.intersperse "<->" . map (<> ":*") . map T.singleton . T.unpack $ t

1230− else mempty

1231− ) <> ")"

1232−

1233−queryFromText :: Text -> Text

1234−queryFromText = T.unwords . L.intersperse "&" . map processTerm . filter (not . T.null) . T.split (not . isPrint)

1235− where

1236− processTerm :: Text -> Text

1237− processTerm t = t <> ":*"

1238−

1239−directionToOperator

1240− :: P.PaginationDirection

1241− -> (ConditionOp schema0 from0 grouping0 params0 nullity0 nullity1 (ty :: PGType),

1242− (Expression schema2 from2 grouping2 params2 _ -> SortExpression schema2 from2 grouping2 params2))

1243−directionToOperator P.BackPagination = ((.<), Desc)

1244−directionToOperator P.ForwardPagination = ((.>), Asc)

1245−

1246foldMaybe :: [Maybe a] -> Maybe [a]

362foldMaybe :: [Maybe a] -> Maybe [a]

1247foldMaybe [] = Just []

363foldMaybe [] = Just []

1248foldMaybe (Nothing : _) = Nothing

364foldMaybe (Nothing : _) = Nothing

1249foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs

365foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs

1250

366

367+userIdsFromPostResponse :: [Post] -> [UserId]

368+userIdsFromPostResponse = Set.toList . Set.fromList . map postAuthorId

369+

1251rowsToPosts :: [PostRowResponse] -> Maybe [Post]

370rowsToPosts :: [PostRowResponse] -> Maybe [Post]

1252rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)

371rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)

1253

372

@@ -1264,53 +383,11 @@ idsToColumn (i:ii) = Just $ values (unsafeIntToExpr i `as` #id) $ map ((`as` #id

1264unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty

383unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty

1265unsafeIntToExpr = UnsafeExpression . pack . show

384unsafeIntToExpr = UnsafeExpression . pack . show

1266

385

1267−data ResponseWithUsers r = ResponseWithUsers {

386+wrapIntoPostResponse :: [Post] -> StaticPQ (Maybe PostResponse)

1268− response :: r,

387+wrapIntoPostResponse ps = do

1269− users :: M.Map UserId (User Faculty)

1270−} deriving (Generic)

1271−

1272−instance (ToJSON r) => ToJSON (ResponseWithUsers r)

1273−

1274−instance (FromJSON r) => FromJSON (ResponseWithUsers r)

1275−

1276−class HasUsers r where

1277− userSet :: r -> Set.Set UserId

1278−

1279− wrapIntoResponse :: r -> StaticPQ (Maybe (ResponseWithUsers r))

1280− wrapIntoResponse r = wrapIntoUsers r $ userSet r

1281−

1282−instance HasUsers Dialog where

1283− userSet (GroupDialog chat _) = userSet chat

1284− userSet (UserDialog _ mess) = userSet mess

1285−

1286−instance HasUsers GroupChat where

1287− userSet (GroupChat _ (Jsonb gUsers) _) = Set.fromList . M.keys $ gUsers

1288−

1289−instance HasUsers Message where

1290− userSet (Message _ aId (UserChatDestination uId) _ _) = Set.fromList [aId, uId]

1291− userSet (Message _ aId (GroupChatDestination _) _ _) = Set.singleton aId

1292−

1293−instance (Foldable t, HasUsers r) => HasUsers (t r) where

1294− userSet = foldMap userSet

1295−

1296−instance HasUsers Post where

1297− userSet = Set.singleton . postAuthorId

1298−

1299−wrapIntoUsers :: r -> Set.Set UserId -> StaticPQ (Maybe (ResponseWithUsers r))

1300−wrapIntoUsers r us

1301− | Set.null us = return . Just $ ResponseWithUsers r M.empty

1302− | otherwise = do

1303− pUsers <- getUsers $ Set.toList us

388+ pUsers <- getUsers $ userIdsFromPostResponse ps

1304− return $ ResponseWithUsers r . M.fromList . mapFirstBy userId <$> pUsers

389+ return $ PostResponse ps . M.fromList . mapFirstBy userId <$> pUsers

1305

390

1306liftMaybe :: Applicative f => Maybe a -> (a -> f (Maybe b)) -> f (Maybe b)

391liftMaybe :: Applicative f => Maybe a -> (a -> f (Maybe b)) -> f (Maybe b)

1307liftMaybe Nothing _ = pure Nothing

392liftMaybe Nothing _ = pure Nothing

1308−liftMaybe (Just a) f = f a

393+liftMaybe (Just a) f = f a

1309−

1310−fromMaybe500 :: Maybe a -> StaticPQ a

1311−fromMaybe500 Nothing = lift $ S.throwError S.err500

1312−fromMaybe500 (Just a) = return a

1313−

1314−fromMaybe404 :: Maybe a -> StaticPQ a

1315−fromMaybe404 Nothing = lift $ S.throwError S.err404

1316−fromMaybe404 (Just a) = return a

denis/src/Data/Schema.hs+32−161

@@ -15,39 +15,20 @@ module Data.Schema (

15) where

17import Squeal.PostgreSQL

18−import Data.GroupChat

19−import Data.PostElement

20−import Data.Message

22−type Schema =

19+type Schema =

23 '[

20 '[

24− "faculties" ::: 'Table ('[

25− "pk_faculties" ::: 'PrimaryKey '["facultyUrl"]] :=>

26− '[

27− "facultyName" ::: 'NoDef :=> 'NotNull 'PGtext,

28− "facultyUrl" ::: 'NoDef :=> 'NotNull 'PGtext,

29− "facultyPath" ::: 'NoDef :=> 'NotNull 'PGtext,

30− "facultyCampusName" ::: 'NoDef :=> 'NotNull 'PGtext,

31− "facultyCampusCode" ::: 'NoDef :=> 'NotNull 'PGtext,

32− "facultyTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext)),

33− "facultyAddress" ::: 'NoDef :=> 'NotNull 'PGtext

34− ]),

35 "users" ::: 'Table ( '[

21 "users" ::: 'Table ( '[

36− "pk_users" ::: 'PrimaryKey '["userRowId"],

22+ "pk_users" ::: 'PrimaryKey '["userId"]] :=>

37− "user_email" ::: 'Unique '["userRowEmail"],

38− "fk_user_faculty" ::: 'ForeignKey '["userRowFacultyUrl"] "faculties" '["facultyUrl"]] :=>

39 '[

23 '[

40− "userRowId" ::: 'Def :=> 'NotNull 'PGint8,

24+ "userId" ::: 'Def :=> 'NotNull 'PGint8,

41− "userRowFirstName" ::: 'NoDef :=> 'NotNull 'PGtext,

42− "userRowMiddleName" ::: 'NoDef :=> 'NotNull 'PGtext,

43− "userRowLastName" ::: 'NoDef :=> 'NotNull 'PGtext,

25+ "firstName" ::: 'NoDef :=> 'NotNull 'PGtext,

44− "userRowFacultyUrl" ::: 'NoDef :=> 'NotNull 'PGtext,

26+ "middleName" ::: 'NoDef :=> 'NotNull 'PGtext,

45− "userRowEmail" ::: 'NoDef :=> 'NotNull 'PGtext,

27+ "lastName" ::: 'NoDef :=> 'NotNull 'PGtext

46− "userRowIsValidated" ::: 'NoDef :=> 'NotNull 'PGbool

47 ]),

28 ]),

48 "posts" ::: 'Table ( '[

29 "posts" ::: 'Table ( '[

49 "pk_posts" ::: 'PrimaryKey '["postRowId"],

30 "pk_posts" ::: 'PrimaryKey '["postRowId"],

50− "fk_author_id" ::: 'ForeignKey '["postRowAuthorId"] "users" '["userRowId"]] :=>

31+ "fk_author_id" ::: 'ForeignKey '["postRowAuthorId"] "users" '["userId"]] :=>

51 '[

32 '[

52 "postRowId" ::: 'Def :=> 'NotNull 'PGint8,

33 "postRowId" ::: 'Def :=> 'NotNull 'PGint8,

53 "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8,

34 "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8,

@@ -55,7 +36,7 @@ type Schema =

55 "postRowTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext))

36 "postRowTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext))

56 ]),

37 ]),

57 "quotes" ::: 'Table (

38 "quotes" ::: 'Table (

58− '[

39+ '[

59 "pk_post_quotes" ::: 'PrimaryKey '["quoteRowId"],

40 "pk_post_quotes" ::: 'PrimaryKey '["quoteRowId"],

60 "fk_quote_post_id" ::: 'ForeignKey '["quoteRowPostId"] "posts" '["postRowId"] ] :=>

41 "fk_quote_post_id" ::: 'ForeignKey '["quoteRowPostId"] "posts" '["postRowId"] ] :=>

61 '[

42 '[

@@ -75,7 +56,7 @@ type Schema =

75 "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,

56 "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,

76 "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,

57 "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,

77 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,

58 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,

78− "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,

59+ "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,

79 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext

60 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext

80 ]),

61 ]),

81 "quoteElements" ::: 'Table (

62 "quoteElements" ::: 'Table (

@@ -91,88 +72,22 @@ type Schema =

91 "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,

72 "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,

92 "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,

73 "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,

93 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,

74 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,

94− "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,

75+ "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,

95 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext

76 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext

96 ]),

77 ]),

97 "channels" ::: 'Table (

78 "channels" ::: 'Table (

98− '[

79+ '[

99− "pk_channels" ::: 'PrimaryKey '["namedChannelFullId"],

80+ "pk_channels" ::: 'PrimaryKey '["namedChannelFullId"],

100− "fk_channels_users_id" ::: 'ForeignKey '["namedChannelFullOwner"] "users" '["userRowId"]

81+ "fk_channels_users_id" ::: 'ForeignKey '["namedChannelFullOwner"] "users" '["userId"]

101− ] :=>

82+ ] :=>

102 '[

83 '[

103 "namedChannelFullId" ::: 'Def :=> 'NotNull 'PGint8,

84 "namedChannelFullId" ::: 'Def :=> 'NotNull 'PGint8,

104 "namedChannelFullOwner" ::: 'NoDef :=> 'NotNull 'PGint8,

85 "namedChannelFullOwner" ::: 'NoDef :=> 'NotNull 'PGint8,

105 "namedChannelFullName" ::: 'NoDef :=> 'NotNull 'PGtext,

86 "namedChannelFullName" ::: 'NoDef :=> 'NotNull 'PGtext,

106 "namedChannelFullTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext)),

87 "namedChannelFullTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext)),

107 "namedChannelFullPeopleIds" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGint8))

88 "namedChannelFullPeopleIds" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGint8))

108− ]),

89+ ]

109− "groupChats" ::: 'Table (

90+ )

110− '[

111− "pk_group_chats" ::: 'PrimaryKey '["groupChatId"]

112− ] :=>

113− '[

114− "groupChatId" ::: 'Def :=> 'NotNull 'PGint8,

115− "groupChatUsers" ::: 'NoDef :=> 'NotNull (PG (Jsonb UserPermissions)),

116− "groupChatName" ::: 'NoDef :=> 'NotNull 'PGtext

117− ]),

118− -- "userMessages" ::: 'Table (

119− -- '[

120− -- "pk_user_messages" ::: 'PrimaryKey '["userMessageId"],

121− -- "fk_user_messages_from" ::: 'ForeignKey '["userMessageFrom"] "users" '["userRowId"],

122− -- "fk_user_messages_to" ::: 'ForeignKey '["userMessageTo"] "users" '["userRowId"]

123−

124− -- ] :=>

125− -- '[

126− -- "userMessageId" ::: 'Def :=> 'NotNull 'PGint8,

127− -- "userMessageFrom" ::: 'NoDef :=> 'NotNull 'PGint8,

128− -- "userMessageTo" ::: 'NoDef :=> 'NotNull 'PGint8,

129− -- "userMessageBody" ::: 'NoDef :=> 'NotNull (PG (Jsonb (PostElement UserMessage))),

130− -- "userMessageTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz

131− -- ]),

132− -- "groupChatMessages" ::: 'Table (

133− -- '[

134− -- "pk_group_messages" ::: 'PrimaryKey '["groupChatMessageId"],

135− -- "fk_group_messages_group" ::: 'ForeignKey '["groupChatMessageGroupChatId"] "groupChats" '["groupChatId"],

136− -- "fk_group_messages_author" ::: 'ForeignKey '["groupChatMessageAuthorId"] "users" '["userRowId"]

137− -- ] :=>

138− -- '[

139− -- "groupChatMessageId" ::: 'Def :=> 'NotNull 'PGint8,

140− -- "groupChatMessageGroupChatId" ::: 'NoDef :=> 'NotNull 'PGint8,

141− -- "groupChatMessageAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8,

142− -- "groupChatMessageBody" ::: 'NoDef :=> 'NotNull (PG (Jsonb (PostElement GroupChatMessage))),

143− -- "groupChatMessageTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz

144− -- ])

145− "messages" ::: 'Table (

146− '[

147− "pk_messages" ::: 'PrimaryKey '["messageStorageId"],

148− "fk_messages_author" ::: 'ForeignKey '["messageStorageAuthorId"] "users" '["userRowId"],

149− "fk_messages_group" ::: 'ForeignKey '["messageStorageDestinationGroupId"] "groupChats" '["groupChatId"],

150− "fk_messages_to_user" ::: 'ForeignKey '["messageStorageDestinationUserId"] "users" '["userRowId"]

151− ] :=>

152− '[

153− "messageStorageId" ::: 'Def :=> 'NotNull 'PGint8,

154− "messageStorageAuthorId" ::: 'NoDef :=> 'Null 'PGint8,

155− "messageStorageDestinationGroupId" ::: 'NoDef :=> 'Null 'PGint8,

156− "messageStorageDestinationUserId" ::: 'NoDef :=> 'Null 'PGint8,

157− "messageStorageBody" ::: 'NoDef :=> 'Null (PG (Jsonb (PostElement Message))),

158− "messageStorageTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz

159− ]),

160− "tokens" ::: 'Table (

161− '[

162− -- "pk_token" ::: 'PrimaryKey '["tokenValue"],

163− "fk_user_token" ::: 'ForeignKey '["tokenUserId"] "users" '["userRowId"]

164− ] :=>

165− '[

166− "tokenUserId" ::: 'NoDef :=> 'NotNull 'PGint8,

167− "tokenValue" ::: 'NoDef :=> 'NotNull 'PGbytea,

168− "tokenExpiryDate" ::: 'NoDef :=> 'NotNull 'PGtimestamptz,

169− "tokenVerificationCode" ::: 'NoDef :=> 'Null 'PGbytea, -- null == verified

170− "tokenActivationTriesLeft" ::: 'NoDef :=> 'NotNull 'PGint4,

171− "tokenUserAgent" ::: 'NoDef :=> 'NotNull 'PGtext,

172− "tokenActivationCode" ::: 'NoDef :=> 'Null 'PGbytea,

173− "tokenDeactivationCode" ::: 'NoDef :=> 'NotNull 'PGbytea

174− ])

175−

176 -- "postsView" ::: 'View (RowPG PostRowResponse)

91 -- "postsView" ::: 'View (RowPG PostRowResponse)

177 -- ('[

92 -- ('[

178 -- "postRowId" ::: 'NotNull 'PGint8,

93 -- "postRowId" ::: 'NotNull 'PGint8,

@@ -182,36 +97,21 @@ type Schema =

182 -- "rowElementMarkdown" ::: 'Null 'PGtext,

97 -- "rowElementMarkdown" ::: 'Null 'PGtext,

183 -- "rowElementLatex" ::: 'Null 'PGtext,

98 -- "rowElementLatex" ::: 'Null 'PGtext,

184 -- "rowElementImage" ::: 'Null 'PGtext,

99 -- "rowElementImage" ::: 'Null 'PGtext,

185− -- "rowElementQuote" ::: 'Null 'PGint8,

100+ -- "rowElementQuote" ::: 'Null 'PGint8,

186 -- "rowElementAttachment" ::: 'Null 'PGtext

101 -- "rowElementAttachment" ::: 'Null 'PGtext

187 -- ])

102 -- ])

188−

103+

189 ]

104 ]

190−

105+

191

106

192createTables :: Definition '[] Schema

107createTables :: Definition '[] Schema

193−createTables = createTable #faculties (

108+createTables = createTable #users (

194− notNullable text `as` #facultyName :*

195− notNullable text `as` #facultyUrl :*

196− notNullable text `as` #facultyPath :*

197− notNullable text `as` #facultyCampusName :*

198− notNullable text `as` #facultyCampusCode :*

199− notNullable (vararray text) `as` #facultyTags :*

200− notNullable text `as` #facultyAddress

201− ) (

202− primaryKey #facultyUrl `as` #pk_faculties

203− ) >>> createTable #users (

204− serial8 `as` #userRowId :*

109+ serial8 `as` #userId :*

205− notNullable text `as` #userRowFirstName :*

206− notNullable text `as` #userRowMiddleName :*

110+ notNullable text `as` #firstName :*

207− notNullable text `as` #userRowLastName :*

208− notNullable text `as` #userRowFacultyUrl :*

111+ notNullable text `as` #middleName :*

209− notNullable text `as` #userRowEmail :*

112+ notNullable text `as` #lastName

210− notNullable bool `as` #userRowIsValidated

211 ) (

113 ) (

212− primaryKey #userRowId `as` #pk_users :*

114+ primaryKey #userId `as` #pk_users

213− unique #userRowEmail `as` #user_email :*

214− foreignKey #userRowFacultyUrl #faculties #facultyUrl OnDeleteRestrict OnUpdateCascade `as` #fk_user_faculty

215 ) >>> createTable #posts (

115 ) >>> createTable #posts (

216 serial8 `as` #postRowId :*

116 serial8 `as` #postRowId :*

217 notNullable int8 `as` #postRowAuthorId :*

117 notNullable int8 `as` #postRowAuthorId :*

@@ -219,13 +119,13 @@ createTables = createTable #faculties (

219 notNullable (vararray text) `as` #postRowTags

119 notNullable (vararray text) `as` #postRowTags

220 ) (

120 ) (

221 primaryKey #postRowId `as` #pk_posts :*

121 primaryKey #postRowId `as` #pk_posts :*

222− foreignKey #postRowAuthorId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_author_id

122+ foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_author_id

223 ) >>> createTable #quotes (

123 ) >>> createTable #quotes (

224 serial8 `as` #quoteRowId :*

124 serial8 `as` #quoteRowId :*

225 notNullable int8 `as` #quoteRowPostId

125 notNullable int8 `as` #quoteRowPostId

226 ) (

126 ) (

227 primaryKey #quoteRowId `as` #pk_post_quotes :*

127 primaryKey #quoteRowId `as` #pk_post_quotes :*

228− foreignKey #quoteRowPostId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_post_id

128+ foreignKey #quoteRowPostId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_post_id

229 ) >>> createTable #postElements (

129 ) >>> createTable #postElements (

230 notNullable int8 `as` #rowElementId :*

130 notNullable int8 `as` #rowElementId :*

231 notNullable int8 `as` #rowElementOrd :*

131 notNullable int8 `as` #rowElementOrd :*

@@ -236,7 +136,7 @@ createTables = createTable #faculties (

236 nullable text `as` #rowElementAttachment

136 nullable text `as` #rowElementAttachment

237 ) (

137 ) (

238 foreignKey #rowElementId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_self_id :*

138 foreignKey #rowElementId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_self_id :*

239− foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_id

139+ foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_id

240 ) >>> createTable #quoteElements (

140 ) >>> createTable #quoteElements (

241 notNullable int8 `as` #rowElementId :*

141 notNullable int8 `as` #rowElementId :*

242 notNullable int8 `as` #rowElementOrd :*

142 notNullable int8 `as` #rowElementOrd :*

@@ -247,7 +147,7 @@ createTables = createTable #faculties (

247 nullable text `as` #rowElementAttachment

147 nullable text `as` #rowElementAttachment

248 ) (

148 ) (

249 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*

149 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*

250− foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id

150+ foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id

251 ) >>> createTable #channels (

151 ) >>> createTable #channels (

252 serial8 `as` #namedChannelFullId :*

152 serial8 `as` #namedChannelFullId :*

253 notNullable int8 `as` #namedChannelFullOwner :*

153 notNullable int8 `as` #namedChannelFullOwner :*

@@ -256,7 +156,7 @@ createTables = createTable #faculties (

256 notNullable (vararray int8) `as` #namedChannelFullPeopleIds

156 notNullable (vararray int8) `as` #namedChannelFullPeopleIds

257 ) (

157 ) (

258 primaryKey #namedChannelFullId `as` #pk_channels :*

158 primaryKey #namedChannelFullId `as` #pk_channels :*

259− foreignKey #namedChannelFullOwner #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_channels_users_id

159+ foreignKey #namedChannelFullOwner #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_channels_users_id

260 -- ) >>> createView #postsView (select (

160 -- ) >>> createView #postsView (select (

261 -- #posts ! #postRowId :*

161 -- #posts ! #postRowId :*

262 -- #posts ! #postRowAuthorId :*

162 -- #posts ! #postRowAuthorId :*

@@ -268,38 +168,9 @@ createTables = createTable #faculties (

268 -- #postElements ! #rowElementQuote :*

168 -- #postElements ! #rowElementQuote :*

269 -- #postElements ! #rowElementAttachment

169 -- #postElements ! #rowElementAttachment

270 -- ) (

170 -- ) (

271− -- from ((table #posts) &

171+ -- from ((table #posts) &

272 -- (innerJoin (table #postElements)

172 -- (innerJoin (table #postElements)

273 -- (#posts ! #postRowId .== #postElements ! #rowElementId))))

173 -- (#posts ! #postRowId .== #postElements ! #rowElementId))))

274− ) >>> createTable #groupChats (

275− serial8 `as` #groupChatId :*

276− notNullable jsonb `as` #groupChatUsers :*

277− notNullable text `as` #groupChatName

278− ) (

279− primaryKey #groupChatId `as` #pk_group_chats

280− ) >>> createTable #messages (

281− serial8 `as` #messageStorageId :*

282− nullable int8 `as` #messageStorageAuthorId :*

283− nullable int8 `as` #messageStorageDestinationGroupId :*

284− nullable int8 `as` #messageStorageDestinationUserId :*

285− nullable jsonb `as` #messageStorageBody :*

286− notNullable timestampWithTimeZone `as` #messageStorageTime

287− ) (

288− primaryKey #messageStorageId `as` #pk_messages :*

289− foreignKey #messageStorageAuthorId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_messages_author :*

290− foreignKey #messageStorageDestinationGroupId #groupChats #groupChatId OnDeleteCascade OnUpdateCascade `as` #fk_messages_group :*

291− foreignKey #messageStorageDestinationUserId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_messages_to_user

292− ) >>> createTable #tokens (

293− notNullable int8 `as` #tokenUserId :*

294− notNullable bytea `as` #tokenValue :*

295− notNullable timestampWithTimeZone `as` #tokenExpiryDate :*

296− nullable bytea `as` #tokenVerificationCode :*

297− notNullable int4 `as` #tokenActivationTriesLeft :*

298− notNullable text `as` #tokenUserAgent :*

299− nullable bytea `as` #tokenActivationCode :*

300− notNullable bytea `as` #tokenDeactivationCode

301− ) (

302− foreignKey #tokenUserId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_user_token

303 )

174 )

304-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])

175-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])

305-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $

176-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $

@@ -307,4 +178,4 @@ createTables = createTable #faculties (

307-- (ifThenElse (isNull #rowElementOrd) 1 0) +

178-- (ifThenElse (isNull #rowElementOrd) 1 0) +

308-- (ifThenElse (isNull #rowElementOrd) 1 0) +

179-- (ifThenElse (isNull #rowElementOrd) 1 0) +

309-- (ifThenElse (isNull #rowElementOrd) 1 0) +

180-- (ifThenElse (isNull #rowElementOrd) 1 0) +

310−-- (ifThenElse (isNull #rowElementOrd) 1 0)) .== 0

181+-- (ifThenElse (isNull #rowElementOrd) 1 0)) .== 0

denis/src/Data/Tags/Completions.hsdeleted−43

@@ -1,43 +0,0 @@

1−{-# LANGUAGE

2− TupleSections,

3− DeriveGeneric,

4− FlexibleInstances #-}

5−{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

6−

7−module Data.Tags.Completions (

8− CompletionTree(..),

9− mkCompletionTree

10− ) where

11−

12−import qualified Data.Map as M

13−import Data.Aeson

14−import Data.List

15−import Data.Function

16−import Data.Either

17−import Data.Bifunctor

18−import Data.Maybe

19−import GHC.Generics

20−import Servant.Docs

21−import Data.Char

22−

23−instance ToSample CompletionTree where

24− toSamples _ = singleSample . mkCompletionTree $

25− ["aa", "aaab", "ba", "b", "bab"]

26−

27−data CompletionTree = CompletionTreeNode {

28− value :: Maybe String,

29− subtree :: M.Map Char CompletionTree

30− } deriving (Show, Generic)

31−

32−instance ToJSON CompletionTree where

33−

34−mkCompletionTree :: [String] -> CompletionTree

35−mkCompletionTree = mkCompletionTree' . map (\ a -> (map toLower a, a)) . sort

36− where

37− mkCompletionTree' :: [(String, String)] -> CompletionTree

38− mkCompletionTree' = uncurry CompletionTreeNode . bimap listToMaybe (M.map mkCompletionTree' . M.fromList) .

39− second (map (\ u@((k,_):_) -> (k, map snd u)) . groupBy ((==) `on` fst)) . partitionEithers . map processGroup

40− where

41− processGroup :: (String, String) -> Either String (Char, (String, String))

42− processGroup ([], b) = Left b

43− processGroup ((k:rest), aa) = Right (k, (rest, aa))

denis/src/Data/Tags/Validation.hsdeleted−25

@@ -1,25 +0,0 @@

1−module Data.Tags.Validation (

2− validateTag,

3− validateTag'

4− ) where

5−

6−import Data.Text as T

7−import Data.Char as C

8−import qualified Data.Set as S

9−

10−validateTag :: T.Text -> Maybe T.Text

11−validateTag tag =

12− let

13− normalised = T.strip $ tag

14− in if validateTag' normalised

15− then Just normalised

16− else Nothing

17−

18−validateTag' :: T.Text -> Bool

19−validateTag' = T.all validChar

20−

21−validChars :: S.Set Char

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

23−

24−validChar :: Char -> Bool

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

denis/src/Data/Text/Validator.hsdeleted−59

@@ -1,59 +0,0 @@

1−{-# LANGUAGE FlexibleInstances #-}

2−

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−import Data.Limits

16−

17−isValidChar :: Char -> Bool

18−isValidChar '\n' = True

19−isValidChar '\r' = True

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

21−

22−class HasValidatableText t where

23− validateText :: t -> Bool

24−

25−data ExtraPredicate t = ExtraPredicate t (t -> Bool)

26−

27−infixl 5 ~=

28−(~=) :: t -> (t -> Bool) -> ExtraPredicate t

29−(~=) = ExtraPredicate

30−

31−instance (HasValidatableText t) => HasValidatableText (ExtraPredicate t) where

32− validateText (t `ExtraPredicate` p) = validateText t && p t

33−

34−

35−infixl 5 ~<

36−(~<) :: t -> Int -> RangeableText t

37−t ~< n = t <~> (0, n)

38−

39−infixl 5 <~>

40−(<~>) :: t -> (Int, Int) -> RangeableText t

41−(<~>) = RangeableText

42−

43−data RangeableText t = RangeableText t (Int, Int)

44−

45−instance HasValidatableText (RangeableText String) where

46− validateText (t `RangeableText` (lower, upper)) = len >= lower && len <= upper && validateText t

47− where

48− len = length t

49−

50−instance HasValidatableText (RangeableText T.Text) where

51− validateText (t `RangeableText` (lower, upper)) = len >= lower && len <= upper && validateText t

52− where

53− len = T.length t

54−

55−instance HasValidatableText T.Text where

56− validateText t = T.all isValidChar t && (not . T.null) t && T.length t < globalTextLimit

57−

58−instance HasValidatableText String where

59− validateText t = all isValidChar t && length t > 0 && length t < globalTextLimit

denis/src/Data/User.hs+15−54

@@ -5,16 +5,12 @@

5 OverloadedStrings ,

6 TypeApplications ,

7 TypeOperators,

8− OverloadedStrings,

8+ OverloadedStrings #-}

9− DeriveAnyClass,

10− RecordWildCards #-}

12module Data.User (

10module Data.User (

13 User(..),

11 User(..),

14− UserId,

12+ UserId

15− UserEmail,

16− UserUpdate(..)

17−) where

13+) where

19import Data.Int (Int64)

15import Data.Int (Int64)

20import qualified Generics.SOP as SOP

16import qualified Generics.SOP as SOP

@@ -22,66 +18,31 @@ import qualified GHC.Generics as GHC

22import Data.Text (Text)

18import Data.Text (Text)

23import Data.Aeson

19import Data.Aeson

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

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

25−import Data.Proxy

26−import Data.Faculty

27−import Data.Limits

28−import Data.Text.Validator

30-- MARK: Documentation

22-- MARK: Documentation

32−instance (ToSample f) => ToSample (User f) where

24+instance ToSample User where

33− toSamples _ = samples $ [User 8 "Vasya" "Pupkinovuch" "Pupkin", User 69 "Seva" "Algebrovich" "Leonidov"] <*> (map snd $ toSamples Proxy) <*> ["foo@hse.ru"]

25+ toSamples _ = samples [User 8 "Vasya" "Pupkinovuch" "Pupkin", User 69 "Seva" "Algebrovich" "Leonidov"]

34−

35−instance ToSample (UserUpdate) where

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

37−

38−instance HasValidatableText UserUpdate where

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

41-- MARK: Implementation

27-- MARK: Implementation

43type UserId = Int64

29type UserId = Int64

44−type UserEmail = Text

46−data User f = User {

31+data User = User {

47 userId :: UserId,

32 userId :: UserId,

48 firstName :: Text,

33 firstName :: Text,

49 middleName :: Text,

34 middleName :: Text,

50− lastName :: Text,

35+ lastName :: Text

51− userFaculty :: f,

52− userEmail :: UserEmail

53−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

36+} deriving (GHC.Generic)

55−instance (ToJSON f) => ToJSON (User f) where

38+instance SOP.Generic User

56− toJSON (User uId fName mName lName faculty email) = object [

57− "id" .= uId,

58− "firstName" .= fName,

59− "middleName" .= mName,

60− "lastName" .= lName,

61− "faculty" .= faculty,

62− "email" .= email

63− ]

65−instance (FromJSON f) => FromJSON (User f) where

40+instance SOP.HasDatatypeInfo User

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

67− User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"

69−data UserUpdate = UserUpdate {

70− userUpdateFirstName :: Text,

71− userUpdateMiddleName :: Text,

72− userUpdateLastName :: Text,

73− userUpdateUserFaculty :: FacultyUrl

74−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

75−

76−instance ToJSON UserUpdate where

42+instance ToJSON User where

77− toJSON (UserUpdate fName mName lName faculty) = object [

43+ toJSON (User uId fName mName lName) = object [

44+ "id" .= uId,

78 "firstName" .= fName,

45 "firstName" .= fName,

79 "middleName" .= mName,

46 "middleName" .= mName,

80− "lastName" .= lName,

47+ "lastName" .= lName

81− "faculty" .= faculty

82− ]

48+ ]

83−

84−instance FromJSON UserUpdate where

85− parseJSON = withObject "user creation" $ \e ->

86− UserUpdate <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty"

87−

denis/src/Server/API.hs+18−65

@@ -1,10 +1,9 @@

1−{-# LANGUAGE

1+{-# LANGUAGE

2 FlexibleInstances,

3 DataKinds,

4 TypeOperators,

5 OverloadedStrings,

6− ScopedTypeVariables,

6+ ScopedTypeVariables #-}

7− RecordWildCards #-}

8{-# OPTIONS_GHC -Wno-orphans #-}

7{-# OPTIONS_GHC -Wno-orphans #-}

10module Server.API (

9module Server.API (

@@ -12,8 +11,8 @@ module Server.API (

12 serverProxy,

11 serverProxy,

13 mkServerAPI,

12 mkServerAPI,

14 Authentication

13 Authentication

15−) where

14+) where

16−

15+

17import Data.Proxy

16import Data.Proxy

18import Servant.API

17import Servant.API

19import Data.User

18import Data.User

@@ -27,86 +26,40 @@ import Server.Logger

27import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))

26import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))

28import Server.API.Channels

27import Server.API.Channels

29import Control.Lens

28import Control.Lens

30−import Server.Query.ComplexQuery

29+

31−import Server.API.Completions

32−import Server.API.Messages

33−import Data.Faculty

34−import Server.API.Faculty

35−import Data.Text (Text)

36−import Data.Maybe (isJust)

37−import Control.Monad.Except

38−import Server.Error

39−import Data.Text.Validator

41-- MARK: Documentation

31-- MARK: Documentation

43instance HasDocs api => HasDocs (Authentication :> api) where

33instance HasDocs api => HasDocs (Authentication :> api) where

44 docsFor Proxy (endpoint, action) =

34 docsFor Proxy (endpoint, action) =

45− docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `498 Invalid Token` if the token is invalid or the token header is missing. Returns `401 Unathorized` if the token doesn't permit access to the requested data."]])

35+ 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 premit access to the requested data."]])

46−

47−type UserSearchDescription = Description "Searches for users with the given string.\n\nFeed in the raw user input string."

49−type UpdateUserDescription = Description "Updates the current user.\n\nThrow 401 if you try to change email or something like that."

50−

51−type DeactivateAllDescription = Description "Deactivates all tokens for the logged in user including the one used to authenticate this request."

53-- MARK: Implementation

38-- MARK: Implementation

55type Authentication = AuthProtect "basicAuth"

40type Authentication = AuthProtect "basicAuth"

57−type API =

42+type API =

58 LoggerAPI :<|>

43 LoggerAPI :<|>

59 "authentication" :> AuthenticationHandler :<|>

44 "authentication" :> AuthenticationHandler :<|>

60− Authentication :> ComplexQuery :> (

45+ Authentication :> (

61 "authentication" :> "me" :> Post '[JSON] UserId :<|>

46 "authentication" :> "me" :> Post '[JSON] UserId :<|>

62− "deactivateAll" :> DeactivateAllDescription

63− :> DeleteNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>

64− "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>

47+ "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>

65− "users" :> "all" :> Post '[JSON] [User Faculty] :<|>

48+ "users" :> "all" :> Post '[JSON] [User] :<|>

66− "users" :> "search" :> UserSearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [User Faculty] :<|>

67− "users" :> "update" :> UpdateUserDescription :> ReqBody '[JSON] UserUpdate :> PostNoContent '[JSON, PlainText] NoContent :<|>

68 "posts" :> PostApi :<|>

49 "posts" :> PostApi :<|>

69− "channels" :> ChannelsApi :<|>

50+ "channels" :> ChannelsApi

70− MessagesApi

51+ )

71− ) :<|>

72− "tags" :> TagsAPI :<|>

73− "faculty" :> FacultyAPI

75serverProxy :: Proxy API

53serverProxy :: Proxy API

76serverProxy = Proxy

54serverProxy = Proxy

78mkServerAPI :: Logger -> ServerT API App

56mkServerAPI :: Logger -> ServerT API App

79−mkServerAPI l =

57+mkServerAPI l =

80− l :<|>

58+ l :<|>

81− authenticationAPI :<|> (\uId ->

59+ authenticationAPI :<|> (\uId ->

82 return uId :<|>

60 return uId :<|>

83− deactivateApi uId :<|>

84 maybeNotFound . runQnotFound . getUsers :<|>

61 maybeNotFound . runQnotFound . getUsers :<|>

85− runQerror getAllUsers :<|>

62+ runQnotFound getAllUsers :<|>

86− runQerror . searchUsers :<|>

87− updateUserApi uId :<|>

88 postApi uId :<|>

63 postApi uId :<|>

89− channelsApi uId :<|>

64+ channelsApi uId

90− messagesServer uId

65+ )

91− ) :<|>

92− tagsServer :<|>

93− facultyServer

94−

95−updateUserApi :: UserId -> UserUpdate -> App NoContent

96−updateUserApi uId UserUpdate{..} = do

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

98− facultyIsValid <- runQerror $ isValidFaculty userUpdateUserFaculty

99− unless (facultyIsValid) $ throwError impossibleContent

100− res <- runQ impossibleContent $ updateUser UserUpdateRow {

101− userUpdateRowId = uId,

102− userUpdateRowFirstName = userUpdateFirstName,

103− userUpdateRowMiddleName = userUpdateMiddleName,

104− userUpdateRowLastName = userUpdateLastName,

105− userUpdateRowUserFaculty = userUpdateUserFaculty

106− }

107− if isJust res

108− then return NoContent

109− else throwError err401

110−

111−deactivateApi :: UserId -> App NoContent

112−deactivateApi uId = runQerror (killAllTokens uId) >> return NoContent

denis/src/Server/API/Channels.hs+23−54

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

4 OverloadedLabels,

5 OverloadedStrings ,

6 TypeApplications ,

7− TypeOperators,

7+ TypeOperators #-}

8− RecordWildCards #-}

10module Server.API.Channels (

9module Server.API.Channels (

11 ChannelsApi,

10 ChannelsApi,

@@ -13,82 +12,52 @@ module Server.API.Channels (

13) where

12) where

15import Servant.API

14import Servant.API

15+import qualified Data.Post as P

16+import Data.Aeson

16import Server.App

17import Server.App

17import Servant.Server

18import Servant.Server

18import Data.Query

19import Data.Query

19import Data.User

20import Data.User

20import Data.Connection

21import Data.Connection

22+import Data.Word (Word64)

23+import Servant.Docs (ToSample, toSamples, samples)

24+import Server.LimitingRequest

21import Data.Channel.NamedChannel

25import Data.Channel.NamedChannel

22import Data.Channel.AnonymousChannel

26import Data.Channel.AnonymousChannel

23−import qualified Data.Post as P

27+

24−import Server.Query.Pagination

25−import Server.Error

26−import Data.Text (Text)

27−import Data.Text.Validator

28−import Control.Monad

29−import Data.Limits

30−import qualified Data.Text as T

31−import Data.Char

32−

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

34−

35−type SearchDescription = Description "Search for user channels."

36−

37-- MARK: Implementation

28-- MARK: Implementation

30+type NamedChannelRequest = LimitingRequest NamedChannelId

31+

39type ChannelsApi = Post '[JSON] [NamedChannel UserId] :<|>

32type ChannelsApi = Post '[JSON] [NamedChannel UserId] :<|>

40− "get" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe NamedChannelId)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>

33+ "get" :> ReqBody '[JSON] NamedChannelRequest :> Post '[JSON] PostResponse :<|>

41− "getAnonymous" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe AnonymousChannel)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>

34+ "getAnonymous" :> ReqBody '[JSON] (LimitingRequest AnonymousChannel) :> Post '[JSON] PostResponse :<|>

42− "create" :> CreateDescription :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>

35+ "create" :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>

43 "update" :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>

36 "update" :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>

44− "delete" :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>

37+ "delete" :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent

45− "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [NamedChannel UserId]

47channelsApi :: UserId -> ServerT ChannelsApi App

39channelsApi :: UserId -> ServerT ChannelsApi App

51getChannelsApi :: UserId -> App [NamedChannel UserId]

43getChannelsApi :: UserId -> App [NamedChannel UserId]

52getChannelsApi uId = runQnotFound $ getAllChannels uId

44getChannelsApi uId = runQnotFound $ getAllChannels uId

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

46+getAnonymousChannelsApi :: LimitingRequest AnonymousChannel -> App PostResponse

55−getAnonymousChannelsApi req'@(PaginatingRequest pId lim (Just req) dir) = do

56− unless (validateText req && validatePaginationRequest req') $ throwError lengthExceeded

57− runQnotFound $ getAnonymousChannelPosts pId lim dir req

47+getAnonymousChannelsApi (LimitingRequest req lim) = runQnotFound $ getAnonymousChannelPosts lim req

58−getAnonymousChannelsApi req@(PaginatingRequest pId lim Nothing dir) = do

59− unless (validatePaginationRequest req) $ throwError lengthExceeded

60− maybeNotFound . runQnotFound $ getLastPosts pId lim dir

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

49+getChannel :: UserId -> NamedChannelRequest -> App PostResponse

63−getChannel uId req@(PaginatingRequest pId lim (Just cId) dir) = do

64− unless (validatePaginationRequest req) $ throwError lengthExceeded

65− runQnotFound $ getChannelPosts uId pId lim dir cId

50+getChannel uId (LimitingRequest cId lim) = runQnotFound $ getChannelPosts uId lim cId

66−getChannel _ req@(PaginatingRequest pId lim Nothing dir) = do

67− unless (validatePaginationRequest req) $ throwError lengthExceeded

68− maybeNotFound . runQnotFound $ getLastPosts pId lim dir

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

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

71−createChannelApi uId req = do

72− cCount <- runQerror $ channelCountForUser uId

73− unless (validateText req) $ throwError lengthExceeded

74− if cCount >= channelCountLimit

75− then throwError $ amountExceeded

76− else maybeNotFound . runQerror $ createNewChannel uId req

53+createChannelApi uId req = maybeNotFound . runQnotFound $ createNewChannel uId req

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

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

79−updateChannelApi uId req@NamedChannel{..} = do

56+updateChannelApi uId req = do

80− unless (validateText req) $ throwError lengthExceeded

81− runQnotFound $ updateChannel uId req

57+ runQ err500 $ updateChannel uId req

82 return NoContent

58 return NoContent

84deleteChannelApi :: UserId -> NamedChannelId -> App NoContent

60deleteChannelApi :: UserId -> NamedChannelId -> App NoContent

85−deleteChannelApi uId cId = do

61+deleteChannelApi uId cId = do

86 runQnotFound $ deleteNamedChannel uId cId

62 runQnotFound $ deleteNamedChannel uId cId

87− return NoContent

63+ return NoContent

88−

89−searchChannelsApi :: UserId -> Text -> App [NamedChannel UserId]

90−searchChannelsApi uId query = do

91− unless (validateText query) $ throwError lengthExceeded

92− if (T.null . T.filter (not . isSpace) . T.filter isPrint) query

93− then return []

94− else runQerror . searchChannels uId $ query

denis/src/Server/API/Completions.hsdeleted−83

@@ -1,83 +0,0 @@

1−{-# LANGUAGE

2− DataKinds ,

3− DeriveGeneric ,

4− OverloadedLabels,

5− OverloadedStrings ,

6− TypeApplications ,

7− TypeOperators,

8− LambdaCase #-}

9−

10−module Server.API.Completions (

11− TagsAPI,

12− tagsServer

13− ) where

14−

15−import Servant.Server

16−import Servant

17−import Data.Tags.Completions

18−import Server.App

19−import Data.Connection

20−import Data.Query

21−import Data.Text (Text)

22−import Data.Tags.Validation

23−import Server.Error

24−import qualified Data.Text as T

25−import Data.Char

26−

27−type CompletionsDescription = Description "\

28− \Gets tag completion tree\n\n\

29− \```haskell\n\

30− \data CompletionTree = CompletionTreeNode {\n\

31− \ value :: Maybe String,\n\

32− \ subtree :: Map Char CompletionTree\n\

33− \}\n\

34− \```\n\n\

35− \The psuedocode for retrieving all completions from the tree:\n\n\

36− \```swift\n\

37− \func getCompletion(tree: CompletionTree, word: String) -> [String] {\n\

38− \ if word == \"\" {\n\

39− \ return getValues(tree: tree)\n\

40− \ }\n\

41− \\n\

42− \ let character = word.first\n\

43− \\n\

44− \ if tree.subtree[character] == null {\n\

45− \ return []\n\

46− \ } else {\n\

47− \ return getCompletion(tree: tree.subtree[character], word.withoutFirst)\n\

48− \ }\n\

49− \}\n\

50− \\n\

51− \func getValues(tree: CompletionTree) -> [String] {\n\

52− \ var out = []\n\

53− \\n\

54− \ if tree.value != null {\n\

55− \ out += tree.value\n\

56− \ }\n\

57− \\n\

58− \ for (key, subtree) in tree {\n\

59− \ out += getValues(tree: tree)\n\

60− \ }\n\

61− \\n\

62− \ return out\n\

63− \}\n\

64− \```"

65−

66−type SearchDescription = Description "Returns top 1000 tag completions for given user input."

67−

68−type TagsAPI = "completions" :> CompletionsDescription :> Get '[JSON] CompletionTree :<|>

69− "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [Text]

70−

71−tagsServer :: ServerT TagsAPI App

72−tagsServer = completionHandler :<|> tagSearch

73−

74−completionHandler :: App CompletionTree

75−completionHandler = runQerror $ mkCompletionTree <$> getTags 1000

76−

77−tagSearch :: Text -> App [Text]

78−tagSearch query' =

79− if T.null . T.filter (not . isSpace) . T.filter isPrint $ query'

80− then return []

81− else do

82− query <- fromMaybeThrow formatError . return $ validateTag query'

83− runQerror . searchTags $ query

denis/src/Server/API/Faculty.hsdeleted−42

@@ -1,42 +0,0 @@

1−{-# LANGUAGE

2− DataKinds ,

3− DeriveGeneric ,

4− OverloadedLabels,

5− OverloadedStrings ,

6− TypeApplications ,

7− TypeOperators,

8− LambdaCase #-}

9−

10−module Server.API.Faculty (

11− FacultyAPI,

12− facultyServer

13− ) where

14−

15−import Servant.Server

16−import Servant

17−import Server.App

18−import Data.Connection

19−import Data.Query

20−import Data.Text (Text)

21−import qualified Data.Text as T

22−import Data.Faculty

23−import Data.Text.Validator

24−import Control.Monad

25−import Server.Error

26−import Data.Char

27−

28−type SearchDescription = Description "Returns faculties for given string"

29−

30−type FacultyAPI =

31− "search" :> SearchDescription :> ReqBody '[PlainText, JSON] Text :> Post '[JSON] [Faculty]

32−

33−facultyServer :: ServerT FacultyAPI App

34−facultyServer = search

35−

36−search :: Text -> App [Faculty]

37−search query = do

38− if T.null . T.filter (not . isSpace) . T.filter isPrint $ query

39− then return []

40− else do

41− unless (validateText query) $ throwError lengthExceeded

42− runQerror . getFacultyFromQuery $ query

denis/src/Server/API/Messages.hsdeleted−110

@@ -1,110 +0,0 @@

1−{-# LANGUAGE

2− DataKinds ,

3− DeriveGeneric ,

4− OverloadedLabels,

5− OverloadedStrings ,

6− TypeApplications ,

7− TypeOperators,

8− RecordWildCards #-}

9−

10−module Server.API.Messages (

11− MessagesApi,

12− messagesServer

13−) where

14−

15−import Servant.API

16−import Server.App

17−import Servant.Server

18−import Data.Query

19−import Data.User

20−import Data.Connection

21−import Server.Query.Pagination

22−import Data.Message

23−import Data.GroupChat

24−import Server.Query.Dialog

25−import Data.Text.Validator

26−import Control.Monad

27−import Server.Error

28−import qualified Data.Map as M

29−import Squeal.PostgreSQL.Schema

30−import Data.Limits

31−

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."

40−

41−type MessagesApi =

42− "chats" :> (

43− "getAll" :> GetAllChatsDescription :> ReqBody '[JSON] (PaginatingRequest MessageId (Maybe ())) :> Post '[JSON] (ResponseWithUsers [Dialog]) :<|>

44− "getGroupChat" :> GetGroupChatDescription :> ReqBody '[JSON] (GroupChatId) :> Post '[JSON] GroupChat :<|>

45− "updateGroupChat" :> GetUpdateGroupChatDescription :> ReqBody '[JSON] GroupChat :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>

46− "createGroupChat" :> CreateGroupChatDescription :> ReqBody '[JSON] GroupChatCreation :> Post '[JSON] GroupChatId :<|>

47− "leaveGroupChat" :> LeaveGroupChatDescription :> ReqBody '[JSON] GroupChatId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent) :<|>

48− "messages" :> (

49− "get" :> (

50− "groupChat" :> MessagesGetGroupChatDesctiption :> ReqBody '[JSON] (PaginatingRequest MessageId GroupChatId) :> Post '[JSON] [Message] :<|>

51− "userChat" :> MessagesGetUserChatDesctiption :> ReqBody '[JSON] (PaginatingRequest MessageId UserId) :> Post '[JSON] [Message]) :<|>

52− "send" :> MessagesSend :> ReqBody '[JSON] MessageCreation :> Post '[JSON] MessageId)

53−

54−

55−messagesServer :: UserId -> ServerT MessagesApi App

56−messagesServer uId =

57− (

58− getChats uId :<|>

59− getGroupChatInfo uId :<|>

60− updateGroupChatApi uId :<|>

61− createGroupChatApi uId :<|>

62− leaveChatAPI uId) :<|>

63− (getGroupChat uId :<|> getUserChat uId) :<|>

64− sendMessageApi uId

65−

66−

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

68−getChats uId req@(PaginatingRequest mId lim _ dir) = do

69− unless (validatePaginationRequest req) $ throwError lengthExceeded

70− runQerror $ getDialogs uId mId lim dir

71−

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

73−getGroupChat uId req@(PaginatingRequest mId lim gId dir) = do

74− unless (validatePaginationRequest req) $ throwError lengthExceeded

75− runQerror $ getMessagesInGroupChat uId gId mId lim dir

76−

77−getUserChat :: UserId -> PaginatingRequest MessageId UserId -> App [Message]

78−getUserChat uId req@(PaginatingRequest mId lim dId dir) = do

79− unless (validatePaginationRequest req) $ throwError lengthExceeded

80− runQerror $ getMessagesInUserChat uId dId mId lim dir

81−

82−getGroupChatInfo :: UserId -> GroupChatId -> App GroupChat

83−getGroupChatInfo uId gId = do

84− groupIsValid <- runQerror $ groupChatIsValidForUser uId gId

85− unless (groupIsValid) $ throwError impossibleContent

86− runQerror $ getGroupChatForUser uId gId

87−

88−updateGroupChatApi :: UserId -> GroupChat -> App NoContent

89−updateGroupChatApi uId group = do

90− unless (validateText group) $ throwError lengthExceeded

91− groupIsValid <- runQerror $ groupChatIsValidForUser uId (groupChatId group)

92− unless (groupIsValid) $ throwError impossibleContent

93− runQerror (updateGroupChat uId group) >> return NoContent

94−

95−sendMessageApi :: UserId -> MessageCreation -> App MessageId

96−sendMessageApi uId mes = do

97− unless (validateText mes) $ throwError lengthExceeded

98− runQerror $ sendMessage uId mes

99−

100−createGroupChatApi :: UserId -> GroupChatCreation -> App GroupChatId

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

102− unless (validateText group) $ throwError lengthExceeded

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

104− runQerror $ createGroupChat uId group

105−

106−leaveChatAPI :: UserId -> GroupChatId -> App NoContent

107−leaveChatAPI uId gId = do

108− groupIsValid <- runQerror $ groupChatIsValidForUser uId gId

109− unless (groupIsValid) $ throwError impossibleContent

110− runQerror (leaveGroupChat uId gId) >> return NoContent

denis/src/Server/API/Posts.hs+17−25

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

9module Server.API.Posts (

10 PostApi,

11− postApi

11+ postApi,

12+ UserPostsRequest

12) where

13) where

14import Servant.API

15import Servant.API

@@ -18,38 +19,29 @@ import Servant.Server

18import Data.Query

19import Data.Query

19import Data.User

20import Data.User

20import Data.Connection

21import Data.Connection

21−import Server.Query.Pagination

22+import Data.Word (Word64)

22−import Data.Limits

23−import Server.Error

23+import Server.LimitingRequest

24−import Control.Monad

25−import Data.Text.Validator

27-- MARK: Implementation

25-- MARK: Implementation

29−type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>

27+type UserPostsRequest = LimitingRequest UserId

30− "last" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe ())) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>

31− "forUser" :> ReqBody '[JSON] (PaginatingRequest P.PostId UserId) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>

32− "publish" :> ReqBody '[JSON] P.PostCreation :> Post '[JSON] P.PostId

29+type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] PostResponse :<|>

30+ "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] PostResponse :<|>

31+ "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] PostResponse :<|>

32+ "publish" :> ReqBody '[JSON] P.PostCreation :> Post '[JSON] P.PostId

33+

34postApi :: UserId -> ServerT PostApi App

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

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

37+getPostsApi :: [P.PostId] -> App PostResponse

38−getPostsApi req = do

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

40− maybeNotFound . runQnotFound . getPosts $ req

38+getPostsApi = maybeNotFound . runQnotFound . getPosts

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

40+lastPosts :: Word64 -> App PostResponse

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

44− unless (validatePaginationRequest req) $ throwError lengthExceeded

45− maybeNotFound . runQnotFound $ getLastPosts pId lim dir

41+lastPosts = maybeNotFound . runQnotFound . getLastPosts

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

43+getPostsForUserApi :: UserPostsRequest -> App PostResponse

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

49− unless (validatePaginationRequest req) $ throwError lengthExceeded

50− maybeNotFound . runQnotFound $ getPostsForUser pId lim dir uId

44+getPostsForUserApi (LimitingRequest uId lim) = maybeNotFound . runQnotFound $ getPostsForUser lim uId

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

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

53−publishPostApi uId creation = do

54− unless (validateText creation) $ throwError lengthExceeded

55− runQerror . publishPost uId $ creation

47+publishPostApi uId = runQerror . publishPost uId

denis/src/Server/App.hs+5−30

@@ -4,9 +4,7 @@

4 OverloadedLabels,

5 OverloadedStrings ,

6 TypeApplications ,

7− TypeOperators,

7+ TypeOperators #-}

8− TypeSynonymInstances,

9− FlexibleInstances #-}

11module Server.App (

9module Server.App (

12 App,

10 App,

@@ -14,9 +12,7 @@ module Server.App (

14 Config(..),

12 Config(..),

15 ask,

13 ask,

16 asks,

14 asks,

17− liftIO,

15+ liftIO

18− MailConfig(..),

19− fromMaybeThrow

20) where

16) where

22import Servant.Server

18import Servant.Server

@@ -25,33 +21,12 @@ import Squeal.PostgreSQL.Pool

25import Data.Schema

21import Data.Schema

26import Generics.SOP (K)

22import Generics.SOP (K)

27import Squeal.PostgreSQL.PQ (Connection)

23import Squeal.PostgreSQL.PQ (Connection)

28−import Crypto.RNG

24+import Control.Monad.IO.Class ()

29−import Server.Error

31−type App = ReaderT Config Handler

26+type App = ReaderT Config Handler

33type DBConnection = Pool (K Connection Schema)

28type DBConnection = Pool (K Connection Schema)

35data Config = Config {

30data Config = Config {

36− getPool :: !DBConnection,

31+ getPool :: DBConnection

37− cryptoState :: !CryptoRNGState,

38− selfRootUrl :: !String,

39− mailConfig :: !MailConfig

40}

32}

41−

42−data MailConfig = MailConfig {

43− mailHost :: !String,

44− mailPort :: !Int,

45− mailUser :: !String,

46− mailPassword :: !String

47−}

48−

49−instance CryptoRNG App where

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+48−344

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

7 ScopedTypeVariables,

8 TypeFamilies,

9 TypeOperators,

10− UndecidableInstances,

10+ UndecidableInstances #-}

11− DeriveAnyClass,

12− RecordWildCards #-}

13−{-# OPTIONS_GHC -Wno-orphans #-}

15module Server.Auth (

12module Server.Auth (

16 checkToken,

13 checkToken,

@@ -20,8 +17,7 @@ module Server.Auth (

20 logIn,

17 logIn,

21 contextProxy,

18 contextProxy,

22 AuthenticationCredits(..),

19 AuthenticationCredits(..),

23− authenticationAPI,

20+ authenticationAPI

24− TokenActivationData

25) where

21) where

27import Server.App

23import Server.App

@@ -32,6 +28,7 @@ import qualified Data.ByteString.Lazy.Char8 as L

32import Data.Query

28import Data.Query

33import Server.Error

29import Server.Error

34import Control.Monad.Except

30import Control.Monad.Except

31+import Text.Read (readMaybe)

35import Data.Connection

32import Data.Connection

36import Servant.Server.Experimental.Auth

33import Servant.Server.Experimental.Auth

37import Servant.API

34import Servant.API

@@ -43,336 +40,70 @@ import Data.Time.Calendar

43import Data.Proxy

40import Data.Proxy

44import qualified GHC.Generics as GHC

41import qualified GHC.Generics as GHC

45import Data.Aeson

42import Data.Aeson

46−import qualified Data.Aeson as A

47import Data.Binary.Builder (toLazyByteString)

43import Data.Binary.Builder (toLazyByteString)

48−import Servant.Docs

44+import Servant.Docs (ToSample, samples, toSamples)

49−import qualified Data.Text as T

50−import qualified Data.Text.Encoding as T

51−import Text.Regex

52−import qualified Data.ByteString.Base64.URL as BS

53−import Data.Maybe

54−import Server.Auth.Token

55−import Server.Auth.Mail

56−import Web.UAParser

57−import qualified Data.Text.Lazy as TL

58−import Server.Auth.HTML

59−import Data.Char

60−import Data.Text.Validator

62-- MARK: Documentation

46-- MARK: Documentation

64instance ToSample AuthenticationCredits where

48instance ToSample AuthenticationCredits where

65− toSamples _ = samples $ map AuthenticationCredits ["vchernyshev@hse.ru", "iikostyuchenko@hse.ru"]

49+ toSamples _ = samples $ map AuthenticationCredits [56, 103, 8]

66−

50+

67−instance ToSample UserLoginResponse where

68− toSamples _ = samples $ map UserLoginResponse [UserIsRegistered, UserCanRegister, InvalidUser]

69−

70−instance ToSample Int where

71− toSamples _ = samples [382934, 103845, 294905]

72−

73−instance ToSample UserCreation where

74− toSamples _ = samples $ [UserCreation "Seva" "Algebrovich" "Leonidov" "cs.hse.ru/dse/" "vchernyshev@hse.ru"]

75−

76−instance ToSample TokenActivationData where

77− toSamples _ = singleSample $ TokenActivationData 69 "ABCDE"

78−

79−instance ToSample TokenActivationResult where

80− toSamples _ = samples [TokenActivationResultYou, TokenActivationResultNotYou]

81−

82−instance ToParam (QueryParam' mods "data" String) where

83− toParam _ =

84− DocQueryParam "data"

85− ["AAABBBC="]

86− "The data recieved from the email."

87− Normal

88−

89−instance ToParam (QueryParam' mods "id" UserId) where

90− toParam _ =

91− DocQueryParam "id"

92− ["8"]

93− "The id of the user."

94− Normal

95−

96−instance ToSample Markup where

97− toSamples _ = noSamples

98−

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."

100−

101−type LogoutDescription = Description "Log out with the given cookie"

102−

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."

104−

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`."

106−

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."

108−

109−type ActivateDescription = Description "Activates a token using data from email"

110−

111−type DeactivateDescription = Description "Deactivates a token using data from email"

112−

113-- MARK: Implementation

51-- MARK: Implementation

114

115−type AuthenticationHandler =

53+type AuthenticationHandler =

116− "login" :> LoginDescription :>

54+ "login" :>

117− ReqBody '[JSON] AuthenticationCredits :>

55+ ReqBody '[JSON] AuthenticationCredits :>

118− Header "User-Agent" String :>

119− Post '[JSON] (Headers '[Header "Set-Cookie" String] UserLoginResponse) :<|>

56+ Post '[JSON] (Headers '[Header "Set-Cookie" String] UserId) :<|>

120− "logout" :> LogoutDescription

57+ "logout" :>

121− :> Header "cookie" String

122− :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent) :<|>

58+ PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)

123− "verify" :> VerifyDescription :>

124− Header "cookie" String :> ReqBody '[JSON] Int :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>

125− "register" :> RegisterDescription :>

126− ReqBody '[JSON] UserCreation :>

127− Header "User-Agent" String :>

128− PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent) :<|>

129− "checkCookie" :> CheckCookieDescription :>

130− Header "cookie" String :> GetNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>

131− "activate" :> ActivateDescription

132− :> Header "cookie" String

133− :> ReqBody '[JSON] TokenActivationData

134− :> Post '[JSON] TokenActivationResult :<|>

135− "deactivate" :> DeactivateDescription

136− :> ReqBody '[JSON] TokenActivationData

137− :> PostNoContent '[JSON] NoContent :<|>

138− "activateUser"

139− :> QueryParam "id" UserId

140− :> QueryParam "data" String

141− :> Get '[HTML] Markup :<|>

142− "deactivateUser"

143− :> QueryParam "id" UserId

144− :> QueryParam "data" String

145− :> Get '[HTML] Markup

146−

147−data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser

148− deriving (Show)

149−

150−instance ToJSON UserResponseStatus where

151− toJSON UserIsRegistered = "registered"

152− toJSON UserCanRegister = "canRegister"

153− toJSON InvalidUser = "invalid"

154−

155−data UserLoginResponse = UserLoginResponse {

156− userStatus :: UserResponseStatus

157−} deriving (Show, GHC.Generic, ToJSON)

158−

159−data AuthenticationCookieData = AuthenticationCookieData {

160− cookieUserId :: UserId,

161− cookieUserToken :: BS.ByteString

162−} deriving (Show, GHC.Generic, ToJSON, FromJSON)

163−

164−data TokenActivationData = TokenActivationData {

165− tokenVerificationUserId :: UserId,

166− tokenVerificationData :: BS.ByteString

167−} deriving (Show, GHC.Generic)

168−

169−instance ToJSON TokenActivationData where

170− toJSON (TokenActivationData uId vData) = object [

171− "id" .= uId,

172− "data" .= vData

173− ]

174−

175−instance FromJSON TokenActivationData where

176− parseJSON = withObject "token verification data" $ \ e ->

177− TokenActivationData <$> e .: "id" <*> e .: "data"

178−

179−data TokenActivationResult = TokenActivationResultYou | TokenActivationResultNotYou

180

181−instance ToJSON TokenActivationResult where

60+newtype AuthenticationCredits = AuthenticationCredits {authenticationId :: UserId}

182− toJSON TokenActivationResultYou = object ["you" .= True]

61+ deriving GHC.Generic

183− toJSON TokenActivationResultNotYou = object ["you" .= False]

184

185−instance ToJSON BS.ByteString where

63+instance ToJSON AuthenticationCredits

186− toJSON = A.String . T.decodeUtf8 . BS.encode

187−

188−instance FromJSON BS.ByteString where

64+instance FromJSON AuthenticationCredits

189− parseJSON (A.String s) = case (BS.decode . T.encodeUtf8) s of

190− Left e -> fail e

191− Right v -> return v

192− parseJSON _ = fail "Couldn't deserialise ByteString"

193−

194−newtype AuthenticationCredits = AuthenticationCredits {authenticationEmail :: UserEmail}

195− deriving (GHC.Generic, ToJSON, FromJSON)

196−

197−activateUser :: Maybe UserId -> Maybe String -> App Markup

198−activateUser Nothing _ = return $ page "The link is invalid."

199−activateUser _ Nothing = return $ page "The link is invalid."

200−activateUser (Just uId) (Just aData') = catchErrorPage $ do

201− case BS.decode . C.pack $ aData' of

202− Left _ -> return $ page $ "The link is invalid."

203− Right aData -> do

204− tokenData' <- runQerror $ tryActivateToken uId aData

205− case tokenData' of

206− Nothing -> return $ page "This activation link has been invalidated."

207− Just Token{..} -> return $ genActivationPage "in" tokenUserAgent

208−

209−deactivateUser :: Maybe UserId -> Maybe String -> App Markup

210−deactivateUser Nothing _ = return $ page "The link is invalid."

211−deactivateUser _ Nothing = return $ page "The link is invalid."

212−deactivateUser (Just uId) (Just dData') = catchErrorPage $ do

213− case BS.decode . C.pack $ dData' of

214− Left _ -> return $ page $ "The link is invalid."

215− Right dData -> do

216− ua' <- runQerror $ deactivateToken uId dData

217− case ua' of

218− Nothing -> return $ page "This deactivation link has been invalidated."

219− Just ua -> return $ genActivationPage "out" ua

220−

221−catchErrorPage :: App Markup -> App Markup

222−catchErrorPage = flip catchError $ \ (_ :: ServantErr) -> return errorPage

223

224authenticationAPI :: ServerT AuthenticationHandler App

66authenticationAPI :: ServerT AuthenticationHandler App

67+authenticationAPI = logIn :<|> logOut

226−

68+

227−logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)

69+logIn :: AuthenticationCredits -> App (Headers '[Header "Set-Cookie" String] UserId)

228−logIn (AuthenticationCredits email') ua' = do

70+logIn (AuthenticationCredits uId) = do

229− let email = T.toLower . T.strip $ email'

71+ expire <- liftIO $ fmap (addUTCTime (1 * 24 * 60 * 60)) getCurrentTime -- one days

230− if (not . validateEmail) email

72+ tId <- fmap userId . runQ err404 . getUser $ uId

231− then return . noHeader $ UserLoginResponse InvalidUser

73+ let cookie = defaultSetCookie {

232− else do

233− user <- runQerror $ getUserWithEmail email

234− case user of

235− Nothing -> return . noHeader $ UserLoginResponse UserCanRegister

236− Just User{..} -> do

237− let ua = getUserAgent ua'

238− GeneratedToken token value code activation deactivation <- generateToken userId ua

239− runQerror . createToken $ token

240− let cookie = generateCookie token value

241− sendTokenVerificationEmail code userId (BS.encode activation) (BS.encode deactivation) (TL.fromStrict ua) email

242− return . addHeader cookie $ UserLoginResponse UserIsRegistered

243−

244−generateCookie :: Token -> BS.ByteString -> String

245−generateCookie token value = L.unpack . toLazyByteString . renderSetCookie $ defaultSetCookie {

246− setCookieName = cookieTokenKey,

74+ setCookieName = cookieTokenKey,

247− setCookieValue = L.toStrict . encode $ AuthenticationCookieData (tokenUserId token) value,

75+ setCookieValue = C.pack $ show tId,

248− setCookieExpires = Just (tokenExpiryDate token),

249− setCookiePath = Just "/",

250− setCookieHttpOnly = True,

251− setCookieSecure = True }

252−

253−getCookie :: String -> Maybe AuthenticationCookieData

254−getCookie = (>>= (decode . L.fromStrict)) . lookup cookieTokenKey . parseCookies . C.pack

255−

256−checkCookie :: Maybe String -> App NoContent

257−checkCookie cookie = do

258− let token = cookie >>= getCookie

259− case token of

260− Nothing -> throwError err401

261− Just _ -> return NoContent

262−

263−verifyToken :: Maybe String -> Int -> App NoContent

264−verifyToken Nothing _ = throwError err400

265−verifyToken (Just cookie) code = do

266− let mbToken = getCookie cookie

267− case mbToken of

268− Nothing -> throwError err400

269− (Just (AuthenticationCookieData uId tokenData)) -> do

270− token <- runQ invalidToken $ tryVerifyToken uId tokenData code

271− case token of

272− Just _ -> return NoContent

273− Nothing -> throwError err403

274−

275−logOut :: Maybe String -> App (Headers '[Header "Set-Cookie" String] NoContent)

276−logOut cookie = do

277− _ <- fromMaybe (return ()) $ do

278− AuthenticationCookieData uId tokenData <- cookie >>= getCookie

279− return . runQsilent $ invalidateToken uId tokenData

280− let newCookie = defaultSetCookie {

281− setCookieName = cookieTokenKey,

282− setCookieValue = "invalid",

283− setCookieExpires = Just (UTCTime (ModifiedJulianDay 0) 0),

76+ setCookieExpires = Just expire,

284 setCookiePath = Just "/" }

77 setCookiePath = Just "/" }

285− return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ newCookie) NoContent

78+ return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) tId

286−

79+

287−validateTokenApi :: Maybe String -> TokenActivationData -> App TokenActivationResult

80+logOut :: App (Headers '[Header "Set-Cookie" String] NoContent)

288−validateTokenApi cookie' (TokenActivationData uId aData) = do

81+logOut =

289− tokenData' <- runQerror $ tryActivateToken uId aData

82+ let cookie = defaultSetCookie {

290− case tokenData' of

83+ setCookieName = cookieTokenKey,

291− Nothing -> throwError err401

84+ setCookieValue = "invalid",

292− Just Token{..} -> do

85+ setCookieExpires = Just (UTCTime (ModifiedJulianDay 0) 0),

293− case cookie' >>= getCookie of

86+ setCookiePath = Just "/" }

294− Nothing -> return TokenActivationResultNotYou

87+ in return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) NoContent

295− Just (AuthenticationCookieData uId' cData) ->

296− if hash cData == tokenValue && uId' == tokenUserId

297− then return TokenActivationResultYou

298− else return TokenActivationResultNotYou

299−

300−deactivateTokenApi :: TokenActivationData -> App NoContent

301−deactivateTokenApi (TokenActivationData uId dData) = do

302− res <- runQerror $ deactivateToken uId dData

303− if isJust res

304− then return NoContent

305− else throwError err401

306

307−checkToken :: DBConnection -> AuthenticationCookieData -> Handler UserId

89+checkToken :: DBConnection -> BS.ByteString -> Handler UserId

308−checkToken conn (AuthenticationCookieData uId tokenData) = do

90+checkToken conn token = do

309− token <- runQ' conn err500 $ getVerifiedToken uId tokenData

310− case token of

91+ uId <- case ((readMaybe . C.unpack) token :: Maybe UserId) of

92+ Just uId -> return uId

311 Nothing -> throwError invalidToken

93 Nothing -> throwError invalidToken

312− Just (Token newUId _ _ _ _ _ _ _) -> return newUId

94+ fmap userId . runQ' conn invalidToken . getUser $ uId

313−

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

315−register creation' ua' = do

316− let creation = normalizaUser creation'

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

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

319− unless validFaculty $ throwError impossibleContent

320− genToken <- generateTokenM

321− let ua = getUserAgent ua'

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

323− uId <- createUser creation

324− let gToken = genToken uId ua

325− createToken . generatedToken $ gToken

326− return gToken

327− sendTokenVerificationEmail code (tokenUserId token) (BS.encode activation) (BS.encode deactivation) (TL.fromStrict ua) (userCreationUserEmail creation)

328− let cookie = generateCookie token value

329− return $ addHeader cookie NoContent

330−

331−getUserAgent :: Maybe String -> T.Text

332−getUserAgent uaData' = fromMaybe "Unknown" $ do

333− uaData <- fmap C.pack uaData'

334− let os = osrFamily <$> parseOS uaData

335− let browser = uarFamily <$> parseUA uaData

336− foldl (mappendMaybeThrough " — ") Nothing $ [os, browser]

337− where

338− mappendMaybeThrough :: (Semigroup a) => a -> Maybe a -> Maybe a -> Maybe a

339− mappendMaybeThrough _ Nothing (Just a) = Just a

340− mappendMaybeThrough _ (Just a) Nothing = Just a

341− mappendMaybeThrough i (Just a) (Just b) = Just (a <> i <> b)

342− mappendMaybeThrough _ Nothing Nothing = Nothing

343−

344−normalizaUser :: UserCreation -> UserCreation

345−normalizaUser (UserCreation fName mName lName faculty email) =

346− UserCreation

347− (T.strip fName)

348− (T.strip mName)

349− (T.strip lName)

350− (T.toLower . T.strip $ faculty)

351− (T.toLower . T.strip $ email)

352−

353−validateUser :: UserCreation -> Bool

354−validateUser (UserCreation fName mName lName faculty email) =

355− (not . T.null) fName &&

356− (not . T.null) mName &&

357− (not . T.null) lName &&

358− (not . T.null) faculty &&

359− validateEmail email

360

361authHandler :: DBConnection -> AuthHandler Request UserId

96authHandler :: DBConnection -> AuthHandler Request UserId

362authHandler conn = mkAuthHandler handler

97authHandler conn = mkAuthHandler handler

363 where

98 where

99+ maybeToEither = maybe (Left ()) Right

100+ throw = const $ throwError invalidToken

364− handler req = do

101+ handler req = either throw (checkToken conn) $ do

365− let cookie' = lookup "cookie" $ requestHeaders req

102+ cookie <- maybeToEither $ lookup "cookie" $ requestHeaders req

366− case cookie' of

367− Nothing -> throwError (invalidToken)

368− (Just cookie) -> do

369− let mbToken = (>>= (decode . L.fromStrict)) . lookup cookieTokenKey $ parseCookies cookie

103+ maybeToEither $ lookup cookieTokenKey $ parseCookies cookie

370− case mbToken of

371− Nothing -> throwError invalidToken

372− Just t -> checkToken conn t

373

104

374cookieTokenKey :: BS.ByteString

105cookieTokenKey :: BS.ByteString

375−cookieTokenKey = "valera-denis-auth-cookie"

106+cookieTokenKey = "servant-auth-cookie"

376

107

377type instance AuthServerData (AuthProtect "basicAuth") = UserId

108type instance AuthServerData (AuthProtect "basicAuth") = UserId

378

109

@@ -380,31 +111,4 @@ genAuthServerContext :: DBConnection -> Context (AuthHandler Request UserId ': '

380genAuthServerContext conn = authHandler conn :. EmptyContext

111genAuthServerContext conn = authHandler conn :. EmptyContext

381

112

382contextProxy :: Proxy '[AuthHandler Request UserId]

113contextProxy :: Proxy '[AuthHandler Request UserId]

383−contextProxy = Proxy

114+contextProxy = Proxy

384−

385−validateEmail :: T.Text -> Bool

386−validateEmail "ilyakooo0@gmail.com" = True

387−validateEmail "rednikina.com@yandex.ru" = True

388−validateEmail "admikhaleva@edu.hse.ru" = True

389−validateEmail e = if all validChar email

390− then ((isJust . matchRegex regex $ email) || (isJust . matchRegex falseRegex $ email))

391− else False

392− where

393− email = T.unpack $ e

394− regex = mkRegexWithOpts

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

396− False

397− False

398− falseRegex = mkRegexWithOpts

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

400− False

401− False

402−

403−validChar :: Char -> Bool

404−validChar c = isAscii c && isPrint c

405−

406−-- checkString :: String -> App String

407−-- checkString s =

408−-- if any invalidChar s

409−-- then throwError formatError

410−-- else return s

denis/src/Server/Auth/HTML.hsdeleted−49

@@ -1,49 +0,0 @@

1−{-# LANGUAGE DataKinds,

2− DeriveGeneric,

3− FlexibleContexts,

4− FlexibleInstances,

5− MultiParamTypeClasses,

6− OverloadedStrings,

7− ScopedTypeVariables,

8− TypeFamilies,

9− TypeOperators,

10− UndecidableInstances,

11− DeriveAnyClass,

12− RecordWildCards #-}

13−

14−module Server.Auth.HTML (

15− HTML,

16− genActivationPage,

17− Markup,

18− errorPage,

19− page

20− ) where

21−

22−import Servant.HTML.Blaze

23−import Text.Blaze.Html5 as H

24−import Text.Blaze.XHtml5.Attributes as A

25−import Data.Text (Text)

26−

27−genActivationPage :: Text -> Text -> Markup

28−genActivationPage verb ua = genPage $ do

29− "You have successfully "

30− u $ do

31− "logged "

32− toHtml verb

33− " on "

34− u $ toHtml ua

35−

36−

37−genPage :: Markup -> Markup

38−genPage pageContent = html $ do

39− H.head $ do

40− meta ! name "viewport" ! content "width=device-width, initial-scale=1"

41− body ! A.style "font-family: sans-serif; background-color: #f8f8f8" $ do

42− H.div ! A.style "text-align: center; margin-top: 20vh; margin-left: 10%; margin-right: 10%" $ do

43− H.div ! A.style "font-size: 40px; font-weight: bold;" $ pageContent

44−

45−errorPage :: Markup

46−errorPage = genPage $ "Sorry, something went wrong."

47−

48−page :: Text -> Markup

49−page t = genPage $ toHtml t

denis/src/Server/Auth/Mail.hsdeleted−71

@@ -1,71 +0,0 @@

1−{-# LANGUAGE DataKinds,

2− DeriveGeneric,

3− FlexibleContexts,

4− FlexibleInstances,

5− MultiParamTypeClasses,

6− OverloadedStrings,

7− ScopedTypeVariables,

8− TypeFamilies,

9− TypeOperators,

10− UndecidableInstances,

11− DeriveAnyClass,

12− RecordWildCards #-}

13−{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

14−

15−module Server.Auth.Mail (

16− sendTokenVerificationEmail

17− ) where

18−

19−import Network.Mail.SMTP

20−import Server.App

21−import Server.Auth.Token

22−import Control.Monad.IO.Class

23−import Network.Mail.Mime (Mail, Part)

24−import Data.Text (Text)

25−import qualified Data.Text.Lazy as TL

26−import Text.Blaze.Html5 as H

27−import Text.Blaze.XHtml5.Attributes as A

28−import Text.Blaze.Html.Renderer.Text

29−import Data.ByteString (ByteString)

30−import Data.User

31−import Data.ByteString.Char8 (unpack)

32−

33−sendTokenVerificationEmail :: TokenVerificationCode -> UserId -> ByteString -> ByteString -> TL.Text -> Text -> App ()

34−sendTokenVerificationEmail userCode uId activation deactivation ua email = do

35− cfg <- ask

36− let mailCfg = mailConfig cfg

37− let rootUrl = selfRootUrl cfg

38− let mail = simpleMail

39− (Address (Just "HSE Social Network") "noreply@hse.ru")

40− [Address Nothing email] [] []

41− "HSE Social Network Verification Code"

42− [genMail rootUrl userCode uId (unpack activation) (unpack deactivation) ua]

43− sendMailWithConfig mailCfg mail

44−

45−sendMailWithConfig :: (MonadIO m) => MailConfig -> Mail -> m ()

46−sendMailWithConfig (MailConfig host port user pass) =

47− liftIO . sendMailWithLogin' host (fromIntegral port) user pass

48−

49−genMail :: String -> TokenVerificationCode -> UserId -> String -> String -> TL.Text -> Part

50−genMail rootUrl userCode uId activation deactivation ua = htmlPart . renderHtml $ html $ body ! A.style "font-family: sans-serif;" $ do

51− H.div ! A.style "display: none; max-height: 0px; overflow: hidden;" $ do

52− "Verification code: " <> toHtml ua

53− br

54− toHtml [a', b', ' ', c', d', ' ', e', f']

55− H.div ! A.style "display: none; max-height: 0px; overflow: hidden;" $ " "

56− H.div ! A.style "text-align: center; margin-top: 55px;" $ do

57− H.a ! href (stringValue $ rootUrl <> "/authentication/activateUser?id=" <> show uId <> "&data=" <> activation) ! A.style "font-size: 34px; font-weight: bold; display: inline-block; padding: 7px 13px 7px 13px; margin-bottom: 89px; text-decoration: underline; font-family: sans-serif; color: #555;" $ "Log in"

58− br

59− H.div ! A.style "font-size: 34px; font-weight: bold;" $ do

60− H.span ! A.style "color: #bbb; font-weight: bold;" $ "from: "

61− toHtml ua

62− br

63− H.div ! A.style "font-size: 55px; font-weight: bold; border-radius: 10px; background-color: #eee; display: inline-block; padding: 7px 13px 7px 13px; box-shadow: 0px 5px 21px #bbb; background-image: linear-gradient(#f9f9f9, #eee);" $ do

64− toHtml [a', b']

65− H.div ! A.style "display: inline-block; width: 13px;" $ mempty

66− toHtml [c', d']

67− H.div ! A.style "display: inline-block; width: 13px;" $ mempty

68− toHtml [e', f']

69− H.div ! A.style "text-align: center; margin-top: 233px;" $ H.a ! href (stringValue $ rootUrl <> "/authentication/deactivateUser?id=" <> show uId <> "&data=" <> deactivation) ! A.style "text-decoration: underline; font-family: sans-serif; color: #555;font-size: 13px; margin-bottom: 21px;" $ "Revoke access"

70− where

71− [a', b', c', d', e', f'] = reverse . take 6 . (++ repeat '0') . reverse . show $ userCode

denis/src/Server/Auth/Token.hsdeleted−76

@@ -1,76 +0,0 @@

1−{-# LANGUAGE DataKinds,

2− DeriveGeneric,

3− FlexibleContexts,

4− FlexibleInstances,

5− MultiParamTypeClasses,

6− OverloadedStrings,

7− ScopedTypeVariables,

8− TypeFamilies,

9− TypeOperators,

10− DeriveAnyClass #-}

11−

12−module Server.Auth.Token (

13− Token(..),

14− generateToken,

15− TokenVerificationCode,

16− generateTokenM,

17− hashVerificationCode,

18− GeneratedToken(..),

19− hash

20− ) where

21−

22−import Data.Time.Clock

23−import Data.ByteString

24−import Data.User

25−import qualified Generics.SOP as SOP

26−import qualified GHC.Generics as GHC

27−import Data.Int

28−import Control.Monad.IO.Class

29−import Crypto.RNG

30−import Data.Text (Text)

31−import Crypto.Hash.SHA512

32−import qualified Data.ByteString.Char8 as C

33−

34−type TokenVerificationCode = Int

35−

36−data GeneratedToken = GeneratedToken {

37− generatedToken :: Token,

38− generatedTokenValue :: ByteString,

39− generatedVerificationCode :: Int,

40− generatedActivationCode :: ByteString,

41− generatedDeactivationCode :: ByteString

42−}

43−

44−data Token = Token {

45− tokenUserId :: UserId,

46− tokenValue :: ByteString,

47− tokenExpiryDate :: UTCTime,

48− tokenVerificationCode :: Maybe ByteString,

49− tokenActivationTriesLeft :: Int32,

50− tokenUserAgent :: Text,

51− tokenActivationCode :: Maybe ByteString,

52− tokenDeactivationCode :: ByteString

53−} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

54−

55−generateToken :: (MonadIO m, CryptoRNG m) => UserId -> Text -> m GeneratedToken

56−generateToken uId ua = do

57− gen <- generateTokenM

58− return $ gen uId ua

59−

60−generateTokenM :: (MonadIO m, CryptoRNG m) => m (UserId -> Text -> GeneratedToken)

61−generateTokenM = do

62− token <- randomBytes 64

63− activationToken <- randomBytes 64

64− deactivationToken <- randomBytes 64

65− code <- randomR (0, 999999)

66− expire <- liftIO $ fmap (addUTCTime (nominalDay * 365)) getCurrentTime -- one year

67− return $ \ uId ua -> GeneratedToken {

68− generatedToken = Token uId (hash token) expire (Just . hashVerificationCode $ code) 10 ua (Just . hash $ activationToken) (hash deactivationToken),

69− generatedTokenValue = token,

70− generatedVerificationCode = code,

71− generatedActivationCode = activationToken,

72− generatedDeactivationCode = deactivationToken

73− }

74−

75−hashVerificationCode :: Int -> ByteString

76−hashVerificationCode = hash . C.pack . show

denis/src/Server/Error.hs+3−42

@@ -1,54 +1,15 @@

1{-# LANGUAGE OverloadedStrings #-}

3module Server.Error (

4− invalidToken,

4+ invalidToken

5− amountExceeded,

6− lengthExceeded,

7− formatError,

8− impossibleContent,

9− throwError

10−) where

5+) where

12import Servant.Server

7import Servant.Server

13−import Control.Monad.Except

15invalidToken :: ServantErr

9invalidToken :: ServantErr

16invalidToken = ServantErr {

10invalidToken = ServantErr {

17 errHTTPCode = 498,

11 errHTTPCode = 498,

18 errReasonPhrase = "Invalid Token",

12 errReasonPhrase = "Invalid Token",

19− errBody = "",

13+ errBody = "The supplied token is invalid",

20 errHeaders = []

14 errHeaders = []

21}

15}

22−

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 = []

37−}

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/LimitingRequest.hsnew file+29

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

1+{-# LANGUAGE OverloadedStrings #-}

3+module Server.LimitingRequest (

4+ LimitingRequest(..)

5+) where

7+import Data.Word (Word64)

8+import Servant.Docs (ToSample, toSamples, samples)

9+import Data.Aeson

10+import Data.Proxy

11+

12+instance (ToSample r) => ToSample (LimitingRequest r) where

13+ toSamples _ = samples $ LimitingRequest <$> (map snd $ toSamples Proxy) <*> [1, 11, 17]

14+

15+

16+data LimitingRequest r = LimitingRequest {

17+ requestRequest :: r,

18+ requestLimit :: Word64

19+}

20+

21+instance (ToJSON r) => ToJSON (LimitingRequest r) where

22+ toJSON (LimitingRequest r l) = object [

23+ "request" .= r,

24+ "limit" .= l ]

25+

26+instance (FromJSON r) => FromJSON (LimitingRequest r) where

27+ parseJSON = withObject "limiting request" $ \e ->

28+ LimitingRequest <$> e .: "request" <*> e .: "limit"

29+

denis/src/Server/Logger.hs+4−11

@@ -1,10 +1,7 @@

1{-# LANGUAGE DataKinds,

2 TypeOperators,

3 OverloadedStrings,

4− ScopedTypeVariables,

4+ ScopedTypeVariables #-}

5− TypeSynonymInstances,

6− FlexibleInstances #-}

7−{-# OPTIONS_GHC -Wno-orphans #-}

9module Server.Logger (

6module Server.Logger (

10 Logger,

7 Logger,

@@ -25,10 +22,6 @@ import Server.App

25import Network.Wai.Middleware.RequestLogger

22import Network.Wai.Middleware.RequestLogger

26import Data.Default.Class

23import Data.Default.Class

27import qualified System.Log.FastLogger as FL

24import qualified System.Log.FastLogger as FL

28−import Servant.Docs

29−

30−instance HasDocs "log" where

31− docsFor _ _ _ = emptyAPI

33type Log = T.Text

26type Log = T.Text

@@ -45,11 +38,11 @@ getLog :: TVar (CyclicBuffer BL.ByteString) -> Logger

45getLog buff = decodeUtf8 . BL.concat . intersperse "\n" . elems <$> liftIO (readTVarIO buff)

38getLog buff = decodeUtf8 . BL.concat . intersperse "\n" . elems <$> liftIO (readTVarIO buff)

47mkWaiLogger :: TVar (CyclicBuffer BL.ByteString) -> IO Middleware

40mkWaiLogger :: TVar (CyclicBuffer BL.ByteString) -> IO Middleware

48−mkWaiLogger buff = let

41+mkWaiLogger buff = let

49 settings = def {

42 settings = def {

50− -- outputFormat = CustomOutputFormatWithDetails (\ date req _ _ tDiff bss bldr ->

43+ -- outputFormat = CustomOutputFormatWithDetails (\ date req _ _ tDiff bss bldr ->

51 -- FL.toLogStr (show date) <> (FL.toLogStr . unpack $ fold bss))

44 -- FL.toLogStr (show date) <> (FL.toLogStr . unpack $ fold bss))

52 outputFormat = Detailed False,

45 outputFormat = Detailed False,

53− destination = Callback (atomically . modifyTVar buff . flip insertIntoCyclicBuffer . FL.fromLogStr)

46+ destination = Callback (atomically . modifyTVar buff . flip insertIntoCyclicBuffer . FL.fromLogStr)

54 }

47 }

55 in mkRequestLogger settings

48 in mkRequestLogger settings

denis/src/Server/Periodic.hsdeleted−29

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

1−module Server.Periodic (

2− periodically,

3− seconds,

4− minutes,

5− hours

6− ) where

7−

8−import Control.Monad.IO.Class

9−import Control.Concurrent

10−import System.Random

11−import Control.Monad

12−

13−seconds :: Int

14−seconds = 1000000

15−

16−minutes :: Int

17−minutes = 60 * seconds

18−

19−hours :: Int

20−hours = 60 * minutes

21−

22−periodically :: (MonadIO m) => Int -> IO () -> m ThreadId

23−periodically delay action = liftIO $ do

24− forkIO $ do

25− initialDelay <- randomRIO (0, delay)

26− threadDelay initialDelay

27− forever $ do

28− action

29− threadDelay delay

denis/src/Server/Query/ComplexQuery.hsdeleted−138

@@ -1,138 +0,0 @@

1−{-# LANGUAGE

2− FlexibleInstances,

3− DataKinds,

4− TypeOperators,

5− OverloadedStrings,

6− ScopedTypeVariables,

7− MultiParamTypeClasses,

8− KindSignatures,

9− TypeFamilies,

10− LambdaCase,

11− PartialTypeSignatures,

12− TupleSections,

13− DeriveGeneric #-}

14−

15−{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

16−{-# OPTIONS_GHC -Wno-orphans #-}

17−

18−module Server.Query.ComplexQuery (

19− ComplexQuery

20−) where

21−

22−import Data.ByteString.Lazy (ByteString)

23−import Data.ByteString.Builder (toLazyByteString)

24−import qualified Data.ByteString.Lazy.Char8 as BSC

25−import qualified Data.ByteString.Char8 as BC

26−import Servant.Server

27−import Data.Proxy

28−import Servant.API

29−import Servant.Server.Internal

30−import qualified Data.Text as T

31−import GHC.Conc

32−import Network.Wai.Internal

33−import Control.Monad.IO.Class

34−import Control.Concurrent.STM.TVar

35−import Data.IORef (newIORef,modifyIORef',readIORef)

36−import Network.Wai

37−import Control.Monad

38−import Control.Monad.Error.Class

39−import Servant.Docs hiding (Response)

40−import qualified Data.Map as M

41−import Data.Text.Encoding (decodeUtf8)

42−import Data.Aeson

43−import GHC.Generics

44−

45−-- MARK: Documentation

46−

47−instance (HasDocs api) => HasDocs (ComplexQuery :> api) where

48− docsFor _ = docsFor (Proxy :: Proxy (ComplexApi :<|> api))

49−

50−instance {-# Overlapping #-} ToSample [ComplexQueryRequest] where

51− toSamples _ = singleSample $ [ComplexQueryRequest "channels/" "", ComplexQueryRequest "posts/last" "3"]

52−

53−instance {-# Overlapping #-} ToSample [ComplexQueryRepsonse] where

54− toSamples _ = singleSample $ map ComplexQueryRepsonse ["[{\"people\":[1],\"name\":\"newChannelName\",\"id\":7,\"tags\":[]},{\"people\":[1],\"name\":\"newChannelName\",\"id\":6,\"tags\":[]},{\"people\":[1],\"name\":\"newChannelName\",\"id\":5,\"tags\":[]},{\"people\":[1,1,2,2,2],\"name\":\"sssss\",\"id\":4,\"tags\":[\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsHashTag\",\"thisIsAlsoHashTag\",\"cs\"]},{\"people\":[1,7,2,19],\"name\":\"соытвототтоциология\",\"id\":1,\"tags\":[\"sos\"]}]","{\"users\":{\"1\":{\"middleName\":\"FirstUser\",\"lastName\":\"FirstUser\",\"firstName\":\"FirstUser\",\"id\":1}},\"response\":[{\"body\":[{\"markdown\":\"hello\"}],\"authorId\":1,\"id\":28,\"updated\":\"2019-04-13T16:14:38.495832Z\",\"tags\":[]},{\"body\":[{\"markdown\":\"Hello, blyat\"}],\"authorId\":1,\"id\":27,\"updated\":\"2005-01-03T12:34:56Z\",\"tags\":[]}]}"]

55−

56−-- MARK: Implementation

57−

58−data ComplexQuery

59−

60−

61−data ComplexQueryRequest = ComplexQueryRequest {

62− url :: T.Text,

63− body :: String

64−} deriving (Generic)

65−

66−instance ToJSON ComplexQueryRequest

67−instance FromJSON ComplexQueryRequest

68−

69−newtype ComplexQueryRepsonse = ComplexQueryRepsonse {responseText :: T.Text}

70−

71−instance ToJSON ComplexQueryRepsonse where

72− toJSON = toJSON . responseText

73−

74−type ComplexQueryDescription = Description "Complex query\n\nAllows you to query several endpoints within one request.\n\nResponses are returned in the same order as the requests are sent.\n\nThe order of query execution is not determined. If one of the queries returns a non-2XX response, the first such response is returned.\n\n## Do not perform modifications in this query. You will have no way of telling whether it succeeded."

75−

76−type ComplexApi = "complex" :> ComplexQueryDescription :> ReqBody '[JSON] ([ComplexQueryRequest]) :> Post '[JSON] [ComplexQueryRepsonse]

77−

78−instance HasServer api context => HasServer (ComplexQuery :> api :: *) context where

79−

80− type ServerT (ComplexQuery :> api) m = ServerT api m

81−

82− hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)

83−

84− route _ context subserver = choice complex rest

85− where

86− rest = route (Proxy :: Proxy api) context subserver

87− complexProxy = Proxy :: Proxy (ComplexApi)

88− complexServer :: _ -> Request -> [ComplexQueryRequest] -> Handler [ComplexQueryRepsonse]

89− complexServer env req query = do

90− responses <- liftIO . newTVarIO $ Right M.empty

91− recieved <- liftIO $ forM (zip [0..] query) $ uncurry $ \queryIndex (ComplexQueryRequest queryPath queryBody) -> do

92− newReq <- replaceBody (BSC.pack queryBody) req

93− serverRest (replacePath queryPath newReq) $ respond responses queryIndex

94− recieved `seq` do

95− result <- liftIO $ readTVarIO responses

96− case result of

97− Left err -> throwError err

98− Right resp -> sequence . map (fmap ComplexQueryRepsonse . throwMaybe . flip M.lookup resp) $ [0..((length query) - 1)]

99− where

100− serverRest = runRouterEnv (route (Proxy :: Proxy api) context subserver) env

101− respond :: TVar (Either ServantErr (M.Map Int T.Text)) -> Int -> RouteResult Response -> IO ResponseReceived

102− respond responses queryIndex = (>> return ResponseReceived) .

103− \case

104− (Fail err) -> atomically . writeTVar responses $ Left err

105− (FailFatal err) -> atomically . writeTVar responses $ Left err

106− (Route r) -> do

107− rBody <- decodeUtf8 . BSC.toStrict <$> responseBody r

108− atomically . modifyTVar responses $ fmap (M.insert queryIndex rBody)

109− throwMaybe :: Maybe a -> Handler a

110− throwMaybe Nothing = throwError err500

111− throwMaybe (Just a) = return a

112− complex = RawRouter $ \env req ->

113− (flip runRouterEnv env $ route complexProxy context (emptyDelayed (Route $ complexServer env req))) req

114−

115−-- ref: https://stackoverflow.com/questions/45467648/how-to-read-response-body-in-wai-middleware

116−responseBody :: Response -> IO ByteString

117−responseBody res =

118− let (_,_,rBody) = responseToStream res in

119− rBody $ \f -> do

120− content <- newIORef mempty

121− f (\chunk -> modifyIORef' content (<> chunk)) (return ())

122− toLazyByteString <$> readIORef content

123−

124−replaceBody :: ByteString -> Request -> IO Request

125−replaceBody newB resp = do

126− t <- newTVarIO True

127− return resp {

128− requestBody = do

129− v <- atomically $ do

130− oldValue <- readTVar t

131− writeTVar t False

132− return oldValue

133− return $ if v then BSC.toStrict newB else BC.empty

134− }

135−

136−replacePath :: T.Text -> Request -> Request

137−replacePath newPath req = req {

138− pathInfo = T.splitOn "/" newPath}

denis/src/Server/Query/Dialog.hsdeleted−76

@@ -1,76 +0,0 @@

1−{-# LANGUAGE

2− OverloadedStrings,

3− DeriveGeneric #-}

4−

5−module Server.Query.Dialog (

6− ChatsResponse(..),

7− responseToDialogs,

8− Dialog(..)

9− ) where

10−

11−import Data.Aeson

12−import Data.Message

13−import Data.GroupChat

14−import Data.User

15−import qualified Generics.SOP as SOP

16−import qualified GHC.Generics as GHC

17−import Squeal.PostgreSQL.Schema

18−import Data.Text (Text)

19−import Data.Time (UTCTime)

20−import Data.PostElement

21−import Servant.Docs

22−import Data.Proxy

23−

24−instance ToSample Dialog where

25− toSamples _ = samples (take 1 (UserDialog <$> [69] <*> map snd (toSamples Proxy)) <>

26− (GroupDialog <$> map snd (toSamples Proxy) <*> map snd (toSamples Proxy)))

27−

28−data Dialog = GroupDialog GroupChat (Maybe Message) | UserDialog UserId Message

29− deriving Show

30−

31−instance ToJSON Dialog where

32− toJSON (GroupDialog chat mess) = object [

33− "groupChat" .= object [

34− "group" .= chat,

35− "lastMessage" .= mess

36− ]

37− ]

38− toJSON (UserDialog uId mess) = object [

39− "userChat" .= object [

40− "user" .= uId,

41− "lastMessage" .= mess

42− ]

43− ]

44−

45−data ChatsResponse = ChatsResponse {

46− chatResponseMessageId :: MessageId,

47− chatResponseMessageAuthorId :: Maybe UserId,

48− chatResponseMessageDestinationGroupId :: Maybe GroupChatId,

49− chatResponseMessageDestinationUserId :: Maybe UserId,

50− chatResponseMessageBody :: Maybe (Jsonb (PostElement Message)),

51− chatResponseMessageTime :: UTCTime,

52− chatResponseGroupUsers :: Maybe (Jsonb UserPermissions),

53− chatResponseGroupName :: Maybe Text

54−} deriving (GHC.Generic)

55−

56−instance SOP.Generic ChatsResponse

57−instance SOP.HasDatatypeInfo ChatsResponse

58−

59−responseToDialogs :: UserId -> [ChatsResponse] -> Maybe [Dialog]

60−responseToDialogs selfId = sequence . map toDialog

61− where

62− toDialog :: ChatsResponse -> Maybe Dialog

63− toDialog (ChatsResponse mId (Just uId) Nothing (Just dId) (Just (Jsonb mb)) mt Nothing Nothing) =

64− Just $ UserDialog

65− (if selfId == uId then dId else uId)

66− (Message mId uId (UserChatDestination dId) mb mt)

67− toDialog (ChatsResponse mId (Just uId) (Just gId) Nothing (Just (Jsonb mb)) mt (Just users) (Just name)) =

68− Just $ GroupDialog

69− (GroupChat gId users name)

70− (Just $ Message mId uId (GroupChatDestination gId) mb mt)

71− toDialog (ChatsResponse _ Nothing (Just gId) Nothing Nothing _ (Just users) (Just name)) =

72− Just $ GroupDialog

73− (GroupChat gId users name)

74− Nothing

75− toDialog _ = Nothing

76−

denis/src/Server/Query/Pagination.hsdeleted−51

@@ -1,51 +0,0 @@

1−{-# LANGUAGE

2− DataKinds ,

3− DeriveGeneric ,

4− OverloadedLabels,

5− OverloadedStrings ,

6− TypeApplications ,

7− TypeOperators,

8− FlexibleInstances,

9− MultiParamTypeClasses,

10− TypeFamilies,

11− UndecidableInstances,

12− UndecidableSuperClasses #-}

13−

14−module Server.Query.Pagination (

15− PaginatingRequest(..),

16− PaginationDirection(..),

17− validatePaginationRequest

18− ) where

19−

20−import GHC.Generics

21−import Data.Aeson as A

22−import Servant.Docs

23−import Data.Proxy

24−import Data.Word (Word64)

25−

26−instance (ToSample i, ToSample r) => ToSample (PaginatingRequest i r) where

27− toSamples _ = samples $ PaginatingRequest <$> ([const Nothing, Just] <*> [snd . head $ toSamples Proxy]) <*> [20] <*> map snd (toSamples Proxy) <*> [BackPagination, ForwardPagination]

28−

29−data PaginatingRequest i r = PaginatingRequest {

30− exclusiveFrom :: Maybe i,

31− limit :: Word64,

32− request :: r,

33− direction :: PaginationDirection

34−} deriving (Generic)

35−

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

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

38−

39−instance (ToJSON r, ToJSON i) => ToJSON (PaginatingRequest i r) where

40−instance (FromJSON r, FromJSON i) => FromJSON (PaginatingRequest i r) where

41−

42−data PaginationDirection = BackPagination | ForwardPagination

43−

44−instance ToJSON PaginationDirection where

45− toJSON BackPagination = A.String "backward"

46− toJSON ForwardPagination = A.String "forward"

47−

48−instance FromJSON PaginationDirection where

49− parseJSON (A.String "backward") = return BackPagination

50− parseJSON (A.String "forward") = return ForwardPagination

51− parseJSON _ = fail "couldn't match magination direction."

denis/src/Server/Server.hs+13−50

@@ -1,12 +1,7 @@

1−{-# LANGUAGE

2− OverloadedStrings,

1+{-# LANGUAGE OverloadedStrings #-}

3− TypeOperators,

4− DataKinds #-}

6module Server.Server (

3module Server.Server (

7− runServer,

4+ runServer

8− hoistedServer,

9− getConfig

10) where

5) where

12import Server.API

7import Server.API

@@ -20,61 +15,40 @@ import Squeal.PostgreSQL.Pool

20import Data.Maybe

15import Data.Maybe

21import Control.Monad.Reader

16import Control.Monad.Reader

22import Network.Wai.Handler.Warp

17import Network.Wai.Handler.Warp

23−import Network.HTTP.Types.Method

18+import Network.HTTP.Types.Method

24import Server.Logger

19import Server.Logger

25−import Data.Faculty.Parser

20+

26−import Data.Connection

27−import Data.Query

28−import Crypto.RNG

29import Network.Wai.Middleware.Cors

21import Network.Wai.Middleware.Cors

30−import Server.Periodic

22+

32getDBString :: IO B.ByteString

24getDBString :: IO B.ByteString

33getDBString = do

25getDBString = do

34 mDatabaseURL <- lookupEnv "DATABASE_URL"

26 mDatabaseURL <- lookupEnv "DATABASE_URL"

35 return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL

27 return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL

37−getMailConfig :: IO MailConfig

38−getMailConfig = do

39− (Just host) <- lookupEnv "MAIL_HOST"

40− port <- (fromMaybe 25 . fmap read) <$> lookupEnv "MAIL_PORT"

41− (Just user) <- lookupEnv "MAIL_USER"

42− (Just pass) <- lookupEnv "MAIL_PASS"

43− return $ MailConfig host port user pass

44−

45getServerPort :: IO Int

29getServerPort :: IO Int

46−getServerPort = maybe 2000 read <$> lookupEnv "PORT"

30+getServerPort = maybe 2000 read <$> lookupEnv "PORT"

48getConfig :: IO Config

32getConfig :: IO Config

49getConfig = do

33getConfig = do

50 databaseURL <- getDBString

34 databaseURL <- getDBString

51 conn <- createConnectionPool databaseURL 3 0.5 10

35 conn <- createConnectionPool databaseURL 3 0.5 10

52− crypto <- newCryptoRNGState

53− selfRoot <- fromMaybe "http://localhost:2000" <$> lookupEnv "SELF_ROOT_URL"

54− mail <- getMailConfig

55− return $ Config conn crypto selfRoot mail

36+ return $ Config conn

56−

57−hoistedServer :: Logger -> Config -> Server API

58−hoistedServer logger cfg =

59− let serverAPI = mkServerAPI logger

60− in hoistServerWithContext serverProxy contextProxy (flip runReaderT cfg) serverAPI

62runServer :: IO ()

38runServer :: IO ()

63runServer = do

39runServer = do

64 port <- getServerPort

40 port <- getServerPort

65 cfg <- getConfig

41 cfg <- getConfig

66− updateFaculties cfg

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

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

69 let ctx = genAuthServerContext $ getPool cfg

42 let ctx = genAuthServerContext $ getPool cfg

70− (middleLogger, logger) <- mkLogger 500

43+ (middleLogger, logger) <- mkLogger 100

71− let s = hoistedServer logger cfg

44+ let serverAPI = mkServerAPI logger

45+ let s = hoistServerWithContext serverProxy contextProxy (flip runReaderT cfg) serverAPI

72 runSettings (settings port) $ cors (const $ Just policy) . middleLogger $ serveWithContext serverProxy ctx s

46 runSettings (settings port) $ cors (const $ Just policy) . middleLogger $ serveWithContext serverProxy ctx s

74policy :: CorsResourcePolicy

48policy :: CorsResourcePolicy

75policy = CorsResourcePolicy {

49policy = CorsResourcePolicy {

76− corsOrigins = Just (["http://localhost:8080", "http://localhost:4000", "http://127.0.0.1:4000", "http://127.0.0.1:8080", "http://lvh.me:4000", "http://lvh.me:8080", "http://valera-kristina.herokuapp.com", "https://valera-kristina.herokuapp.com"], True), -- Nothing,

50+ corsOrigins = Just (["http://localhost:8080", "http://localhost:4000", "http://127.0.0.1:4000", "http://127.0.0.1:8080", "http://lvh.me:4000", "http://lvh.me:8080"], True), -- Nothing,

77− corsMethods=[methodGet, methodPost, methodDelete],

51+ corsMethods=[methodGet, methodPost],

78 corsRequestHeaders = ["content-type"],

52 corsRequestHeaders = ["content-type"],

79 corsExposedHeaders = Nothing,

53 corsExposedHeaders = Nothing,

80 corsMaxAge = Nothing,

54 corsMaxAge = Nothing,

@@ -84,15 +58,4 @@ policy = CorsResourcePolicy {

84}

58}

86settings :: Int -> Settings

60settings :: Int -> Settings

87−settings port = setPort port . setServerName "Denis" $ defaultSettings

61+settings port = setPort port . setServerName "Denis" $ defaultSettings

88−

89−updateFaculties :: Config -> IO ()

90−updateFaculties cfg = do

91− fs <- getFaculties

92− forM_ fs (runTask cfg . runQerror . updateFaculty)

93−

94−runTask :: Config -> App () -> IO ()

95−runTask cfg = void . runHandler . flip runReaderT cfg

96−

97−runDbTask :: Config -> StaticPQ () -> IO ()

98−runDbTask cfg = runTask cfg . runQsilent

denis/src/test/Orphans.hsdeleted−104

@@ -1,104 +0,0 @@

1−{-# LANGUAGE

2− OverloadedStrings,

3− TypeOperators,

4− DataKinds,

5− FlexibleInstances,

6− UndecidableInstances #-}

7−

8−module Orphans where

9−

10−import Server.API

11−import Server.Server

12−import Test.QuickCheck

13−import Servant.QuickCheck

14−import Test.Hspec

15−import Server.App

16−import Servant.Server

17−import Data.User

18−import Servant.Server.Experimental.Auth

19−import Network.Wai

20−import Servant.QuickCheck.Internal.HasGenRequest

21−import Servant.API

22−import Server.Query.ComplexQuery

23−import Test.QuickCheck

24−import Server.Query.Pagination

25−import Test.QuickCheck.Arbitrary.Generic

26−import Data.Post

27−import Data.Channel.NamedChannel

28−import Test.QuickCheck.Instances

29−import Server.Auth

30−import Data.Query

31−import Data.User

32−import Data.PostElement

33−import Data.Channel.AnonymousChannel

34−import Data.Channel.NamedChannel

35−import Data.GroupChat

36−import Squeal.PostgreSQL.Schema

37−import Data.Message

38−

39−instance (Arbitrary i, Arbitrary r) => Arbitrary (PaginatingRequest i r) where

40− arbitrary = genericArbitrary

41− shrink = genericShrink

42−

43−instance Arbitrary PaginationDirection where

44− arbitrary = elements [BackPagination, ForwardPagination]

45−

46−instance (Arbitrary u) => Arbitrary (NamedChannel u) where

47− arbitrary = genericArbitrary

48− shrink = genericShrink

49−

50−instance Arbitrary AuthenticationCredits where

51− arbitrary = genericArbitrary

52− shrink = genericShrink

53−

54−instance Arbitrary UserCreation where

55− arbitrary = genericArbitrary

56− shrink = genericShrink

57−

58−instance Arbitrary TokenActivationData where

59− arbitrary = genericArbitrary

60− shrink = genericShrink

61−

62−instance Arbitrary UserUpdate where

63− arbitrary = genericArbitrary

64− shrink = genericShrink

65−

66−instance Arbitrary PostCreation where

67− arbitrary = genericArbitrary

68− shrink = genericShrink

69−

70−instance Arbitrary (PostElement p) where

71− arbitrary = genericArbitrary

72− shrink = genericShrink

73−

74−instance Arbitrary PostQuote where

75− arbitrary = genericArbitrary

76− shrink = genericShrink

77−

78−instance Arbitrary AnonymousChannel where

79− arbitrary = genericArbitrary

80− shrink = genericShrink

81−

82−instance Arbitrary NamedChannelCreationRequest where

83− arbitrary = genericArbitrary

84− shrink = genericShrink

85−

86−instance Arbitrary GroupChat where

87− arbitrary = genericArbitrary

88− shrink = genericShrink

89−

90−instance Arbitrary GroupChatPermissions where

91− arbitrary = genericArbitrary

92− shrink = genericShrink

93−

94−instance Arbitrary GroupChatCreation where

95− arbitrary = genericArbitrary

96− shrink = genericShrink

97−

98−instance Arbitrary MessageCreation where

99− arbitrary = genericArbitrary

100− shrink = genericShrink

101−

102−instance (Arbitrary a) => Arbitrary (Jsonb a) where

103− arbitrary = genericArbitrary

104− shrink = genericShrink

denis/src/test/Spec.hsdeleted−101

@@ -1,101 +0,0 @@

1−{-# LANGUAGE

2− OverloadedStrings,

3− TypeOperators,

4− DataKinds,

5− FlexibleInstances,

6− UndecidableInstances,

7− ScopedTypeVariables #-}

8−

9−import Server.API

10−import Server.Server

11−import Test.QuickCheck

12−import Servant.QuickCheck

13−import Test.Hspec

14−import Server.App

15−import Servant.Server

16−import Data.User

17−import Servant.Server.Experimental.Auth

18−import Network.Wai

19−import Servant.QuickCheck.Internal.HasGenRequest

20−import Servant.API

21−import Server.Query.ComplexQuery

22−import Orphans

23−import qualified Network.HTTP.Client as HTTP

24−import qualified Data.ByteString.Char8 as B

25−import qualified Data.ByteString.Lazy.Char8 as LB

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

27−

28−main :: IO ()

29−main = do

30− cfg <- getCfg

31−

32− hspec $ do

33− let

34− test :: Predicates -> IO ()

35− test predicates = withServantServerAndContext serverProxy mockAuth

36− (return $ hoistedServer (return "") cfg) $ \burl ->

37− serverSatisfies serverProxy burl testArgs

38− (printPredicate <%> predicates)

39−

40− it "Doesn't have errors" $

41− test $ not500 <%> mempty

42−

43− it "Honours accept headers" $

44− test $ honoursAcceptHeader <%> mempty

45−

46− it "Doesn't take longer than 1 second" $

47− test $ notLongerThan (1 * seconds) <%> mempty

48−

49−mockAuth :: Context (AuthHandler Request UserId ': '[])

50−mockAuth = mkAuthHandler (const $ return 3) :. EmptyContext

51−

52−milliseconds :: Integer

53−milliseconds = 1000000

54−

55−seconds :: Integer

56−seconds = 1000 * milliseconds

57−

58−getCfg :: IO Config

59−getCfg = do

60− cfg <- getConfig

61− return cfg {

62− mailConfig = mail

63− }

64−

65−mail :: MailConfig

66−mail = MailConfig {

67− mailHost = "",

68− mailPort = 25,

69− mailUser = "",

70− mailPassword = ""

71−}

72−

73−testArgs :: Args

74−testArgs = Args

75− { replay = Nothing

76− , maxSuccess = 1000

77− , maxDiscardRatio = 10

78− , maxSize = 100

79− , chatty = True

80− , maxShrinks = maxBound

81− }

82−

83−printPredicate = RequestPredicate $ \ req mgr -> do

84− let url = HTTP.path req

85− let (HTTP.RequestBodyLBS bs) = HTTP.requestBody req

86− resp <- HTTP.httpLbs req mgr

87− let code = statusCode $ HTTP.responseStatus resp

88− putStr "\tRequest:\t"

89− putStrLn $ B.unpack url

90− putStrLn . filter (/= '\a') $ LB.unpack bs

91− putStr "\tResponse:\t"

92− print code

93− putStrLn ""

94− return []

95−

96−

97−instance (HasGenRequest a) => HasGenRequest (Authentication :> a) where

98− genRequest (Proxy :: Proxy (Authentication :> a)) = genRequest (Proxy :: Proxy a)

99−

100−instance HasGenRequest api => HasGenRequest (ComplexQuery :> api) where

101− genRequest (Proxy :: Proxy (ComplexQuery :> api)) = genRequest (Proxy :: Proxy api)

dump.sqldeleted−499

@@ -1,499 +0,0 @@

1−

2−

3−--

4−-- Data for Name: groupChats; Type: TABLE DATA; Schema: public; Owner: qsfrneimsrtpjz

5−--

6−

7−COPY public."groupChats" ("groupChatId", "groupChatUsers", "groupChatName") FROM stdin;

8−12 {"7": {"isAdmin": false}} Untitled1

9−14 {"6": {"isAdmin": false}, "7": {"isAdmin": false}} new chat

10−15 {"7": {"isAdmin": false}} hello

11−19 {"6": {"isAdmin": false}}

12−13 {"6": {"isAdmin": true}, "7": {"isAdmin": false}} Проверка

13−18 {"3": {"isAdmin": true}, "11": {"isAdmin": false}} proverka

14−17 {"6": {"isAdmin": true}, "11": {"isAdmin": false}} Sosatt

15−22 {"6": {"isAdmin": true}} Untitled

16−23 {"6": {"isAdmin": true}} Тест

17−21 {"3": {"isAdmin": true}, "6": {"isAdmin": false}} new name of chat

18−20 {"3": {"isAdmin": true}} Untitled

19−16 {"6": {"isAdmin": true}} Hello

20−\.

21−

22−

23−--

24−-- Data for Name: messages; Type: TABLE DATA; Schema: public; Owner: qsfrneimsrtpjz

25−--

26−

27−COPY public.messages ("messageStorageId", "messageStorageAuthorId", "messageStorageDestinationGroupId", "messageStorageDestinationUserId", "messageStorageBody", "messageStorageTime") FROM stdin;

28−56 \N 12 \N \N 2019-05-12 19:00:42.217465+00

29−57 \N 13 \N \N 2019-05-12 20:00:15.500388+00

30−60 3 \N 6 {"markdown": "Идёшь завтра на лекцию???"} 2019-05-12 21:16:53.471869+00

31−61 \N 14 \N \N 2019-05-12 21:17:28.177618+00

32−62 3 12 \N {"markdown": "hello"} 2019-05-12 21:17:38.560284+00

33−63 \N 15 \N \N 2019-05-12 21:19:35.607156+00

34−64 6 \N 3 {"markdown": "Da!"} 2019-05-12 22:22:34.636955+00

35−69 6 \N 3 {"markdown": "Проверка"} 2019-05-13 09:00:04.543673+00

36−75 \N 16 \N \N 2019-05-13 09:42:35.621514+00

37−76 3 \N 6 {"markdown": "аааа я пишу с сайта "} 2019-05-13 09:51:45.216052+00

38−77 6 \N 3 {"markdown": ")))"} 2019-05-13 09:59:04.464285+00

39−78 6 \N 3 {"markdown": "Ты еще можешь отправлять сообщения на ентер"} 2019-05-13 09:59:17.664861+00

40−79 \N 17 \N \N 2019-05-13 10:34:51.369108+00

41−80 12 17 \N {"markdown": "New chat!"} 2019-05-13 10:34:59.396363+00

42−81 12 17 \N {"markdown": "Write me something pls"} 2019-05-13 10:38:06.641916+00

43−82 6 17 \N {"markdown": "Hello!"} 2019-05-13 10:39:02.53931+00

44−83 12 16 \N {"markdown": "Hello!"} 2019-05-13 10:49:47.834312+00

45−84 12 17 \N {"markdown": "Кикнула Илью из беседы)"} 2019-05-13 10:50:45.408526+00

46−85 12 17 \N {"markdown": "привет как дела"} 2019-05-13 10:58:54.034185+00

47−86 6 17 \N {"markdown": "Хорошо, а у тебя?"} 2019-05-13 11:00:03.129155+00

48−87 12 \N 3 {"markdown": "Привет!"} 2019-05-13 12:23:21.226991+00

49−88 12 \N 3 {"markdown": "Как у тебя дела?"} 2019-05-13 12:23:28.143832+00

50−89 12 17 \N {"markdown": "Ну так плюс минус жить можно)"} 2019-05-13 12:24:43.553721+00

51−90 12 17 \N {"markdown": "привет"} 2019-05-13 13:16:37.040853+00

52−91 12 17 \N {"markdown": "Всем пис"} 2019-05-13 13:16:50.7915+00

53−92 12 \N 3 {"markdown": "Аняяяя"} 2019-05-13 13:20:25.214522+00

54−93 3 \N 12 {"markdown": "Нормально"} 2019-05-13 14:08:52.660103+00

55−94 3 \N 12 {"markdown": "Ты как?"} 2019-05-13 14:09:00.358669+00

56−95 3 \N 6 {"markdown": "Я так и делала!!!"} 2019-05-13 14:09:48.991844+00

57−96 \N 18 \N \N 2019-05-13 14:18:30.872479+00

58−97 \N 19 \N \N 2019-05-13 15:24:01.710566+00

59−98 3 19 \N {"markdown": "hello"} 2019-05-13 15:27:17.523456+00

60−99 \N 20 \N \N 2019-05-13 15:27:36.736424+00

61−100 3 20 \N {"markdown": "Darya "} 2019-05-13 15:27:53.856998+00

62−101 3 20 \N {"markdown": "pls sent message"} 2019-05-13 15:28:18.065107+00

63−102 \N 21 \N \N 2019-05-13 17:23:22.627985+00

64−103 3 21 \N {"markdown": "hellooooo\\n## markdown"} 2019-05-13 17:27:35.021832+00

65−104 12 18 \N {"markdown": "Help"} 2019-05-13 17:40:57.74548+00

66−105 12 20 \N {"markdown": "Pls"} 2019-05-13 17:41:28.669253+00

67−106 12 20 \N {"markdown": "Send"} 2019-05-13 17:41:33.713239+00

68−107 12 20 \N {"markdown": "Nudes"} 2019-05-13 17:41:37.030689+00

69−108 3 \N 12 {"markdown": "i"} 2019-05-13 18:04:27.566263+00

70−109 3 \N 12 {"markdown": "need"} 2019-05-13 18:04:29.597069+00

71−110 3 \N 12 {"markdown": "a"} 2019-05-13 18:04:30.747952+00

72−111 3 \N 12 {"markdown": "lot"} 2019-05-13 18:04:32.866007+00

73−112 3 \N 12 {"markdown": "of"} 2019-05-13 18:04:34.439089+00

74−113 3 \N 12 {"markdown": "messages"} 2019-05-13 18:04:37.348507+00

75−114 3 \N 12 {"markdown": "lets"} 2019-05-13 18:04:41.274395+00

76−115 3 \N 12 {"markdown": "check "} 2019-05-13 18:04:43.225609+00

77−116 3 \N 12 {"markdown": "pagination"} 2019-05-13 18:04:46.724472+00

78−117 3 \N 12 {"markdown": "))))"} 2019-05-13 18:04:49.117602+00

79−118 3 \N 12 {"markdown": "Darya"} 2019-05-13 18:04:58.079826+00

80−119 3 \N 12 {"markdown": "chto delaesh?"} 2019-05-13 18:05:06.691576+00

81−120 3 \N 12 {"markdown": "native eeeee"} 2019-05-13 18:05:13.633699+00

82−121 3 21 \N {"markdown": "блин мне нравится сидеть с сайта"} 2019-05-13 18:38:41.575588+00

83−122 6 21 \N {"markdown": "Фига"} 2019-05-13 18:59:23.480114+00

84−123 6 21 \N {"markdown": "Неожиданно"} 2019-05-13 18:59:28.098338+00

85−124 6 21 \N {"markdown": "А еще мне тоже не хватает смайликов"} 2019-05-13 18:59:36.924505+00

86−125 6 21 \N {"markdown": "Надо бы прикрутить))"} 2019-05-13 18:59:41.452505+00

87−126 12 \N 3 {"markdown": "Привет"} 2019-05-13 19:30:55.962054+00

88−127 12 \N 3 {"markdown": "У Кости тут время не отображается сообщения, когда ты мне писать то успеваешь!!! _удивлена_ _поражена_ _раздосадована_"} 2019-05-13 19:31:22.510321+00

89−128 12 \N 3 {"markdown": "привет"} 2019-05-13 19:34:50.753794+00

90−129 12 \N 3 {"markdown": "блять ну привет ало"} 2019-05-13 19:35:21.876566+00

91−130 12 \N 3 {"markdown": "Приветттттт!"} 2019-05-13 19:36:01.406531+00

92−131 12 \N 3 {"markdown": ""} 2019-05-13 19:36:02.600456+00

93−132 12 \N 3 {"markdown": "привет"} 2019-05-13 19:36:05.515343+00

94−133 12 \N 3 {"markdown": "где сообщения????"} 2019-05-13 19:36:18.145702+00

95−134 \N 22 \N \N 2019-05-13 19:37:11.909828+00

96−135 \N 23 \N \N 2019-05-13 19:37:28.304101+00

97−136 12 \N 11 {"markdown": "Соси писю"} 2019-05-13 19:56:44.176754+00

98−137 12 \N 3 {"markdown": "Пис"} 2019-05-13 19:58:39.660301+00

99−138 11 \N 12 {"markdown": "Сама I just want people to be happy "} 2019-05-13 19:59:20.391998+00

100−139 12 \N 11 {"markdown": "Починила я твои сэйфэриа"} 2019-05-13 20:19:53.326795+00

101−140 12 \N 11 {"markdown": "Иди и make people happy again сам"} 2019-05-13 20:20:17.66819+00

102−141 6 23 \N {"markdown": "Ну что"} 2019-05-13 20:39:46.038071+00

103−142 6 22 \N {"markdown": "Тесты"} 2019-05-13 20:39:52.353636+00

104−143 6 21 \N {"markdown": "Интеграционные!"} 2019-05-13 20:40:01.990466+00

105−144 6 19 \N {"markdown": "Инновационные!"} 2019-05-13 20:40:08.21061+00

106−145 6 \N 3 {"markdown": "И сюда"} 2019-05-13 20:40:17.047374+00

107−146 6 16 \N {"markdown": "Бадумс"} 2019-05-13 20:40:24.582964+00

108−147 6 17 \N {"markdown": "Все работает? "} 2019-05-13 20:40:33.688546+00

109−148 12 \N 11 {"markdown": "Привет"} 2019-05-13 20:47:15.369318+00

110−149 6 17 \N {"markdown": "Привет!"} 2019-05-13 20:55:12.148039+00

111−150 12 \N 12 {"markdown": "пннггргрг"} 2019-05-13 20:59:00.544809+00

112−154 12 \N 11 {"markdown": "Ильяяяяяяяя"} 2019-05-13 21:02:21.115633+00

113−155 18 \N 12 {"markdown": "Привеееет"} 2019-05-13 21:16:46.458811+00

114−156 12 \N 18 {"markdown": "Привет солнце"} 2019-05-13 21:19:24.020172+00

115−157 11 \N 12 {"markdown": "ильяяяяя"} 2019-05-13 21:36:37.985452+00

116−158 11 \N 12 {"markdown": "ильяяяяя"} 2019-05-13 21:37:04.22538+00

117−159 3 \N 6 {"markdown": "Проверка связи"} 2019-05-13 21:40:41.308023+00

118−160 6 \N 3 {"markdown": "Прием-прием"} 2019-05-13 22:04:37.477219+00

119−161 3 \N 6 {"markdown": "Костя"} 2019-05-13 22:20:58.83048+00

120−162 3 \N 6 {"markdown": "Ты сделал коммит?"} 2019-05-13 22:21:14.089104+00

121−163 3 21 \N {"markdown": "Contrary to popular belief, Lorem Ipsum is not simply random text. It has roots in a piece of ."} 2019-05-13 22:24:06.104804+00

122−164 3 21 \N {"markdown": "### hellllooooo"} 2019-05-13 22:24:16.578672+00

123−\.

124−

125−

126−--

127−-- Data for Name: postElements; Type: TABLE DATA; Schema: public; Owner: qsfrneimsrtpjz

128−--

129−

130−COPY public."postElements" ("rowElementId", "rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment") FROM stdin;

131−3 0 грустно((((( \n## куда плакать \N \N \N \N

132−4 0 я из **Питера** \n_а вы????_ \N \N \N \N

133−6 0 Я написал длинный пост, а он не отправился, потому что у меня истек токен \N \N \N \N

134−8 0 Я придумал! давайте устроим бунт и уроним сервер Илья! \N \N \N \N

135−10 0 Ну сервер не вопротивился, значит можно))\nТипо для привлечения внимания\nВыглядит хначительно серьезнее)) \N \N \N \N

136−19 0 Тест! \N \N \N \N

137−23 0 Привет \N \N \N \N

138−24 0 Еще раз \N \N \N \N

139−27 0 Новый пост! \N \N \N \N

140−28 0 Всем привет \N \N \N \N

141−29 0 Привет! \N \N \N \N

142−30 0 I am back with information about _UIKit_ !\n\nThe **UIKit** framework provides the required infrastructure for your iOS or tvOS apps. It provides the window and view architecture for implementing your interface, the event handling infrastructure for delivering _Multi-Touch _and other types of input to your app, and the main run loop needed to manage interactions among the user, the system, and your app. Other features offered by the framework include animation support, document support, drawing and printing support, information about the current device, text management and display, search support, accessibility support, app extension support, and resource management.\n \N \N \N \N

143−31 0 IOS is the best!I will publish a lot of posts about it! Follow _iOS_ channel with hashtags about _Apple_, _iOS_, _UIKit_! \N \N \N \N

144−32 0 Lorem Ipsum is simply dummy text of the printing and typesetting industry. Lorem Ipsum has been the industry's standard dummy text ever since the\n 1500s, when an unknown printer took a galley of type and scrambled it to make a type specimen book. It has survived not only five centuries, but also the leap into electronic typesetting, remaining essentially unchanged. It was popularised in the 1960s with the release of Letraset sheets containing Lorem Ipsum passages, and more recently with desktop publishing software like Aldus PageMaker including versions of Lorem Ipsum.fjedhfdjdhfdjfd \N \N \N \N

145−33 0 San Francisco journalist says police raided his home after he refused to identify source\n\n \N \N \N \N

146−34 0 It is a long established fact that a reader will be distracted by the readable content of a page when looking at its layout. The point of using Lorem Ipsum is that it has a more-or-less normal distribution of letters, as opposed to using 'Content here, content here', making it look like readable English. Many desktop publishing packages and web page editors now use Lorem Ipsum as their default model text, and a search for 'lorem ipsum' will uncover many web sites still in their infancy. Various versions have evolved over the years, sometimes by accident, sometimes on purpose (injected humour and the like). \N \N \N \N

147−35 0 приветик всем, я пишу с сайтика Кости \n\nэто так прикольноооооооооооо, я хочу смайлики(((( \N \N \N \N

148−36 0 Тоже пишу с сайта Костика! \N \N \N \N

149−37 0 # пост про веб и любовь\n\nЯ люблю веб! А вы? _??????_ Я уверена, что тоже! \N \N \N \N

150−38 0 У меня что нет постов на страничке??? Не может быть!\n \N \N \N \N

151−39 0 Я люблю сосать \N \N \N \N

152−40 0 (очень) \N \N \N \N

153−41 0 _Всем привет_!!! Как дела? _Завтра к МК_ :( \N \N \N \N

154−42 0 Привет!!!! Привет!!!! Привет!!!! Привет!!!! Привет!!!! Привет!!!! Привет!!!! Привет!!!!\n\n# не бейте меня это проверка связи\n\n> quote \n> another quote\n\n_help_\n\n\n\n\n\n\nПривет!!!! Привет!!!! Привет!!!! Привет!!!! Привет!!!! Привет!!!! Привет!!!! Привет!!!!\n\n# не бейте меня это проверка связи\n\n> quote \n> another quote\n\n_help_ \N \N \N \N

155−43 0 Куку\n \N \N \N \N

156−44 0 ) \N \N \N \N

157−45 0 # New post!\n\nThis is an example post about our _Social network_, **iOS** application! \n\nThis is a demonstration of writing a new _post_\n\n> quote can be made like this!\n\n- list\n- is something 🍀\n- like this \N \N \N \N

158−46 0 )) \N \N \N \N

159−47 0 ###### очень маленький писюн \N \N \N \N

160−48 0 hello, ilya \N \N \N \N

161−49 0 proverka \N \N \N \N

162−\.

163−

164−

165−--

166−-- Data for Name: posts; Type: TABLE DATA; Schema: public; Owner: qsfrneimsrtpjz

167−--

168−

169−COPY public.posts ("postRowId", "postRowAuthorId", "postRowUpdateTime", "postRowTags") FROM stdin;

170−3 3 2019-05-12 11:06:56.113423+00 {hse,new,tag,hello,я,ничего,не,успеваю}

171−4 3 2019-05-12 11:08:28.56758+00 {Питер,вышка,ура}

172−6 6 2019-05-12 12:41:48.579615+00 {Злюсь}

173−8 6 2019-05-12 13:13:59.958842+00 {Бунт,Бунд,Бунт}

174−10 6 2019-05-12 13:19:59.825686+00 {Бунт,Бунт," Бунт"}

175−19 6 2019-05-13 08:55:38.703923+00 {Apple}

176−23 6 2019-05-13 08:58:18.327297+00 {}

177−24 6 2019-05-13 08:58:57.09688+00 {eb}

178−27 12 2019-05-13 09:56:38.510814+00 {tag}

179−28 12 2019-05-13 10:58:05.757737+00 {ag}

180−29 6 2019-05-13 12:17:40.144256+00 {унт}

181−30 12 2019-05-13 12:31:11.967519+00 {UIKit,mobileDevelopment,iOS}

182−31 12 2019-05-13 12:33:09.981899+00 {mobileDevelopment,Swift,iOS}

183−32 12 2019-05-13 13:27:40.118674+00 {lorem,ipsum}

184−33 3 2019-05-13 18:09:10.681441+00 {привет,новый,пост,Бунт}

185−34 3 2019-05-13 18:10:26.800786+00 {tag,new,lorem}

186−35 3 2019-05-13 18:43:07.731224+00 {obileDevelopment,ышка,ello,Бунт}

187−36 12 2019-05-13 19:27:48.658511+00 {}

188−37 12 2019-05-13 19:29:45.334246+00 {web," js",webDev,kosya,ялюблюсвоюработу,веб}

189−38 12 2019-05-13 19:38:06.900945+00 {}

190−39 11 2019-05-13 20:02:49.600981+00 {}

191−40 11 2019-05-13 20:07:02.280734+00 {злюсь}

192−41 12 2019-05-13 20:52:39.125909+00 {" Бунт"}

193−42 12 2019-05-13 20:54:41.973395+00 {markdown,help}

194−43 12 2019-05-13 21:03:30.724701+00 {}

195−44 6 2019-05-13 21:24:20.968302+00 {orem}

196−45 12 2019-05-13 21:25:21.929693+00 {social_network,tag,markdown}

197−46 6 2019-05-13 21:30:40.207788+00 {lorem}

198−47 11 2019-05-13 21:58:00.669801+00 {}

199−48 3 2019-05-13 22:17:51.138898+00 {писюн,маленький,Илья}

200−49 3 2019-05-13 22:28:48.651112+00 {tags,news,hse,web,js,mobileDevelopment,work,kursach}

201−\.

202−

203−

204−--

205−-- Data for Name: quoteElements; Type: TABLE DATA; Schema: public; Owner: qsfrneimsrtpjz

206−--

207−

208−COPY public."quoteElements" ("rowElementId", "rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment") FROM stdin;

209−\.

210−

211−

212−--

213−-- Data for Name: quotes; Type: TABLE DATA; Schema: public; Owner: qsfrneimsrtpjz

214−--

215−

216−COPY public.quotes ("quoteRowId", "quoteRowPostId") FROM stdin;

217−\.

218−

219−

220−--

221−-- Data for Name: tokens; Type: TABLE DATA; Schema: public; Owner: qsfrneimsrtpjz

222−--

223−

224−COPY public.tokens ("tokenUserId", "tokenValue", "tokenExpiryDate", "tokenVerificationCode", "tokenActivationTriesLeft", "tokenUserAgent", "tokenActivationCode", "tokenDeactivationCode") FROM stdin;

225−17 \\x1a0b89fca490bb64dd1526d2b833079f6954da89e14fb1635623a5800a8c31e25757d75048313d4f07547e228a8971db531faf2be52584307347828ebfc20945 2020-05-12 16:35:45.006489+00 \\xf1fbeea5b543738b22acc2673bbbfa69ea2776f46ba234f85ec251d5dc76287c6351ec553317785c5f23c5bee9c1698a42d27955c5bcaff09305b7ba0ae55310 10 okhttp \\x0b3e68e5974a5e8b29779e78332278d93b58483f5b06584a4821e1c1ea551ce13a28cd7c9e9350f96577843fe82469bc6bc1876c2ee65337025e4d79dfa7fa2d \\x0bf0c404a09f2949e9bc26765bdc0671c79865def476cbb2c39de66bcf7c5d386e26db3687ca0d493443c50fbbf68ba0ffe6864abdd3b08b00400024a7852da1

226−3 \\xd0e9cf3a38ef778783a2d6b4ecc82c30868eed82c62284ed2627eee305c7fbda649e4a40b3e911b7504e18603e8c76ba7291740f3d83200884a3c562256c252a 2020-05-12 18:36:07.869759+00 \N 10 Mac OS X — Chrome \N \\x913b36ffad3a049648705f39fee5ffebc9576ce1c59d4aac0558462325b0ef19c6ea17804cc9097af33792baa9655947ed3c275a9f84a5a5d48ab13effeded1a

227−11 \\x9fb88c39f22896feddaa5e176c6b459701d28f2fa56a83d80b0d8e9fd874618165e934468c2e6932156584daca665b3f41636e4e3dbfd4e9fd70356ede2273d4 2020-05-12 19:57:53.635167+00 \N 10 iOS \N \\xe98830312baaa841f4b7b65c799c852fc12f75dd9edecb42a304cebf2dc6ab149a56d9bdacbd16ffb94aff2c188c5af8639e8ff6b9cd18ef34e31e222c35a0a0

228−12 \\x6c3ea86a478f9f2b3caf61d8bcef018a61b954609e81fb8fdc6dccd9ebce1134e7ef922bbf89c2d274b9cc974b5552b3480042a0980571d79753dcbb143c3d2c 2020-05-12 20:08:01.486261+00 \N 10 iOS \N \\x186d1a9dbcd9e3eb35e69b1cb05309a1635d38b8350cfbfbefdc68bd3f37c11af1d9b5670d6c14827e428bcdedfb8f681d9ac3c982d08d8fb29a62f7ebaf810a

229−6 \\xe10faca3c9403b42d3e5d6ad7dad1bc95be3933b3330b94b55b6f9b6d108cfdac1288e7defbcab6b7e2a94f31756f4f217ed77ae887eac409b268388bc6724cf 2020-05-11 19:57:14.624458+00 \\x5271d7def0733e698a19f9a9378e1b54ba95a8593b2a90a3e404a465f0e8635d56c6894bca0a6eb5c49f5da10ad411e1c316068bb5eed84f4850d71a8a8faf35 10 Windows 10 — Chrome \\xdf4465993fce0f9ea7b628cd78ab65f1513ee2096139a481b35e7cecc18eacdadaa041bbd2fc5cce11a4137787645e1a6054e98da06777361882d9d952011b91 \\x03f547951f4a8eccc92891efa566f4b9f8370ab41bc428a2c78db322da07efde78b4028a2a0e76e2c92a76e29afdafd97411999fa7b57772f3f3b51fc45a4d7a

230−6 \\x6ee17d4e1b23c56f626571c1f7ebdf7f2b5b28973402d4e98e8337f43c3b1e73778580616fead50ae62233df4c9bcdcde47e635f0b62bdebd0ebbeebd1151394 2020-05-12 21:06:00.33602+00 \N 10 Windows 10 — Chrome \N \\x47015bd8699a424bd41f081dde3bd3122cf6b7b2fde87590ba0eb084196c4f693415d50d8f760af208d8313e9f3e8d8f74aa0fba35d58b6ce69a99d8e33574db

231−3 \\x4944451363b0a133b458548113ac5091a58a07de228d81e3e4c6345a2f7dec13e3d0a23336460b54991025e4888ceb721e43ca984b456ad0d7b01e5a5bb90bc0 2020-05-12 21:39:15.57724+00 \N 10 okhttp \N \\xcca681ba42dd011d288178f9034bf55a5ed4299ccbbe97383774b207f25225559f710e6e587bc8467ad6f09446f4cebca9187ea4cdb144872e6c0bf83128d50f

232−6 \\x9d74794077a85bde414f93d51c1c2ea12beb41d68ae7053efb0932a2ee0e8da694ab2ce9b4c18823a44df024b7ab7167e81188a360bd051a5f166ce1f5d34866 2020-05-11 19:57:17.459942+00 \N 10 Windows 10 — Chrome \N \\x4ee19017009b90b1d8f6e813f5fd5234d29bf0316ac7fc5dfb8504228efe3c100d5364600917dd58317a9a18ba796c3b982df4fa1dd67d9663a7960e7e4e88c4

233−6 \\x9e7d4f2869f48112728aa46b8c8b757f612b32a62c4081cfe8920977bb2cb87aa966157670fa02255c04e84c66c13eb5a86af54698ce24a2ff0a91157aaebe5c 2020-05-11 14:48:22.634562+00 \N 10 Windows 10 — Chrome \N \\x1ce4d8b76b9aa4d528eea1aabe0df7497fd156e0760d0829a30c0963ad252507f1c00a8beaed4648470deccc319caf531e98ebce0b0f653f030bc2c882d7959b

234−9 \\x8ec80e74ce3720a8028f4f4bcd9c5598ca0343afd63cff5a8933729b1e2e28ca5e1a761420ae898ca51080b8e431ac1eaa5936dcdfaa4a04eeefe016adcdf86a 2020-05-11 15:36:57.456372+00 \\x2c1efa77bd7c3f09179efa261bb10ada6b6b2bdc2aa52f4f7f3f75de3093c0c80afedb8e09441b6fe683e73cd4e28dcdab78cc3d6d8c667c9ce8abb8c7f062d6 10 iOS \\xf0beaa45dc5b744d1691c0db6389a21e350280c8023a211adb45bcd62328312b89f663fb17452cb1708559eea67895e3d25d55422911053f4b4bb38206f88883 \\x10e95dd6f45681fe8b55e5f43905738a4b2bf49b8b119b559d8aa33090d1141a4071fc67eab7f9426b1932d5674e6690d2b3cd059c12f9b8fdef51f13e708cee

235−12 \\x7f76401afb1167a59d1aadf3b051900498332e56a909927f004073f676253b65fe8c75860ce8635d7d2e72aeb25f405db4c814304f4ac5120d83d51b8de24e3e 2020-05-12 09:44:34.181474+00 \N 10 iOS \N \\xd7132d27c779f16cb32eab613c3716f0436348833fca1ff8ed45a27121a2bd4c6ad4c7cbfaceb588b801708d45bcc578a3dbc19730392fe661d2a37aac086c7e

236−10 \\xfca54c43c5e2a8e6853d48325cb700a7f50ecbe635fd0a5353a36ea7858ba904a9c712c6a7d2d6e6e8d20aa3aae9f326c0fbe7d8c96f6357295012f5898bea84 2020-05-11 15:52:01.741885+00 \\x3f1fcbaba55307ac237249c0a17d1d2747dfccec6338be65fbefee8b01466f9515c376cedb6951b35a0b286d793284d4277e9e556406f26daae0af69d3362ff9 10 curl \\x2005dda2be269b6d23c185e0418200f42a17e0ac5b94e8a2a76753470128b1fa2da58b434fa15c2b68228b3212d775fe7a92bf0cb4d4d7dcf1377ed43eb16429 \\x26633323ef3a3c83ff8f4051ebe3d53778a0372534c8bdccfa0538309ee2b545e4baf9f07dfa1ec1728e4ddb95597d033370633a8fab70fc328b2c3932dbfc00

237−12 \\x3e81a2f178cc25b8280ef5bca9fee6f71e81f00e997a14810d7b6059ed638047aa55c06d9d51aef7eb1732de963ea12a7e12bd3864a3b05f696663f9129c6088 2020-05-12 09:58:42.998106+00 \N 10 iOS \N \\x0dc1c1286c3bc853f69ceb5f03dc0480187bd0acb089be8f1aa61dc51d68198cfc017d82ad3c2713e8c67b30e8cfaa81d87969744e231670fc3118a38d89714c

238−12 \\x25db505e0f4bc136b75ec2ef96132868d31baf8b659ccd89f797ac6d4a6375fa713506a9434d5a4c5f4d6b2663d31dcb6478e3eb92520c9201d6728c315e1424 2020-05-12 10:01:45.081199+00 \\x4c05612fff5c714d46abf6098a308744205ed345003b74d21f9e19622a9544ad5d186f1a84345d2d91dbd1d3a53e0d05461f66439f6b21a7c1c76b483a7b3641 10 iOS \\x7ebe3eb07ebf2ac66cab89a5fa26f8acc53f3ec06df7bad7522ff58ed5d02086c7f48687bea499b7ce47c04c79245cd06c0c56910f38d9f2b1af265b8de4775b \\x0a9df3cdc3b1a21eac72e3d77971ada874c899ac14937cb454a1e5c781b1886cfbb8822fb829273da5580ba2b15db947082463cbb36bb050445ea27b15d366a0

239−12 \\x3f0a881a910c85ea7dfd6ede9f732427bdf08e62b3dd19eb060d4536bf14e153a5804b86a16a61235c22d78dbac959b4fbb8b013d18c656c3d0faa6819727b8c 2020-05-12 10:02:27.63402+00 \N 10 iOS \N \\x9581a372265f20f5f51259f89d471e4e14aefe32989f17548832f3a31ec046ce93cc244885c2b7ea607a39249a14643d45b736ad5e786886c9cc2aaf86f89475

240−12 \\x12e21098059ff5efe4957f54e542fb0d03162f6a1dbdf4881f3d0915afc0e85ac2f29f75a99f706928ba57e77c1ab3b4f6563e4bc740f8dc06589b63774cdc85 2020-05-12 10:56:28.957574+00 \N 10 Mac OS X — Chrome \N \\xa61575d8f89b31a6e6ff558c72befaddea92294797433da8cee0d8238953541bf6fe9603f1d9f08fbf1eb094c34ce51de8c20ceb2a0e4704a57473eb6a2d8047

241−12 \\x239fc16e587f11903a0b983e3e9cc10ce5f9e320b753831190d03f647c55e00ca7f4635211c187a082d827fa5e8c038e40ab0cce47e68ec5a13ab56bc2886259 2020-05-12 19:26:46.204018+00 \\xa0dfb4c9699729277c23f492064763c2dc6496cf8f3c0805b374cffb38eec1f12f3df0c033b832db025a6f5a9deb7d6282fb72526a9e1a55876300848aede8ca 10 Mac OS X — Chrome \\x55224d5b28d6fa16e692740d8639eb033d142ed1a77ca0e50912acb4c952c9dccbc3616bc6454caebed3f1dbc3a5d5d9b939c7b8956a22b9fbefc3763d1916a0 \\x409a3cfd6904ec3c12b4dd33632040e89f4f340fe90e9b75abb76a787b58311f090204fd718b22e5cf9f6438e1f7984f335142624260f5d0248494ca96ba02b7

242−11 \\x41da42b65822526a52dec3f651a6d432fa950ddc795fd0a582b5b722b4c6e4956292b329dd58b4471a270a9784e9542f63142d799af8e6c96679e8bd86171835 2020-05-12 20:06:05.904528+00 \N 10 Mac OS X — Chrome \N \\xd2af034090688a7c03b7492d69c4bfeacbdf0b9e68be7bd3cc45182a689300dd3c5bb34e38d7e6152057e169b99fc6118cd876ed9987d7ae0e7a69f2dbd82c5c

243−12 \\x065e8193c701d5e8600eb30f3632845d8ac76f59b81155f88f520ff179bf13a3867e3363fb2589ca93ef438187c1cd990abd3ddd5e126fa722bbe727c13e9348 2020-05-12 20:45:55.846716+00 \N 10 iOS \N \\x52274795f5999d01a681f51a5e29afe4edd26889ddaaa77d1d2a85a2bfd08be4af9253d356bb360822034a5171819562177c3cea0e7df6e71212f672fee86f53

244−18 \\x897a5aa341b7709c7d9cb58f425723458658a1570a26429976b3c92c0da1613fa7e27fbe4a8429b5ab3d4cf2938caf1d730e57911a8b51b2d4f17257473bbd69 2020-05-12 21:13:54.40466+00 \N 10 Mac OS X — Chrome \N \\xcae63685d7a24031e550c5e49ac1e8ed8bd3b3bfff51051977c0c2cceba8af2a01faa964cebdac5724c8f0be7ce19f8af7902f6710bb8e989ce35c93833fc9fa

245−6 \\x6963dfdbf872528ed1f985e4d788cac5b96a9afc5c9e1aa78073e8fca1505a201b459695d3c5dbf8123b8f80f35b7672990389ce26be1bf6873c3fe59f4757ee 2020-05-12 12:37:07.199628+00 \N 10 Windows 10 — Chrome \N \\x766516d234fb7cabb224fbd991193784a60d62106e5d4b7ceeb7bdf123d7504a35ca9db3c1e14aacd3bd060c98b3e4e5e4f6bc7e0ee61440437c6464a63eb596

246−6 \\xef2cec0fe597a7158618a567da72595f81324e5ab42df9ee6f17024f9937267e1b6da7aada49defa7f2938b9e9584aed098087da4796c966fabeaff348d4e5c6 2020-05-12 12:37:55.467622+00 \N 10 Windows 10 — Chrome \N \\xc0d6f362c33fc9d3d2e61fef09eed321c7845968e4bd1ae17ddb61128c59861f25db12ac030c5f1871725be3d73e5e68f8ae64a29284cd07a8e1aa693beddf22

247−6 \\xf26ebf4f5880219a2fc8ae8624adcf8727a3ecd3521f396c811a90ca6ea7c15788b97145e33d6ee6bad7aefca1d53d51c852a4fd951b7204d6ef50b38b3305c6 2020-05-12 12:46:13.117509+00 \N 10 Windows 10 — Chrome \N \\x8e0519e8f56e7a4bbab46b58ff498e87a733e6371cd647c597551ad151b3a63c3be4e733d2130bf568a01e59f79c01bf9b38ed6a96940746f8f12ea009019ed3

248−6 \\x8b48c76b4d6005bf0c02ba7a7b765b6372246e1a7d503b249e901e6ddbade8e1f660272595de6b876afb945cb93cd9e03ab3b0498016e0285864acdb4d1ed228 2020-05-12 12:47:57.324299+00 \N 10 Windows 10 — Chrome \N \\xd89f6f8f5c3b9d6c66639febb0d2208023f46851bd402fffb2f86a05684bbde9f2964fdf443405fbf637d51257040e46971194f984927b1801635281497f93b6

249−6 \\x89fcb726e07982cd2ad61504ed85d2f6ab390108b501ce9533900cc232434409f7c37d66a64fdc48a3b145f110412290bf440d69b3360b323ba9138358d47432 2020-05-12 12:48:18.89163+00 \N 10 Windows 10 — Chrome \N \\x8d1344a463e9a6f3f5a334e5bccd532e3d42aed478808c46d0ebf711fcb6eb7e40890b04d713c6d5636e0ac1596c887771100e52b9619cb7aba344119b2adf15

250−6 \\x2a4e2f5621af53d8aca32b0e6ef9f784661e0d25e9f3c1a6147da28c8ec582b86c1edfd9ad50672156c5b8956eab0f4039ef9f5194c078ae09b6b908997cb828 2020-05-12 12:58:03.390233+00 \N 10 Windows 10 — Chrome \N \\xa0fa6918589bee447fa3d63548390836d95571cf94e4056e4cd51cab5f5cdad579774c55385173893bb5cf8f7123ea123fa8de7d6c1fd22bb07fae05eb82c470

251−6 \\xe79fbed1a6a85dca69674ce3c8f0d04087e3ca08e61a1e6570402405f56f6d7e1ff405c345027645636799e3b67ff432d3885e8f87fd9f37dcbdd509264ab4c9 2020-05-12 13:02:15.709627+00 \N 10 Windows 10 — Chrome \N \\xf39f55f18841a4c029d2721dd911e07738011cc0043b783c615d6f68238b60ddc3fc9f13e0f93ca918a81b274c86c6c412b0d1d5d283eea26e5d331ab4eceb63

252−6 \\x791f98bdab86f17dc631d8a641308babd1bf6a6d80c8d9a13474847b5bdd403a07ceda5bfda647ceeea52cc15d24dcb84417c3900f7744d548f3c11c4927a636 2020-05-12 13:00:39.90702+00 \N 10 Windows 10 — Chrome \N \\x54277fb3f03893ee8ca550f6cfd7b2cf03f792ee987dae7a36ecb6b052f5bc46d1262eabc34e2ee6d896f3ba50a9c309cba785ed55928866b1f4d1217e5d62fe

253−6 \\x8475047b3f4cf52c58d31b5f40f51fbcb421e889b9545af40685b50f77c32060c08adb7593733d174d0d705e7a11b05352745f997e151383c3df4087b87aa437 2020-05-12 13:08:36.061589+00 \N 10 Windows 10 — Chrome \N \\x32b6441572986f12c92b4cab97231ed416b0c1538589061bc1498af55b12d6abf16ba10842c97f950ace47bd6a34499a458112de353e003336eaefd87232a441

254−6 \\xe50a1cabdbce47cd7384ea7e7b9a4ebd1f70bd4d2270f7fd1449243e3c2a514f6374a9415b838a88d44be91260b1c8e789c02451a5215caa823e85ce9a6c6a35 2020-05-12 13:11:01.163827+00 \N 10 Windows 10 — Chrome \N \\x4cc5ab60a8b31de5109f9f0f86754e5654aecc8a83b5c553854809690a576d94d71f474d776d490828522db88349c607968d120af014bebdfcc984ff11ec97f3

255−6 \\x14ecc52de16df124a0cfdd6fac2af58998d7ef75a4b77dc6ffcbebfcb1a0641933125399ccb83ff162b5a4c526cae43989c73db33f5f4e9cd0d667ffa64b1491 2020-05-12 13:15:09.286079+00 \\xa3c9a1ed5ad4cf49cc0d90f9e0f179975cddab69f2306e205a35f1a4daac65dc75cd5182de269d7b1b4f21e6de154279363c31ff7807ee0998e54cc408c542a4 10 Windows 10 — Opera \\x53b20233e1912eb3e1889f7d62813852a6f00160c923640e0500b3c8056c0e1582cc6ab1f0860c9ea377b7bc057cabc8d1107bfd09a4e1de1a5200facc9e4680 \\x976304336533e75ebd013d336daaec896ea6aac620ba76593cf0f5e9067bbcbd7c22db86c9cf570e555a7d3d38840dea671897363c5de797628db25819cea194

256−12 \\x9a3f1bc8ad7af3256544d16b10af39f170671b37913ad0795b7c83b92c165815d52e04ae41a778ba1987ceb7ec3771a8a96c2117b1a93e53086a7aa72b744101 2020-05-12 13:17:22.323574+00 \\x68614722f437fd805c9bef73e1319a60ab7ae8d1e669afe8a52c7853d19da646dbd72ad8026329c2555c0b5e5ad4f16793b0a0b55e33f5ca97b941b4d28a03ae 10 Mac OS X — Chrome \\x03906cccc155cfe4ef4b237e7663f05616623b7a10c2443248f79f3ff9fd3df9c4052107b11e3426a66427b7a22c1205ef6b6b8eaa366500f4ed775281a44bb9 \\x1d33623701873d27f030afc04b3af27554adde549230e814b1791c9104591ca1751e865c89591b689df1e02ffbdfe279fccfd59335d448313a6c7b0c6db34818

257−12 \\xdb2021edc253bfdf75870708682c0b17c60d9d2552d614da87874341127549d811b49b331f66902e583937282f8b433b64111a28647447bac45457fbc4951397 2020-05-12 13:17:25.803874+00 \N 9 Mac OS X — Chrome \N \\x404618e3db88af5f6f48d97526ba2d813ae4cd98943892a3eb33d606182a4c685d1f251c577894aa2d6f192446e6c377250c0f1c199eaae0164e6908921d56d3

258−6 \\xff236155bcdc965d10d97e37b95498cd48e84f91d84cbf9eeb7149d4488174d0c011ebcec15a708775fc02eb48d987c6a707460cf3f4ad6a5920acfa25e4097d 2020-05-12 13:20:49.70022+00 \N 10 Windows 10 — Chrome \N \\xac51b5e531a71c2b90024e308ded6bcf291327ccf58c2a38a79e93cd21aef908469e3ba731d438df0dd830bd9e91a3b4af8baefcf1481539face9f7bd284dc63

259−6 \\xd8068bbf1c75403f98bc65d5b5023773391eb157e71b1796d5ef8ff6e51e12dfa8eee816dd387a8284e62abf3622bdd62e986ab70d4e7c06eadf0c336c7ddf65 2020-05-12 13:42:52.574211+00 \N 10 Windows 10 — Chrome \N \\xfe79ff74735cb836511460da0b64387353ac5d1328f8c429312e09ad27d7d76344ff0ff760beca020bcc651ce6e2014049836bdf8fd2e0b79c752bb58a44edd2

260−6 \\x4054af8d092a164806b1f5c1a9272fef54d04b14fea1c5c7e1cdbb82541339198bb449f10aeaa6c729b5d60b72201230ccf2cc023d4457cc7990b37b74c53680 2020-05-12 13:43:48.856981+00 \N 10 Windows 10 — Opera \N \\x34cf5f64da39a5f9348f024fe04ca22c0f71b85fe3e1538474d1605aef8e65e0dd6b01a31dbb5a6ca5d957edfc746e395a40832406cf6fe3b4bf6f9d67f6d2b1

261−6 \\xca1eaaff2de79c350e2b452a8adac5d465def68a81b2cae0ce6c6ab06b79fb862594b8557b3d45da17ad2ec2d6cdb19792f6168be7513f30afd709a04bf4a045 2020-05-12 14:12:24.590032+00 \N 10 Windows 10 — Chrome \N \\x3099f74e612c1ef8b65d742748232025bdb7c6e54dbcdca70ff015b3f6ed1ed9b6b8b03e5a9cefe80a81598b40e8603ac8d643a4728904a96f8283b4132a670b

262−12 \\xe9135b7110691c01639db7fe5828c1bbb1fda424d4eb4ede378413493742ef360af3fd97b71f2a99977222725d9e22c8eef62e89331ae2dd269678d8549c44f7 2020-05-12 17:39:51.225664+00 \N 10 iOS \N \\x78ccada9b2d8e9a7aa553ad2d1143eff23b8b59caaf3e573cfb115bd66aa2c2d3735fab6bee8fe0c83bc00148129793b806824c2901adc73665841f88b8f15f0

263−12 \\x4b61df40968e85661eb637ede9aa49bedb12eb9fbaad1250317f102390ae474bc9fc6e49e9f06b61a9b2f79eb9a72c59d0178080d4699abae2b3406bd3702fd0 2020-05-12 19:26:49.449533+00 \N 10 Mac OS X — Chrome \N \\xfc0df82243a1174a1c60f066369a22fb75c516e071061dbc539a61cee7853b081dfdb0e6ef05f85cf6a70d9a6a184daa2f8d46de41ae5aab95c0f0f553875411

264−6 \\x2d1108aa6559686f85b32cb0ed446d42c64021ff43539b4e4462b697dcf2ec1c6c6c306100be9aee0e1321dac27a5dcee76a34abcfda77a7949b01e64a6acdb6 2020-05-12 14:22:04.298934+00 \N 10 Windows 10 — Chrome \N \\x347810d21c6b1c39fc8deb5056df65f5aff393a8b94b4f9fc80064a5d4e3b98d3b6de9ea8e2fcc0625ede95a3cf94f707c490710da086d6dfe645f6bc498d814

265−11 \\xd0c382a30c6508107c4095fbe6713c8b987d51145e5e95b25fe082d00c89af26c9d4f46b5c6a9a63bbc82a63a57c9c0d488cb6787f64465a0b29dbe4b481aec1 2020-05-12 20:06:08.427816+00 \N 10 Mac OS X — Chrome \N \\xc7d039fa0c13356ffd1379a8ec10a97b3bbfafb0a3222aaabff85c5467ffb8224bbf1e450aafd278642aa457db904d4318d05a37a3ad65b6e42055729baa992c

266−6 \\x783d36a882b22f9e35e0e67f16058bb01d07bbaee4f35465f84125868367161aa77a48c24fce9a8587ab5baeaefc7f20d2d1fbe6b9ffc3e7ea079ce4b4fc2065 2020-05-12 21:05:34.945924+00 \\xaed141900570ffbc6027328ebaedc19516014fd15e51f2dac2f63d0ebdcc0b6e42893be3ad9edca85b521412357bb0e2ec74eb359af17b6d7d5bbac9b59912e4 10 Windows 10 — Chrome \\xa17c601d49975527b36bdeccfedca7f66bbc0603ed8456fe99c8592e270f070ab15dd083efc278665c295af2667b345c24f1da9d1d19299bbd001971b4e3f112 \\xe887bda8dc9e076244c88d678885f81b21b93d228fe24cd0f8619203671e40e0db8d4f50168083f1742809cb75338ddc62c08ba017790ea6f15602ef2fa77fac

267−11 \\x467a1e43d01b6d92be00e984d74d2984225cead7380ddba3a3b962b64fa7c99878cfda33c15bc72826fd4d747c05b1905a51fcecd7bdc2c20322c1c9c0cde1b8 2020-05-12 21:35:38.166955+00 \N 10 Mac OS X — Chrome \N \\xab87612391d51e870bce7b33ed618fbc1310cf2bfffe7cb8a887a161a107187924848e0f9aab60fd2719155984a800181a4d1dc7b58680da197b2b1e373df210

268−\.

269−

270−

271−--

272−-- Data for Name: users; Type: TABLE DATA; Schema: public; Owner: qsfrneimsrtpjz

273−--

274−

275−COPY public.users ("userRowId", "userRowFirstName", "userRowMiddleName", "userRowLastName", "userRowFacultyUrl", "userRowEmail", "userRowIsValidated") FROM stdin;

276−12 Дарья Юрьевна Редникина strategy.hse.ru/ dyurednikina@edu.hse.ru t

277−18 Darya _ _ cs.hse.ru/dse/ rednikina.com@yandex.ru t

278−6 Костя Игоревич Манежин perm.hse.ru/sgf/hum/ kimanezhin@edu.hse.ru t

279−11 Костюченко Игоревич Илья spb.hse.ru/fmcs/math/ iikostyuchenko@edu.hse.ru t

280−3 Анна Денисовна Михалева spb.hse.ru/humart/design/ admikhaleva@edu.hse.ru t

281−9 Darya Yuryevna Rednikina cs.hse.ru/dse/ dyrednikina@edu.hse.ru f

282−17 anna denisovna mikhaleva scem.spb.hse.ru/man/ hello@edu.hse.ru f

283−10 Seva Algebrovich Leonidov cs.hse.ru/dse/ iikostyuchen@edu.hse.ru f

284−\.

285−

286−

287−--

288−-- Name: channels_namedChannelFullId_seq; Type: SEQUENCE SET; Schema: public; Owner: qsfrneimsrtpjz

289−--

290−

291−SELECT pg_catalog.setval('public."channels_namedChannelFullId_seq"', 37, true);

292−

293−

294−--

295−-- Name: groupChats_groupChatId_seq; Type: SEQUENCE SET; Schema: public; Owner: qsfrneimsrtpjz

296−--

297−

298−SELECT pg_catalog.setval('public."groupChats_groupChatId_seq"', 24, true);

299−

300−

301−--

302−-- Name: messages_messageStorageId_seq; Type: SEQUENCE SET; Schema: public; Owner: qsfrneimsrtpjz

303−--

304−

305−SELECT pg_catalog.setval('public."messages_messageStorageId_seq"', 164, true);

306−

307−

308−--

309−-- Name: posts_postRowId_seq; Type: SEQUENCE SET; Schema: public; Owner: qsfrneimsrtpjz

310−--

311−

312−SELECT pg_catalog.setval('public."posts_postRowId_seq"', 49, true);

313−

314−

315−--

316−-- Name: quotes_quoteRowId_seq; Type: SEQUENCE SET; Schema: public; Owner: qsfrneimsrtpjz

317−--

318−

319−SELECT pg_catalog.setval('public."quotes_quoteRowId_seq"', 1, false);

320−

321−

322−--

323−-- Name: users_userRowId_seq; Type: SEQUENCE SET; Schema: public; Owner: qsfrneimsrtpjz

324−--

325−

326−SELECT pg_catalog.setval('public."users_userRowId_seq"', 18, true);

327−

328−

329−--

330−-- Name: channels pk_channels; Type: CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

331−--

332−

333−ALTER TABLE ONLY public.channels

334− ADD CONSTRAINT pk_channels PRIMARY KEY ("namedChannelFullId");

335−

336−

337−--

338−-- Name: faculties pk_faculties; Type: CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

339−--

340−

341−ALTER TABLE ONLY public.faculties

342− ADD CONSTRAINT pk_faculties PRIMARY KEY ("facultyUrl");

343−

344−

345−--

346−-- Name: groupChats pk_group_chats; Type: CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

347−--

348−

349−ALTER TABLE ONLY public."groupChats"

350− ADD CONSTRAINT pk_group_chats PRIMARY KEY ("groupChatId");

351−

352−

353−--

354−-- Name: messages pk_messages; Type: CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

355−--

356−

357−ALTER TABLE ONLY public.messages

358− ADD CONSTRAINT pk_messages PRIMARY KEY ("messageStorageId");

359−

360−

361−--

362−-- Name: quotes pk_post_quotes; Type: CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

363−--

364−

365−ALTER TABLE ONLY public.quotes

366− ADD CONSTRAINT pk_post_quotes PRIMARY KEY ("quoteRowId");

367−

368−

369−--

370−-- Name: posts pk_posts; Type: CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

371−--

372−

373−ALTER TABLE ONLY public.posts

374− ADD CONSTRAINT pk_posts PRIMARY KEY ("postRowId");

375−

376−

377−--

378−-- Name: users pk_users; Type: CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

379−--

380−

381−ALTER TABLE ONLY public.users

382− ADD CONSTRAINT pk_users PRIMARY KEY ("userRowId");

383−

384−

385−--

386−-- Name: users user_email; Type: CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

387−--

388−

389−ALTER TABLE ONLY public.users

390− ADD CONSTRAINT user_email UNIQUE ("userRowEmail");

391−

392−

393−--

394−-- Name: posts fk_author_id; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

395−--

396−

397−ALTER TABLE ONLY public.posts

398− ADD CONSTRAINT fk_author_id FOREIGN KEY ("postRowAuthorId") REFERENCES public.users("userRowId") ON UPDATE CASCADE ON DELETE CASCADE;

399−

400−

401−--

402−-- Name: channels fk_channels_users_id; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

403−--

404−

405−ALTER TABLE ONLY public.channels

406− ADD CONSTRAINT fk_channels_users_id FOREIGN KEY ("namedChannelFullOwner") REFERENCES public.users("userRowId") ON UPDATE CASCADE ON DELETE CASCADE;

407−

408−

409−--

410−-- Name: messages fk_messages_author; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

411−--

412−

413−ALTER TABLE ONLY public.messages

414− ADD CONSTRAINT fk_messages_author FOREIGN KEY ("messageStorageAuthorId") REFERENCES public.users("userRowId") ON UPDATE CASCADE ON DELETE CASCADE;

415−

416−

417−--

418−-- Name: messages fk_messages_group; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

419−--

420−

421−ALTER TABLE ONLY public.messages

422− ADD CONSTRAINT fk_messages_group FOREIGN KEY ("messageStorageDestinationGroupId") REFERENCES public."groupChats"("groupChatId") ON UPDATE CASCADE ON DELETE CASCADE;

423−

424−

425−--

426−-- Name: messages fk_messages_to_user; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

427−--

428−

429−ALTER TABLE ONLY public.messages

430− ADD CONSTRAINT fk_messages_to_user FOREIGN KEY ("messageStorageDestinationUserId") REFERENCES public.users("userRowId") ON UPDATE CASCADE ON DELETE CASCADE;

431−

432−

433−--

434−-- Name: postElements fk_post_quote_id; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

435−--

436−

437−ALTER TABLE ONLY public."postElements"

438− ADD CONSTRAINT fk_post_quote_id FOREIGN KEY ("rowElementQuote") REFERENCES public.quotes("quoteRowId") ON UPDATE CASCADE ON DELETE CASCADE;

439−

440−

441−--

442−-- Name: postElements fk_post_quote_self_id; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

443−--

444−

445−ALTER TABLE ONLY public."postElements"

446− ADD CONSTRAINT fk_post_quote_self_id FOREIGN KEY ("rowElementId") REFERENCES public.posts("postRowId") ON UPDATE CASCADE ON DELETE CASCADE;

447−

448−

449−--

450−-- Name: quotes fk_quote_post_id; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

451−--

452−

453−ALTER TABLE ONLY public.quotes

454− ADD CONSTRAINT fk_quote_post_id FOREIGN KEY ("quoteRowPostId") REFERENCES public.posts("postRowId") ON UPDATE CASCADE ON DELETE CASCADE;

455−

456−

457−--

458−-- Name: quoteElements fk_quote_quote_id; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

459−--

460−

461−ALTER TABLE ONLY public."quoteElements"

462− ADD CONSTRAINT fk_quote_quote_id FOREIGN KEY ("rowElementQuote") REFERENCES public.quotes("quoteRowId") ON UPDATE CASCADE ON DELETE CASCADE;

463−

464−

465−--

466−-- Name: quoteElements fk_quotes_quote_self_id; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

467−--

468−

469−ALTER TABLE ONLY public."quoteElements"

470− ADD CONSTRAINT fk_quotes_quote_self_id FOREIGN KEY ("rowElementId") REFERENCES public.quotes("quoteRowId") ON UPDATE CASCADE ON DELETE CASCADE;

471−

472−

473−--

474−-- Name: users fk_user_faculty; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

475−--

476−

477−ALTER TABLE ONLY public.users

478− ADD CONSTRAINT fk_user_faculty FOREIGN KEY ("userRowFacultyUrl") REFERENCES public.faculties("facultyUrl") ON UPDATE CASCADE ON DELETE RESTRICT;

479−

480−

481−--

482−-- Name: tokens fk_user_token; Type: FK CONSTRAINT; Schema: public; Owner: qsfrneimsrtpjz

483−--

484−

485−ALTER TABLE ONLY public.tokens

486− ADD CONSTRAINT fk_user_token FOREIGN KEY ("tokenUserId") REFERENCES public.users("userRowId") ON UPDATE CASCADE ON DELETE CASCADE;

487−

488−

489−--

490−-- Name: LANGUAGE plpgsql; Type: ACL; Schema: -; Owner: postgres

491−--

492−

493−GRANT ALL ON LANGUAGE plpgsql TO qsfrneimsrtpjz;

494−

495−

496−--

497−-- PostgreSQL database dump complete

498−--

499−

stack.yaml+1−3

@@ -37,9 +37,7 @@ packages:

37# Dependency packages to be pulled from upstream that are not in the resolver

38# using the same syntax as the packages field.

39# (e.g., acme-missiles-0.3)

40−extra-deps:

40+# extra-deps:

41−- taggy-0.2.1

42−- crypto-rng-0.1.0.2

43# - servant-options-0.1.0.0

41# - servant-options-0.1.0.0