52da846 · denis · git.iko.soy

git.iko.soy/denis

Merge pull request #107 from ilyakooo0/develop

52da846iko7 years ago

denis/email.html+4−1

@@ -6,9 +6,12 @@

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

7 Log in

8 </a>

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

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

11+ </div>

9 <br />

12 <br />

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

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

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

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

12 </div>

15 </div>

13 </div>

16 </div>

14 <div align="center" style="margin-top: 233px;">

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

denis/package.yaml+2

@@ -61,6 +61,8 @@ dependencies:

61- regex-compat

62- smtp-mail

63- mime-mail

64+- periodic

65+- ua-parser

denis/src/Data/Query.hs+8−2

@@ -582,7 +582,10 @@ createTokenQ = insertRow_ #tokens (

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

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

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

585− Set (param @5) `as` #tokenActivationTriesLeft

585+ Set (param @5) `as` #tokenActivationTriesLeft :*

586+ Set (param @6) `as` #tokenUserAgent :*

587+ Set (param @7) `as` #tokenActivationCode :*

588+ Set (param @8) `as` #tokenDeactivationCode

586 )

589 )

587

590

588updateTokenQ :: Manipulation Schema (TuplePG Token) '[]

591updateTokenQ :: Manipulation Schema (TuplePG Token) '[]

@@ -591,7 +594,10 @@ updateTokenQ = update_ #tokens (

591 Same `as` #tokenValue :*

594 Same `as` #tokenValue :*

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

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

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

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

594− Set (param @5) `as` #tokenActivationTriesLeft)

597+ Set (param @5) `as` #tokenActivationTriesLeft :*

598+ Set (param @6) `as` #tokenUserAgent :*

599+ Set (param @7) `as` #tokenActivationCode :*

600+ Set (param @8) `as` #tokenDeactivationCode)

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

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

596

602

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

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

denis/src/Data/Schema.hs+8−2

@@ -166,7 +166,10 @@ type Schema =

166 "tokenValue" ::: 'NoDef :=> 'NotNull 'PGbytea,

167 "tokenExpiryDate" ::: 'NoDef :=> 'NotNull 'PGtimestamptz,

168 "tokenVerificationCode" ::: 'NoDef :=> 'Null 'PGint4, -- null == verified

169− "tokenActivationTriesLeft" ::: 'NoDef :=> 'NotNull 'PGint4

169+ "tokenActivationTriesLeft" ::: 'NoDef :=> 'NotNull 'PGint4,

170+ "tokenUserAgent" ::: 'NoDef :=> 'NotNull 'PGtext,

171+ "tokenActivationCode" ::: 'NoDef :=> 'Null 'PGbytea,

172+ "tokenDeactivationCode" ::: 'NoDef :=> 'NotNull 'PGbytea

170 ])

173 ])

171

174

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

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

@@ -289,7 +292,10 @@ createTables = createTable #faculties (

289 notNullable bytea `as` #tokenValue :*

292 notNullable bytea `as` #tokenValue :*

290 notNullable timestampWithTimeZone `as` #tokenExpiryDate :*

293 notNullable timestampWithTimeZone `as` #tokenExpiryDate :*

291 nullable int4 `as` #tokenVerificationCode :*

294 nullable int4 `as` #tokenVerificationCode :*

292− notNullable int4 `as` #tokenActivationTriesLeft

295+ notNullable int4 `as` #tokenActivationTriesLeft :*

296+ notNullable text `as` #tokenUserAgent :*

297+ nullable bytea `as` #tokenActivationCode :*

298+ notNullable bytea `as` #tokenDeactivationCode

293 ) (

299 ) (

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

300 foreignKey #tokenUserId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_user_token

295 )

301 )

denis/src/Server/Auth.hs+20−10

@@ -52,6 +52,8 @@ import Data.Maybe

52import Server.Auth.Token

53import Server.Auth.Mail

54import Data.Int

55+import Web.UAParser

56+import qualified Data.Text.Lazy as TL

56-- MARK: Documentation

