a2440cc · denis · git.iko.soy

git.iko.soy/denis

Registration.

commita2440ccefc9124bbd0145b27f0282a45cb30c677 authoriko <ilyakooo0@gmail.com> dateFri 10 May 2019, 16:21 (7 years ago) parent8f09a48

15 files changed+704−156

compare with master

unifiedsplit

denis/docs/Docs.hs+3 denis/package.yaml+5−1 denis/src/Data/Connection.hs+6−1 denis/src/Data/Faculty.hs+24−9 denis/src/Data/Query.hs+236−32 denis/src/Data/Schema.hs+67−40 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+13−3 stack.yaml+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+5−1

@@ -55,8 +55,12 @@ dependencies:

5555- req

5656- data-default

5757- lens

58−

58+- crypto-rng

5959- wai-cors

60+- base64-bytestring

61+- regex-compat

62+- smtp-mail

63+- mime-mail

6064

6165

6266

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.hs+24−9

@@ -5,10 +5,12 @@

55 OverloadedStrings ,

66 TypeApplications ,

77 TypeOperators,

8− OverloadedStrings #-}

8+ OverloadedStrings,

9+ DeriveAnyClass #-}

910

1011module Data.Faculty (

11− Faculty(..)

12+ Faculty(..),

13+ FacultyUrl

1214 ) where

1315

1416import qualified Generics.SOP as SOP

@@ -16,26 +18,39 @@ import qualified GHC.Generics as GHC

1618import Data.Aeson

1719import qualified Data.Text as T

1820import 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

1928

2029data Faculty = Faculty {

2130 facultyName :: T.Text,

22− facultyURL :: T.Text,

31+ facultyUrl :: FacultyUrl,

2332 facultyPath :: T.Text,

2433 facultyCampusName :: T.Text,

2534 facultyCampusCode :: T.Text,

2635 facultyTags :: V.Vector T.Text

27−} deriving (GHC.Generic, Show)

36+} deriving (GHC.Generic, Show, SOP.Generic, SOP.HasDatatypeInfo)

2837

2938instance ToJSON Faculty where

30− toJSON (Faculty name url path campusName campusCode tags) = object [

39+ toJSON (Faculty name url p campusName campusCode tags) = object [

3140 "name" .= name,

3241 "url" .= url,

33− "path" .= path,

42+ "path" .= p,

3443 "campusName" .= campusName,

3544 "campusCode" .= campusCode,

3645 "tags" .= tags

3746 ]

3847

39−instance SOP.Generic Faculty

40−instance SOP.HasDatatypeInfo Faculty

41−

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/Query.hs+236−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,

@@ -43,8 +45,16 @@ module Data.Query (

4345 getGroupChatForUser,

4446 getFaculty,

4547 updateFaculty,

46− getFacultyFromQuery

47−) where

48+ getFacultyFromQuery,

49+ getUserWithEmail,

50+ createToken,

51+ validateToken,

52+ invalidateToken,

53+ tryVerifyToken,

54+ getVerifiedToken,

55+ UserCreation(..),

56+ createUser

57+ ) where

4858

4959import Squeal.PostgreSQL

5060import Data.User

@@ -83,6 +93,9 @@ import Data.Faculty

8393import Data.ByteString (ByteString)

8494import Data.Foldable (fold)

8595import Data.Char

96+import qualified Data.Vector as V

97+import Server.Auth.Token

98+import Data.Int

8699

87100-- MARK: Documentation

88101

@@ -145,26 +158,68 @@ getPostQ oTe te = select (

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

146159-- return $ M.lookup qId rows >>= rowsToQuote rows

147160

148−getUserQ :: Query Schema (TuplePG (Only UserId)) (RowPG User)

149−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))

150172

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

152174verifiedUserIdsQ uIds = case idsToColumn uIds of

153− 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) &

