git.iko.soy/denis
on a403d84 help sign in
8646813
swap
0 ahead, 170 behind
.gitignore+1−2
since splitsnapshots
unifiedsplit
@@ -21,5 +21,4 @@ cabal.project.local~
21.HTF/
21.HTF/
22.ghc.environment.*
22.ghc.environment.*
23/backup/
23/backup/
24−.DS_Store
24+.DS_Store
25−/docs/
Procfile+1−1
@@ -1 +1 @@
1−web: denis-exe +RTS -N
1+web: denis-exe
denis/docs/Docs.hs+31−30
@@ -6,10 +6,13 @@
6
6
7import Server.API
7import Server.API
8import Servant.Docs
8import Servant.Docs
9+import Servant.API
10+import Data.Post
9import qualified Data.Text as T
11import qualified Data.Text as T
10import Servant.Server
12import Servant.Server
11import Servant
13import Servant
12import Server.Auth
14import Server.Auth
15+import Control.Lens
13import Data.Aeson
16import Data.Aeson
14import Data.PostElement
17import Data.PostElement
15import Data.Proxy
18import Data.Proxy
@@ -17,46 +20,44 @@ import Data.User
17import Data.Int (Int64)
20import Data.Int (Int64)
18import Data.Word (Word64)
21import Data.Word (Word64)
19import Server.API.Posts
22import Server.API.Posts
23+import Server.API.Draft
20import Server.Logger
24import Server.Logger
21−import Server.Auth
22−import Server.API.Channels
23−import 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
29−
30−docsWriter :: HasDocs api => String -> Proxy api -> IO ()
31−docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs
32−
33−main = do
34− docsWriter "posts" $ pretty (Proxy :: Proxy ("posts" :> PostApi))
35− docsWriter "messages" $ pretty (Proxy :: Proxy (MessagesApi))
36− docsWriter "all" $ pretty serverProxy
37− docsWriter "authentication" $ pretty (Proxy :: Proxy ("authentication" :> AuthenticationHandler :<|>
38− Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))
39− 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))
42
25
26+main = writeFile "docs.md" . markdown . docs . pretty $ serverProxy
27+
28+instance ToSample AuthenticationCredits where
29+ toSamples _ = samples $ map AuthenticationCredits [56, 103, 8]
43
30
44instance ToSample Char where
31instance ToSample Char where
45− toSamples _ = singleSample 'c'
32+ toSamples _ = singleSample $ 'c'
33+
34+instance HasDocs api => HasDocs ((AuthProtect "basicAuth") :> api) where
35+ docsFor Proxy (endpoint, action) =
36+ docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `401 Unauthorized` if the cookies are invalid or don't premit access to the requested data."]])
37+
38+instance ToSample (PostData a) where
39+ toSamples _ = samples $ [PostData 8 17] <*> (map snd $ toSamples Proxy)
40+
41+instance ToSample (PostElement p) where
42+ toSamples _ = samples [
43+ Markdown "# This is a markdown title\nThis is body.",
44+ Markdown "## This is a subtitle\n_hello._"
45+ ]
46
46
47instance ToSample Int64 where
47instance ToSample Int64 where
48 toSamples _ = samples [1, 7, 2, 19]
48 toSamples _ = samples [1, 7, 2, 19]
49
49
50instance ToSample Word64 where
50instance ToSample Word64 where
51 toSamples _ = samples [1, 7, 2, 19]
51 toSamples _ = samples [1, 7, 2, 19]
52+
53+instance ToSample User where
54+ toSamples _ = samples [User 8 "Vasya" "Pupkin", User 69 "Seva" "Leonidov"]
52
55
53−instance ToSample Log where
56+instance ToSample UserPostsRequest where
54− toSamples _ = noSamples
57+ toSamples _ = samples [UserPostsRequest 8 10, UserPostsRequest 42 20]
55
58
56−instance ToSample () where
59+instance ToSample DraftUpdate where
57− toSamples _ = singleSample ()
60+ toSamples _ = samples $ [DraftUpdate 8] <*> (map snd $ toSamples Proxy)
58
61
59−normalizer :: String -> String
62+instance ToSample Log where
60−normalizer (' ':' ':' ':' ':'`':'`':'`':xs) = "```" ++ normalizer xs
63+ toSamples _ = samples ["Log"]
61−normalizer (x:xs) = x : normalizer xs
62−normalizer "" = ""
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−29
@@ -27,10 +27,12 @@ dependencies:
27- text
27- text
28- aeson
28- aeson
29- bytestring
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
@@ -46,27 +48,12 @@ dependencies:
46- wai-extra
48- wai-extra
47- data-default-class
49- data-default-class
48- fast-logger
50- fast-logger
49−- vector
51+
50−- taggy
51−- unordered-containers
52−- req
53−- data-default
54- lens
52- lens
55−- crypto-rng
53+
56- wai-cors
54- wai-cors
57−- base64-bytestring
55+
58−- regex-compat
56+
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
70
57
71library:
58library:
72 source-dirs: src
59 source-dirs: src
@@ -109,13 +96,4 @@ executables:
109 - -rtsopts
96 - -rtsopts
110 - -with-rtsopts=-N
97 - -with-rtsopts=-N
111 dependencies:
98 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
99 - 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.hsdeleted−61
@@ -1,61 +0,0 @@
1−{-# LANGUAGE
2− DataKinds ,
3− DeriveGeneric ,
4− OverloadedLabels,
5− OverloadedStrings ,
6− TypeApplications ,
7− TypeOperators,
8− OverloadedStrings,
9− RecordWildCards #-}
10−
11−module Data.Channel.AnonymousChannel (
12− AnonymousChannelId,
13− AnonymousChannel(..)
14−) where
15−
16−import Data.Int (Int64)
17−import qualified Generics.SOP as SOP
18−import qualified GHC.Generics as GHC
19−import Data.Aeson
20−import Servant.Docs (ToSample, toSamples, samples)
21−import Data.Text (Text)
22−import qualified Data.Vector as V
23−import Data.User
24−import qualified Data.Set as Set
25−import Data.Tags.Validation
26−import Data.Text.Validator
27−
28−-- MARK: Documentation
29−
30−instance ToSample AnonymousChannel where
31− toSamples _ = samples $ AnonymousChannel <$> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [[2, 7, 8]]
32−
33−
34−instance HasValidatableText AnonymousChannel where
35− validateText AnonymousChannel{..} = all (validateText . (~= validateTag')) anonymousChannelTags
36−
37−-- MARK: Implementation
38−
39−type AnonymousChannelId = Int64
40−
41−data AnonymousChannel = AnonymousChannel {
42− anonymousChannelTags :: V.Vector Text,
43− anonymousChannelPeopleIds :: [UserId]
44−} deriving GHC.Generic
45−
46−instance SOP.Generic AnonymousChannel
47−instance SOP.HasDatatypeInfo AnonymousChannel
48−
49−instance ToJSON AnonymousChannel where
50− toJSON (AnonymousChannel cTags cPeople) = object [
51− "tags" .= cTags,
52− "people" .= cPeople ]
53−
54−instance FromJSON AnonymousChannel where
55− parseJSON = withObject "anonymous channel" $ \e ->
56− AnonymousChannel <$> fmap (V.fromList . removeDuplicates) (e .: "tags") <*> fmap removeDuplicates (e .: "people")
57− where
58− removeDuplicates :: Ord a => [a] -> [a]
59− removeDuplicates = Set.toList . Set.fromList
60−
61−
denis/src/Data/Channel/NamedChannel.hsdeleted−93
@@ -1,93 +0,0 @@
1−{-# LANGUAGE
2−DataKinds ,
3−DeriveGeneric ,
4−OverloadedLabels,
5−OverloadedStrings ,
6−TypeApplications ,
7−TypeOperators,
8−OverloadedStrings,
9−RecordWildCards #-}
10−
11−module Data.Channel.NamedChannel (
12− NamedChannelId,
13− NamedChannel(..),
14− NamedChannelCreationRequest(..)
15−) where
16−
17−import Data.Int (Int64)
18−import qualified Generics.SOP as SOP
19−import qualified GHC.Generics as GHC
20−import Data.Aeson
21−import Servant.Docs (ToSample, toSamples, samples)
22−import Data.Proxy
23−import Data.Text (Text)
24−import qualified Data.Vector as V
25−import Data.User
26−import qualified Data.Set as Set
27−import Data.Text.Validator
28−import Data.Tags.Validation
29−import Data.Limits
30−
31−-- MARK: Documentation
32−
33−instance (ToSample u) => ToSample (NamedChannel u) where
34− toSamples _ = samples $ NamedChannel <$> [8] <*> ["социология", "ФКН"] <*> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [V.fromList (map snd $ toSamples Proxy)]
35−
36−instance ToSample NamedChannelCreationRequest where
37− toSamples _ = samples $ NamedChannelCreationRequest <$> ["социология", "ФКН"] <*> [V.fromList ["thisIsHashTag", "thisIsAlsoHashTag"]] <*> [V.fromList [2, 7, 8]]
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
46−
47−type NamedChannelId = Int64
48−
49−-- Note: Channel owner only exists in sql
50−data NamedChannel u = NamedChannel {
51− namedChannelId :: NamedChannelId,
52− namedChannelName :: Text,
53− namedChannelTags :: V.Vector Text,
54− namedChannelPeopleIds :: V.Vector u
55−} deriving GHC.Generic
56−
57−instance (ToJSON u) => ToJSON (NamedChannel u) where
58− toJSON (NamedChannel cId cName cTags cPeople) = object [
59− "id" .= cId,
60− "name" .= cName,
61− "tags" .= cTags,
62− "people" .= cPeople ]
63−
64−instance (FromJSON u, Ord u) => FromJSON (NamedChannel u) where
65− parseJSON = withObject "named channel" $ \e ->
66− NamedChannel <$> e .: "id" <*> e .: "name" <*> fmap removeDuplicates (e .: "tags") <*> fmap removeDuplicates (e .: "people")
67− where
68− removeDuplicates :: Ord a => [a] -> V.Vector a
69− removeDuplicates = V.fromList . Set.toList . Set.fromList
70−
71−-- MARK: NamedChannelCreationRequest
72−
73−data NamedChannelCreationRequest = NamedChannelCreationRequest {
74− namedChannelCreationRequestName :: Text,
75− namedChannelCreationRequestTags :: V.Vector Text,
76− namedChannelCreationRequestPeopleIds :: V.Vector UserId
77−} deriving GHC.Generic
78−
79−instance SOP.Generic NamedChannelCreationRequest
80−instance SOP.HasDatatypeInfo NamedChannelCreationRequest
81−
82−instance ToJSON NamedChannelCreationRequest where
83− toJSON (NamedChannelCreationRequest cName cTags cPeople) = object [
84− "name" .= cName,
85− "tags" .= cTags,
86− "people" .= cPeople ]
87−
88−instance FromJSON NamedChannelCreationRequest where
89− parseJSON = withObject "named channel" $ \e ->
90− NamedChannelCreationRequest <$> e .: "name" <*> fmap removeDuplicates (e .: "tags") <*> fmap removeDuplicates (e .: "people")
91− where
92− removeDuplicates :: Ord a => [a] -> V.Vector a
93− removeDuplicates = V.fromList . Set.toList . Set.fromList
denis/src/Data/Connection.hs+8−38
@@ -4,65 +4,35 @@
4 OverloadedLabels,
4 OverloadedLabels,
5 OverloadedStrings ,
5 OverloadedStrings ,
6 TypeApplications ,
6 TypeApplications ,
7− TypeOperators,
7+ TypeOperators #-}
8− FlexibleContexts #-}
9
8
10module Data.Connection (
9module Data.Connection (
11 Connection,
10 Connection,
12 StaticPQ,
11 StaticPQ,
13 runQ,
12 runQ,
14 runQ',
13 runQ',
15− runQnotFound,
14+ runQnotFound
16− runQerror,
17− maybeNotFound,
18− maybeInvalidToken,
19− commitedTransactionallyUpdate,
20− runQsilent
21) where
15) where
22
16
23import Squeal.PostgreSQL
17import Squeal.PostgreSQL
18+import Squeal.PostgreSQL.PQ
24import Squeal.PostgreSQL.Pool
19import Squeal.PostgreSQL.Pool
20+import qualified Generics.SOP as SOP
25import Data.Schema
21import Data.Schema
26import Server.App
22import Server.App
23+import Control.Monad.Base
27import Control.Monad.Reader
24import Control.Monad.Reader
28−import Control.Monad.Except
29import Servant.Server
25import Servant.Server
30−import Server.Error
26+import Control.Monad.Error
31−import Control.Monad.Trans.Control
27+import Servant.Server
32
28
33type StaticPQ = PoolPQ Schema Handler
29type StaticPQ = PoolPQ Schema Handler
34
30
35−printRed :: (Show a) => a -> IO ()
36−printRed a = do
37− putStr "\a\x001b[31m"
38− print a
39− putStr "\x001b[0m"
40
31
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
43
34
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
46
37
47−runQnotFound :: StaticPQ a -> App a
48runQnotFound = runQ err404
38runQnotFound = runQ err404
49−
50−runQerror :: StaticPQ a -> App a
51−runQerror = runQ err500
52−
53−runQsilent :: StaticPQ a -> App ()
54−runQsilent req = handleSqueal (liftIO . print) $ asks getPool >>= lift . runPoolPQ req
55− >> return ()
56−
57−maybeNotFound :: App (Maybe a) -> App a
58−maybeNotFound = (>>= (\t -> case t of
59− Just y -> return y
60− Nothing -> throwError err404))
61−
62−maybeInvalidToken :: App (Maybe a) -> App a
63−maybeInvalidToken = (>>= (\t -> case t of
64− Just y -> return y
65− Nothing -> throwError invalidToken))
66−
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+62−79
@@ -5,112 +5,95 @@
5 OverloadedStrings ,
5 OverloadedStrings ,
6 TypeApplications ,
6 TypeApplications ,
7 TypeOperators,
7 TypeOperators,
8− OverloadedStrings #-}
8+ OverloadedStrings,
9+ KindSignatures #-}
9
10
10module Data.Post (
11module Data.Post (
11− Post(..),
12+ Post,
13+ postId,
14+ postAuthorId,
15+ postBody,
12− PostElement,
16+ PostElement(..),
17+ PostQuote(..),
18+ PostRow,
19+ PostQuoteRow,
20+ ElementRow,
21+ postToRow,
22+ postToElementRows,
13 rowsToPost,
23 rowsToPost,
14 PostId,
24 PostId,
15 QuoteId,
25 QuoteId,
16− PostRowResponse(..),
26+ Draft,
17− PostCreation(..)
27+ DraftId,
28+ mkDraft,
29+ fromDraft,
30+
31+ -- for docs only
32+ PostData(..),
33+ PostType(..)
18−) where
34+) where
19
35
20import Data.Int (Int64)
36import Data.Int (Int64)
37+-- import Squeal.PostgreSQL
38+-- import Squeal.PostgreSQL.Render
39+-- import qualified Squeal.PostgreSQL.PQ as P
21import qualified Generics.SOP as SOP
40import qualified Generics.SOP as SOP
22import qualified GHC.Generics as GHC
41import qualified GHC.Generics as GHC
42+-- import Squeal.PostgreSQL.Schema
23import Data.Aeson
43import Data.Aeson
24−import Servant.Docs (ToSample, toSamples, samples)
25−import Data.Proxy
26−import Data.PostElement
27−import Data.Text (Text)
28−import Data.Function (on)
29−import Data.Time.Clock
30−import Data.Time.Calendar
31−import qualified Data.Vector as V
44+import qualified Data.Map.Lazy as M
32−import Data.Tags.Validation
33−import Data.Text.Validator
34−
35−-- MARK: Documentation
36−
37−instance ToSample Post where
38− toSamples _ = samples $ [Post 8 17 time $ V.fromList ["hse", "cs", "machineLearning"]] <*> (map snd $ toSamples Proxy)
39− where time = UTCTime (ModifiedJulianDay 1000) 8
40
45
41−instance ToSample PostCreation where
46+import Data.PostElement
42− toSamples _ = samples $ PostCreation <$> (map snd $ toSamples Proxy) <*> [(V.fromList ["hse", "cs", "machineLearning"])]
47+-- import Data.RowConvertable
43−
44−instance HasValidatableText PostCreation where
45− validateText (PostCreation body tags) = all validateText body && all (validateText . (~= validateTag')) tags
46
48
47−-- MARK: Actual type
49+-- MARK: Actual type
48
50
49type PostId = Int64
51type PostId = Int64
50type QuoteId = Int64
52type QuoteId = Int64
53+type DraftId = Int64
51
54
52−data Post = Post {
55+data PostType = Draft | NonDraft
56+
57+data PostData (p :: PostType) = PostData {
53 postId :: Int64,
58 postId :: Int64,
54 postAuthorId :: Int64,
59 postAuthorId :: Int64,
55− updated :: UTCTime,
56− postTags :: V.Vector Text,
57− postBody :: [PostElement Post]
60+ postBody :: [PostElement (PostData p)]
58−} deriving (Show)
61+}
59−
60−instance ToJSON Post where
61− toJSON (Post pId aId tm tags pb) = object [
62− "id" .= pId,
63− "authorId" .= aId,
64− "updated" .= tm,
65− "tags" .= tags,
66− "body" .= pb ]
67
62
68−data PostCreation = PostCreation {
63+type Post = (PostData 'NonDraft)
69− postCreationBody :: [PostElement Post],
64+type Draft = (PostData 'Draft)
70− postCreationTags :: V.Vector Text
71−} deriving GHC.Generic
72
65
73−instance SOP.Generic PostCreation
66+mkDraft :: DraftId -> Int64 -> [PostElement Draft] -> Draft
74−instance SOP.HasDatatypeInfo PostCreation
67+mkDraft = PostData
75
68
76−instance ToJSON PostCreation where
69+instance ToJSON (PostData p) where
77− toJSON (PostCreation body tags) = object [
70+ toJSON (PostData pId aId pb) = object [
78− "tags" .= tags,
71+ "id" .= pId,
72+ "authorId" .= aId,
79− "body" .= body ]
73+ "body" .= pb ]
80−
81−instance FromJSON PostCreation where
82− parseJSON = withObject "post creation" $ \e ->
83− PostCreation <$> e .: "body" <*> e .: "tags"
84
74
85
75
86-- MARK: Rows
76-- MARK: Rows
87
77
88−-- Need to manually maintain. Future: https://github.com/morphismtech/squeal/issues/96
78+data PostRow = PostRow {
89−
90−data PostRowResponse = PostRowResponse {
91− -- PostRow
92 postRowId :: Int64,
79 postRowId :: Int64,
93− postRowAuthorId :: Int64,
80+ postRowAuthorId :: Int64
94− postRowUpdateTime :: UTCTime,
95− postRowTags :: V.Vector Text,
96−
97− -- ElementRow
98− rowElementOrd :: Int64,
99− rowElementMarkdown :: Maybe Text,
100− rowElementLatex :: Maybe Text,
101− rowElementImage :: Maybe Text,
102− rowElementQuote :: Maybe Int64,
103− rowElementAttachment :: Maybe Text
104} deriving (GHC.Generic)
81} deriving (GHC.Generic)
105
82
106−instance SOP.Generic PostRowResponse
83+instance SOP.Generic PostRow
107−instance SOP.HasDatatypeInfo PostRowResponse
84+instance SOP.HasDatatypeInfo PostRow
85+
86+postToRow :: Post -> PostRow
87+postToRow (PostData pId aId _) = PostRow pId aId
88+
89+postToElementRows :: PostData p -> [ElementRow (PostData p)]
90+postToElementRows (PostData pId _ pb) = elementsToRows pId pb
108
91
109−unRow :: MkElementRow x -> PostRowResponse -> x
92+rowsToPost :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostRow -> [ElementRow (PostData p)] -> Maybe (PostData p)
110−unRow f' (PostRowResponse _ _ _ _ _ a b c d e) = f' a b c d e
93+rowsToPost erqs pqrs (PostRow pId aId) elementRows = PostData pId aId <$> rowsToElements erqs pqrs elementRows
111
94
112−rowsToPost :: [PostRowResponse] -> Maybe Post
95+fromDraft :: PostId -> ElementRow Draft -> ElementRow Post
113−rowsToPost [] = Nothing
96+fromDraft pId (ElementRow _ b c d e f g) = ElementRow pId b c d e f g
114−rowsToPost (el:els) = if all (((==) `on` postRowId) el) els
97+
115− then Post (postRowId el) (postRowAuthorId el) (postRowUpdateTime el) (postRowTags el) <$> traverse (unRow rowsToElement) (el:els)
98+-- tupleFirst :: (a -> b) -> a -> (b, a)
116− else Nothing
99+-- tupleFirst f a = (f a, a)
denis/src/Data/PostElement.hs+63−87
@@ -6,44 +6,26 @@
6 TypeApplications ,
6 TypeApplications ,
7 TypeOperators,
7 TypeOperators,
8 OverloadedStrings #-}
8 OverloadedStrings #-}
9−{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
10
9
11
10
12module Data.PostElement (
11module Data.PostElement (
13− elemenToRow,
14− rowsToElement,
15− MkElementRow,
16− PostElementRow(..),
17 PostElement(..),
12 PostElement(..),
13+ ElementRow(..),
18 elementsToRows,
14 elementsToRows,
15+ PostQuoteRow(..),
19 PostQuote(..),
16 PostQuote(..),
20− stripPostElement
17+ rowsToElements
21−) where
18+) where
22
19
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
25+import qualified Data.Map.Lazy as M
26+import Data.List (sortBy)
27+import Data.Function (on)
28import Control.Applicative ((<|>))
28import Control.Applicative ((<|>))
29−import Servant.Docs (ToSample, toSamples, samples)
30−import Data.Text.Validator
31−import Data.Limits
32−
33−-- MARK: Documentation
34−
35−instance ToSample (PostElement p) where
36− toSamples _ = samples [
37− Markdown "# This is a markdown title\nThis is body.",
38− Markdown "## This is a subtitle\n_hello._"
39− ]
40−
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
29
48
30
49-- MARK: PostElement
31-- MARK: PostElement
@@ -51,16 +33,24 @@ instance HasValidatableText (PostElement p) where
51data PostElement a = Markdown Text
33data PostElement a = Markdown Text
52 | Latex Text
34 | Latex Text
53 | Image Text
35 | Image Text
54− | Quote ()
36+ | Quote PostQuote
55 | Attachment Text
37 | Attachment Text
56− deriving (Show, GHC.Generic)
57
38
58−stripPostElement :: (PostElement a) -> (PostElement a)
39+
59−stripPostElement (Markdown t) = Markdown (strip t)
40+data ElementRow a = ElementRow {
60−stripPostElement (Latex t) = Latex (strip t)
41+ rowElementId :: Int64, -- the source id
61−stripPostElement u = u
42+ rowElementOrd :: Int64,
43+ rowElementMarkdown :: Maybe Text,
44+ rowElementLatex :: Maybe Text,
45+ rowElementImage :: Maybe Text,
46+ rowElementQuote :: Maybe Int64,
47+ rowElementAttachment :: Maybe Text
48+} deriving (GHC.Generic)
62
49
50+instance SOP.Generic (ElementRow a)
51+instance SOP.HasDatatypeInfo (ElementRow a)
52+
63−instance ToJSON (PostElement t) where
53+instance ToJSON (PostElement t) where
64 toJSON (Markdown m) = object ["markdown" .= m]
54 toJSON (Markdown m) = object ["markdown" .= m]
65 toJSON (Latex l) = object ["latex" .= l]
55 toJSON (Latex l) = object ["latex" .= l]
66 toJSON (Image i) = object ["image" .= i]
56 toJSON (Image i) = object ["image" .= i]
@@ -68,7 +58,7 @@ instance ToJSON (PostElement t) where
68 toJSON (Attachment a) = object ["attachment" .= a]
58 toJSON (Attachment a) = object ["attachment" .= a]
69
59
70instance FromJSON (PostElement t) where
60instance FromJSON (PostElement t) where
71− parseJSON = withObject "post element" $ \e ->
61+ parseJSON = withObject "post element" $ \e ->
72 Markdown <$> e .: "markdown" <|>
62 Markdown <$> e .: "markdown" <|>
73 Latex <$> e .: "latex" <|>
63 Latex <$> e .: "latex" <|>
74 Image <$> e .: "image" <|>
64 Image <$> e .: "image" <|>
@@ -76,73 +66,59 @@ instance FromJSON (PostElement t) where
76 Attachment <$> e .: "attachment"
66 Attachment <$> e .: "attachment"
77
67
78
68
79−-- -- MARK: PostElementRows
69+-- MARK: PostElementRows
80−
81−type MkElementRow x = Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> x
82−
83−elemenToRow :: MkElementRow x -> PostElement p -> x
84−elemenToRow f el = case el of
85− Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
86− Latex l -> f Nothing (Just l) Nothing Nothing Nothing
87− Image i -> f Nothing Nothing (Just i) Nothing Nothing
88− -- 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)
91
70
92−rowsToElement :: MkElementRow (Maybe (PostElement p))
71+-- TODO: After embeding id into quote
72+rowsToElements :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> [ElementRow p] -> Maybe [PostElement p]
73+rowsToElements erqs pqrs = traverse elementRowToElement . sortBy (compare `on` rowElementOrd)
74+ where
75+ elementRowToElement :: ElementRow a -> Maybe (PostElement a)
93−rowsToElement (Just m) Nothing Nothing Nothing Nothing = Just $ Markdown m
76+ elementRowToElement (ElementRow _ _ (Just m) Nothing Nothing Nothing Nothing) = Just $ Markdown m
94−rowsToElement Nothing (Just l) Nothing Nothing Nothing = Just $ Latex l
77+ elementRowToElement (ElementRow _ _ Nothing (Just l) Nothing Nothing Nothing) = Just $ Latex l
95−rowsToElement Nothing Nothing (Just i) Nothing Nothing = Just $ Image i
78+ elementRowToElement (ElementRow _ _ Nothing Nothing (Just i) Nothing Nothing) = Just $ Image i
96−-- rowsToElement Nothing Nothing Nothing (Just q) Nothing =
79+ -- elementRowToElement (ElementRow _ _ Nothing Nothing Nothing (Just q) Nothing) =
97−-- fmap Quote $ M.lookup q pqrs >>= rowsToQuote erqs pqrs
80+ -- fmap Quote $ M.lookup q pqrs >>= rowsToQuote erqs pqrs
98−rowsToElement Nothing Nothing Nothing Nothing (Just a) = Just $ Attachment a
81+ elementRowToElement (ElementRow _ _ Nothing Nothing Nothing Nothing (Just a)) = Just $ Attachment a
99−rowsToElement _ _ _ _ _ = Nothing
82+ elementRowToElement _ = Nothing
100
83
101−data PostElementRow a = PostElementRow {
84+elementsToRows :: Int64 -> [PostElement p] -> [ElementRow p]
102− rowElementId :: Int64,
85+elementsToRows pId pb = map (uncurry finish) $ flip zip pb $ ElementRow pId <$> [0..]
103− rowElementOrd :: Int64,
86+ where finish :: (Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int64 -> Maybe Text -> ElementRow p) -> PostElement p -> ElementRow p
104− rowElementMarkdown :: Maybe Text,
87+ finish f pe = case pe of
105− rowElementLatex :: Maybe Text,
88+ Markdown m -> f (Just m) Nothing Nothing Nothing Nothing
106− rowElementImage :: Maybe Text,
89+ Latex l -> f Nothing (Just l) Nothing Nothing Nothing
107− rowElementQuote :: Maybe Int64,
90+ Image i -> f Nothing Nothing (Just i) Nothing Nothing
108− rowElementAttachment :: Maybe Text
91+ Quote q -> f Nothing Nothing Nothing (Just $ quoteId q) Nothing
109−} deriving (GHC.Generic)
92+ Attachment a -> f Nothing Nothing Nothing Nothing (Just a)
110
93
111−instance SOP.Generic (PostElementRow a)
112−instance SOP.HasDatatypeInfo (PostElementRow a)
113
94
114−
115−elementsToRows :: Int64 -> [PostElement a] -> [PostElementRow a]
116−elementsToRows pId els = map (\(el, f) -> elemenToRow f el) . zip els . map (PostElementRow pId) $ [0..]
117−
118−
119−-- -- MARK: Quote
95+-- MARK: Quote
120
96
121data PostQuote = PostQuote {
97data PostQuote = PostQuote {
122 quoteId :: Int64,
98 quoteId :: Int64,
123 quoteBody :: [PostElement PostQuote],
99 quoteBody :: [PostElement PostQuote],
124 quotePostId :: Int64
100 quotePostId :: Int64
125−} deriving (Show, GHC.Generic)
101+}
126
102
127instance ToJSON PostQuote where
103instance ToJSON PostQuote where
128 toJSON (PostQuote qId pb pId) = object [
104 toJSON (PostQuote qId pb pId) = object [
129− "id" .= qId,
105+ "id" .= qId,
130 "postId" .= pId,
106 "postId" .= pId,
131 "quoteBody" .= pb ]
107 "quoteBody" .= pb ]
132
108
109+
110+-- MARK: PostQuoteRow
133
111
134−-- -- MARK: PostQuoteRow
135−
136−-- data PostQuoteRow = PostQuoteRow {
112+data PostQuoteRow = PostQuoteRow {
137−-- quoteRowId :: Int64,
113+ quoteRowId :: Int64,
138−-- quoteRowPostId :: Int64
114+ quoteRowPostId :: Int64
139−-- } deriving (GHC.Generic)
115+} deriving (GHC.Generic)
140−
141−-- instance SOP.Generic PostQuoteRow
142−-- instance SOP.HasDatatypeInfo PostQuoteRow
143
116
117+instance SOP.Generic PostQuoteRow
118+instance SOP.HasDatatypeInfo PostQuoteRow
119+
144−-- rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote
120+rowsToQuote :: M.Map Int64 [ElementRow PostQuote] -> M.Map Int64 PostQuoteRow -> PostQuoteRow -> Maybe PostQuote
145−-- rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do
121+rowsToQuote erqs pqrs (PostQuoteRow qId pId) = do
146−-- elementRows <- M.lookup qId erqs
122+ elementRows <- M.lookup qId erqs
147−-- elements <- rowsToElements erqs pqrs elementRows
123+ elements <- rowsToElements erqs pqrs elementRows
148−-- return $ PostQuote qId elements pId
124+ return $ PostQuote qId elements pId
denis/src/Data/Query.hs+160−1267
@@ -1,289 +1,113 @@
1{-# LANGUAGE
1{-# LANGUAGE
2− DataKinds,
2+ DataKinds ,
3− DeriveGeneric,
3+ DeriveGeneric ,
4 OverloadedLabels,
4 OverloadedLabels,
5− OverloadedStrings,
5+ OverloadedStrings ,
6− TypeApplications,
6+ TypeApplications ,
7− TypeOperators,
7+ TypeOperators #-}
8− PartialTypeSignatures,
9− FlexibleInstances,
10− KindSignatures,
11− DeriveAnyClass,
12− RecordWildCards,
13− ScopedTypeVariables #-}
14−
15−{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
16−
17
8
18module Data.Query (
9module Data.Query (
19 Schema,
10 Schema,
20 createTables,
11 createTables,
21− getPosts,
12+ getPost,
22− -- getUser,
13+ getUser,
23− getUsers,
14+ createDraft,
24− getAllUsers,
15+ updateDraft,
16+ publishDraft,
17+ getDrafts,
25 getLastPosts,
18 getLastPosts,
26− getPostsForUser,
19+ getPostsForUser
27− Limit,
28− publishPost,
29− getChannelPosts,
30− updateChannel,
31− createNewChannel,
32− getAllChannels,
33− getAnonymousChannelPosts,
34− deleteNamedChannel,
35− HasUsers(..),
36− wrapIntoUsers,
37− ResponseWithUsers(..),
38− getTags,
39− getDialogs,
40− getMessagesInUserChat,
41− getMessagesInGroupChat,
42− sendMessage,
43− createGroupChat,
44− updateGroupChat,
45− leaveGroupChat,
46− getGroupChatForUser,
47− getFaculty,
48− updateFaculty,
49− getFacultyFromQuery,
50− getUserWithEmail,
51− createToken,
52− validateToken,
53− invalidateToken,
54− tryVerifyToken,
55− getVerifiedToken,
56− UserCreation(..),
57− createUser,
58− tryActivateToken,
59− deactivateToken,
60− searchUsers,
61− searchTags,
62− updateUser,
63− UserUpdateRow(..),
64− killAllTokens,
65− channelCountForUser,
66− pruneAuth,
67− searchChannels,
68− isValidFaculty,
69− groupChatIsValidForUser
70− ) where
20+) where
71
21
72import Squeal.PostgreSQL
22import Squeal.PostgreSQL
23+import Squeal.PostgreSQL.Expression
24+import Squeal.PostgreSQL.Schema
73import Data.User
25import Data.User
74import Data.Post
26import Data.Post
75import Data.Schema
27import Data.Schema
28+import Data.List
76import Data.Function (on)
29import Data.Function (on)
30+import qualified Data.Map.Lazy as M
31+import Server.App
77import Data.Connection
32import Data.Connection
78import Data.PostElement
33import Data.PostElement
34+import Control.Monad.Base
35+import Control.Monad ((<$!>))
79import qualified Servant as S
36import qualified Servant as S
80−import Control.Monad
81import Control.Monad.Morph
37import Control.Monad.Morph
38+import Data.Maybe
82import Data.Word (Word64)
39import Data.Word (Word64)
83−import qualified Data.List as L
84−import qualified Data.Map.Strict as M
85−import qualified Data.Set as Set
86−import qualified Generics.SOP as SOP
87−import qualified GHC.Generics as GHC
88−import Data.Int (Int64)
89−import Data.ByteString.Char8 (pack)
90−import GHC.Generics (Generic)
91−import Data.Aeson hiding (Null)
92−import Servant.Docs
93−import Data.Proxy
94−import Data.Vector (Vector, toList, fromList)
95−import Data.Text (Text)
96−import qualified Data.Text as T
97−import Data.Channel.NamedChannel
98−import Data.Channel.AnonymousChannel
99−import Data.Maybe (fromMaybe, catMaybes, isJust)
100−import Squeal.PostgreSQL.Render
101−import Data.GroupChat
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
115−
116−instance (ToSample r) => ToSample (ResponseWithUsers r) where
117− toSamples _ = samples $ ResponseWithUsers <$> (map snd $ toSamples Proxy) <*> [M.fromList $ map (tupleFirst userId . snd) (toSamples Proxy)]
118−
119−
120−-- MARK: Generalized Post Queries
121−
122−type TableEndo schema params from grouping = TableExpression schema params from grouping ->
123− TableExpression schema params from grouping
124−
125−postsQ :: TableEndo Schema params _ 'Ungrouped -> Query Schema params _
126−postsQ te = selectStar $ te (from $ table #posts)
127−
128−postViewT :: TableEndo Schema params _ 'Ungrouped -> TableExpression Schema params _ 'Ungrouped
129−postViewT te = from $ subquery (postsQ te `As` #posts) &
130− innerJoin (table #postElements)
131− (#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)
139−getPostQ oTe te = select (
140− #posts ! #postRowId :*
141− #posts ! #postRowAuthorId :*
142− #posts ! #postRowUpdateTime :*
143− #posts ! #postRowTags :*
144− -- #rowElementId :*
145− #postElements ! #rowElementOrd :*
146− #postElements ! #rowElementMarkdown :*
147− #postElements ! #rowElementLatex :*
148− #postElements ! #rowElementImage :*
149− #postElements ! #rowElementQuote :*
150− #postElements ! #rowElementAttachment)
151− (oTe $ postViewT te)
152
40
153
41
154−-- MARK: Concrete Queries
42+getQuoteRowsQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG (ElementRow Post))
43+getQuoteRowsQ = UnsafeQuery "WITH RECURSIVE getQuote AS ( \
44+ \SELECT * FROM \"quoteElements\" quote WHERE \"rowElementId\" = $1 \
45+ \UNION ALL \
46+ \SELECT newQuote.* FROM \"quoteElements\" newQuote \
47+ \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
48+ \) \
49+ \SELECT * FROM getQuote"
155
50
156−-- getQuoteRowsQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG (ElementRow Post))
157−-- getQuoteRowsQ = UnsafeQuery "WITH RECURSIVE getQuote AS ( \
158−-- \SELECT * FROM \"quoteElements\" quote WHERE \"rowElementId\" = $1 \
159−-- \UNION ALL \
160−-- \SELECT newQuote.* FROM \"quoteElements\" newQuote \
161−-- \INNER JOIN getQuote q ON q.\"rowElementQuote\" = newQuote.\"rowElementId\" \
162−-- \) \
163−-- \SELECT * FROM getQuote"
164−
165−-- getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
51+getQuoteQ :: Query Schema (TuplePG (Only QuoteId)) (RowPG PostQuoteRow)
166−-- getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
52+getQuoteQ = selectStar $ from (table #quotes) & where_ (#quoteRowId .== param @1)
167
53
168-- getQuote :: QuoteId -> PQ Quote
54-- getQuote :: QuoteId -> PQ Quote
169-- getQuote qId = do
55-- getQuote qId = do
170-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows
56-- rows' <- runQuery getQuoteQ (Only qId) >>= getRows
171-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0
57-- qRow <- runQuery getQuoteQ (Only qId) >>= getRow 0
172-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
58-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
173−-- return $ M.lookup qId rows >>= rowsToQuote rows
59+-- return $ M.lookup qId rows >>= rowsToQuote rows
60+
61+getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)
62+getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)
174
63
175−getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))
64+getPostRowQ :: Query Schema (TuplePG (Only PostId)) (RowPG PostRow)
176−getUserWithEmailQ = select (
65+getPostRowQ = selectStar $ from (table #posts) & where_ (#postRowId .== param @1)
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) &
184− where_ (#userRowEmail .== param @1) &
185− where_ (notNull #userRowIsValidated))
186
66
187−verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
67+getDraftRowQ :: Query Schema (TuplePG (Only DraftId)) (RowPG PostRow)
188−verifiedUserIdsQ uIds = case idsToColumn uIds of
68+getDraftRowQ = selectStar $ from (table #drafts) & where_ (#postRowId .== param @1)
189− Just idQ -> Just $ select (#users ! #userRowId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
190− innerJoin (table #users)
191− (#ids ! #id .== #users ! #userRowId))
192− Nothing -> Nothing
193
69
194−getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))
70+getPostElementsQ :: Query Schema (TuplePG (Only PostId)) (RowPG (ElementRow Post))
195−getUsersQ uIds = case idsToColumn uIds of
71+getPostElementsQ = selectStar $ from (table #postElements) & where_ (#rowElementId .== param @1)
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) &
212− innerJoin (table #users)
213− (#ids ! #id .== #users ! #userRowId) &
214− innerJoin (table #faculties)
215− (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl)) &
216− where_ (notNull $ #users ! #userRowIsValidated))
217− Nothing -> Nothing
218
72
219−getAllUsersQ :: Query Schema '[] (RowPG UserRow)
73+getDraftElementsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
220−getAllUsersQ = select (
74+getDraftElementsQ = selectStar $ from (table #draftElements) & where_ (#rowElementId .== param @1)
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
75
240−getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
76+getPost :: PostId -> StaticPQ (Maybe Post)
241−getPostsByIdQ pIds = case idsToColumn pIds of
77+getPost pId = do
242− Just idQ -> Just $ selectDotStar #posts $ from (subquery (idQ `As` #ids) &
78+ postRow <- runQueryParams getPostRowQ (Only pId) >>= getRow 0
243− innerJoin (subquery $ getPostQ
79+ postRowElements <- runQueryParams getPostElementsQ (Only pId) >>= getRows
244− (orderBy [#postElements ! #rowElementId & Desc, #postElements ! #rowElementOrd & Asc]) id `As` #posts)
80+ return $ rowsToPost M.empty M.empty postRow postRowElements
245− (#ids ! #id .== #posts ! #postRowId))
246− Nothing -> Nothing
247
81
248−type Limit = Word64
82+getLastPostRowsQ :: Word64 -> Query Schema '[] (RowPG (Only PostId))
83+getLastPostRowsQ n = select (#postRowId `as` #fromOnly) $
84+ (from $ table #posts) &
85+ orderBy [#postRowId & Desc] &
86+ limit n
249
87
250−isNotFalse
88+getLastPosts :: Word64 -> StaticPQ [Post]
251− :: Expression schema from grouping params ('Null ty)
89+getLastPosts n = do
252− -- ^ possibly @NULL@
90+ postIds <- runQuery (getLastPostRowsQ n) >>= getRows
253− -> Condition schema from grouping params
91+ catMaybes <$> traverse getPost (map fromOnly postIds)
254−isNotFalse x = UnsafeExpression $ renderExpression x <+> "IS NOT FALSE"
255
92
256−getLastPostsQ
93+getUser :: UserId -> StaticPQ User
257− :: TableEndo _ _ _ _
94+getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0
258− -> Limit
259− -> P.PaginationDirection
260− -> Query Schema ('Null (PG Int64) ': params) (RowPG PostRowResponse)
261−getLastPostsQ te lim dir = getPostQ
262− (orderBy [#postElements ! #rowElementId & Desc, #postElements ! #rowElementOrd & Asc])
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
95
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
96
276−createPostRowQ :: Manipulation Schema (TuplePG (UserId, Vector Text)) (RowPG (Only PostId))
97+createDraftRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
277−createPostRowQ = insertRow #posts
98+createDraftRowQ = insertRow #drafts
278− (Default `as` #postRowId :*
279− Set (param @1) `as` #postRowAuthorId :*
99+ (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
280− Set currentTimestamp `as` #postRowUpdateTime :*
281− Set (param @2) `as` #postRowTags)
282− OnConflictDoRaise
100+ OnConflictDoRaise
283 (Returning $ #postRowId `as` #fromOnly)
101 (Returning $ #postRowId `as` #fromOnly)
284
102
285−createPostElementRowsQ :: Manipulation Schema (TuplePG (PostElementRow Post)) '[]
103+createPostRowQ :: Manipulation Schema (TuplePG (Only UserId)) (RowPG (Only PostId))
286−createPostElementRowsQ = insertRow_ #postElements
104+createPostRowQ = insertRow #posts
105+ (Default `as` #postRowId :* Set (param @1) `as` #postRowAuthorId)
106+ OnConflictDoRaise
107+ (Returning $ #postRowId `as` #fromOnly)
108+
109+createDraftElementRowsQ :: Manipulation Schema (TuplePG (ElementRow Draft)) '[]
110+createDraftElementRowsQ = insertRow_ #draftElements
287 (Set (param @1) `as` #rowElementId :*
111 (Set (param @1) `as` #rowElementId :*
288 Set (param @2) `as` #rowElementOrd :*
112 Set (param @2) `as` #rowElementOrd :*
289 Set (param @3) `as` #rowElementMarkdown :*
113 Set (param @3) `as` #rowElementMarkdown :*
@@ -292,1025 +116,94 @@ createPostElementRowsQ = insertRow_ #postElements
292 Set (param @6) `as` #rowElementQuote :*
116 Set (param @6) `as` #rowElementQuote :*
293 Set (param @7) `as` #rowElementAttachment)
117 Set (param @7) `as` #rowElementAttachment)
294
118
295−getChannelForUserQ :: Query Schema (TuplePG (UserId, NamedChannelId)) (RowPG NamedChannelFull)
119+createPostElementRowsQ :: Manipulation Schema (TuplePG (ElementRow Post)) '[]
296−getChannelForUserQ = selectStar $
120+createPostElementRowsQ = insertRow_ #postElements
297− from (table #channels) &
121+ (Set (param @1) `as` #rowElementId :*
298− where_ (#namedChannelFullOwner .== param @1 .&& #namedChannelFullId .== param @2)
122+ Set (param @2) `as` #rowElementOrd :*
299−
123+ Set (param @3) `as` #rowElementMarkdown :*
300−updateUserQ :: Manipulation Schema (TuplePG (UserUpdateRow)) (RowPG (Only UserId))
124+ Set (param @4) `as` #rowElementLatex :*
301−updateUserQ = update #users (
125+ Set (param @5) `as` #rowElementImage :*
302− Same `as` #userRowId :*
126+ Set (param @6) `as` #rowElementQuote :*
303− Set (param @2) `as` #userRowFirstName :*
127+ Set (param @7) `as` #rowElementAttachment)
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−
312−getAllChannelsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG NamedChannelFull)
313−getAllChannelsForUserQ = selectStar $
314− from (table #channels) &
315− where_ (#namedChannelFullOwner .== param @1) &
316− orderBy [#namedChannelFullId & Desc]
317−
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−
352−createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
353−createNamedChannelQ = insertRow #channels
354− (
355− Default `as` #namedChannelFullId :*
356− Set (param @1) `as` #namedChannelFullOwner :*
357− Set (param @2) `as` #namedChannelFullName :*
358− Set (param @3) `as` #namedChannelFullTags :*
359− Set (param @4) `as` #namedChannelFullPeopleIds
360− )
361− OnConflictDoRaise
362− (Returning $ #namedChannelFullId `as` #fromOnly)
363−
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−
369−deleteNamedChannelQ :: Manipulation Schema (TuplePG (Only NamedChannelId)) '[]
370−deleteNamedChannelQ = deleteFrom_ #channels (#namedChannelFullId .== param @1)
371−
372−updateNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelFull) '[]
373−updateNamedChannelQ = update_ #channels
374− (
375− Same `as` #namedChannelFullId :*
376− Same `as` #namedChannelFullOwner :*
377− Set (param @3) `as` #namedChannelFullName :*
378− Set (param @4) `as` #namedChannelFullTags :*
379− Set (param @5) `as` #namedChannelFullPeopleIds
380− )
381− (#namedChannelFullOwner .== param @2 .&& #namedChannelFullId .== param @1)
382−
383−getChannelPostsQ
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)
392−getChannelPostsQ lim dir uIds tags = getLastPostsQ
393− (where_ $ jsonbLit tags .?| #postRowTags .|| isUser #postRowAuthorId)
394− lim
395− dir
396− where
397− isUser = case idsToColumn uIds of
398− Just uIdsQ -> (`in_` uIdsQ)
399− Nothing -> const $ false
400−
401−getTagsQ :: Query Schema params (RowPG (Only String))
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−
791−-- MARK: FrontEnd Data Structures
792−
793−instance HasValidatableText UserCreation where
794− validateText UserCreation{..} = all validateText [
795− userCreationFirstName,
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)
829−
830−
831−data NamedChannelCreation = NamedChannelCreation {
832− namedChannelCreationOwner :: UserId,
833− namedChannelCreationName :: Text,
834− namedChannelCreationTags :: Vector Text,
835− namedChannelCreationPeopleIds :: Vector UserId
836−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
837−
838−addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
839−addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
840−
841−data NamedChannelFull = NamedChannelFull {
842− namedChannelFullId :: NamedChannelId,
843− namedChannelFullOwner :: UserId,
844− namedChannelFullName :: Text,
845− namedChannelFullTags :: Vector Text,
846− namedChannelFullPeopleIds :: Vector UserId
847−} deriving GHC.Generic
848−
849−instance SOP.Generic NamedChannelFull
850−instance SOP.HasDatatypeInfo NamedChannelFull
851−
852−addUserToChannelUpdate :: UserId -> NamedChannel UserId -> NamedChannelFull
853−addUserToChannelUpdate uId (NamedChannel cId cName cTags cPeople) = NamedChannelFull cId uId cName cTags cPeople
854−
855−removeUserFromChannel :: NamedChannelFull -> NamedChannel UserId
856−removeUserFromChannel (NamedChannelFull cId _ cName cTags cPeople) = NamedChannel cId cName cTags cPeople
857−
858−getChannelForUser :: UserId -> NamedChannelId -> StaticPQ NamedChannelFull
859−getChannelForUser uId cId = do
860− channel <- runQueryParams getChannelForUserQ (uId, cId) >>= firstRow
861− case (channel :: Maybe NamedChannelFull) of
862− (Just c) -> return c
863− Nothing -> lift $ S.throwError S.err404
864−
865−-- TODO: Reject bad requests. Should be binary.
866−verifyUsers :: [UserId] -> StaticPQ ()
867−verifyUsers uIds =
868− case verifiedUserIdsQ uIds of
869− Just uIdsQ -> do
870− (us :: [UserId]) <- fmap fromOnly <$> (runQuery uIdsQ >>= getRows)
871− when (length us /= length uIds) $ lift $ S.throwError impossibleContent
872− Nothing -> return ()
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−
894−-- MARK: FrontEnd functions
895−
896−-- Nothing <=> no user
897−getPostsForUser
898− :: Maybe PostId
899− -> Limit
900− -> P.PaginationDirection
901− -> UserId
902− -> StaticPQ (Maybe (ResponseWithUsers [Post]))
903−getPostsForUser pId lim dir uId = do
904− postRows <- runQueryParams (getLastNPostsForUserQ lim dir) (pId, uId) >>= getRows
905− wrapIntoResponse (fromMaybe [] . rowsToPosts $ postRows)
906−
907−getPosts :: [PostId] -> StaticPQ (Maybe (ResponseWithUsers [Post]))
908−getPosts pId =
909− case getPostsByIdQ pId of
910− Just psQ -> do
911− postRows <- runQuery psQ >>= getRows
912− rowsToPosts postRows `liftMaybe` wrapIntoResponse
913− Nothing -> return Nothing
914−
915−getLastPosts
916− :: Maybe PostId
917− -> Limit
918− -> P.PaginationDirection
919− -> StaticPQ (Maybe (ResponseWithUsers [Post]))
920−getLastPosts pId lim dir = do
921− postRows <- runQueryParams (getLastPostsQ id lim dir) (Only pId) >>= getRows
922− rowsToPosts postRows `liftMaybe` wrapIntoResponse
923−
924−getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))
925−getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow
926−
927−getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])
928−getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))
929−
930−getAllUsers :: StaticPQ [User Faculty]
931−getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
932−
933−publishPost :: UserId -> PostCreation -> StaticPQ PostId
934−publishPost uId pc = commitedTransactionallyUpdate $ do
935− pId' <- manipulateParams createPostRowQ (uId, postCreationTags pc) >>= firstRow
936− case pId' of
937− (Just (Only pId)) -> do
938− traversePrepared_ createPostElementRowsQ $ elementsToRows pId (map stripPostElement $ postCreationBody pc)
939− return pId
940− _ -> lift $ S.throwError S.err404
941−
942−createNewChannel :: UserId -> NamedChannelCreationRequest -> StaticPQ (Maybe NamedChannelId)
943−createNewChannel uId req = commitedTransactionallyUpdate $ do
944− let uIds = toList $ namedChannelCreationRequestPeopleIds req
945− verifyUsers uIds
946− cId <- manipulateParams createNamedChannelQ (addUserToChannelCreate uId (req {namedChannelCreationRequestPeopleIds = fromList uIds})) >>= firstRow
947− return $ fmap fromOnly cId
948−
949−channelCountForUser :: UserId -> StaticPQ Int64
950−channelCountForUser uId = (fromMaybe 0 . fmap fromOnly) <$> (runQueryParams countChannelsQ (Only uId) >>= firstRow)
951−
952−updateChannel :: UserId -> NamedChannel UserId -> StaticPQ ()
953−updateChannel uId req = do
954− let uIds = namedChannelPeopleIds req
955− verifyUsers (toList uIds)
956− _ <- getChannelForUser uId $ namedChannelId req
957− _ <- commitedTransactionallyUpdate $ manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
958− return ()
959−
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
972− :: UserId
973− -> Maybe PostId
974− -> Limit
975− -> P.PaginationDirection
976− -> NamedChannelId
977− -> StaticPQ (ResponseWithUsers [Post])
978−getChannelPosts uId pId lim dir cId = do
979− channel <- getChannelForUser uId cId
980− postRows <- runQueryParams (getChannelPostsQ
981− lim
982− dir
983− (toList $ namedChannelFullPeopleIds channel)
984− (namedChannelFullTags channel))
985− (Only pId)
986− >>= getRows
987− fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
988−
989−getAnonymousChannelPosts
990− :: Maybe PostId
991− -> Limit
992− -> P.PaginationDirection
993− -> AnonymousChannel
994− -> StaticPQ (ResponseWithUsers [Post])
995−getAnonymousChannelPosts pId lim dir (AnonymousChannel tags people) = do
996− postRows <- runQueryParams (getChannelPostsQ lim dir people tags) (Only pId) >>= getRows
997− fmap (fromMaybe $ ResponseWithUsers mempty mempty) $ rowsToPosts postRows `liftMaybe` wrapIntoResponse
998−
999−getAllChannels :: UserId -> StaticPQ [NamedChannel UserId]
1000−getAllChannels uId = fmap (map removeUserFromChannel) $
1001− runQueryParams getAllChannelsForUserQ (Only uId) >>= getRows
1002−
1003−deleteNamedChannel :: UserId -> NamedChannelId -> StaticPQ ()
1004−deleteNamedChannel uId cId = do
1005− _ <- getChannelForUser uId cId
1006− _ <- commitedTransactionallyUpdate $ 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 ()
1126−
1127−searchChannels :: UserId -> Text -> StaticPQ [NamedChannel UserId]
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
1178−
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−
1246−foldMaybe :: [Maybe a] -> Maybe [a]
1247−foldMaybe [] = Just []
1248−foldMaybe (Nothing : _) = Nothing
1249−foldMaybe (Just x : xs) = (x :) <$> foldMaybe xs
1250−
1251−rowsToPosts :: [PostRowResponse] -> Maybe [Post]
1252−rowsToPosts = foldMaybe . map rowsToPost . L.groupBy ((==) `on` postRowId)
1253−
1254−tupleFirst :: (a -> b) -> a -> (b, a)
1255−tupleFirst f a = (f a, a)
1256−
1257−mapFirstBy :: (a -> b) -> [a] -> [(b, a)]
1258−mapFirstBy f = map $ tupleFirst f
1259−
1260−idsToColumn :: [Int64] -> Maybe (Query schema params '["id" ::: 'NotNull 'PGint8])
1261−idsToColumn [] = Nothing
1262−idsToColumn (i:ii) = Just $ values (unsafeIntToExpr i `as` #id) $ map ((`as` #id) . unsafeIntToExpr) ii
1263−
1264−unsafeIntToExpr :: Int64 -> Expression schema from grouping params ty
1265−unsafeIntToExpr = UnsafeExpression . pack . show
1266−
1267−data ResponseWithUsers r = ResponseWithUsers {
1268− response :: r,
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
1304− return $ ResponseWithUsers r . M.fromList . mapFirstBy userId <$> pUsers
1305−
1306−liftMaybe :: Applicative f => Maybe a -> (a -> f (Maybe b)) -> f (Maybe b)
1307−liftMaybe Nothing _ = pure Nothing
1308−liftMaybe (Just a) f = f a
1309
128
1310−fromMaybe500 :: Maybe a -> StaticPQ a
129+createDraft :: UserId -> [PostElement Draft] -> StaticPQ Draft
130+createDraft uId els = transactionally_ $ do
131+ dId' <- manipulateParams createDraftRowQ (Only uId)
132+ dId <- lift $ fromOnly <$> getRow 0 dId'
133+ traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els
134+ return $ mkDraft dId uId els
135+
136+getDraftsForUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
137+getDraftsForUserQ = select (#postRowId `as` #fromOnly) $
138+ (from $ table #drafts) &
139+ where_ (#postRowAuthorId .== param @1)
140+
141+getPostsForUserLimitingQ :: Word64 -> Query Schema (TuplePG (Only UserId)) (RowPG (Only DraftId))
142+getPostsForUserLimitingQ lim = select (#postRowId `as` #fromOnly) $
143+ (from $ table #posts) &
144+ where_ (#postRowAuthorId .== param @1) &
145+ orderBy [#postRowId & Desc] &
146+ limit lim
147+
148+getPostsForUser :: Word64 -> UserId -> StaticPQ [Post]
149+getPostsForUser lim uId = do
150+ postIds <- runQueryParams (getPostsForUserLimitingQ lim) (Only uId) >>= getRows
151+ catMaybes <$> traverse getPost (map fromOnly postIds)
152+
153+
154+getDraft :: DraftId -> StaticPQ (Maybe Draft)
155+getDraft dId = do
156+ draftRow <- runQueryParams getDraftRowQ (Only dId) >>= getRow 0
157+ draftRowElements <- runQueryParams getDraftElementsQ (Only dId) >>= getRows
158+ return $ rowsToPost M.empty M.empty draftRow draftRowElements
159+
160+getDrafts :: UserId -> StaticPQ [Draft]
161+getDrafts uId = do
162+ draftRow <- runQueryParams getDraftsForUserQ (Only uId) >>= getRows
163+ catMaybes <$> traverse getDraft (map fromOnly draftRow)
164+
165+getDraftForUserWithIdQ :: Query Schema (TuplePG (UserId, DraftId)) (RowPG PostRow)
166+getDraftForUserWithIdQ = selectStar $
167+ (from $ table #drafts) &
168+ where_ (#postRowAuthorId .== param @1 .&& #postRowId .== param @2)
169+
170+deleteElementsForIdQ :: Manipulation Schema (TuplePG (Only DraftId)) '[]
171+deleteElementsForIdQ = deleteFrom_ #draftElements (#rowElementId .== param @1)
172+
173+deleteDraftQ :: Manipulation Schema (TuplePG (Only DraftId)) '[]
174+deleteDraftQ = deleteFrom_ #drafts (#postRowId .== param @1)
175+
176+updateDraft :: UserId -> DraftId -> [PostElement Draft] -> StaticPQ ()
177+updateDraft uId dId els = transactionally_ $ do
178+ rs <- runQueryParams getDraftForUserWithIdQ (uId, dId) >>= getRows
179+ let c = length (rs :: [PostRow])
180+ if c /= 1 then
1311−fromMaybe500 Nothing = lift $ S.throwError S.err500
181+ lift $ S.throwError S.err404
182+ else do
183+ manipulateParams deleteElementsForIdQ (Only dId)
184+ traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els
185+
186+getDraftElementRowsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))
187+getDraftElementRowsQ = selectStar $
188+ (from $ table #draftElements) &
189+ where_ (#rowElementId .== param @1) &
190+ orderBy [#rowElementOrd & Asc]
191+
192+publishDraft :: UserId -> DraftId -> StaticPQ ()
193+publishDraft uId dId = transactionally_ $ do
194+ rs <- runQueryParams getDraftForUserWithIdQ (uId, dId) >>= getRows
195+ let c = length (rs :: [PostRow])
196+ if c /= 1 then
197+ lift $ S.throwError S.err404
198+ else do
199+ els <- runQueryParams getDraftElementRowsQ (Only dId) >>= getRows
200+ pId' <- manipulateParams createPostRowQ (Only uId)
201+ pId <- lift $ fromOnly <$> getRow 0 pId'
202+ traversePrepared_ createPostElementRowsQ $ map (fromDraft pId) els
203+ manipulateParams deleteDraftQ (Only dId)
1312−fromMaybe500 (Just a) = return a
204+ return ()
205+
206+
207+-- tupleFirst :: (a -> b) -> a -> (b, a)
208+-- tupleFirst f x = (f x, x)
1313
209
1314−fromMaybe404 :: Maybe a -> StaticPQ a
1315−fromMaybe404 Nothing = lift $ S.throwError S.err404
1316−fromMaybe404 (Just a) = return a
denis/src/Data/RowConvertable.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+
10+module Data.RowConvertable (
11+ -- RowConvertable(..)
12+ ) where
13+
14+import Data.Int (Int64)
15+import Squeal.PostgreSQL
16+import Squeal.PostgreSQL.Schema
17+import GHC.TypeLits (Symbol)
18+import Squeal.PostgreSQL.Render
19+import qualified Squeal.PostgreSQL.PQ as P
20+import qualified Generics.SOP as SOP
21+import qualified GHC.Generics as GHC
22+import Data.Text (Text)
23+
24+
25+-- class RowConvertable t r where
26+-- convertToRow :: a -> RowPG r
27+-- fromRow :: TuplePG r -> a
28+
denis/src/Data/Schema.hs+65−207
@@ -4,10 +4,7 @@
4 OverloadedLabels,
4 OverloadedLabels,
5 OverloadedStrings ,
5 OverloadedStrings ,
6 TypeApplications ,
6 TypeApplications ,
7− TypeOperators,
7+ TypeOperators #-}
8− OverloadedStrings,
9− KindSignatures #-}
10−
11
8
12module Data.Schema (
9module Data.Schema (
13 Schema,
10 Schema,
@@ -15,53 +12,42 @@ module Data.Schema (
15) where
12) where
16
13
17import Squeal.PostgreSQL
14import Squeal.PostgreSQL
18−import Data.GroupChat
15+import Squeal.PostgreSQL.Expression
16+import Squeal.PostgreSQL.Schema
19−import Data.PostElement
17+import Data.User
20−import Data.Message
18+import Data.Post
21
19
22−type Schema =
20+type Schema =
23 '[
21 '[
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 ( '[
22 "users" ::: 'Table ( '[
36− "pk_users" ::: 'PrimaryKey '["userRowId"],
23+ "pk_users" ::: 'PrimaryKey '["userId"]] :=>
37− "user_email" ::: 'Unique '["userRowEmail"],
38− "fk_user_faculty" ::: 'ForeignKey '["userRowFacultyUrl"] "faculties" '["facultyUrl"]] :=>
39 '[
24 '[
40− "userRowId" ::: 'Def :=> 'NotNull 'PGint8,
25+ "userId" ::: 'Def :=> 'NotNull 'PGint8,
41− "userRowFirstName" ::: 'NoDef :=> 'NotNull 'PGtext,
26+ "firstName" ::: 'NoDef :=> 'NotNull 'PGtext,
42− "userRowMiddleName" ::: 'NoDef :=> 'NotNull 'PGtext,
43− "userRowLastName" ::: 'NoDef :=> 'NotNull 'PGtext,
44− "userRowFacultyUrl" ::: 'NoDef :=> 'NotNull 'PGtext,
45− "userRowEmail" ::: 'NoDef :=> 'NotNull 'PGtext,
27+ "secondName" ::: '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
54− "postRowUpdateTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz,
55− "postRowTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext))
56 ]),
35 ]),
57 "quotes" ::: 'Table (
36 "quotes" ::: 'Table (
58− '[
37+ '[
59 "pk_post_quotes" ::: 'PrimaryKey '["quoteRowId"],
38 "pk_post_quotes" ::: 'PrimaryKey '["quoteRowId"],
60 "fk_quote_post_id" ::: 'ForeignKey '["quoteRowPostId"] "posts" '["postRowId"] ] :=>
39 "fk_quote_post_id" ::: 'ForeignKey '["quoteRowPostId"] "posts" '["postRowId"] ] :=>
61 '[
40 '[
62 "quoteRowId" ::: 'Def :=> 'NotNull 'PGint8,
41 "quoteRowId" ::: 'Def :=> 'NotNull 'PGint8,
63 "quoteRowPostId" ::: 'NoDef :=> 'NotNull 'PGint8
42 "quoteRowPostId" ::: 'NoDef :=> 'NotNull 'PGint8
64 ]),
43 ]),
44+ "drafts" ::: 'Table ( '[
45+ "pk_drafts" ::: 'PrimaryKey '["postRowId"],
46+ "fk_draft_author_id" ::: 'ForeignKey '["postRowAuthorId"] "users" '["userId"]] :=>
47+ '[
48+ "postRowId" ::: 'Def :=> 'NotNull 'PGint8,
49+ "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8
50+ ]),
65 "postElements" ::: 'Table (
51 "postElements" ::: 'Table (
66 '[
52 '[
67 "fk_post_quote_self_id" ::: 'ForeignKey '["rowElementId"] "posts" '["postRowId"],
53 "fk_post_quote_self_id" ::: 'ForeignKey '["rowElementId"] "posts" '["postRowId"],
@@ -75,7 +61,7 @@ type Schema =
75 "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
61 "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
76 "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
62 "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
77 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
63 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
78− "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
64+ "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
79 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
65 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
80 ]),
66 ]),
81 "quoteElements" ::: 'Table (
67 "quoteElements" ::: 'Table (
@@ -91,141 +77,54 @@ type Schema =
91 "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
77 "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
92 "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
78 "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
93 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
79 "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
94− "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
80+ "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
95 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
81 "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
96 ]),
82 ]),
97− "channels" ::: 'Table (
83+ "draftElements" ::: 'Table (
98− '[
99− "pk_channels" ::: 'PrimaryKey '["namedChannelFullId"],
100− "fk_channels_users_id" ::: 'ForeignKey '["namedChannelFullOwner"] "users" '["userRowId"]
101− ] :=>
102− '[
103− "namedChannelFullId" ::: 'Def :=> 'NotNull 'PGint8,
104− "namedChannelFullOwner" ::: 'NoDef :=> 'NotNull 'PGint8,
105− "namedChannelFullName" ::: 'NoDef :=> 'NotNull 'PGtext,
106− "namedChannelFullTags" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGtext)),
107− "namedChannelFullPeopleIds" ::: 'NoDef :=> 'NotNull ('PGvararray ('NotNull 'PGint8))
108− ]),
109− "groupChats" ::: 'Table (
110− '[
111− "pk_group_chats" ::: 'PrimaryKey '["groupChatId"]
112− ] :=>
113 '[
84 '[
114− "groupChatId" ::: 'Def :=> 'NotNull 'PGint8,
85+ "fk_draft_quote_self_id" ::: 'ForeignKey '["rowElementId"] "drafts" '["postRowId"],
115− "groupChatUsers" ::: 'NoDef :=> 'NotNull (PG (Jsonb UserPermissions)),
86+ "fk_draft_quote_id" ::: 'ForeignKey '["rowElementQuote"] "quotes" '["quoteRowId"]
116− "groupChatName" ::: 'NoDef :=> 'NotNull 'PGtext
87+ -- ,
117− ]),
88+ -- "unique_post_quote" ::: 'Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"]
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− ] :=>
89+ ] :=>
165 '[
90 '[
166− "tokenUserId" ::: 'NoDef :=> 'NotNull 'PGint8,
91+ "rowElementId" ::: 'NoDef :=> 'NotNull 'PGint8,
167− "tokenValue" ::: 'NoDef :=> 'NotNull 'PGbytea,
92+ "rowElementOrd" ::: 'NoDef :=> 'NotNull 'PGint8,
168− "tokenExpiryDate" ::: 'NoDef :=> 'NotNull 'PGtimestamptz,
93+ "rowElementMarkdown" ::: 'NoDef :=> 'Null 'PGtext,
169− "tokenVerificationCode" ::: 'NoDef :=> 'Null 'PGbytea, -- null == verified
94+ "rowElementLatex" ::: 'NoDef :=> 'Null 'PGtext,
170− "tokenActivationTriesLeft" ::: 'NoDef :=> 'NotNull 'PGint4,
95+ "rowElementImage" ::: 'NoDef :=> 'Null 'PGtext,
171− "tokenUserAgent" ::: 'NoDef :=> 'NotNull 'PGtext,
96+ "rowElementQuote" ::: 'NoDef :=> 'Null 'PGint8,
172− "tokenActivationCode" ::: 'NoDef :=> 'Null 'PGbytea,
97+ "rowElementAttachment" ::: 'NoDef :=> 'Null 'PGtext
173− "tokenDeactivationCode" ::: 'NoDef :=> 'NotNull 'PGbytea
174 ])
98 ])
175−
99+
176− -- "postsView" ::: 'View (RowPG PostRowResponse)
177− -- ('[
178− -- "postRowId" ::: 'NotNull 'PGint8,
179− -- "postRowAuthorId" ::: 'NotNull 'PGint8,
180− -- "rowElementId" ::: 'NotNull 'PGint8,
181− -- "rowElementOrd" ::: 'NotNull 'PGint8,
182− -- "rowElementMarkdown" ::: 'Null 'PGtext,
183− -- "rowElementLatex" ::: 'Null 'PGtext,
184− -- "rowElementImage" ::: 'Null 'PGtext,
185− -- "rowElementQuote" ::: 'Null 'PGint8,
186− -- "rowElementAttachment" ::: 'Null 'PGtext
187− -- ])
188−
189 ]
100 ]
190−
101+
191
102
192createTables :: Definition '[] Schema
103createTables :: Definition '[] Schema
193−createTables = createTable #faculties (
104+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 :*
105+ serial8 `as` #userId :*
205− notNullable text `as` #userRowFirstName :*
206− notNullable text `as` #userRowMiddleName :*
106+ notNullable text `as` #firstName :*
207− notNullable text `as` #userRowLastName :*
208− notNullable text `as` #userRowFacultyUrl :*
209− notNullable text `as` #userRowEmail :*
107+ notNullable text `as` #secondName
210− notNullable bool `as` #userRowIsValidated
211 ) (
108 ) (
212− primaryKey #userRowId `as` #pk_users :*
109+ 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 (
110 ) >>> createTable #posts (
216 serial8 `as` #postRowId :*
111 serial8 `as` #postRowId :*
217− notNullable int8 `as` #postRowAuthorId :*
112+ notNullable int8 `as` #postRowAuthorId
218− notNullable timestampWithTimeZone `as` #postRowUpdateTime :*
219− notNullable (vararray text) `as` #postRowTags
220 ) (
113 ) (
221 primaryKey #postRowId `as` #pk_posts :*
114 primaryKey #postRowId `as` #pk_posts :*
222− foreignKey #postRowAuthorId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_author_id
115+ foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_author_id
223 ) >>> createTable #quotes (
116 ) >>> createTable #quotes (
224 serial8 `as` #quoteRowId :*
117 serial8 `as` #quoteRowId :*
225 notNullable int8 `as` #quoteRowPostId
118 notNullable int8 `as` #quoteRowPostId
226 ) (
119 ) (
227 primaryKey #quoteRowId `as` #pk_post_quotes :*
120 primaryKey #quoteRowId `as` #pk_post_quotes :*
228− foreignKey #quoteRowPostId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_post_id
121+ foreignKey #quoteRowPostId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_post_id
122+ ) >>> createTable #drafts (
123+ serial8 `as` #postRowId :*
124+ notNullable int8 `as` #postRowAuthorId
125+ ) (
126+ primaryKey #postRowId `as` #pk_drafts :*
127+ foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_draft_author_id
229 ) >>> createTable #postElements (
128 ) >>> createTable #postElements (
230 notNullable int8 `as` #rowElementId :*
129 notNullable int8 `as` #rowElementId :*
231 notNullable int8 `as` #rowElementOrd :*
130 notNullable int8 `as` #rowElementOrd :*
@@ -236,7 +135,7 @@ createTables = createTable #faculties (
236 nullable text `as` #rowElementAttachment
135 nullable text `as` #rowElementAttachment
237 ) (
136 ) (
238 foreignKey #rowElementId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_self_id :*
137 foreignKey #rowElementId #posts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_self_id :*
239− foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_id
138+ foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_post_quote_id
240 ) >>> createTable #quoteElements (
139 ) >>> createTable #quoteElements (
241 notNullable int8 `as` #rowElementId :*
140 notNullable int8 `as` #rowElementId :*
242 notNullable int8 `as` #rowElementOrd :*
141 notNullable int8 `as` #rowElementOrd :*
@@ -247,64 +146,23 @@ createTables = createTable #faculties (
247 nullable text `as` #rowElementAttachment
146 nullable text `as` #rowElementAttachment
248 ) (
147 ) (
249 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*
148 foreignKey #rowElementId #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quotes_quote_self_id :*
250− foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id
149+ foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_quote_quote_id
251− ) >>> createTable #channels (
150+ ) >>> createTable #draftElements (
252− serial8 `as` #namedChannelFullId :*
253− notNullable int8 `as` #namedChannelFullOwner :*
151+ notNullable int8 `as` #rowElementId :*
254− notNullable text `as` #namedChannelFullName :*
255− notNullable (vararray text) `as` #namedChannelFullTags :*
256− notNullable (vararray int8) `as` #namedChannelFullPeopleIds
257− ) (
258− primaryKey #namedChannelFullId `as` #pk_channels :*
259− foreignKey #namedChannelFullOwner #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_channels_users_id
260− -- ) >>> createView #postsView (select (
261− -- #posts ! #postRowId :*
262− -- #posts ! #postRowAuthorId :*
263− -- -- #rowElementId :*
264− -- #postElements ! #rowElementOrd :*
152+ notNullable int8 `as` #rowElementOrd :*
265− -- #postElements ! #rowElementMarkdown :*
153+ nullable text `as` #rowElementMarkdown :*
266− -- #postElements ! #rowElementLatex :*
154+ nullable text `as` #rowElementLatex :*
267− -- #postElements ! #rowElementImage :*
155+ nullable text `as` #rowElementImage :*
268− -- #postElements ! #rowElementQuote :*
156+ nullable int8 `as` #rowElementQuote :*
269− -- #postElements ! #rowElementAttachment
157+ nullable text `as` #rowElementAttachment
270− -- ) (
271− -- from ((table #posts) &
272− -- (innerJoin (table #postElements)
273− -- (#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 ) (
158 ) (
302− foreignKey #tokenUserId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_user_token
159+ foreignKey #rowElementId #drafts #postRowId OnDeleteCascade OnUpdateCascade `as` #fk_draft_quote_self_id :*
160+ foreignKey #rowElementQuote #quotes #quoteRowId OnDeleteCascade OnUpdateCascade `as` #fk_draft_quote_id
303− )
161+ )
304-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])
162-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])
305-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $
163-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $
306-- ((ifThenElse (isNull #rowElementOrd) 1 0) +
164-- ((ifThenElse (isNull #rowElementOrd) 1 0) +
307-- (ifThenElse (isNull #rowElementOrd) 1 0) +
165-- (ifThenElse (isNull #rowElementOrd) 1 0) +
308-- (ifThenElse (isNull #rowElementOrd) 1 0) +
166-- (ifThenElse (isNull #rowElementOrd) 1 0) +
309-- (ifThenElse (isNull #rowElementOrd) 1 0) +
167-- (ifThenElse (isNull #rowElementOrd) 1 0) +
310−-- (ifThenElse (isNull #rowElementOrd) 1 0)) .== 0
168+-- (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+13−62
@@ -5,83 +5,34 @@
5 OverloadedStrings ,
5 OverloadedStrings ,
6 TypeApplications ,
6 TypeApplications ,
7 TypeOperators,
7 TypeOperators,
8− OverloadedStrings,
8+ OverloadedStrings #-}
9− DeriveAnyClass,
10− RecordWildCards #-}
11
9
12module Data.User (
10module Data.User (
13 User(..),
11 User(..),
14− UserId,
12+ UserId
15− UserEmail,
16− UserUpdate(..)
17−) where
13+) where
18
14
19import Data.Int (Int64)
15import Data.Int (Int64)
20import qualified Generics.SOP as SOP
16import qualified Generics.SOP as SOP
21import qualified GHC.Generics as GHC
17import qualified GHC.Generics as GHC
22import Data.Text (Text)
18import Data.Text (Text)
23import Data.Aeson
19import Data.Aeson
24−import Servant.Docs (ToSample, toSamples, samples)
25−import Data.Proxy
26−import Data.Faculty
27−import Data.Limits
28−import Data.Text.Validator
29−
30−-- MARK: Documentation
31−
32−instance (ToSample f) => ToSample (User f) where
33− toSamples _ = samples $ [User 8 "Vasya" "Pupkinovuch" "Pupkin", User 69 "Seva" "Algebrovich" "Leonidov"] <*> (map snd $ toSamples Proxy) <*> ["foo@hse.ru"]
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]
40−
41−-- MARK: Implementation
42
20
43type UserId = Int64
21type UserId = Int64
44−type UserEmail = Text
45
22
46−data User f = User {
23+data User = User {
47 userId :: UserId,
24 userId :: UserId,
48 firstName :: Text,
25 firstName :: Text,
49− middleName :: Text,
26+ secondName :: Text
50− lastName :: Text,
51− userFaculty :: f,
52− userEmail :: UserEmail
53−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
27+} deriving (GHC.Generic)
54
28
55−instance (ToJSON f) => ToJSON (User f) where
29+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− ]
64−
65−instance (FromJSON f) => FromJSON (User f) where
66− parseJSON = withObject "named channel" $ \e ->
67− User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
68
30
69−data UserUpdate = UserUpdate {
70− userUpdateFirstName :: Text,
71− userUpdateMiddleName :: Text,
72− userUpdateLastName :: Text,
73− userUpdateUserFaculty :: FacultyUrl
74−} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
31+instance SOP.HasDatatypeInfo User
75
32
76−instance ToJSON UserUpdate where
33+instance ToJSON User where
77− toJSON (UserUpdate fName mName lName faculty) = object [
34+ toJSON (User uId fName sName) = object [
35+ "id" .= uId,
78 "firstName" .= fName,
36 "firstName" .= fName,
79− "middleName" .= mName,
37+ "secondName" .= sName
80− "lastName" .= lName,
81− "faculty" .= faculty
82− ]
38+ ]
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+31−84
@@ -1,112 +1,59 @@
1−{-# LANGUAGE
2− FlexibleInstances,
3− DataKinds,
1+{-# LANGUAGE DataKinds,
4 TypeOperators,
2 TypeOperators,
5 OverloadedStrings,
3 OverloadedStrings,
6− ScopedTypeVariables,
4+ ScopedTypeVariables #-}
7− RecordWildCards #-}
8−{-# OPTIONS_GHC -Wno-orphans #-}
9
5
10module Server.API (
6module Server.API (
11 API,
7 API,
12 serverProxy,
8 serverProxy,
13− mkServerAPI,
9+ mkServerAPI
14− Authentication
15−) where
10+) where
16−
11+
17import Data.Proxy
12import Data.Proxy
18import Servant.API
13import Servant.API
14+-- import Servant
15+import Servant.Server.Experimental.Auth
19import Data.User
16import Data.User
17+import qualified Data.Post as P
20import Server.Auth
18import Server.Auth
19+import Data.ByteString
20+import Data.Int (Int64)
21import Servant.Server
21import Servant.Server
22import Data.Connection
22import Data.Connection
23import Data.Query
23import Data.Query
24+import Server.Auth
24import Server.App
25import Server.App
26+import Control.Monad.Error
27+import Server.API.Draft
25import Server.API.Posts
28import Server.API.Posts
26import Server.Logger
29import Server.Logger
27−import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))
28−import Server.API.Channels
29−import Control.Lens
30−import Server.Query.ComplexQuery
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
40−
41−-- MARK: Documentation
42−
43−instance HasDocs api => HasDocs (Authentication :> api) where
44− 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."]])
46−
47−type UserSearchDescription = Description "Searches for users with the given string.\n\nFeed in the raw user input string."
48−
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."
52−
53−-- MARK: Implementation
54
30
55−type Authentication = AuthProtect "basicAuth"
31+maybeNotFound :: App (Maybe a) -> App a
32+maybeNotFound = (>>= (\t -> case t of
33+ Just y -> return y
34+ Nothing -> throwError err404))
56
35
57−type API =
36+type API =
58 LoggerAPI :<|>
37 LoggerAPI :<|>
59− "authentication" :> AuthenticationHandler :<|>
38+ "authenticate" :> AuthenticationHandler :<|>
60− Authentication :> ComplexQuery :> (
39+ AuthProtect "basicAuth" :> (
61− "authentication" :> "me" :> Post '[JSON] UserId :<|>
62− "deactivateAll" :> DeactivateAllDescription
63− :> DeleteNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
64− "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>
40+ "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
65− "users" :> "all" :> Post '[JSON] [User Faculty] :<|>
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 :<|>
41 "posts" :> PostApi :<|>
69− "channels" :> ChannelsApi :<|>
42+ "drafts" :> DraftApi
70− MessagesApi
43+ )
71− ) :<|>
72− "tags" :> TagsAPI :<|>
73− "faculty" :> FacultyAPI
74
44
75serverProxy :: Proxy API
45serverProxy :: Proxy API
76serverProxy = Proxy
46serverProxy = Proxy
77
47
78mkServerAPI :: Logger -> ServerT API App
48mkServerAPI :: Logger -> ServerT API App
79−mkServerAPI l =
49+mkServerAPI l =
80− l :<|>
50+ l :<|>
81− authenticationAPI :<|> (\uId ->
51+ authenticate :<|> (\uId ->
82− return uId :<|>
83− deactivateApi uId :<|>
84− maybeNotFound . runQnotFound . getUsers :<|>
52+ mapM (runQnotFound . getUser) :<|>
85− runQerror getAllUsers :<|>
86− runQerror . searchUsers :<|>
87− updateUserApi uId :<|>
88 postApi uId :<|>
53 postApi uId :<|>
89− channelsApi uId :<|>
54+ draftApi uId
90− messagesServer uId
55+ )
91− ) :<|>
92− tagsServer :<|>
93− facultyServer
94
56
95−updateUserApi :: UserId -> UserUpdate -> App NoContent
57+-- getPostsS :: [UserId] -> App [User]
96−updateUserApi uId UserUpdate{..} = do
58+-- getPostsS = mapM getPost
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
59
111−deactivateApi :: UserId -> App NoContent
112−deactivateApi uId = runQerror (killAllTokens uId) >> return NoContent
denis/src/Server/API/Channels.hsdeleted−94
@@ -1,94 +0,0 @@
1−{-# LANGUAGE
2− DataKinds ,
3− DeriveGeneric ,
4− OverloadedLabels,
5− OverloadedStrings ,
6− TypeApplications ,
7− TypeOperators,
8− RecordWildCards #-}
9−
10−module Server.API.Channels (
11− ChannelsApi,
12− channelsApi
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 Data.Channel.NamedChannel
22−import Data.Channel.AnonymousChannel
23−import qualified Data.Post as P
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
38−
39−type ChannelsApi = Post '[JSON] [NamedChannel UserId] :<|>
40− "get" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe NamedChannelId)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
41− "getAnonymous" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe AnonymousChannel)) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
42− "create" :> CreateDescription :> ReqBody '[JSON] NamedChannelCreationRequest :> Post '[JSON] NamedChannelId :<|>
43− "update" :> ReqBody '[JSON] (NamedChannel UserId) :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
44− "delete" :> ReqBody '[JSON] NamedChannelId :> PostNoContent '[JSON, FormUrlEncoded, PlainText] NoContent :<|>
45− "search" :> SearchDescription :> ReqBody '[JSON, PlainText] Text :> Post '[JSON] [NamedChannel UserId]
46−
47−channelsApi :: UserId -> ServerT ChannelsApi App
48−channelsApi uId = getChannelsApi uId :<|> getChannel uId :<|> getAnonymousChannelsApi :<|> createChannelApi uId :<|> updateChannelApi uId :<|> deleteChannelApi uId :<|> searchChannelsApi uId
49−
50−
51−getChannelsApi :: UserId -> App [NamedChannel UserId]
52−getChannelsApi uId = runQnotFound $ getAllChannels uId
53−
54−getAnonymousChannelsApi :: PaginatingRequest P.PostId (Maybe AnonymousChannel) -> App (ResponseWithUsers [P.Post])
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
58−getAnonymousChannelsApi req@(PaginatingRequest pId lim Nothing dir) = do
59− unless (validatePaginationRequest req) $ throwError lengthExceeded
60− maybeNotFound . runQnotFound $ getLastPosts pId lim dir
61−
62−getChannel :: UserId -> PaginatingRequest P.PostId (Maybe NamedChannelId) -> App (ResponseWithUsers [P.Post])
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
66−getChannel _ req@(PaginatingRequest pId lim Nothing dir) = do
67− unless (validatePaginationRequest req) $ throwError lengthExceeded
68− maybeNotFound . runQnotFound $ getLastPosts pId lim dir
69−
70−createChannelApi :: 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
77−
78−updateChannelApi :: UserId -> NamedChannel UserId -> App NoContent
79−updateChannelApi uId req@NamedChannel{..} = do
80− unless (validateText req) $ throwError lengthExceeded
81− runQnotFound $ updateChannel uId req
82− return NoContent
83−
84−deleteChannelApi :: UserId -> NamedChannelId -> App NoContent
85−deleteChannelApi uId cId = do
86− runQnotFound $ deleteNamedChannel uId cId
87− 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/Draft.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE
2+ DataKinds ,
3+ DeriveGeneric ,
4+ OverloadedLabels,
5+ OverloadedStrings ,
6+ TypeApplications ,
7+ TypeOperators #-}
8+
9+module Server.API.Draft (
10+ DraftApi,
11+ draftApi,
12+ DraftUpdate(..)
13+) where
14+
15+import Data.Proxy
16+import Servant.API
17+import qualified Data.Post as P
18+import Data.Aeson
19+import GHC.Generics
20+import Data.Int (Int64)
21+import Server.App
22+import Servant.Server
23+import Data.Query
24+import Data.User
25+import Data.Connection
26+
27+data DraftUpdate = DraftUpdate {
28+ draftId :: P.DraftId,
29+ draftContent :: [P.PostElement P.Draft]
30+ } deriving Generic
31+
32+instance FromJSON DraftUpdate where
33+ parseJSON = withObject "Post update object" $ \e ->
34+ DraftUpdate <$> e .: "id" <*> e.: "body"
35+instance ToJSON DraftUpdate where
36+ toJSON (DraftUpdate dId body) = object [
37+ "id" .= dId,
38+ "body" .= body
39+ ]
40+
41+
42+type DraftApi = "create" :> ReqBody '[JSON] [P.PostElement P.Draft] :> Post '[JSON] P.DraftId :<|>
43+ "update" :> ReqBody '[JSON] DraftUpdate :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
44+ "publish" :> ReqBody '[JSON] P.DraftId :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
45+ "all" :> Post '[JSON] [DraftUpdate]
46+
47+draftApi :: UserId -> ServerT DraftApi App
48+draftApi uId =
49+ (fmap P.postId . runQnotFound . createDraft uId) :<|> updateDraftApi uId :<|>
50+ publishDraftApi uId :<|>
51+ runQnotFound (fmap (map postToDraft) $ getDrafts uId)
52+
53+updateDraftApi :: UserId -> DraftUpdate -> App NoContent
54+updateDraftApi uId (DraftUpdate dId els) = do
55+ runQnotFound $ updateDraft uId dId els
56+ return NoContent
57+
58+publishDraftApi :: UserId -> P.DraftId -> App NoContent
59+publishDraftApi uId dId = do
60+ runQnotFound $ publishDraft uId dId
61+ return NoContent
62+
63+postToDraft :: P.Draft -> DraftUpdate
64+postToDraft (P.PostData dId _ body) = DraftUpdate dId body
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+38−33
@@ -8,48 +8,53 @@
8
8
9module Server.API.Posts (
9module Server.API.Posts (
10 PostApi,
10 PostApi,
11− postApi
11+ postApi,
12+ UserPostsRequest(..)
12) where
13) where
13
14
15+import Data.Proxy
14import Servant.API
16import Servant.API
15import qualified Data.Post as P
17import qualified Data.Post as P
18+import Data.Aeson
19+import GHC.Generics
20+import Data.Int (Int64)
16import Server.App
21import Server.App
17import Servant.Server
22import Servant.Server
18import Data.Query
23import Data.Query
19import Data.User
24import Data.User
20import Data.Connection
25import Data.Connection
21−import Server.Query.Pagination
26+import Servant
22−import Data.Limits
27+import Data.Word (Word64)
23−import Server.Error
28+
24−import Control.Monad
29+data UserPostsRequest = UserPostsRequest {
25−import Data.Text.Validator
30+ userPostRequestId :: UserId,
31+ userPostRequestLimit :: Word64
32+}
33+
34+instance ToJSON UserPostsRequest where
35+ toJSON (UserPostsRequest uId lim) = object ["userId" .= uId, "limit" .= lim]
36+instance FromJSON UserPostsRequest where
37+ parseJSON = withObject "User posts request" $ \e ->
38+ UserPostsRequest <$> e .: "userId" <*> e.: "limit"
39+
40+type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] [P.Post] :<|>
41+ "last" :> ReqBody '[JSON] Word64 :> Post '[JSON] [P.Post] :<|>
42+ "forUser" :> ReqBody '[JSON] UserPostsRequest :> Post '[JSON] [P.Post]
43+
44+maybeNotFound :: App (Maybe a) -> App a
45+maybeNotFound = (>>= (\t -> case t of
46+ Just y -> return y
47+ Nothing -> throwError err404))
48+
49+
50+postApi :: UserId -> ServerT PostApi App
51+postApi uId = getPosts :<|> lastPosts :<|> getPostsForUserApi
26
52
27−-- MARK: Implementation
53+getPosts :: [P.PostId] -> App [P.Post]
54+getPosts = mapM (maybeNotFound . runQnotFound . getPost)
28
55
29−type PostApi = ReqBody '[JSON] [P.PostId] :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
56+lastPosts :: Word64 -> App [P.Post]
30− "last" :> ReqBody '[JSON] (PaginatingRequest P.PostId (Maybe ())) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
57+lastPosts = runQnotFound . getLastPosts
31− "forUser" :> ReqBody '[JSON] (PaginatingRequest P.PostId UserId) :> Post '[JSON] (ResponseWithUsers [P.Post]) :<|>
32− "publish" :> ReqBody '[JSON] P.PostCreation :> Post '[JSON] P.PostId
33
58
34−postApi :: UserId -> ServerT PostApi App
59+getPostsForUserApi :: UserPostsRequest -> App [P.Post]
35−postApi uId = getPostsApi :<|> lastPosts :<|> getPostsForUserApi :<|> publishPostApi uId
36−
37−getPostsApi :: [P.PostId] -> App (ResponseWithUsers [P.Post])
38−getPostsApi req = do
39− unless (listLimit < length req) $ throwError lengthExceeded
40− maybeNotFound . runQnotFound . getPosts $ req
41−
42−lastPosts :: PaginatingRequest P.PostId (Maybe ()) -> App (ResponseWithUsers [P.Post])
43−lastPosts req@(PaginatingRequest pId lim _ dir) = do
44− unless (validatePaginationRequest req) $ throwError lengthExceeded
45− maybeNotFound . runQnotFound $ getLastPosts pId lim dir
46−
47−getPostsForUserApi :: PaginatingRequest P.PostId UserId -> App (ResponseWithUsers [P.Post])
48−getPostsForUserApi req@(PaginatingRequest pId lim uId dir) = do
49− unless (validatePaginationRequest req) $ throwError lengthExceeded
50− maybeNotFound . runQnotFound $ getPostsForUser pId lim dir uId
60+getPostsForUserApi (UserPostsRequest uId lim) = runQnotFound $ getPostsForUser lim uId
51−
52−publishPostApi :: UserId -> P.PostCreation -> App P.PostId
53−publishPostApi uId creation = do
54− unless (validateText creation) $ throwError lengthExceeded
55− runQerror . publishPost uId $ creation
denis/src/Server/App.hs+5−30
@@ -4,9 +4,7 @@
4 OverloadedLabels,
4 OverloadedLabels,
5 OverloadedStrings ,
5 OverloadedStrings ,
6 TypeApplications ,
6 TypeApplications ,
7− TypeOperators,
7+ TypeOperators #-}
8− TypeSynonymInstances,
9− FlexibleInstances #-}
10
8
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
21
17
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
30
25
31−type App = ReaderT Config Handler
26+type App = ReaderT Config Handler
32
27
33type DBConnection = Pool (K Connection Schema)
28type DBConnection = Pool (K Connection Schema)
34
29
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+42−355
@@ -7,31 +7,29 @@
7 ScopedTypeVariables,
7 ScopedTypeVariables,
8 TypeFamilies,
8 TypeFamilies,
9 TypeOperators,
9 TypeOperators,
10− UndecidableInstances,
10+ UndecidableInstances #-}
11− DeriveAnyClass,
12− RecordWildCards #-}
13−{-# OPTIONS_GHC -Wno-orphans #-}
14
11
15module Server.Auth (
12module Server.Auth (
16 checkToken,
13 checkToken,
17 cookieTokenKey,
14 cookieTokenKey,
18 genAuthServerContext,
15 genAuthServerContext,
19 AuthenticationHandler,
16 AuthenticationHandler,
20− logIn,
17+ authenticate,
21 contextProxy,
18 contextProxy,
22− AuthenticationCredits(..),
19+ AuthenticationCredits(..)
23− authenticationAPI,
24− TokenActivationData
25) where
20) where
26
21
27import Server.App
22import Server.App
28import Data.User
23import Data.User
29−import qualified Data.ByteString as BS
24+import Data.ByteString
30import qualified Data.ByteString.Char8 as C
25import qualified Data.ByteString.Char8 as C
31import qualified Data.ByteString.Lazy.Char8 as L
26import qualified Data.ByteString.Lazy.Char8 as L
32import Data.Query
27import Data.Query
28+import Data.Binary (decode)
33import Server.Error
29import Server.Error
34−import Control.Monad.Except
30+import Control.Monad.Error
31+import Text.Read (readMaybe)
32+import Squeal.PostgreSQL.PQ
35import Data.Connection
33import Data.Connection
36import Servant.Server.Experimental.Auth
34import Servant.Server.Experimental.Auth
37import Servant.API
35import Servant.API
@@ -39,340 +37,56 @@ import Network.Wai (Request, requestHeaders)
39import Servant.Server
37import Servant.Server
40import Web.Cookie
38import Web.Cookie
41import Data.Time.Clock
39import Data.Time.Clock
42−import Data.Time.Calendar
40+import Data.Monoid ((<>))
41+import Data.Text
43import Data.Proxy
42import Data.Proxy
44import qualified GHC.Generics as GHC
43import qualified GHC.Generics as GHC
45import Data.Aeson
44import Data.Aeson
46−import qualified Data.Aeson as A
47import Data.Binary.Builder (toLazyByteString)
45import Data.Binary.Builder (toLazyByteString)
48−import Servant.Docs
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
61
46
62−-- MARK: Documentation
47+type AuthenticationHandler = ReqBody '[JSON] AuthenticationCredits :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
63
48
64−instance ToSample AuthenticationCredits where
49+data AuthenticationCredits = AuthenticationCredits {authenticationId :: UserId}
65− toSamples _ = samples $ map AuthenticationCredits ["vchernyshev@hse.ru", "iikostyuchenko@hse.ru"]
50+ deriving GHC.Generic
66
51
67−instance ToSample UserLoginResponse where
52+instance ToJSON AuthenticationCredits
68− toSamples _ = samples $ map UserLoginResponse [UserIsRegistered, UserCanRegister, InvalidUser]
53+instance FromJSON AuthenticationCredits
69
54
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
114−
115−type AuthenticationHandler =
116− "login" :> LoginDescription :>
117− ReqBody '[JSON] AuthenticationCredits :>
118− Header "User-Agent" String :>
119− Post '[JSON] (Headers '[Header "Set-Cookie" String] UserLoginResponse) :<|>
120− "logout" :> LogoutDescription
121− :> Header "cookie" String
122− :> 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
182− toJSON TokenActivationResultYou = object ["you" .= True]
183− toJSON TokenActivationResultNotYou = object ["you" .= False]
184−
185−instance ToJSON BS.ByteString where
186− toJSON = A.String . T.decodeUtf8 . BS.encode
187−
188−instance FromJSON BS.ByteString where
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−
224−authenticationAPI :: ServerT AuthenticationHandler App
55+authenticate :: ServerT AuthenticationHandler App
225−authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register :<|> checkCookie :<|> validateTokenApi :<|> deactivateTokenApi :<|> activateUser :<|> deactivateUser
226−
227−logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
228−logIn (AuthenticationCredits email') ua' = do
56+authenticate (AuthenticationCredits uId) = do
229− let email = T.toLower . T.strip $ email'
57+ conn <- ask
230− if (not . validateEmail) email
58+ expire <- liftIO $ fmap (addUTCTime (1 * 24 * 60 * 60)) getCurrentTime -- one days
231− then return . noHeader $ UserLoginResponse InvalidUser
59+ tId <- fmap userId . runQ invalidToken . getUser $ uId
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,
247− setCookieValue = L.toStrict . encode $ AuthenticationCookieData (tokenUserId token) value,
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 {
60+ let cookie = defaultSetCookie {
281− setCookieName = cookieTokenKey,
61+ setCookieName = cookieTokenKey,
282− setCookieValue = "invalid",
62+ setCookieValue = C.pack $ show tId,
283− setCookieExpires = Just (UTCTime (ModifiedJulianDay 0) 0),
63+ setCookieExpires = Just expire,
64+ -- setCookieDomain = Just "127.0.0.1",
284 setCookiePath = Just "/" }
65 setCookiePath = Just "/" }
66+ -- let token = cookieTokenKeyString <> "=" <> show tId <> "; Expires=" <> show expire <> "; Domain=127.0.0.1:2000; Path=/" -- ; Secure" --; HttpOnly"
285− return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ newCookie) NoContent
67+ return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) NoContent
286−
287−validateTokenApi :: Maybe String -> TokenActivationData -> App TokenActivationResult
288−validateTokenApi cookie' (TokenActivationData uId aData) = do
289− tokenData' <- runQerror $ tryActivateToken uId aData
290− case tokenData' of
291− Nothing -> throwError err401
292− Just Token{..} -> do
293− case cookie' >>= getCookie of
294− Nothing -> return TokenActivationResultNotYou
295− Just (AuthenticationCookieData uId' cData) ->
296− if hash cData == tokenValue && uId' == tokenUserId
297− then return TokenActivationResultYou
298− else return TokenActivationResultNotYou
299
68
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
69
307−checkToken :: DBConnection -> AuthenticationCookieData -> Handler UserId
70+checkToken :: DBConnection -> ByteString -> Handler UserId
308−checkToken conn (AuthenticationCookieData uId tokenData) = do
71+checkToken conn token = do
309− token <- runQ' conn err500 $ getVerifiedToken uId tokenData
310− case token of
72+ uId <- case ((readMaybe . C.unpack) token :: Maybe UserId) of
73+ Just uId -> return uId
311 Nothing -> throwError invalidToken
74 Nothing -> throwError invalidToken
312− Just (Token newUId _ _ _ _ _ _ _) -> return newUId
75+ 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
76
361authHandler :: DBConnection -> AuthHandler Request UserId
77authHandler :: DBConnection -> AuthHandler Request UserId
362authHandler conn = mkAuthHandler handler
78authHandler conn = mkAuthHandler handler
363 where
79 where
80+ maybeToEither e = maybe (Left e) Right
81+ throw401 msg = throwError $ err401 { errBody = msg }
364− handler req = do
82+ handler req = either throw401 (checkToken conn) $ do
365− let cookie' = lookup "cookie" $ requestHeaders req
83+ cookie <- maybeToEither "Missing cookie header" $ 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
84+ maybeToEither "Missing token in cookie" $ lookup cookieTokenKey $ parseCookies cookie
370− case mbToken of
85+
371− Nothing -> throwError invalidToken
86+cookieTokenKey :: ByteString
372− Just t -> checkToken conn t
87+cookieTokenKey = "servant-auth-cookie"
373
88
374−cookieTokenKey :: BS.ByteString
89+cookieTokenKeyString = C.unpack cookieTokenKey
375−cookieTokenKey = "valera-denis-auth-cookie"
376
90
377type instance AuthServerData (AuthProtect "basicAuth") = UserId
91type instance AuthServerData (AuthProtect "basicAuth") = UserId
378
92
@@ -380,31 +94,4 @@ genAuthServerContext :: DBConnection -> Context (AuthHandler Request UserId ': '
380genAuthServerContext conn = authHandler conn :. EmptyContext
94genAuthServerContext conn = authHandler conn :. EmptyContext
381
95
382contextProxy :: Proxy '[AuthHandler Request UserId]
96contextProxy :: Proxy '[AuthHandler Request UserId]
383−contextProxy = Proxy
97+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+4−43
@@ -1,54 +1,15 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2
2
3module Server.Error (
3module Server.Error (
4− invalidToken,
4+ invalidToken
5− amountExceeded,
6− lengthExceeded,
7− formatError,
8− impossibleContent,
9− throwError
10−) where
5+) where
11
6
12import Servant.Server
7import Servant.Server
13−import Control.Monad.Except
14
8
15invalidToken :: ServantErr
9invalidToken :: ServantErr
16invalidToken = ServantErr {
10invalidToken = ServantErr {
17− errHTTPCode = 498,
11+ errHTTPCode = 401,
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/Logger.hs+11−11
@@ -1,10 +1,7 @@
1{-# LANGUAGE DataKinds,
1{-# LANGUAGE DataKinds,
2 TypeOperators,
2 TypeOperators,
3 OverloadedStrings,
3 OverloadedStrings,
4− ScopedTypeVariables,
4+ ScopedTypeVariables #-}
5− TypeSynonymInstances,
6− FlexibleInstances #-}
7−{-# OPTIONS_GHC -Wno-orphans #-}
8
5
9module Server.Logger (
6module Server.Logger (
10 Logger,
7 Logger,
@@ -17,18 +14,21 @@ import Network.Wai
17import Control.Concurrent.STM
14import Control.Concurrent.STM
18import Data.CyclicBuffer
15import Data.CyclicBuffer
19import Servant
16import Servant
17+import Servant.API
18+import Servant.Server
20import Data.Text.Encoding
19import Data.Text.Encoding
21import qualified Data.Text as T
20import qualified Data.Text as T
21+import Data.Foldable
22import qualified Data.ByteString as BL
22import qualified Data.ByteString as BL
23import Data.List
23import Data.List
24import Server.App
24import Server.App
25+import Data.CaseInsensitive (original)
26+import Data.Monoid ((<>), mempty, mappend)
27+import Network.HTTP.Types.Header
25import Network.Wai.Middleware.RequestLogger
28import Network.Wai.Middleware.RequestLogger
26import Data.Default.Class
29import Data.Default.Class
27import qualified System.Log.FastLogger as FL
30import qualified System.Log.FastLogger as FL
28−import Servant.Docs
31+import Data.ByteString.Char8 (unpack)
29−
30−instance HasDocs "log" where
31− docsFor _ _ _ = emptyAPI
32
32
33type Log = T.Text
33type Log = T.Text
34
34
@@ -45,11 +45,11 @@ getLog :: TVar (CyclicBuffer BL.ByteString) -> Logger
45getLog buff = decodeUtf8 . BL.concat . intersperse "\n" . elems <$> liftIO (readTVarIO buff)
45getLog buff = decodeUtf8 . BL.concat . intersperse "\n" . elems <$> liftIO (readTVarIO buff)
46
46
47mkWaiLogger :: TVar (CyclicBuffer BL.ByteString) -> IO Middleware
47mkWaiLogger :: TVar (CyclicBuffer BL.ByteString) -> IO Middleware
48−mkWaiLogger buff = let
48+mkWaiLogger buff = let
49 settings = def {
49 settings = def {
50− -- outputFormat = CustomOutputFormatWithDetails (\ date req _ _ tDiff bss bldr ->
50+ -- outputFormat = CustomOutputFormatWithDetails (\ date req _ _ tDiff bss bldr ->
51 -- FL.toLogStr (show date) <> (FL.toLogStr . unpack $ fold bss))
51 -- FL.toLogStr (show date) <> (FL.toLogStr . unpack $ fold bss))
52 outputFormat = Detailed False,
52 outputFormat = Detailed False,
53− destination = Callback (atomically . modifyTVar buff . flip insertIntoCyclicBuffer . FL.fromLogStr)
53+ destination = Callback (atomically . modifyTVar buff . flip insertIntoCyclicBuffer . FL.fromLogStr)
54 }
54 }
55 in mkRequestLogger settings
55 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+20−51
@@ -1,12 +1,7 @@
1−{-# LANGUAGE
2− OverloadedStrings,
1+{-# LANGUAGE OverloadedStrings #-}
3− TypeOperators,
4− DataKinds #-}
5
2
6module Server.Server (
3module Server.Server (
7− runServer,
4+ runServer
8− hoistedServer,
9− getConfig
10) where
5) where
11
6
12import Server.API
7import Server.API
@@ -14,67 +9,52 @@ import Server.Auth
14import Server.App
9import Server.App
15
10
16import Servant.Server
11import Servant.Server
12+import Servant.API
17import System.Environment
13import System.Environment
18import qualified Data.ByteString.Char8 as B
14import qualified Data.ByteString.Char8 as B
19import Squeal.PostgreSQL.Pool
15import Squeal.PostgreSQL.Pool
20import Data.Maybe
16import Data.Maybe
21import Control.Monad.Reader
17import Control.Monad.Reader
22import Network.Wai.Handler.Warp
18import Network.Wai.Handler.Warp
23−import Network.HTTP.Types.Method
19+import Network.HTTP.Types.Method
24import Server.Logger
20import Server.Logger
25−import Data.Faculty.Parser
21+
26−import Data.Connection
27−import Data.Query
28−import Crypto.RNG
29import Network.Wai.Middleware.Cors
22import Network.Wai.Middleware.Cors
30−import Server.Periodic
23+
31
24
32getDBString :: IO B.ByteString
25getDBString :: IO B.ByteString
33getDBString = do
26getDBString = do
34 mDatabaseURL <- lookupEnv "DATABASE_URL"
27 mDatabaseURL <- lookupEnv "DATABASE_URL"
35 return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL
28 return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL
36
29
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
30getServerPort :: IO Int
46−getServerPort = maybe 2000 read <$> lookupEnv "PORT"
31+getServerPort = maybe 2000 read <$> lookupEnv "PORT"
47
32
48getConfig :: IO Config
33getConfig :: IO Config
49getConfig = do
34getConfig = do
50 databaseURL <- getDBString
35 databaseURL <- getDBString
51− conn <- createConnectionPool databaseURL 3 0.5 10
36+ conn <- createConnectionPool databaseURL 1 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
37+ 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
61
38
62runServer :: IO ()
39runServer :: IO ()
63runServer = do
40runServer = do
64 port <- getServerPort
41 port <- getServerPort
65 cfg <- getConfig
42 cfg <- getConfig
66− updateFaculties cfg
67− _ <- periodically (1 * hours) $ updateFaculties cfg
68− _ <- periodically (20 * minutes) $ runDbTask cfg pruneAuth
69 let ctx = genAuthServerContext $ getPool cfg
43 let ctx = genAuthServerContext $ getPool cfg
70− (middleLogger, logger) <- mkLogger 500
44+ (middleLogger, logger) <- mkLogger 50
71− let s = hoistedServer logger cfg
45+ let serverAPI = mkServerAPI logger
46+ let s = hoistServerWithContext serverProxy contextProxy (flip runReaderT cfg) serverAPI
72 runSettings (settings port) $ cors (const $ Just policy) . middleLogger $ serveWithContext serverProxy ctx s
47 runSettings (settings port) $ cors (const $ Just policy) . middleLogger $ serveWithContext serverProxy ctx s
48+ -- TODO: remove simpleCors
49+
50+-- runServer :: IO ()
51+-- runServer = do
52+-- s <- getServer
73
53
74policy :: CorsResourcePolicy
54policy :: CorsResourcePolicy
75policy = CorsResourcePolicy {
55policy = 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,
56+ 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],
57+ corsMethods=[methodGet, methodPost],
78 corsRequestHeaders = ["content-type"],
58 corsRequestHeaders = ["content-type"],
79 corsExposedHeaders = Nothing,
59 corsExposedHeaders = Nothing,
80 corsMaxAge = Nothing,
60 corsMaxAge = Nothing,
@@ -84,15 +64,4 @@ policy = CorsResourcePolicy {
84}
64}
85
65
86settings :: Int -> Settings
66settings :: Int -> Settings
87−settings port = setPort port . setServerName "Denis" $ defaultSettings
67+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+2−4
@@ -37,10 +37,8 @@ packages:
37# Dependency packages to be pulled from upstream that are not in the resolver
37# Dependency packages to be pulled from upstream that are not in the resolver
38# using the same syntax as the packages field.
38# using the same syntax as the packages field.
39# (e.g., acme-missiles-0.3)
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
44
42
45
43
46# Override default flag values for local packages and extra-deps
44# Override default flag values for local packages and extra-deps