58-- MARK: Documentation

@@ -80,6 +82,7 @@ type RegisterDescription = Description "Register the user for a new account.\n\n

80type AuthenticationHandler =

82type AuthenticationHandler =

81 "login" :> LoginDescription :>

83 "login" :> LoginDescription :>

82 ReqBody '[JSON] AuthenticationCredits :>

84 ReqBody '[JSON] AuthenticationCredits :>

85+ Header "User-Agent" String :>

83 Post '[JSON] (Headers '[Header "Set-Cookie" String] UserLoginResponse) :<|>

86 Post '[JSON] (Headers '[Header "Set-Cookie" String] UserLoginResponse) :<|>

84 "logout" :> LogoutDescription

87 "logout" :> LogoutDescription

85 :> Header "cookie" String

88 :> Header "cookie" String

@@ -87,7 +90,9 @@ type AuthenticationHandler =

87 "verify" :> VerifyDescription :>

90 "verify" :> VerifyDescription :>

88 Header "cookie" String :> ReqBody '[JSON] Int32 :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>

91 Header "cookie" String :> ReqBody '[JSON] Int32 :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>

89 "register" :> RegisterDescription :>

92 "register" :> RegisterDescription :>

93+ ReqBody '[JSON] UserCreation :>

94+ Header "User-Agent" String :>

90− ReqBody '[JSON] UserCreation :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)

95+ PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)

92data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser

97data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser

93 deriving (Show)

98 deriving (Show)

@@ -121,8 +126,8 @@ newtype AuthenticationCredits = AuthenticationCredits {authenticationEmail :: Us

121authenticationAPI :: ServerT AuthenticationHandler App

126authenticationAPI :: ServerT AuthenticationHandler App

122authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register

127authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register

123

128

124−logIn :: AuthenticationCredits -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)

129+logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)

