git.iko.soy/denis
on master help sign in
Added user agent and activation/deactivation tokens
commit271116d2f6b07dc95538451e22b70e6716bf4e2c authoriko <ilyakooo0@gmail.com> dateFri 10 May 2019, 23:23 (7 years ago) parenta5f9f69
9 files changed+61−27
compare with master
unifiedsplit
denis/email.html+4−1 denis/package.yaml+2 denis/src/Data/Query.hs+8−2 denis/src/Data/Schema.hs+8−2 denis/src/Server/Auth.hs+20−10 denis/src/Server/Auth/Mail.hs+5−5 denis/src/Server/Auth/Token.hs+12−6 denis/src/Server/Error.hs+1−1 stack.yaml+1
denis/email.html+4−1
@@ -6,9 +6,12 @@
66 <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;">
77 Log in
88 </a>
9+ <div style="font-size: 34px; font-weight: bold;">
10+ <span style="color: #bbb; font-weight: bold;">from: </span>macOS
11+ </div>
912 <br />
1013 <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
1215 </div>
1316 </div>
1417 <div align="center" style="margin-top: 233px;">
denis/package.yaml+2
@@ -61,6 +61,8 @@ dependencies:
6161- regex-compat
6262- smtp-mail
6363- mime-mail
64+- periodic
65+- ua-parser
6466
6567
6668
denis/src/Data/Query.hs+8−2
@@ -582,7 +582,10 @@ createTokenQ = insertRow_ #tokens (
582582 Set (param @2) `as` #tokenValue :*
583583 Set (param @3) `as` #tokenExpiryDate :*
584584 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
586589 )
587590
588591updateTokenQ :: Manipulation Schema (TuplePG Token) '[]
@@ -591,7 +594,10 @@ updateTokenQ = update_ #tokens (
591594 Same `as` #tokenValue :*
592595 Set (param @3) `as` #tokenExpiryDate :*
593596 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)
595601 (#tokenUserId .== param @1 .&& #tokenValue .== param @2)
596602
597603deleteTokenQ :: Manipulation Schema (TuplePG (UserId, ByteString)) '[]
denis/src/Data/Schema.hs+8−2
@@ -166,7 +166,10 @@ type Schema =
166166 "tokenValue" ::: 'NoDef :=> 'NotNull 'PGbytea,
167167 "tokenExpiryDate" ::: 'NoDef :=> 'NotNull 'PGtimestamptz,
168168 "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
170173 ])
171174
172175 -- "postsView" ::: 'View (RowPG PostRowResponse)
@@ -289,7 +292,10 @@ createTables = createTable #faculties (
289292 notNullable bytea `as` #tokenValue :*
290293 notNullable timestampWithTimeZone `as` #tokenExpiryDate :*
291294 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
293299 ) (
294300 foreignKey #tokenUserId #users #userRowId OnDeleteCascade OnUpdateCascade `as` #fk_user_token
295301 )
denis/src/Server/Auth.hs+20−10
@@ -52,6 +52,8 @@ import Data.Maybe
5252import Server.Auth.Token
5353import Server.Auth.Mail
5454import Data.Int
55+import Web.UAParser
56+import qualified Data.Text.Lazy as TL
5557
5658-- MARK: Documentation
5759
@@ -80,6 +82,7 @@ type RegisterDescription = Description "Register the user for a new account.\n\n
8082type AuthenticationHandler =
8183 "login" :> LoginDescription :>
8284 ReqBody '[JSON] AuthenticationCredits :>
85+ Header "User-Agent" String :>
8386 Post '[JSON] (Headers '[Header "Set-Cookie" String] UserLoginResponse) :<|>
8487 "logout" :> LogoutDescription
8588 :> Header "cookie" String
@@ -87,7 +90,9 @@ type AuthenticationHandler =
8790 "verify" :> VerifyDescription :>
8891 Header "cookie" String :> ReqBody '[JSON] Int32 :> PostNoContent '[JSON, PlainText, FormUrlEncoded] NoContent :<|>
8992 "register" :> RegisterDescription :>
90− ReqBody '[JSON] UserCreation :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
93+ ReqBody '[JSON] UserCreation :>
94+ Header "User-Agent" String :>
95+ PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)
9196
9297data UserResponseStatus = UserIsRegistered | UserCanRegister | InvalidUser
9398 deriving (Show)
@@ -121,8 +126,8 @@ newtype AuthenticationCredits = AuthenticationCredits {authenticationEmail :: Us
121126authenticationAPI :: ServerT AuthenticationHandler App
122127authenticationAPI = logIn :<|> logOut :<|> verifyToken :<|> register
123128
124−logIn :: AuthenticationCredits -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
125−logIn (AuthenticationCredits email') = do
129+logIn :: AuthenticationCredits -> Maybe String -> App (Headers '[Header "Set-Cookie" String] UserLoginResponse)
130+logIn (AuthenticationCredits email') ua' = do
126131 let email = T.toLower . T.strip $ email'
127132 if (not . validateEmail) email
128133 then return . noHeader $ UserLoginResponse InvalidUser
@@ -131,12 +136,13 @@ logIn (AuthenticationCredits email') = do
131136 case user of
132137 Nothing -> return . noHeader $ UserLoginResponse UserCanRegister
133138 Just User{..} -> do
134− token <- generateToken userId
139+ let ua = getUserAgent ua'
140+ token <- generateToken userId ua
135141 runQerror . createToken $ token
136142 let cookie = generateCookie token
137143 case tokenVerificationCode token of
138144 Just code -> do
139− sendTokenVerificationEmail code email
145+ sendTokenVerificationEmail code (TL.fromStrict ua) email
140146 return . addHeader cookie $ UserLoginResponse UserIsRegistered
141147 Nothing -> throwError err500
142148
@@ -182,25 +188,29 @@ checkToken conn (AuthenticationCookieData uId tokenData) = do
182188 token <- runQ' conn err500 $ getVerifiedToken uId tokenData
183189 case token of
184190 Nothing -> throwError invalidToken
185− Just (Token newUId _ _ _ _) -> return newUId
191+ Just (Token newUId _ _ _ _ _ _ _) -> return newUId
186192
187−register :: UserCreation -> App (Headers '[Header "Set-Cookie" String] NoContent)
188−register creation' = do
193+register :: UserCreation -> Maybe String -> App (Headers '[Header "Set-Cookie" String] NoContent)
194+register creation' ua' = do
189195 let creation = normalizaUser creation'
190196 unless (validateUser creation) $ throwError err400
191197 genToken <- generateTokenM
198+ let ua = getUserAgent ua'
192199 token <- runQ err409 . commitedTransactionallyUpdate $ do
193200 uId <- createUser creation
194− let token = genToken uId
201+ let token = genToken uId ua
195202 createToken token
196203 return token
197204 case tokenVerificationCode token of
198205 Just code -> do
199− sendTokenVerificationEmail code (userCreationUserEmail creation)
206+ sendTokenVerificationEmail code (TL.fromStrict ua) (userCreationUserEmail creation)
200207 let cookie = generateCookie token
201208 return $ addHeader cookie NoContent
202209 Nothing -> throwError err500
203210
211+getUserAgent :: Maybe String -> T.Text
212+getUserAgent = fromMaybe "Unknown" . fmap osrFamily . join . fmap parseOS . fmap C.pack
213+
204214normalizaUser :: UserCreation -> UserCreation
205215normalizaUser (UserCreation fName mName lName faculty email) =
206216 UserCreation
denis/src/Server/Auth/Mail.hs+5−5
@@ -24,21 +24,21 @@ import Network.Mail.Mime (Mail, Part)
2424import Data.Text (Text)
2525import qualified Data.Text.Lazy as TL
2626
27−sendTokenVerificationEmail :: TokenVerificationCode -> Text -> App ()
28−sendTokenVerificationEmail code email = do
27+sendTokenVerificationEmail :: TokenVerificationCode -> TL.Text -> Text -> App ()
28+sendTokenVerificationEmail code ua email = do
2929 mailCfg <- mailConfig <$> ask
3030 let mail = simpleMail
3131 (Address (Just "HSE Social Network") "noreply@hse.ru")
3232 [Address Nothing email] [] []
3333 "HSE Social Network Verification Code"
34− [genMail code]
34+ [genMail code ua]
3535 sendMailWithConfig mailCfg mail
3636
3737sendMailWithConfig :: (MonadIO m) => MailConfig -> Mail -> m ()
3838sendMailWithConfig (MailConfig host port user pass) =
3939 liftIO . sendMailWithLogin' host (fromIntegral port) user pass
4040
41−genMail :: TokenVerificationCode -> 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>"
41+genMail :: TokenVerificationCode -> TL.Text -> Part
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>"
4343 where
4444 [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
2424import Data.Int
2525import Control.Monad.IO.Class
2626import Crypto.RNG
27+import Data.Text (Text)
2728
2829type TokenVerificationCode = Int32
2930
@@ -32,17 +33,22 @@ data Token = Token {
3233 tokenValue :: ByteString,
3334 tokenExpiryDate :: UTCTime,
3435 tokenVerificationCode :: Maybe TokenVerificationCode,
35− tokenActivationTriesLeft :: Int32
36+ tokenActivationTriesLeft :: Int32,
37+ tokenUserAgent :: Text,
38+ tokenActivationCode :: Maybe ByteString,
39+ tokenDeactivationCode :: ByteString
3640} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
3741
38−generateToken :: (MonadIO m, CryptoRNG m) => UserId -> m Token
39−generateToken uId = do
42+generateToken :: (MonadIO m, CryptoRNG m) => UserId -> Text -> m Token
43+generateToken uId ua = do
4044 gen <- generateTokenM
41− return $ gen uId
45+ return $ gen uId ua
4246
43−generateTokenM :: (MonadIO m, CryptoRNG m) => m (UserId -> Token)
47+generateTokenM :: (MonadIO m, CryptoRNG m) => m (UserId -> Text -> Token)
4448generateTokenM = do
4549 token <- randomBytes 64
50+ activationToken <- randomBytes 64
51+ deactivationToken <- randomBytes 64
4652 code <- randomR (0, 999999)
4753 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 @@
22
33module Server.Error (
44 invalidToken
5−) where
5+) where
66
77import Servant.Server
88
stack.yaml+1
@@ -40,6 +40,7 @@ packages:
4040extra-deps:
4141- taggy-0.2.1
4242- crypto-rng-0.1.0.2
43+- periodic-0.1.0.0
4344# - servant-options-0.1.0.0
4445
4546