154176 innerJoin (table #users)

155− (#ids ! #id .== #users ! #userId))

177+ (#ids ! #id .== #users ! #userRowId))

156178 Nothing -> Nothing

157179

158−

159−getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG User))

180+getUsersQ :: [UserId] -> Maybe (Query Schema '[] (RowPG UserRow))

160181getUsersQ uIds = case idsToColumn uIds of

161− 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) &

162197 innerJoin (table #users)

163− (#ids ! #id .== #users ! #userId))

198+ (#ids ! #id .== #users ! #userRowId) &

199+ innerJoin (table #faculties)

200+ (#users ! #userRowFacultyUrl .== #faculties ! #facultyUrl)) &

201+ where_ (notNull $ #users ! #userRowIsValidated))

164202 Nothing -> Nothing

165203

166−getAllUsersQ :: Query Schema '[] (RowPG User)

167−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))

168223

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

170225getPostsByIdQ pIds = case idsToColumn pIds of

@@ -236,7 +291,7 @@ updateFacultyQ :: Manipulation Schema (TuplePG Faculty) '[]

236291updateFacultyQ = insertRow #faculties

237292 (

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

239− Set (param @2) `as` #facultyURL :*

294+ Set (param @2) `as` #facultyUrl :*

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

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

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

@@ -247,7 +302,7 @@ updateFacultyQ = insertRow #faculties

247302

248303getFacultyQ :: Query Schema (TuplePG (Only Text)) (RowPG Faculty)

249304getFacultyQ = selectStar (from (table #faculties) &

250− where_ (#facultyURL .== param @1))

305+ where_ (#facultyUrl .== param @1))

251306

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

253308createNamedChannelQ = insertRow #channels

@@ -503,17 +558,97 @@ textArrayToText

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

504559textArrayToText = fold . L.intersperse space

505560

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))

622+

506623-- MARK: FrontEnd Data Structures

507624

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+

508646data NamedChannelCreation = NamedChannelCreation {

509647 namedChannelCreationOwner :: UserId,

510648 namedChannelCreationName :: Text,

511649 namedChannelCreationTags :: Vector Text,

512650 namedChannelCreationPeopleIds :: Vector UserId

513−} deriving GHC.Generic

514−

515−instance SOP.Generic NamedChannelCreation

516−instance SOP.HasDatatypeInfo NamedChannelCreation

651+} deriving (GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

517652

518653addUserToChannelCreate :: UserId -> NamedChannelCreationRequest -> NamedChannelCreation

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

@@ -562,7 +697,12 @@ deleteGroupChat gId = do

562697 deleteGroupChatMessagesQ = deleteFrom_ #messages

563698 (#messageStorageDestinationGroupId .== param @1)

564699

565−

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)

566706

567707-- MARK: FrontEnd functions

568708

@@ -594,14 +734,14 @@ getLastPosts pId lim dir = do

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

595735 rowsToPosts postRows `liftMaybe` wrapIntoResponse

596736

597−getUser :: UserId -> StaticPQ User

598−getUser uId = runQueryParams getUserQ (Only uId) >>= getRow 0

737+getUserWithEmail :: UserEmail -> StaticPQ (Maybe (User FacultyUrl))

738+getUserWithEmail email = runQueryParams getUserWithEmailQ (Only email) >>= firstRow

599739

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

601−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))

602742

603−getAllUsers :: StaticPQ [User]

604−getAllUsers = runQuery getAllUsersQ >>= getRows

743+getAllUsers :: StaticPQ [User Faculty]

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

605745

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

607747publishPost uId pc = commitedTransactionallyUpdate $ do

@@ -753,8 +893,72 @@ getFacultyFromQuery :: T.Text -> StaticPQ [Faculty]

753893getFacultyFromQuery query =

754894 runQueryParams getFacultySearchResultQ (Only . queryFromText $ query) >>= getRows

755895

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+

756927-- MARK: Utils

757928

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+

758962queryFromText :: Text -> Text

759963queryFromText = T.unwords . L.intersperse "&" . map (`T.append` ":*") . filter (not . T.null) . T.split (not . isAlphaNum)

760964

@@ -788,7 +992,7 @@ unsafeIntToExpr = UnsafeExpression . pack . show

788992

789993data ResponseWithUsers r = ResponseWithUsers {

790994 response :: r,

791− users :: M.Map UserId User

995+ users :: M.Map UserId (User Faculty)

792996} deriving (Generic)

793997

794998instance (ToJSON r) => ToJSON (ResponseWithUsers r)

denis/src/Data/Schema.hs+67−40

@@ -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,

@@ -141,18 +156,17 @@ type Schema =

141156 "messageStorageBody" ::: 'NoDef :=> 'NotNull (PG (Jsonb (PostElement Message))),

142157 "messageStorageTime" ::: 'NoDef :=> 'NotNull 'PGtimestamptz

143158 ]),

144−

145− "faculties" ::: 'Table (

159+ "tokens" ::: 'Table (

146160 '[

147− "pk_faculties" ::: 'PrimaryKey '["facultyURL"]

161+ -- "pk_token" ::: 'PrimaryKey '["tokenValue"],

162+ "fk_user_token" ::: 'ForeignKey '["tokenUserId"] "users" '["userRowId"]

148163 ] :=>

149164 '[

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

151− "facultyURL" ::: 'NoDef :=> 'NotNull 'PGtext,

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

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

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

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

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

156170 ])

157171

158172 -- "postsView" ::: 'View (RowPG PostRowResponse)

@@ -172,13 +186,27 @@ type Schema =

172186

173187

174188createTables :: Definition '[] Schema

175−createTables = createTable #users (

176− serial8 `as` #userId :*

177− notNullable text `as` #firstName :*

178− notNullable text `as` #middleName :*

179− 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

196+ ) (

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

180206 ) (

181− primaryKey #userId `as` #pk_users

207+ primaryKey #userRowId `as` #pk_users :*

208+ unique #userRowEmail `as` #user_email :*

209+ foreignKey #userRowFacultyUrl #faculties #facultyUrl OnDeleteCascade OnUpdateCascade `as` #fk_user_faculty

182210 ) >>> createTable #posts (