125−logIn (AuthenticationCredits email') = do

130+logIn (AuthenticationCredits email') ua' = do

126 let email = T.toLower . T.strip $ email'

131 let email = T.toLower . T.strip $ email'

127 if (not . validateEmail) email

132 if (not . validateEmail) email

128 then return . noHeader $ UserLoginResponse InvalidUser

133 then return . noHeader $ UserLoginResponse InvalidUser

@@ -131,12 +136,13 @@ logIn (AuthenticationCredits email') = do

131 case user of

136 case user of

132 Nothing -> return . noHeader $ UserLoginResponse UserCanRegister

137 Nothing -> return . noHeader $ UserLoginResponse UserCanRegister

133 Just User{..} -> do

138 Just User{..} -> do

139+ let ua = getUserAgent ua'

134− token <- generateToken userId

140+ token <- generateToken userId ua

135 runQerror . createToken $ token

141 runQerror . createToken $ token

136 let cookie = generateCookie token

142 let cookie = generateCookie token

137 case tokenVerificationCode token of

143 case tokenVerificationCode token of

138 Just code -> do

144 Just code -> do

139− sendTokenVerificationEmail code email

145+ sendTokenVerificationEmail code (TL.fromStrict ua) email

140 return . addHeader cookie $ UserLoginResponse UserIsRegistered

146 return . addHeader cookie $ UserLoginResponse UserIsRegistered

141 Nothing -> throwError err500

147 Nothing -> throwError err500

142

148

@@ -182,25 +188,29 @@ checkToken conn (AuthenticationCookieData uId tokenData) = do

182 token <- runQ' conn err500 $ getVerifiedToken uId tokenData

188 token <- runQ' conn err500 $ getVerifiedToken uId tokenData

183 case token of

189 case token of

184 Nothing -> throwError invalidToken

190 Nothing -> throwError invalidToken

185− Just (Token newUId _ _ _ _) -> return newUId

191+ Just (Token newUId _ _ _ _ _ _ _) -> return newUId

186

192

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

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

188−register creation' = do

194+register creation' ua' = do

189 let creation = normalizaUser creation'

195 let creation = normalizaUser creation'

190 unless (validateUser creation) $ throwError err400

196 unless (validateUser creation) $ throwError err400

191 genToken <- generateTokenM

197 genToken <- generateTokenM

198+ let ua = getUserAgent ua'

192 token <- runQ err409 . commitedTransactionallyUpdate $ do

199 token <- runQ err409 . commitedTransactionallyUpdate $ do

193 uId <- createUser creation

200 uId <- createUser creation

194− let token = genToken uId

201+ let token = genToken uId ua

195 createToken token

202 createToken token

196 return token

203 return token

197 case tokenVerificationCode token of

204 case tokenVerificationCode token of

198 Just code -> do

205 Just code -> do

199− sendTokenVerificationEmail code (userCreationUserEmail creation)

206+ sendTokenVerificationEmail code (TL.fromStrict ua) (userCreationUserEmail creation)

200 let cookie = generateCookie token

207 let cookie = generateCookie token

201 return $ addHeader cookie NoContent

208 return $ addHeader cookie NoContent

202 Nothing -> throwError err500

209 Nothing -> throwError err500

203

210

211+getUserAgent :: Maybe String -> T.Text

212+getUserAgent = fromMaybe "Unknown" . fmap osrFamily . join . fmap parseOS . fmap C.pack

213+

204normalizaUser :: UserCreation -> UserCreation

214normalizaUser :: UserCreation -> UserCreation

205normalizaUser (UserCreation fName mName lName faculty email) =

215normalizaUser (UserCreation fName mName lName faculty email) =

206 UserCreation

216 UserCreation

denis/src/Server/Auth/Mail.hs+5−5

@@ -24,21 +24,21 @@ import Network.Mail.Mime (Mail, Part)

24import Data.Text (Text)

25import qualified Data.Text.Lazy as TL

27−sendTokenVerificationEmail :: TokenVerificationCode -> Text -> App ()

27+sendTokenVerificationEmail :: TokenVerificationCode -> TL.Text -> Text -> App ()

28−sendTokenVerificationEmail code email = do

28+sendTokenVerificationEmail code ua email = do

29 mailCfg <- mailConfig <$> ask

30 let mail = simpleMail

31 (Address (Just "HSE Social Network") "noreply@hse.ru")

32 [Address Nothing email] [] []

33 "HSE Social Network Verification Code"

34− [genMail code]

34+ [genMail code ua]

35 sendMailWithConfig mailCfg mail

37sendMailWithConfig :: (MonadIO m) => MailConfig -> Mail -> m ()

38sendMailWithConfig (MailConfig host port user pass) =

39 liftIO . sendMailWithLogin' host (fromIntegral port) user pass

41−genMail :: TokenVerificationCode -> Part

41+genMail :: TokenVerificationCode -> TL.Text -> Part

42−genMail code = htmlPart $ "<html><body style=\"font-family: sans-serif;\"> <h1> <div align=\"center\" style=\"margin-top: 20vh;\"> <a href=\"#\" style=\"font-size: 34px; font-weight: bold; display: inline-block; padding: 7px 13px 7px 13px; margin-bottom: 89px; text-decoration: underline; font-family: sans-serif; color: #555;\"> Log in </a> <br/> <div style=\"font-size: 55px; font-weight: bold; border-radius: 10px; background-color: #eee; display: inline-block; padding: 7px 13px 7px 13px; box-shadow: 0px 5px 21px #bbb; background-image: linear-gradient(#f9f9f9, #eee);\">" <> TL.pack [a, b] <> "<div style=\"display: inline-block; width: 10px;\"></div>" <> TL.pack [c, d] <> "<div style=\"display: inline-block; width: 10px;\"></div>" <> TL.pack [e, f] <> "</div></div><div align=\"center\" style=\"margin-top: 233px;\"> <a href=\"#\" style=\"text-decoration: underline; font-family: sans-serif; color: #555;font-size: 13px;\">Revoke access</a> </div></body></html>"

42+genMail code ua = htmlPart $ "<html><body style=\"font-family: sans-serif;\"> <h1> <div align=\"center\" style=\"margin-top: 20vh;\"> <a href=\"#\" style=\"font-size: 34px; font-weight: bold; display: inline-block; padding: 7px 13px 7px 13px; margin-bottom: 89px; text-decoration: underline; font-family: sans-serif; color: #555;\"> Log in </a> <div style=\"font-size: 34px; font-weight: bold;\"> <span style=\"color: #bbb; font-weight: bold;\">from: </span>" <> ua <> "</div> <br/> <div style=\"font-size: 55px; font-weight: bold; border-radius: 10px; background-color: #eee; display: inline-block; padding: 7px 13px 7px 13px; box-shadow: 0px 5px 21px #bbb; background-image: linear-gradient(#f9f9f9, #eee);\">" <> TL.pack [a, b] <> "<div style=\"display: inline-block; width: 13px;\"></div>" <> TL.pack [c, d] <> "<div style=\"display: inline-block; width: 13px;\"></div>" <> TL.pack [e, f] <> "</div></div><div align=\"center\" style=\"margin-top: 233px;\"> <a href=\"#\" style=\"text-decoration: underline; font-family: sans-serif; color: #555;font-size: 13px;\">Revoke access</a> </div></body></html>"

43 where

44 [a, b, c, d, e, f] = reverse . take 6 . (++ repeat '0') . reverse . show $ code

denis/src/Server/Auth/Token.hs+12−6

@@ -24,6 +24,7 @@ import qualified GHC.Generics as GHC

24import Data.Int

25import Control.Monad.IO.Class

26import Crypto.RNG

27+import Data.Text (Text)

28type TokenVerificationCode = Int32

29type TokenVerificationCode = Int32

@@ -32,17 +33,22 @@ data Token = Token {

32 tokenValue :: ByteString,

33 tokenValue :: ByteString,

33 tokenExpiryDate :: UTCTime,

34 tokenExpiryDate :: UTCTime,

34 tokenVerificationCode :: Maybe TokenVerificationCode,

35 tokenVerificationCode :: Maybe TokenVerificationCode,

35− tokenActivationTriesLeft :: Int32

36+ tokenActivationTriesLeft :: Int32,

37+ tokenUserAgent :: Text,

38+ tokenActivationCode :: Maybe ByteString,

39+ tokenDeactivationCode :: ByteString

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

40} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)

38−generateToken :: (MonadIO m, CryptoRNG m) => UserId -> m Token

42+generateToken :: (MonadIO m, CryptoRNG m) => UserId -> Text -> m Token

39−generateToken uId = do

43+generateToken uId ua = do

40 gen <- generateTokenM

44 gen <- generateTokenM

41− return $ gen uId

45+ return $ gen uId ua

43−generateTokenM :: (MonadIO m, CryptoRNG m) => m (UserId -> Token)

47+generateTokenM :: (MonadIO m, CryptoRNG m) => m (UserId -> Text -> Token)

44generateTokenM = do

48generateTokenM = do

45 token <- randomBytes 64

49 token <- randomBytes 64

50+ activationToken <- randomBytes 64

51+ deactivationToken <- randomBytes 64

46 code <- randomR (0, 999999)

52 code <- randomR (0, 999999)

47 expire <- liftIO $ fmap (addUTCTime (nominalDay * 365)) getCurrentTime -- one year

53 expire <- liftIO $ fmap (addUTCTime (nominalDay * 365)) getCurrentTime -- one year

48− return $ \ uId -> Token uId token expire (Just code) 10

54+ return $ \ uId ua -> Token uId token expire (Just code) 10 ua (Just activationToken) deactivationToken

denis/src/Server/Error.hs+1−1

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

3module Server.Error (

4 invalidToken

5−) where

5+) where

7import Servant.Server

stack.yaml+1

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

40extra-deps:

41- taggy-0.2.1

42- crypto-rng-0.1.0.2

43+- periodic-0.1.0.0

43# - servant-options-0.1.0.0

44# - servant-options-0.1.0.0