git.iko.soy/denis
on master help sign in
Merge branch 'master' into develop
commit24d179b92504f41a4e96d42099aa66243b1affe4 authoriko <ilyakooo0@gmail.com> dateFri 10 May 2019, 17:11 (7 years ago) parent00091d7f8d9b90
17 files changed+941−135
compare with master
unifiedsplit
denis/docs/Docs.hs+3 denis/package.yaml+9−2 denis/sql/indexes.sql+5 denis/src/Data/Connection.hs+6−1 denis/src/Data/Faculty.hs+56 denis/src/Data/Faculty/Parser.hs+84 denis/src/Data/Query.hs+328−32 denis/src/Data/Schema.hs+72−23 denis/src/Data/User.hs+20−16 denis/src/Server/API.hs+8−4 denis/src/Server/API/Faculty.hs+32 denis/src/Server/App.hs+21−5 denis/src/Server/Auth.hs+181−45 denis/src/Server/Auth/Mail.hs+39 denis/src/Server/Auth/Token.hs+48 denis/src/Server/Server.hs+26−6 stack.yaml+3−1
denis/docs/Docs.hs+3
@@ -25,6 +25,8 @@ import qualified Data.Text.IO as T
2525import Servant.Server.Experimental.Auth
2626import Network.Wai
2727import Server.API.Messages
28+import Server.API.Faculty
29+
2830docsWriter :: HasDocs api => String -> Proxy api -> IO ()
2931docsWriter file = writeFile ("docs/" ++ file ++ ".md") . normalizer . markdown . docs
3032
@@ -36,6 +38,7 @@ main = do
3638 Authentication :> "authentication" :> "me" :> Post '[JSON] UserId ))
3739 docsWriter "channels" $ pretty (Proxy :: Proxy ("channels" :> ChannelsApi))
3840 T.writeFile ("docs/Home.md") . (\t -> "```\n" <> t <> "```\n") $ layoutWithContext serverProxy (undefined :: Context (AuthHandler Request UserId ': '[]))
41+ docsWriter "faculty" $ pretty (Proxy :: Proxy ("faculty" :> FacultyAPI))
3942
4043
4144instance ToSample Char where
denis/package.yaml+9−2
@@ -50,10 +50,17 @@ dependencies:
5050- data-default-class
5151- fast-logger
5252- vector
53−
53+- taggy
54+- unordered-containers
55+- req
56+- data-default
5457- lens
55−
58+- crypto-rng
5659- wai-cors
60+- base64-bytestring
61+- regex-compat
62+- smtp-mail
63+- mime-mail
5764
5865
5966
denis/sql/indexes.sqlnew file+5
@@ -0,0 +1,5 @@
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/Connection.hs+6−1
@@ -16,7 +16,8 @@ module Data.Connection (
1616 runQerror,
1717 maybeNotFound,
1818 maybeInvalidToken,
19− commitedTransactionallyUpdate
19+ commitedTransactionallyUpdate,
20+ runQsilent
2021) where
2122
2223import Squeal.PostgreSQL
@@ -44,6 +45,10 @@ runQnotFound = runQ err404
4445runQerror :: StaticPQ a -> App a
4546runQerror = runQ err500
4647
48+runQsilent :: StaticPQ a -> App ()
49+runQsilent req = handleSqueal (liftIO . print) $ asks getPool >>= lift . runPoolPQ req
50+ >> return ()
51+
4752maybeNotFound :: App (Maybe a) -> App a
4853maybeNotFound = (>>= (\t -> case t of
4954 Just y -> return y
denis/src/Data/Faculty.hsnew file+56
@@ -0,0 +1,56 @@
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 "name" "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+} deriving (GHC.Generic, Show, SOP.Generic, SOP.HasDatatypeInfo)
37+
38+instance ToJSON Faculty where
39+ toJSON (Faculty name url p campusName campusCode tags) = object [
40+ "name" .= name,
41+ "url" .= url,
42+ "path" .= p,
43+ "campusName" .= campusName,
44+ "campusCode" .= campusCode,
45+ "tags" .= tags
46+ ]
47+
48+instance FromJSON Faculty where
49+ parseJSON = withObject "faculty" $ \e ->
50+ Faculty <$>
51+ e .: "name" <*>
52+ e .: "url" <*>
53+ e .: "path" <*>
54+ e .: "campusName" <*>
55+ e .: "campusCode" <*>
56+ e .: "tags"
denis/src/Data/Faculty/Parser.hsnew file+84
@@ -0,0 +1,84 @@
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+ return $ Faculty name url path cName cCode (V.fromList tags)
68+
69+classIs :: T.Text -> Element -> Bool
70+classIs c = (== (Just c)) . HM.lookup "class" . eltAttrs
71+
72+elements :: [Node] -> [Element]
73+elements ((NodeElement el):nn) = el : ((elements . eltChildren) el ++ elements nn)
74+elements _ = []
75+
76+texts' :: HM.HashMap T.Text T.Text -> [Node] -> [(HM.HashMap T.Text T.Text, T.Text)]
77+texts' hm (NodeContent t: nn) = (hm, t) : texts' hm nn
78+texts' hm ((NodeElement el):nn) = ((texts' (HM.union (eltAttrs el) hm) (eltChildren el)) ++ texts' hm nn)
79+texts' _ _ = []
80+
81+data Campus = Campus {
82+ campusName :: T.Text,
83+ campusCode :: T.Text
84+} deriving Show
denis/src/Data/Query.hs+328−32
@@ -1,13 +1,15 @@
11{-# LANGUAGE
2− DataKinds ,
3− DeriveGeneric ,
2+ DataKinds,
3+ DeriveGeneric,
44 OverloadedLabels,
5− OverloadedStrings ,
6− TypeApplications ,
5+ OverloadedStrings,
6+ TypeApplications,
77 TypeOperators,
88 PartialTypeSignatures,
99 FlexibleInstances,
10− KindSignatures #-}
10+ KindSignatures,
11+ DeriveAnyClass,
12+ RecordWildCards #-}
1113
1214{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
1315
@@ -16,7 +18,7 @@ module Data.Query (
1618 Schema,
1719 createTables,
1820 getPosts,
19− getUser,
21+ -- getUser,
2022 getUsers,
2123 getAllUsers,
2224 getLastPosts,
@@ -40,8 +42,19 @@ module Data.Query (
4042 createGroupChat,
4143 updateGroupChat,
4244 leaveGroupChat,
43− getGroupChatForUser
44−) where
45+ getGroupChatForUser,
46+ getFaculty,
47+ updateFaculty,
48+ getFacultyFromQuery,
49+ getUserWithEmail,
50+ createToken,
51+ validateToken,
52+ invalidateToken,
53+ tryVerifyToken,
54+ getVerifiedToken,
55+ UserCreation(..),
56+ createUser
57+ ) where
4558
4659import Squeal.PostgreSQL
4760import Data.User
@@ -67,6 +80,7 @@ import Servant.Docs
6780import Data.Proxy
6881import Data.Vector (Vector, toList, fromList)
6982import Data.Text (Text)
83+import qualified Data.Text as T
7084import Data.Channel.NamedChannel
7185import Data.Channel.AnonymousChannel
7286import Data.Maybe (fromMaybe)
@@ -75,6 +89,13 @@ import Data.GroupChat
7589import Data.Message
7690import Server.Query.Dialog
7791import qualified Server.Query.Pagination as P
92+import Data.Faculty
93+import Data.ByteString (ByteString)
94+import Data.Foldable (fold)
95+import Data.Char
96+import qualified Data.Vector as V
97+import Server.Auth.Token
98+import Data.Int
7899
79100-- MARK: Documentation
80101
@@ -137,26 +158,68 @@ getPostQ oTe te = select (
137158-- let rows = M.fromList $ map (tupleBy $ quoteRowId . head) . groupBy ((==) `on` quoteRowId) . sortBy (compare `on` quoteRowId) $ rows'
138159-- return $ M.lookup qId rows >>= rowsToQuote rows
139160
140−getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)
141−getUserQ = selectStar $ from (table #users) & where_ (#userId .== param @1)
161+getUserWithEmailQ :: Query Schema (TuplePG (Only UserEmail)) (RowPG (User FacultyUrl))
162+getUserWithEmailQ = select (
163+ #userRowId `as` #userId :*
164+ #userRowFirstName `as` #firstName :*
165+ #userRowMiddleName `as` #middleName :*
166+ #userRowLastName `as` #lastName :*
167+ #userRowFacultyUrl `as` #userFaculty :*
168+ #userRowEmail `as` #userEmail
169+ ) (from (table #users) &
170+ where_ (#userRowEmail .== param @1) &
171+ where_ (notNull #userRowIsValidated))
142172
143173verifiedUserIdsQ :: [UserId] -> Maybe (Query Schema '[] (RowPG (Only UserId)))
144174verifiedUserIdsQ uIds = case idsToColumn uIds of
145− Just idQ -> Just $ select (#users ! #userId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
175+ Just idQ -> Just $ select (#users ! #userRowId `as` #fromOnly) $ from (subquery (idQ `As` #ids) &
146176 innerJoin (table #users)
147− (#ids ! #id .== #users ! #userId))
177+ (#ids ! #id .== #users ! #userRowId))
148178 Nothing -> Nothing
149179
150−
151−getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG User))
180+getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))
152181getUsersQ uIds = case idsToColumn uIds of
153− Just idQ -> Just $ selectDotStar #users $ from (subquery (idQ `As` #ids) &
182+ Just idQ -> Just $ select (
183+ #users ! #userRowId :*
184+ #users ! #userRowFirstName :*
185+ #users ! #userRowMiddleName :*
186+ #users ! #userRowLastName :*
187+ #users ! #userRowFacultyUrl :*
188+ #users ! #userRowEmail :*
189+ #users ! #userRowIsValidated :*
190+ #faculties ! #facultyName `as` #userRowFacultyName :*
191+ #faculties ! #facultyUrl `as` #userRowFacultyURL :*
192+ #faculties ! #facultyPath `as` #userRowFacultyPath :*
193+ #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
194+ #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
195+ #faculties ! #facultyTags `as` #userRowFacultyTags
196+ ) (from (subquery (idQ `As` #ids) &
154197 innerJoin (table #users)
155− (#ids ! #id .== #users ! #userId))
198+ (#ids ! #id .== #users ! #userRowId) &
199+ innerJoin (table #faculties)
200+ (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl)) &
201+ where_ (notNull $ #users ! #userRowIsValidated))
156202 Nothing -> Nothing
157203
158−getAllUsersQ :: Query Schema '[] (RowPG User)
159−getAllUsersQ = selectStar $ from $ table #users
204+getAllUsersQ :: Query Schema '[] (RowPG UserRow)
205+getAllUsersQ = select (
206+ #users ! #userRowId :*
207+ #users ! #userRowFirstName :*
208+ #users ! #userRowMiddleName :*
209+ #users ! #userRowLastName :*
210+ #users ! #userRowFacultyUrl :*
211+ #users ! #userRowEmail :*
212+ #users ! #userRowIsValidated :*
213+ #faculties ! #facultyName `as` #userRowFacultyName :*
214+ #faculties ! #facultyUrl `as` #userRowFacultyURL :*
215+ #faculties ! #facultyPath `as` #userRowFacultyPath :*
216+ #faculties ! #facultyCampusName `as` #userRowFacultyCampusName :*
217+ #faculties ! #facultyCampusCode `as` #userRowFacultyCampusCode :*
218+ #faculties ! #facultyTags `as` #userRowFacultyTags
219+ ) (from ((table #users) &
220+ innerJoin (table #faculties)
221+ (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl))&
222+ where_ (notNull $ #users ! #userRowIsValidated))
160223
161224getPostsByIdQ :: [PostId] -> Maybe (Query Schema '[] (RowPG PostRowResponse))
162225getPostsByIdQ pIds = case idsToColumn pIds of
@@ -224,6 +287,23 @@ getAllChannelsForUserQ = selectStar $
224287 where_ (#namedChannelFullOwner .== param @1) &
225288 orderBy [#namedChannelFullId & Desc]
226289
290+updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]
291+updateFacultyQ = insertRow #faculties
292+ (
293+ Set (param @1) `as` #facultyName :*
294+ Set (param @2) `as` #facultyUrl :*
295+ Set (param @3) `as` #facultyPath :*
296+ Set (param @4) `as` #facultyCampusName :*
297+ Set (param @5) `as` #facultyCampusCode :*
298+ Set (param @6) `as` #facultyTags
299+ )
300+ (OnConflictDoNothing)
301+ (Returning Nil)
302+
303+getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
304+getFacultyQ = selectStar (from (table #faculties) &
305+ where_ (#facultyUrl .== param @1))
306+
227307createNamedChannelQ :: Manipulation Schema (TuplePG NamedChannelCreation) (RowPG (Only NamedChannelId))
228308createNamedChannelQ = insertRow #channels
229309 (
@@ -427,18 +507,148 @@ getGroupChatForUserQ = selectStar $
427507 where_ (#groupChatId .== param @2) &
428508 where_ (#groupChatUsers .? param @1)
429509
510+getFacultySearchResultQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)
511+getFacultySearchResultQ = selectStar (from (table #faculties) &
512+ where_ (vector @@ query) &
513+ orderBy [tsRankCd vector query & Desc])
514+ where
515+ vector = tsVector "russian" (textArrayToText [
516+ #facultyName,
517+ #facultyPath,
518+ #facultyCampusName,
519+ (arrayToText #facultyTags)])
520+ query = tsQuery (param @1)
521+
522+tsRankCd
523+ :: Expression schema from grouping params ('NotNull 'PGtext)
524+ -> Expression schema from grouping params ('NotNull 'PGtext)
525+ -> Expression schema from grouping params ('NotNull 'PGfloat4)
526+tsRankCd vector query = UnsafeExpression $
527+ "ts_rank_cd" <> parenthesized (commaSeparated . map renderExpression $ [vector, query])
528+
529+tsVector
530+ :: ByteString -- ^ Language
531+ -> Expression schema from grouping params ('NotNull 'PGtext)
532+ -> Expression schema from grouping params ('NotNull 'PGtext)
533+tsVector lang x = UnsafeExpression $
534+ "to_tsvector" <> parenthesized (commaSeparated [singleQuotedUtf8 lang, renderExpression x])
535+
536+tsQuery
537+ :: Expression schema from grouping params ('NotNull 'PGtext)
538+ -> Expression schema from grouping params ('NotNull 'PGtext)
539+tsQuery = unsafeFunction "to_tsquery"
540+
541+arrayToText
542+ :: Expression schema from grouping params ('NotNull ('PGvararray ('NotNull 'PGtext)))
543+ -> Expression schema from grouping params ('NotNull 'PGtext)
544+arrayToText x = UnsafeExpression $
545+ "array_to_string" <> parenthesized (commaSeparated [renderExpression x, "' '"])
546+
547+(@@)
548+ :: Expression schema from grouping params (nullity0 'PGtext)
549+ -> Expression schema from grouping params (nullity1 'PGtext)
550+ -> Expression schema from grouping params (nullity2 'PGbool)
551+(@@) = unsafeBinaryOp "@@"
552+
553+space :: Expression schema from grouping params ('NotNull 'PGtext)
554+space = UnsafeExpression "' '"
555+
556+textArrayToText
557+ :: [Expression schema from grouping params ('NotNull 'PGtext)]
558+ -> Expression schema from grouping params ('NotNull 'PGtext)
559+textArrayToText = fold . L.intersperse space
560+
561+createUserQ :: Manipulation Schema (TuplePG UserCreation) (RowPG (Only UserId))
562+createUserQ = insertRow #users (
563+ Default `as` #userRowId :*
564+ Set (param @1) `as` #userRowFirstName :*
565+ Set (param @2) `as` #userRowMiddleName :*
566+ Set (param @3) `as` #userRowLastName :*
567+ Set (param @4) `as` #userRowFacultyUrl :*
568+ Set (param @5) `as` #userRowEmail :*
569+ Set false `as` #userRowIsValidated)
570+ OnConflictDoRaise
571+ (Returning (#userRowId `as` #fromOnly))
572+
573+removeUnverifiedUserQ :: Manipulation Schema (TuplePG (Only UserEmail)) '[]
574+removeUnverifiedUserQ = deleteFrom_ #users
575+ (#userRowEmail .== param @1 .&&
576+ (not_ . notNull $ #userRowIsValidated))
577+
578+
579+createTokenQ :: Manipulation Schema (TuplePG Token) '[]
580+createTokenQ = insertRow_ #tokens (
581+ Set (param @1) `as` #tokenUserId :*
582+ Set (param @2) `as` #tokenValue :*
583+ Set (param @3) `as` #tokenExpiryDate :*
584+ Set (param @4) `as` #tokenVerificationCode :*
585+ Set (param @5) `as` #tokenActivationTriesLeft
586+ )
587+
588+updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
589+updateTokenQ = update_ #tokens (
590+ Same `as` #tokenUserId :*
591+ Same `as` #tokenValue :*
592+ Same `as` #tokenExpiryDate :*
593+ Set (param @4) `as` #tokenVerificationCode :*
594+ Set (param @5) `as` #tokenActivationTriesLeft)
595+ (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
596+
597+deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
598+deleteTokenQ = deleteFrom_ #tokens
599+ (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
600+
601+validateUserQ :: Manipulation Schema (TuplePG (Only UserId)) '[]
602+validateUserQ = update_ #users (
603+ Same `as` #userRowId :*
604+ Same `as` #userRowFirstName :*
605+ Same `as` #userRowMiddleName :*
606+ Same `as` #userRowLastName :*
607+ Same `as` #userRowFacultyUrl :*
608+ Same `as` #userRowEmail :*
609+ Set true `as` #userRowIsValidated)
610+ (#userRowId .== param @1)
611+
612+getTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
613+getTokenQ = selectStar (from (table #tokens) &
614+ where_ (#tokenUserId .== param @1 .&&
615+ #tokenValue .== param @2))
616+
617+getVerifiedTokenQ :: Query Schema (TuplePG (UserId, ByteString)) (RowPG Token)
618+getVerifiedTokenQ = selectStar (from (table #tokens) &
619+ where_ (#tokenUserId .== param @1 .&&
620+ #tokenValue .== param @2 .&&
621+ isNull #tokenVerificationCode))
430622
431623-- MARK: FrontEnd Data Structures
432624
625+data UserCreation = UserCreation {
626+ userCreationFirstName :: Text,
627+ userCreationMiddleName :: Text,
628+ userCreationLastName :: Text,
629+ userCreationUserFaculty :: FacultyUrl,
630+ userCreationUserEmail :: Text
631+} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
632+
633+instance ToJSON UserCreation where
634+ toJSON (UserCreation fName mName lName faculty email) = object [
635+ "firstName" .= fName,
636+ "middleName" .= mName,
637+ "lastName" .= lName,
638+ "faculty" .= faculty,
639+ "email" .= email
640+ ]
641+
642+instance FromJSON UserCreation where
643+ parseJSON = withObject "named channel" $ \e ->
644+ UserCreation <$> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
645+
433646data NamedChannelCreation = NamedChannelCreation {
434647 namedChannelCreationOwner :: UserId,
435648 namedChannelCreationName :: Text,
436649 namedChannelCreationTags :: Vector Text,
437650 namedChannelCreationPeopleIds :: Vector UserId
438−} deriving GHC.Generic
439−
440−instance SOP.Generic NamedChannelCreation
441−instance SOP.HasDatatypeInfo NamedChannelCreation
651+} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
442652
443653addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation
444654addUserToChannelCreate uId (NamedChannelCreationRequest cName cTags cPeople) = NamedChannelCreation uId cName cTags cPeople
@@ -487,7 +697,12 @@ deleteGroupChat gId = do
487697 deleteGroupChatMessagesQ = deleteFrom_ #messages
488698 (#messageStorageDestinationGroupId .== param @1)
489699
490−
700+-- NOTE: Not transactional
701+createUser :: UserCreation -> StaticPQ UserId
702+createUser creation = do
703+ _ <- manipulateParams removeUnverifiedUserQ (Only $ userCreationUserEmail creation)
704+ rowThing <- manipulateParams createUserQ creation >>= firstRow >>= fromMaybe500
705+ return (fromOnly rowThing)
491706
492707-- MARK: FrontEnd functions
493708
@@ -519,14 +734,14 @@ getLastPosts pId lim dir = do
519734 postRows <- runQueryParams (getLastPostsQ id lim dir) (Only pId) >>= getRows
520735 rowsToPosts postRows `liftMaybe` wrapIntoResponse
521736
522−getUser :: UserId -> StaticPQ User
523−getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0
737+getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))
738+getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow
524739
525−getUsers :: [UserId] -> StaticPQ (Maybe [User])
526−getUsers ids = getUsersQ ids `liftMaybe` (fmap Just . (runQuery >=> getRows))
740+getUsers :: [UserId] -> StaticPQ (Maybe [User Faculty])
741+getUsers ids = getUsersQ ids `liftMaybe` (fmap (Just . map rowToUser) . (runQuery >=> getRows))
527742
528−getAllUsers :: StaticPQ [User]
529−getAllUsers = runQuery getAllUsersQ >>= getRows
743+getAllUsers :: StaticPQ [User Faculty]
744+getAllUsers = fmap rowToUser <$> (runQuery getAllUsersQ >>= getRows)
530745
531746publishPost :: UserId -> PostCreation -> StaticPQ PostId
532747publishPost uId pc = commitedTransactionallyUpdate $ do
@@ -550,6 +765,12 @@ updateChannel uId req = commitedTransactionallyUpdate $ do
550765 _ <- manipulateParams updateNamedChannelQ $ addUserToChannelUpdate uId (req {namedChannelPeopleIds = uIds})
551766 return ()
552767
768+getFaculty :: Text -> StaticPQ Faculty
769+getFaculty t = runQueryParams getFacultyQ (Only t) >>= firstRow >>= fromMaybe404
770+
771+updateFaculty :: Faculty -> StaticPQ ()
772+updateFaculty fac = void $ manipulateParams updateFacultyQ fac
773+
553774getChannelPosts
554775 :: UserId
555776 -> Maybe PostId
@@ -668,8 +889,79 @@ getGroupChatForUser uId gId = do
668889 (Just c) -> return c
669890 Nothing -> lift $ S.throwError S.err404
670891
892+getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]
893+getFacultyFromQuery query =
894+ runQueryParams getFacultySearchResultQ (Only . queryFromText $ query) >>= getRows
895+
896+createToken :: Token -> StaticPQ ()
897+createToken token = void $ manipulateParams createTokenQ token
898+
899+validateToken :: Token -> StaticPQ ()
900+validateToken token = commitedTransactionallyUpdate $ do
901+ void $ manipulateParams updateTokenQ token{tokenVerificationCode = Nothing}
902+ void $ manipulateParams validateUserQ $ Only $ tokenUserId token
903+
904+invalidateToken :: UserId -> ByteString -> StaticPQ ()
905+invalidateToken uId bs = void . manipulateParams deleteTokenQ $ (uId, bs)
906+
907+tryVerifyToken :: UserId -> ByteString -> Int32 -> StaticPQ (Maybe Token)
908+tryVerifyToken uId tokenData code = commitedTransactionallyUpdate $ do
909+ token' <- runQueryParams getTokenQ (uId, tokenData) >>= firstRow
910+ case token' of
911+ Nothing -> return Nothing
912+ Just token -> do
913+ if (tokenVerificationCode token == Just code)
914+ then validateToken token >> (return $ Just token)
915+ else do
916+ let triesLeft = tokenActivationTriesLeft token - 1
917+ if triesLeft <= 0
918+ then invalidateToken (tokenUserId token) (tokenValue token) >> return Nothing
919+ else do
920+ let newToken = token{tokenActivationTriesLeft = triesLeft}
921+ _ <- manipulateParams updateTokenQ newToken
922+ return Nothing
923+
924+getVerifiedToken :: UserId -> ByteString -> StaticPQ (Maybe Token)
925+getVerifiedToken uId tokenData = runQueryParams getVerifiedTokenQ (uId, tokenData) >>= firstRow
926+
671927-- MARK: Utils
672928
929+data UserRow = UserRow {
930+ userRowId :: UserId,
931+ userRowFirstName :: Text,
932+ userRowMiddleName :: Text,
933+ userRowLastName :: Text,
934+ userRowFacultyUrl :: FacultyUrl,
935+ userRowEmail :: Text,
936+ userRowIsValidated :: Bool,
937+ userRowFacultyName :: T.Text,
938+ userRowFacultyURL :: FacultyUrl,
939+ userRowFacultyPath :: T.Text,
940+ userRowFacultyCampusName :: T.Text,
941+ userRowFacultyCampusCode :: T.Text,
942+ userRowFacultyTags :: V.Vector T.Text
943+} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
944+
945+rowToUser :: UserRow -> User Faculty
946+rowToUser UserRow{..} = User {
947+ userId = userRowId,
948+ firstName = userRowFirstName,
949+ middleName = userRowMiddleName,
950+ lastName = userRowLastName,
951+ userFaculty = Faculty {
952+ facultyName = userRowFacultyName,
953+ facultyUrl = userRowFacultyURL,
954+ facultyPath = userRowFacultyPath,
955+ facultyCampusName = userRowFacultyCampusName,
956+ facultyCampusCode = userRowFacultyCampusCode,
957+ facultyTags = userRowFacultyTags
958+ },
959+ userEmail = userRowEmail
960+ }
961+
962+queryFromText :: Text -> Text
963+queryFromText = T.unwords . L.intersperse "&" . map (`T.append` ":*") . filter (not . T.null) . T.split (not . isAlphaNum)
964+
673965directionToOperator
674966 :: P.PaginationDirection
675967 -> (ConditionOp schema0 from0 grouping0 params0 nullity0 nullity1 (ty :: PGType),
@@ -700,7 +992,7 @@ unsafeIntToExpr = UnsafeExpression . pack . show
700992
701993data ResponseWithUsers r = ResponseWithUsers {
702994 response :: r,
703− users :: M.Map UserId User
995+ users :: M.Map UserId (User Faculty)
704996} deriving (Generic)
705997
706998instance (ToJSON r) => ToJSON (ResponseWithUsers r)
@@ -742,5 +1034,9 @@ liftMaybe Nothing _ = pure Nothing
7421034liftMaybe (Just a) f = f a
7431035
7441036fromMaybe500 :: Maybe a -> StaticPQ a
745−fromMaybe500 Nothing = lift $ S.throwError S.err404
746−fromMaybe500 (Just a) = return a
1037+fromMaybe500 Nothing = lift $ S.throwError S.err500
1038+fromMaybe500 (Just a) = return a
1039+
1040+fromMaybe404 :: Maybe a -> StaticPQ a
1041+fromMaybe404 Nothing = lift $ S.throwError S.err404
1042+fromMaybe404 (Just a) = return a
denis/src/Data/Schema.hs+72−23
@@ -21,17 +21,32 @@ import Data.Message
2121
2222type Schema =
2323 '[
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+ ]),
2434 "users" ::: 'Table ( '[
25− "pk_users" ::: 'PrimaryKey '["userId"]] :=>
35+ "pk_users" ::: 'PrimaryKey '["userRowId"],
36+ "user_email" ::: 'Unique '["userRowEmail"],
37+ "fk_user_faculty" ::: 'ForeignKey '["userRowFacultyUrl"] "faculties" '["facultyUrl"]] :=>
2638 '[
27− "userId" ::: 'Def :=> 'NotNull 'PGint8,
28− "firstName" ::: 'NoDef :=> 'NotNull 'PGtext,
29− "middleName" ::: 'NoDef :=> 'NotNull 'PGtext,
30− "lastName" ::: 'NoDef :=> 'NotNull 'PGtext
39+ "userRowId" ::: 'Def :=> 'NotNull 'PGint8,
40+ "userRowFirstName" ::: 'NoDef :=> 'NotNull 'PGtext,
41+ "userRowMiddleName" ::: 'NoDef :=> 'NotNull 'PGtext,
42+ "userRowLastName" ::: 'NoDef :=> 'NotNull 'PGtext,
43+ "userRowFacultyUrl" ::: 'NoDef :=> 'NotNull 'PGtext,
44+ "userRowEmail" ::: 'NoDef :=> 'NotNull 'PGtext,
45+ "userRowIsValidated" ::: 'NoDef :=> 'NotNull 'PGbool
3146 ]),
3247 "posts" ::: 'Table ( '[
3348 "pk_posts" ::: 'PrimaryKey '["postRowId"],
34− "fk_author_id" ::: 'ForeignKey '["postRowAuthorId"] "users" '["userId"]] :=>
49+ "fk_author_id" ::: 'ForeignKey '["postRowAuthorId"] "users" '["userRowId"]] :=>
3550 '[
3651 "postRowId" ::: 'Def :=> 'NotNull 'PGint8,
3752 "postRowAuthorId" ::: 'NoDef :=> 'NotNull 'PGint8,
@@ -81,7 +96,7 @@ type Schema =
8196 "channels" ::: 'Table (
8297 '[
8398 "pk_channels" ::: 'PrimaryKey '["namedChannelFullId"],
84− "fk_channels_users_id" ::: 'ForeignKey '["namedChannelFullOwner"] "users" '["userId"]
99+ "fk_channels_users_id" ::: 'ForeignKey '["namedChannelFullOwner"] "users" '["userRowId"]
85100 ] :=>
86101 '[
87102 "namedChannelFullId" ::: 'Def :=> 'NotNull 'PGint8,
@@ -102,8 +117,8 @@ type Schema =
102117 -- "userMessages" ::: 'Table (
103118 -- '[
104119 -- "pk_user_messages" ::: 'PrimaryKey '["userMessageId"],
105− -- "fk_user_messages_from" ::: 'ForeignKey '["userMessageFrom"] "users" '["userId"],
106− -- "fk_user_messages_to" ::: 'ForeignKey '["userMessageTo"] "users" '["userId"]
120+ -- "fk_user_messages_from" ::: 'ForeignKey '["userMessageFrom"] "users" '["userRowId"],
121+ -- "fk_user_messages_to" ::: 'ForeignKey '["userMessageTo"] "users" '["userRowId"]
107122
108123 -- ] :=>
109124 -- '[
@@ -117,7 +132,7 @@ type Schema =
117132 -- '[
118133 -- "pk_group_messages" ::: 'PrimaryKey '["groupChatMessageId"],
119134 -- "fk_group_messages_group" ::: 'ForeignKey '["groupChatMessageGroupChatId"] "groupChats" '["groupChatId"],
120− -- "fk_group_messages_author" ::: 'ForeignKey '["groupChatMessageAuthorId"] "users" '["userId"]
135+ -- "fk_group_messages_author" ::: 'ForeignKey '["groupChatMessageAuthorId"] "users" '["userRowId"]
121136 -- ] :=>
122137 -- '[
123138 -- "groupChatMessageId" ::: 'Def :=> 'NotNull 'PGint8,
@@ -129,9 +144,9 @@ type Schema =
129144 "messages" ::: 'Table (
130145 '[
131146 "pk_messages" ::: 'PrimaryKey '["messageStorageId"],
132− "fk_messages_author" ::: 'ForeignKey '["messageStorageAuthorId"] "users" '["userId"],
147+ "fk_messages_author" ::: 'ForeignKey '["messageStorageAuthorId"] "users" '["userRowId"],
133148 "fk_messages_group" ::: 'ForeignKey '["messageStorageDestinationGroupId"] "groupChats" '["groupChatId"],
134− "fk_messages_to_user" ::: 'ForeignKey '["messageStorageDestinationUserId"] "users" '["userId"]
149+ "fk_messages_to_user" ::: 'ForeignKey '["messageStorageDestinationUserId"] "users" '["userRowId"]
135150 ] :=>
136151 '[
137152 "messageStorageId" ::: 'Def :=> 'NotNull 'PGint8,
@@ -140,6 +155,18 @@ type Schema =
140155 "messageStorageDestinationUserId" ::: 'NoDef :=> 'Null 'PGint8,
141156 "messageStorageBody" ::: 'NoDef :=> 'NotNull (PG (Jsonb (PostElement Message))),
142157 "messageStorageTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz
158+ ]),
159+ "tokens" ::: 'Table (
160+ '[
161+ -- "pk_token" ::: 'PrimaryKey '["tokenValue"],
162+ "fk_user_token" ::: 'ForeignKey '["tokenUserId"] "users" '["userRowId"]
163+ ] :=>
164+ '[
165+ "tokenUserId" ::: 'NoDef :=> 'NotNull 'PGint8,
166+ "tokenValue" ::: 'NoDef :=> 'NotNull 'PGbytea,
167+ "tokenExpiryDate" ::: 'NoDef :=> 'NotNull 'PGtimestamptz,
168+ "tokenVerificationCode" ::: 'NoDef :=> 'Null 'PGint4, -- null == verified
169+ "tokenActivationTriesLeft" ::: 'NoDef :=> 'NotNull 'PGint4
143170 ])
144171
145172 -- "postsView" ::: 'View (RowPG PostRowResponse)
@@ -159,13 +186,27 @@ type Schema =
159186
160187
161188createTables :: Definition '[] Schema
162−createTables = createTable #users (
163− serial8 `as` #userId :*
164− notNullable text `as` #firstName :*
165− notNullable text `as` #middleName :*
166− notNullable text `as` #lastName
189+createTables = createTable #faculties (
190+ notNullable text `as` #facultyName :*
191+ notNullable text `as` #facultyUrl :*
192+ notNullable text `as` #facultyPath :*
193+ notNullable text `as` #facultyCampusName :*
194+ notNullable text `as` #facultyCampusCode :*
195+ notNullable (vararray text) `as` #facultyTags
167196 ) (
168− primaryKey #userId `as` #pk_users
197+ primaryKey #facultyUrl `as` #pk_faculties
198+ ) >>> createTable #users (
199+ serial8 `as` #userRowId :*
200+ notNullable text `as` #userRowFirstName :*
201+ notNullable text `as` #userRowMiddleName :*
202+ notNullable text `as` #userRowLastName :*
203+ notNullable text `as` #userRowFacultyUrl :*
204+ notNullable text `as` #userRowEmail :*
205+ notNullable bool `as` #userRowIsValidated
206+ ) (
207+ primaryKey #userRowId `as` #pk_users :*
208+ unique #userRowEmail `as` #user_email :*
209+ foreignKey #userRowFacultyUrl #faculties #facultyUrl OnDeleteCascade OnUpdateCascade `as` #fk_user_faculty
169210 ) >>> createTable #posts (
170211 serial8 `as` #postRowId :*
171212 notNullable int8 `as` #postRowAuthorId :*
@@ -173,7 +214,7 @@ createTables = createTable #users (
173214 notNullable (vararray text) `as` #postRowTags
174215 ) (
175216 primaryKey #postRowId `as` #pk_posts :*
176− foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_author_id
217+ foreignKey #postRowAuthorId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_author_id
177218 ) >>> createTable #quotes (
178219 serial8 `as` #quoteRowId :*
179220 notNullable int8 `as` #quoteRowPostId
@@ -210,7 +251,7 @@ createTables = createTable #users (
210251 notNullable (vararray int8) `as` #namedChannelFullPeopleIds
211252 ) (
212253 primaryKey #namedChannelFullId `as` #pk_channels :*
213− foreignKey #namedChannelFullOwner #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_channels_users_id
254+ foreignKey #namedChannelFullOwner #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_channels_users_id
214255 -- ) >>> createView #postsView (select (
215256 -- #posts ! #postRowId :*
216257 -- #posts ! #postRowAuthorId :*
@@ -240,9 +281,17 @@ createTables = createTable #users (
240281 notNullable timestampWithTimeZone `as` #messageStorageTime
241282 ) (
242283 primaryKey #messageStorageId `as` #pk_messages :*
243− foreignKey #messageStorageAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_messages_author :*
284+ foreignKey #messageStorageAuthorId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_messages_author :*
244285 foreignKey #messageStorageDestinationGroupId #groupChats #groupChatId OnDeleteCascade OnUpdateCascade `as` #fk_messages_group :*
245− foreignKey #messageStorageDestinationUserId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_messages_to_user
286+ foreignKey #messageStorageDestinationUserId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_messages_to_user
287+ ) >>> createTable #tokens (
288+ notNullable int8 `as` #tokenUserId :*
289+ notNullable bytea `as` #tokenValue :*
290+ notNullable timestampWithTimeZone `as` #tokenExpiryDate :*
291+ nullable int4 `as` #tokenVerificationCode :*
292+ notNullable int4 `as` #tokenActivationTriesLeft
293+ ) (
294+ foreignKey #tokenUserId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_user_token
246295 )
247296-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])
248297-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $
@@ -250,4 +299,4 @@ createTables = createTable #users (
250299-- (ifThenElse (isNull #rowElementOrd) 1 0) +
251300-- (ifThenElse (isNull #rowElementOrd) 1 0) +
252301-- (ifThenElse (isNull #rowElementOrd) 1 0) +
253−-- (ifThenElse (isNull #rowElementOrd) 1 0)) .== 0
302+-- (ifThenElse (isNull #rowElementOrd) 1 0)) .== 0
denis/src/Data/User.hs+20−16
@@ -5,11 +5,13 @@
55 OverloadedStrings ,
66 TypeApplications ,
77 TypeOperators,
8− OverloadedStrings #-}
8+ OverloadedStrings,
9+ DeriveAnyClass #-}
910
1011module Data.User (
1112 User(..),
12− UserId
13+ UserId,
14+ UserEmail
1315) where
1416
1517import Data.Int (Int64)
@@ -18,35 +20,37 @@ import qualified GHC.Generics as GHC
1820import Data.Text (Text)
1921import Data.Aeson
2022import Servant.Docs (ToSample, toSamples, samples)
23+import Data.Proxy
2124
2225-- MARK: Documentation
2326
24−instance ToSample User where
25− toSamples _ = samples [User 8 "Vasya" "Pupkinovuch" "Pupkin", User 69 "Seva" "Algebrovich" "Leonidov"]
27+instance (ToSample f) => ToSample (User f) where
28+ toSamples _ = samples $ [User 8 "Vasya" "Pupkinovuch" "Pupkin", User 69 "Seva" "Algebrovich" "Leonidov"] <*> (map snd $ toSamples Proxy) <*> ["foo@hse.ru"]
2629
2730-- MARK: Implementation
2831
2932type UserId = Int64
33+type UserEmail = Text
3034
31−data User = User {
35+data User f = User {
3236 userId :: UserId,
3337 firstName :: Text,
3438 middleName :: Text,
35− lastName :: Text
36−} deriving (GHC.Generic)
39+ lastName :: Text,
40+ userFaculty :: f,
41+ userEmail :: UserEmail
42+} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
3743
38−instance SOP.Generic User
39−
40−instance SOP.HasDatatypeInfo User
41−
42−instance ToJSON User where
43− toJSON (User uId fName mName lName) = object [
44+instance (ToJSON f) => ToJSON (User f) where
45+ toJSON (User uId fName mName lName faculty email) = object [
4446 "id" .= uId,
4547 "firstName" .= fName,
4648 "middleName" .= mName,
47− "lastName" .= lName
49+ "lastName" .= lName,
50+ "faculty" .= faculty,
51+ "email" .= email
4852 ]
4953
50−instance FromJSON User where
54+instance (FromJSON f) => FromJSON (User f) where
5155 parseJSON = withObject "named channel" $ \e ->
52− User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName"
56+ User <$> e .: "id" <*> e .: "firstName" <*> e .: "middleName" <*> e .: "lastName" <*> e .: "faculty" <*> e .: "email"
denis/src/Server/API.hs+8−4
@@ -29,6 +29,8 @@ import Control.Lens
2929import Server.Query.ComplexQuery
3030import Server.API.Completions
3131import Server.API.Messages
32+import Data.Faculty
33+import Server.API.Faculty
3234
3335-- MARK: Documentation
3436
@@ -46,13 +48,14 @@ type API =
4648 "authentication" :> AuthenticationHandler :<|>
4749 Authentication :> ComplexQuery :> (
4850 "authentication" :> "me" :> Post '[JSON] UserId :<|>
49− "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>
50− "users" :> "all" :> Post '[JSON] [User] :<|>
51+ "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User Faculty] :<|>
52+ "users" :> "all" :> Post '[JSON] [User Faculty] :<|>
5153 "posts" :> PostApi :<|>
5254 "channels" :> ChannelsApi :<|>
5355 MessagesApi
5456 ) :<|>
55− "tags" :> TagsAPI
57+ "tags" :> TagsAPI :<|>
58+ "faculty" :> FacultyAPI
5659
5760serverProxy :: Proxy API
5861serverProxy = Proxy
@@ -68,4 +71,5 @@ mkServerAPI l =
6871 channelsApi uId :<|>
6972 messagesServer uId
7073 ) :<|>
71− tagsServer
74+ tagsServer :<|>
75+ facultyServer
denis/src/Server/API/Faculty.hsnew file+32
@@ -0,0 +1,32 @@
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 Data.Faculty
22+
23+type SearchDescription = Description "Returns faculties for given string"
24+
25+type FacultyAPI =
26+ "search" :> SearchDescription :> ReqBody '[PlainText, JSON] Text :> Post '[JSON] [Faculty]
27+
28+facultyServer :: ServerT FacultyAPI App
29+facultyServer = search
30+
31+search :: Text -> App [Faculty]
32+search = runQerror . getFacultyFromQuery
denis/src/Server/App.hs+21−5
@@ -4,7 +4,9 @@
44 OverloadedLabels,
55 OverloadedStrings ,
66 TypeApplications ,
7− TypeOperators #-}
7+ TypeOperators,
8+ TypeSynonymInstances,
9+ FlexibleInstances #-}
810
911module Server.App (
1012 App,
@@ -12,7 +14,8 @@ module Server.App (
1214 Config(..),
1315 ask,
1416 asks,
15− liftIO
17+ liftIO,
18+ MailConfig(..)
1619) where
1720
1821import Servant.Server
@@ -21,12 +24,25 @@ import Squeal.PostgreSQL.Pool
2124import Data.Schema
2225import Generics.SOP (K)
2326import Squeal.PostgreSQL.PQ (Connection)
24−import Control.Monad.IO.Class ()
27+import Crypto.RNG
2528
26−type App = ReaderT Config Handler
29+type App = ReaderT Config Handler
2730
2831type DBConnection = Pool (K Connection Schema)
2932
3033data Config = Config {
31− getPool :: DBConnection
34+ getPool :: !DBConnection,
35+ cryptoState :: !CryptoRNGState,
36+ -- selfRootUrl :: !String,
37+ mailConfig :: !MailConfig
3238}
39+
40+data MailConfig = MailConfig {
41+ mailHost :: !String,
42+ mailPort :: !Int,
43+ mailUser :: !String,
44+ mailPassword :: !String
45+}
46+
47+instance CryptoRNG App where
48+ randomBytes n = join $ asks (liftIO . randomBytesIO n . cryptoState)
denis/src/Server/Auth.hs+181−45
@@ -7,8 +7,10 @@
77 ScopedTypeVariables,
88 TypeFamilies,
99 TypeOperators,
10− UndecidableInstances #-}
11−
10+ UndecidableInstances,
11+ DeriveAnyClass,
12+ RecordWildCards #-}
13+{-# OPTIONS_GHC -Wno-orphans #-}
1214module Server.Auth (
1315 checkToken,
1416 cookieTokenKey,
@@ -28,7 +30,6 @@ import qualified Data.ByteString.Lazy.Char8 as L
2830import Data.Query
2931import Server.Error
3032import Control.Monad.Except
31−import Text.Read (readMaybe)
3233import Data.Connection
3334import Servant.Server.Experimental.Auth
3435import Servant.API
@@ -40,72 +41,192 @@ import Data.Time.Calendar
4041import Data.Proxy
4142import qualified GHC.Generics as GHC
4243import Data.Aeson
44+import qualified Data.Aeson as A
4345import Data.Binary.Builder (toLazyByteString)
4446import Servant.Docs (ToSample, samples, toSamples)
47+import qualified Data.Text as T
48+import qualified Data.Text.Encoding as T
49+import Text.Regex
50+import qualified Data.ByteString.Base64 as BS
51+import Data.Maybe
52+import Server.Auth.Token
53+import Server.Auth.Mail
54+import Data.Int
4555
4656-- MARK: Documentation
4757
4858instance ToSample AuthenticationCredits where
49− toSamples _ = samples $ map AuthenticationCredits [56, 103, 8]
59+ toSamples _ = samples $ map AuthenticationCredits ["vchernyshev@hse.ru", "iikostyuchenko@hse.ru"]
60+
61+instance ToSample UserLoginResponse where
62+ toSamples _ = samples $ map UserLoginResponse [UserIsRegistered, UserCanRegister, InvalidUser]
63+
64+instance ToSample Int32 where
65+ toSamples _ = samples [382934, 103845, 294905]
66+
67+instance ToSample UserCreation where
68+ toSamples _ = samples $ [UserCreation "Seva" "Algebrovich" "Leonidov" "cs.hse.ru/dse" "vchernyshev@hse.ru"]
69+
70+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."
71+
72+type LogoutDescription = Description "Log out with the given cookie"
73+
74+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\n"
75+
76+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`."
5077
5178-- MARK: Implementation
5279
5380type AuthenticationHandler =
54− "login" :>
81+ "login" :> LoginDescription :>
5582 ReqBody '[JSON] AuthenticationCredits :>
56− Post '[JSON] (Headers '[Header "Set-Cookie" String] UserId) :<|>
57− "logout" :>
58− PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
59−
60−newtype AuthenticationCredits = AuthenticationCredits {authenticationId :: UserId}
61− deriving GHC.Generic
62−
63−instance ToJSON AuthenticationCredits
64−instance FromJSON AuthenticationCredits
83+ Post '[JSON] (Headers '[Header "Set-Cookie" String] UserLoginResponse) :<|>
84+ "logout" :> LogoutDescription
85+ :> Header "cookie" String
86+ :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent) :<|>
87+ "verify" :> VerifyDescription :>
88+ Header "cookie" String :> ReqBody '[JSON] Int32 :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
89+ "register" :> RegisterDescription :>
90+ ReqBody '[JSON] UserCreation :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
91+
92+data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser
93+ deriving (Show)
94+
95+instance ToJSON UserResponseStatus where
96+ toJSON UserIsRegistered = "registered"
97+ toJSON UserCanRegister = "canRegister"
98+ toJSON InvalidUser = "invalid"
99+
100+data UserLoginResponse = UserLoginResponse {
101+ userStatus :: UserResponseStatus
102+} deriving (Show, GHC.Generic, ToJSON)
103+
104+data AuthenticationCookieData = AuthenticationCookieData {
105+ cookieUserId :: UserId,
106+ cookieUserToken :: BS.ByteString
107+} deriving (Show, GHC.Generic, ToJSON, FromJSON)
108+
109+instance ToJSON BS.ByteString where
110+ toJSON = A.String . T.decodeUtf8 . BS.encode
111+
112+instance FromJSON BS.ByteString where
113+ parseJSON (A.String s) = case (BS.decode . T.encodeUtf8) s of
114+ Left e -> fail e
115+ Right v -> return v
116+ parseJSON _ = fail "Couldn't deserialise ByteString"
117+
118+newtype AuthenticationCredits = AuthenticationCredits {authenticationEmail :: UserEmail}
119+ deriving (GHC.Generic, ToJSON, FromJSON)
65120
66121authenticationAPI :: ServerT AuthenticationHandler App
67−authenticationAPI = logIn :<|> logOut
68−
69−logIn :: AuthenticationCredits -> App (Headers '[Header "Set-Cookie" String] UserId)
70−logIn (AuthenticationCredits uId) = do
71− expire <- liftIO $ fmap (addUTCTime (1 * 24 * 60 * 60)) getCurrentTime -- one days
72− tId <- fmap userId . runQ err404 . getUser $ uId
73− let cookie = defaultSetCookie {
74− setCookieName = cookieTokenKey,
75− setCookieValue = C.pack $ show tId,
76− setCookieExpires = Just expire,
77− setCookiePath = Just "/",
78− setCookieHttpOnly = True,
79− setCookieSecure = True }
80− return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) tId
81−
82−logOut :: App (Headers '[Header "Set-Cookie" String] NoContent)
83−logOut =
84− let cookie = defaultSetCookie {
122+authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register
123+
124+logIn :: AuthenticationCredits -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
125+logIn (AuthenticationCredits email') = do
126+ let email = T.toLower . T.strip $ email'
127+ if (not . validateEmail) email
128+ then return . noHeader $ UserLoginResponse InvalidUser
129+ else do
130+ user <- runQerror $ getUserWithEmail email
131+ case user of
132+ Nothing -> return . noHeader $ UserLoginResponse UserCanRegister
133+ Just User{..} -> do
134+ token <- generateToken userId
135+ runQerror . createToken $ token
136+ let cookie = generateCookie token
137+ case tokenVerificationCode token of
138+ Just code -> do
139+ sendTokenVerificationEmail code email
140+ return . addHeader cookie $ UserLoginResponse UserIsRegistered
141+ Nothing -> throwError err500
142+
143+generateCookie :: Token -> String
144+generateCookie token = L.unpack . toLazyByteString . renderSetCookie $ defaultSetCookie {
145+ setCookieName = cookieTokenKey,
146+ setCookieValue = L.toStrict . encode $ AuthenticationCookieData
147+ (tokenUserId token)
148+ (tokenValue token),
149+ setCookieExpires = Just (tokenExpiryDate token),
150+ setCookiePath = Just "/",
151+ setCookieHttpOnly = True,
152+ setCookieSecure = True }
153+
154+
155+verifyToken :: Maybe String -> Int32 -> App NoContent
156+verifyToken Nothing _ = throwError err400
157+verifyToken (Just cookie) code = do
158+ let mbToken = (>>= (decode . L.fromStrict)) . lookup cookieTokenKey . parseCookies . C.pack $ cookie
159+ case mbToken of
160+ Nothing -> throwError err400
161+ (Just (AuthenticationCookieData uId tokenData)) -> do
162+ _ <- runQ invalidToken $ tryVerifyToken uId tokenData code
163+ return NoContent
164+
165+logOut :: Maybe String -> App (Headers '[Header "Set-Cookie" String] NoContent)
166+logOut cookie' = do
167+ _ <- fromMaybe (return ()) $ do
168+ cookie <- cookie'
169+ AuthenticationCookieData uId tokenData <- (lookup cookieTokenKey . parseCookies . C.pack $ cookie) >>= (decode . L.fromStrict)
170+ return . runQsilent $ invalidateToken uId tokenData
171+ let newCookie = defaultSetCookie {
85172 setCookieName = cookieTokenKey,
86173 setCookieValue = "invalid",
87174 setCookieExpires = Just (UTCTime (ModifiedJulianDay 0) 0),
88175 setCookiePath = Just "/" }
89− in return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) NoContent
176+ return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ newCookie) NoContent
90177
91−checkToken :: DBConnection -> BS.ByteString -> Handler UserId
92−checkToken conn token = do
93− uId <- case ((readMaybe . C.unpack) token :: Maybe UserId) of
94− Just uId -> return uId
178+checkToken :: DBConnection -> AuthenticationCookieData -> Handler UserId
179+checkToken conn (AuthenticationCookieData uId tokenData) = do
180+ token <- runQ' conn err500 $ getVerifiedToken uId tokenData
181+ case token of
95182 Nothing -> throwError invalidToken
96− fmap userId . runQ' conn invalidToken . getUser $ uId
183+ Just (Token newUId _ _ _ _) -> return newUId
184+
185+register :: UserCreation -> App (Headers '[Header "Set-Cookie" String] NoContent)
186+register creation' = do
187+ let creation = normalizaUser creation'
188+ unless (validateUser creation) $ throwError err400
189+ genToken <- generateTokenM
190+ token <- runQ err409 . commitedTransactionallyUpdate $ do
191+ uId <- createUser creation
192+ let token = genToken uId
193+ createToken token
194+ return token
195+ let cookie = generateCookie token
196+ return $ addHeader cookie NoContent
197+
198+normalizaUser :: UserCreation -> UserCreation
199+normalizaUser (UserCreation fName mName lName faculty email) =
200+ UserCreation
201+ (T.strip fName)
202+ (T.strip mName)
203+ (T.strip lName)
204+ (T.strip faculty)
205+ (T.toLower . T.strip $ email)
206+
207+validateUser :: UserCreation -> Bool
208+validateUser (UserCreation fName mName lName faculty email) =
209+ (not . T.null) fName &&
210+ (not . T.null) mName &&
211+ (not . T.null) lName &&
212+ (not . T.null) faculty &&
213+ validateEmail email
97214
98215authHandler :: DBConnection -> AuthHandler Request UserId
99216authHandler conn = mkAuthHandler handler
100217 where
101− maybeToEither = maybe (Left ()) Right
102− throw = const $ throwError invalidToken
103− handler req = either throw (checkToken conn) $ do
104− cookie <- maybeToEither $ lookup "cookie" $ requestHeaders req
105− maybeToEither $ lookup cookieTokenKey $ parseCookies cookie
218+ handler req = do
219+ let cookie' = lookup "cookie" $ requestHeaders req
220+ case cookie' of
221+ Nothing -> throwError (invalidToken)
222+ (Just cookie) -> do
223+ let mbToken = (>>= (decode . L.fromStrict)) . lookup cookieTokenKey $ parseCookies cookie
224+ case mbToken of
225+ Nothing -> throwError invalidToken
226+ Just t -> checkToken conn t
106227
107228cookieTokenKey :: BS.ByteString
108−cookieTokenKey = "servant-auth-cookie"
229+cookieTokenKey = "valera-denis-auth-cookie"
109230
110231type instance AuthServerData (AuthProtect "basicAuth") = UserId
111232
@@ -113,4 +234,19 @@ genAuthServerContext :: DBConnection -> Context (AuthHandler Request UserId ': '
113234genAuthServerContext conn = authHandler conn :. EmptyContext
114235
115236contextProxy :: Proxy '[AuthHandler Request UserId]
116−contextProxy = Proxy
237+contextProxy = Proxy
238+
239+validateEmail :: T.Text -> Bool
240+validateEmail "ilyakooo0@gmail.com" = True
241+validateEmail "rednikina.com@yandex.ru" = True
242+validateEmail "admikhaleva@edu.hse.ru" = True
243+validateEmail e = (isJust . matchRegex regex . T.unpack $ e) || (isJust . matchRegex falseRegex . T.unpack $ e)
244+ where
245+ regex = mkRegexWithOpts
246+ "^[A-Z0-9a-z._%-]+@hse\\.ru$"
247+ False
248+ False
249+ falseRegex = mkRegexWithOpts
250+ "^[A-Z0-9a-z._%-+]+@edu.hse\\.ru$"
251+ False
252+ False
denis/src/Server/Auth/Mail.hsnew file+39
@@ -0,0 +1,39 @@
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.Mail (
15+ sendTokenVerificationEmail
16+ ) where
17+
18+import Network.Mail.SMTP
19+import Server.App
20+import Server.Auth.Token
21+import Control.Monad.IO.Class
22+import Network.Mail.Mime (Mail)
23+import Data.Text (Text, pack)
24+import Data.Text.Lazy (fromStrict)
25+
26+sendTokenVerificationEmail :: TokenVerificationCode -> Text -> App ()
27+sendTokenVerificationEmail code email = do
28+ mailCfg <- mailConfig <$> ask
29+ let mail = simpleMail
30+ (Address (Just "HSE Social Network") "noreply@hse.ru")
31+ [Address Nothing email] [] []
32+ "HSE Social Network Verification Code"
33+ [plainTextPart . fromStrict . pack . show $ code]
34+ sendMailWithConfig mailCfg mail
35+ -- sendMailWithLogin' "smtp.sendgrid.net" 25 "apikey" "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" (simpleMail (Address (Just "HSE") "foo@hse.ru") [(Address (Just "YOU") "iikostyuchenko@edu.hse.ru")] [] [] "HI" [plainTextPart "HELLO\n\nsosi"])
36+
37+sendMailWithConfig :: (MonadIO m) => MailConfig -> Mail -> m ()
38+sendMailWithConfig (MailConfig host port user pass) =
39+ liftIO . sendMailWithLogin' host (fromIntegral port) user pass
denis/src/Server/Auth/Token.hsnew file+48
@@ -0,0 +1,48 @@
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+ ) where
18+
19+import Data.Time.Clock
20+import Data.ByteString
21+import Data.User
22+import qualified Generics.SOP as SOP
23+import qualified GHC.Generics as GHC
24+import Data.Int
25+import Control.Monad.IO.Class
26+import Crypto.RNG
27+
28+type TokenVerificationCode = Int32
29+
30+data Token = Token {
31+ tokenUserId :: UserId,
32+ tokenValue :: ByteString,
33+ tokenExpiryDate :: UTCTime,
34+ tokenVerificationCode :: Maybe TokenVerificationCode,
35+ tokenActivationTriesLeft :: Int32
36+} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
37+
38+generateToken :: (MonadIO m, CryptoRNG m) => UserId -> m Token
39+generateToken uId = do
40+ gen <- generateTokenM
41+ return $ gen uId
42+
43+generateTokenM :: (MonadIO m, CryptoRNG m) => m (UserId -> Token)
44+generateTokenM = do
45+ token <- randomBytes 64
46+ code <- randomR (0, 999999)
47+ expire <- liftIO $ fmap (addUTCTime (nominalDay * 365)) getCurrentTime -- one year
48+ return $ \ uId -> Token uId token expire (Just code) 10
denis/src/Server/Server.hs+26−6
@@ -15,30 +15,45 @@ import Squeal.PostgreSQL.Pool
1515import Data.Maybe
1616import Control.Monad.Reader
1717import Network.Wai.Handler.Warp
18−import Network.HTTP.Types.Method
18+import Network.HTTP.Types.Method
1919import Server.Logger
20−
20+import Control.Concurrent
21+import Data.Faculty.Parser
22+import Data.Connection
23+import Data.Query
24+import Crypto.RNG
2125import Network.Wai.Middleware.Cors
2226
23−
2427getDBString :: IO B.ByteString
2528getDBString = do
2629 mDatabaseURL <- lookupEnv "DATABASE_URL"
2730 return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL
2831
32+getMailConfig :: IO MailConfig
33+getMailConfig = do
34+ (Just host) <- lookupEnv "MAIL_HOST"
35+ port <- (fromMaybe 25 . fmap read) <$> lookupEnv "MAIL_PORT"
36+ (Just user) <- lookupEnv "MAIL_USER"
37+ (Just pass) <- lookupEnv "MAIL_PASS"
38+ return $ MailConfig host port user pass
39+
2940getServerPort :: IO Int
30−getServerPort = maybe 2000 read <$> lookupEnv "PORT"
41+getServerPort = maybe 2000 read <$> lookupEnv "PORT"
3142
3243getConfig :: IO Config
3344getConfig = do
3445 databaseURL <- getDBString
3546 conn <- createConnectionPool databaseURL 3 0.5 10
36− return $ Config conn
47+ crypto <- newCryptoRNGState
48+ -- (Jusr selfRoot) <- lookupEnv "SELF_ROOT_URL"
49+ mail <- getMailConfig
50+ return $ Config conn crypto mail
3751
3852runServer :: IO ()
3953runServer = do
4054 port <- getServerPort
4155 cfg <- getConfig
56+ void . forkIO $ updateFaculties cfg
4257 let ctx = genAuthServerContext $ getPool cfg
4358 (middleLogger, logger) <- mkLogger 100
4459 let serverAPI = mkServerAPI logger
@@ -58,4 +73,9 @@ policy = CorsResourcePolicy {
5873}
5974
6075settings :: Int -> Settings
61−settings port = setPort port . setServerName "Denis" $ defaultSettings
76+settings port = setPort port . setServerName "Denis" $ defaultSettings
77+
78+updateFaculties :: Config -> IO ()
79+updateFaculties cfg = do
80+ fs <- getFaculties
81+ forM_ fs (runHandler . flip runReaderT cfg . runQerror . updateFaculty)
stack.yaml+3−1
@@ -37,7 +37,9 @@ packages:
3737# Dependency packages to be pulled from upstream that are not in the resolver
3838# using the same syntax as the packages field.
3939# (e.g., acme-missiles-0.3)
40−# extra-deps:
40+extra-deps:
41+- taggy-0.2.1
42+- crypto-rng-0.1.0.2
4143# - servant-options-0.1.0.0
4244
4345