183211 serial8 `as` #postRowId :*

184212 notNullable int8 `as` #postRowAuthorId :*

@@ -186,7 +214,7 @@ createTables = createTable #users (

186214 notNullable (vararray text) `as` #postRowTags

187215 ) (

188216 primaryKey #postRowId `as` #pk_posts :*

189− foreignKey #postRowAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_author_id

217+ foreignKey #postRowAuthorId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_author_id

190218 ) >>> createTable #quotes (

191219 serial8 `as` #quoteRowId :*

192220 notNullable int8 `as` #quoteRowPostId

@@ -223,7 +251,7 @@ createTables = createTable #users (

223251 notNullable (vararray int8) `as` #namedChannelFullPeopleIds

224252 ) (

225253 primaryKey #namedChannelFullId `as` #pk_channels :*

226− foreignKey #namedChannelFullOwner #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_channels_users_id

254+ foreignKey #namedChannelFullOwner #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_channels_users_id

227255 -- ) >>> createView #postsView (select (

228256 -- #posts ! #postRowId :*

229257 -- #posts ! #postRowAuthorId :*

@@ -253,19 +281,18 @@ createTables = createTable #users (

253281 notNullable timestampWithTimeZone `as` #messageStorageTime

254282 ) (

255283 primaryKey #messageStorageId `as` #pk_messages :*

256− foreignKey #messageStorageAuthorId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_messages_author :*

284+ foreignKey #messageStorageAuthorId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_messages_author :*

257285 foreignKey #messageStorageDestinationGroupId #groupChats #groupChatId OnDeleteCascade OnUpdateCascade `as` #fk_messages_group :*

258− foreignKey #messageStorageDestinationUserId #users #userId OnDeleteCascade OnUpdateCascade `as` #fk_messages_to_user

259− ) >>> createTable #faculties (

260− notNullable text `as` #facultyName :*

261− notNullable text `as` #facultyURL :*

262− notNullable text `as` #facultyPath :*

263− notNullable text `as` #facultyCampusName :*

264− notNullable text `as` #facultyCampusCode :*

265− notNullable (vararray text) `as` #facultyTags

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

266293 ) (

267− primaryKey #facultyURL `as` #pk_faculties

268− )

294+ foreignKey #tokenUserId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_user_token

295+ )

269296-- quoteUniquenessCheck :: TableConstraintExpression Schema _ (Check '["rowElementOrd", "rowElementMarkdown", "rowElementLatex", "rowElementImage", "rowElementQuote", "rowElementAttachment"])

270297-- quoteUniquenessCheck = check (#rowElementOrd :* #rowElementMarkdown :* #rowElementLatex :* #rowElementImage :* #rowElementQuote :* #rowElementAttachment) $

271298-- ((ifThenElse (isNull #rowElementOrd) 1 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 #-}

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+13−3

@@ -21,15 +21,22 @@ import Control.Concurrent

2121import Data.Faculty.Parser

2222import Data.Connection

2323import Data.Query

24−

24+import Crypto.RNG

2525import Network.Wai.Middleware.Cors

2626

27−

2827getDBString :: IO B.ByteString

2928getDBString = do

3029 mDatabaseURL <- lookupEnv "DATABASE_URL"

3130 return $ B.pack $ fromMaybe "host=localhost port=5432 dbname=postgres connect_timeout=10" mDatabaseURL

3231

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+

3340getServerPort :: IO Int

3441getServerPort = maybe 2000 read <$> lookupEnv "PORT"

3542

@@ -37,7 +44,10 @@ getConfig :: IO Config

3744getConfig = do

3845 databaseURL <- getDBString

3946 conn <- createConnectionPool databaseURL 3 0.5 10

40− return $ Config conn

47+ crypto <- newCryptoRNGState

48+ -- (Jusr selfRoot) <- lookupEnv "SELF_ROOT_URL"

49+ mail <- getMailConfig

50+ return $ Config conn crypto mail

4151

4252runServer :: IO ()

4353runServer = do

stack.yaml+1

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

3939# (e.g., acme-missiles-0.3)

4040extra-deps:

4141- taggy-0.2.1

42+- crypto-rng-0.1.0.2

4243# - servant-options-0.1.0.0

4344

4445