From 643797777fb1aae54f6a7d265efade21356d2ec0 Mon Sep 17 00:00:00 2001 From: Konstantinos Sideris Date: Mon, 21 Sep 2020 17:21:30 +0300 Subject: [PATCH] Add /auth/users/current endpoint for chrome-wakatime compatibility (#6) --- hakatime.cabal | 1 + src/Haka/Api.hs | 3 + src/Haka/Authentication.hs | 12 +-- src/Haka/Cli.hs | 8 +- src/Haka/DatabaseOperations.hs | 9 +- src/Haka/PasswordUtils.hs | 79 +++++++++++++++ src/Haka/Users.hs | 175 +++++++++++++++++---------------- src/Haka/Utils.hs | 13 ++- 8 files changed, 198 insertions(+), 102 deletions(-) create mode 100644 src/Haka/PasswordUtils.hs diff --git a/hakatime.cabal b/hakatime.cabal index 5846da0..c780a6e 100644 --- a/hakatime.cabal +++ b/hakatime.cabal @@ -64,6 +64,7 @@ library libhaka , Haka.Stats , Haka.Users , Haka.Utils + , Haka.PasswordUtils , Paths_hakatime autogen-modules: Paths_hakatime diff --git a/src/Haka/Api.hs b/src/Haka/Api.hs index ee3fd73..3e62c83 100644 --- a/src/Haka/Api.hs +++ b/src/Haka/Api.hs @@ -11,6 +11,7 @@ import qualified Haka.Heartbeats as Heartbeats import qualified Haka.Projects as Projects import qualified Haka.Stats as Stats import Haka.Types (AppM, ServerSettings (..)) +import qualified Haka.Users as Users import Servant type Static = Raw @@ -25,6 +26,7 @@ type HakaAPI = :<|> Projects.API :<|> Auth.API :<|> Badges.API + :<|> Users.API :<|> Static api :: Proxy HakaAPI @@ -38,4 +40,5 @@ server settings = :<|> Projects.server :<|> Auth.server (hakaEnableRegistration settings) :<|> Badges.server + :<|> Users.server :<|> serveDirectoryFileServer (hakaDashboardPath settings) diff --git a/src/Haka/Authentication.hs b/src/Haka/Authentication.hs index 8b7cbdd..f809e53 100644 --- a/src/Haka/Authentication.hs +++ b/src/Haka/Authentication.hs @@ -13,9 +13,8 @@ import Control.Exception.Safe (throw) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (asks) import Data.Aeson (FromJSON, ToJSON) -import qualified Data.ByteString as Bs import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Encoding (encodeUtf8) import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime (..), getCurrentTime) import GHC.Generics @@ -30,11 +29,11 @@ import Haka.Types StoredApiToken, TokenData (..), ) +import Haka.Utils (getRefreshToken) import Katip import Polysemy (runM) import Polysemy.Error (runError) import Polysemy.IO (embedToMonadIO) -import Safe (headMay) import Servant import Web.Cookie @@ -156,13 +155,6 @@ mkLoginResponse tknData now = tokenUsername = tknOwner tknData } -getRefreshToken :: Bs.ByteString -> Maybe Text -getRefreshToken cookies = - let value = headMay $ map snd $ filter (\(k, _) -> k == "refresh_token") (parseCookies cookies) - in case value of - Just v -> Just $ decodeUtf8 v - Nothing -> Nothing - loginHandler :: AuthRequest -> AppM LoginResponse' loginHandler creds = do now <- liftIO getCurrentTime diff --git a/src/Haka/Cli.hs b/src/Haka/Cli.hs index 1995b95..c87f2bb 100644 --- a/src/Haka/Cli.hs +++ b/src/Haka/Cli.hs @@ -10,7 +10,7 @@ import Data.Bits.Extras (w16) import Data.ByteString.Char8 (pack) import Data.Text (Text, unpack) import Data.Version (showVersion) -import qualified Haka.Users as Users +import qualified Haka.PasswordUtils as PasswordUtils import qualified Haka.Utils as Utils import qualified Hasql.Connection as HasqlConn import qualified Hasql.Pool as HasqlPool @@ -94,7 +94,7 @@ handleCommand (CreateToken ops) _ = do dbSettings <- getDbSettings pass <- Utils.passwordInput "Password: " pool <- HasqlPool.acquire (10, 1, dbSettings) - token <- Users.createToken pool username pass + token <- PasswordUtils.createToken pool username pass case token of Left err -> die $ unpack err Right val -> @@ -107,11 +107,11 @@ handleCommand (CreateUser ops) _ = do dbSettings <- getDbSettings pass <- Utils.passwordInput "Set a password: " pool <- HasqlPool.acquire (10, 1, dbSettings) - hashUser <- Users.mkUser username pass + hashUser <- PasswordUtils.mkUser username pass case hashUser of Left err -> die (show err) Right user -> do - res <- Users.createUser pool user + res <- PasswordUtils.createUser pool user either handleError ( \_ -> do diff --git a/src/Haka/DatabaseOperations.hs b/src/Haka/DatabaseOperations.hs index 60823f1..699c840 100644 --- a/src/Haka/DatabaseOperations.hs +++ b/src/Haka/DatabaseOperations.hs @@ -5,6 +5,7 @@ module Haka.DatabaseOperations ( processHeartbeatRequest, interpretDatabaseIO, + getUserByRefreshToken, getBadgeLinkInfo, getTotalActivityTime, mkBadgeLink, @@ -29,6 +30,7 @@ import Data.Text (Text, pack) import Data.Time.Clock (UTCTime) import qualified Haka.Db.Sessions as Sessions import qualified Haka.Errors as Err +import qualified Haka.PasswordUtils as PUtils import Haka.Types ( ApiToken (..), BadgeRow (..), @@ -40,7 +42,6 @@ import Haka.Types TimelineRow (..), TokenData (..), ) -import Haka.Users (createUser, mkUser, validatePassword) import qualified Haka.Utils as Utils import qualified Hasql.Pool as HqPool import Polysemy @@ -138,7 +139,7 @@ interpretDatabaseIO = res <- liftIO $ HqPool.use pool (Sessions.getUserByRefreshToken token) either (throw . SessionException) pure res ValidateCredentials pool user pass -> do - res <- liftIO $ HqPool.use pool (Sessions.validateUser validatePassword user pass) + res <- liftIO $ HqPool.use pool (Sessions.validateUser PUtils.validatePassword user pass) either (throw . SessionException) ( \isValid -> if isValid then pure $ Just user else pure Nothing @@ -168,11 +169,11 @@ interpretDatabaseIO = either (throw . SessionException) (\_ -> pure tknData) res RegisterUser pool user pass expiry -> do tknData <- liftIO $ mkTokenData user - hashUser <- liftIO $ mkUser user pass + hashUser <- liftIO $ PUtils.mkUser user pass case hashUser of Left err -> throw $ RegistrationFailed (pack $ show err) Right hashUser' -> do - u <- liftIO $ createUser pool hashUser' + u <- liftIO $ PUtils.createUser pool hashUser' case u of Left e -> throw $ OperationException (Utils.toStrError e) Right userCreated -> diff --git a/src/Haka/PasswordUtils.hs b/src/Haka/PasswordUtils.hs new file mode 100644 index 0000000..70996b7 --- /dev/null +++ b/src/Haka/PasswordUtils.hs @@ -0,0 +1,79 @@ +module Haka.PasswordUtils + ( mkUser, + validatePassword, + createUser, + createToken, + ) +where + +import qualified Crypto.Error as CErr +import qualified Crypto.KDF.Argon2 as Argon2 +import qualified Crypto.Random.Entropy as Entropy +import qualified Data.ByteString as Bs +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import qualified Haka.Db.Sessions as Sessions +import Haka.Types (RegisteredUser (..)) +import Haka.Utils (randomToken, toBase64, toStrError) +import qualified Hasql.Pool as HasqlPool + +hashOutputLen :: Int +hashOutputLen = 64 + +hashSaltLen :: Int +hashSaltLen = 64 + +argonHash :: Bs.ByteString -> Text -> CErr.CryptoFailable Bs.ByteString +argonHash salt password = + Argon2.hash Argon2.defaultOptions (encodeUtf8 password) salt hashOutputLen + +mkUser :: Text -> Text -> IO (Either CErr.CryptoError RegisteredUser) +mkUser name pass = do + salt <- Entropy.getEntropy hashSaltLen + case argonHash salt pass of + CErr.CryptoFailed e -> pure $ Left e + CErr.CryptoPassed v -> + pure $ + Right $ + RegisteredUser + { username = name, + hashedPassword = v, + saltUsed = salt + } + +validatePassword :: RegisteredUser -> Text -> Text -> Either CErr.CryptoError Bool +validatePassword savedUser name password = + if name /= username savedUser + then Right False + else case argonHash (saltUsed savedUser) password of + CErr.CryptoFailed e -> Left e + CErr.CryptoPassed v -> Right (hashedPassword savedUser == v) + +-- | Insert the user's credentials. +createUser :: + HasqlPool.Pool -> + RegisteredUser -> + IO (Either HasqlPool.UsageError Bool) +createUser hpool user = HasqlPool.use hpool (Sessions.insertUser user) + +-- | Validate the user credentials and generate a token for it if successful. +createToken :: HasqlPool.Pool -> Text -> Text -> IO (Either Text Text) +createToken hpool name pass = do + validationResult <- HasqlPool.use hpool (Sessions.validateUser validatePassword name pass) + either (pure . Left . toStrError) genToken validationResult + where + genToken :: Bool -> IO (Either Text Text) + genToken isUserValid = + if not isUserValid + then pure $ Left "Wrong username or password" + else do + -- The user has the non-encoded version of the UUID. The wakatime client + -- will encode it to Base64 before sending it. + token <- randomToken + -- We save the Base64 representation of the token in the + -- database for future comparisons. + -- + -- TODO: Encrypt the token + -- + tokenResult <- HasqlPool.use hpool (Sessions.insertToken (toBase64 token) name) + either (pure . Left . toStrError) (\_ -> pure $ Right token) tokenResult diff --git a/src/Haka/Users.hs b/src/Haka/Users.hs index ee2f899..f240b7f 100644 --- a/src/Haka/Users.hs +++ b/src/Haka/Users.hs @@ -1,91 +1,100 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Haka.Users - ( createUser, - mkUser, - createToken, - validatePassword, + ( API, + server, ) where -import qualified Crypto.Error as CErr -import qualified Crypto.KDF.Argon2 as Argon2 -import qualified Crypto.Random.Entropy as Entropy -import qualified Data.ByteString as Bs -import qualified Data.Text as T +import Control.Exception.Safe (throw) +import Control.Monad (when) +import Control.Monad.Reader (asks) +import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) +import Data.Maybe (fromJust, isNothing) +import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) -import qualified Haka.Db.Sessions as Sessions -import Haka.Types (RegisteredUser (..)) -import qualified Haka.Utils as Utils -import qualified Hasql.Pool as HasqlPool - -hashOutputLen :: Int -hashOutputLen = 64 - -hashSaltLen :: Int -hashSaltLen = 64 - -argonHash :: Bs.ByteString -> T.Text -> CErr.CryptoFailable Bs.ByteString -argonHash salt password = - Argon2.hash Argon2.defaultOptions (encodeUtf8 password) salt hashOutputLen - -mkUser :: T.Text -> T.Text -> IO (Either CErr.CryptoError RegisteredUser) -mkUser name pass = do - salt <- Entropy.getEntropy hashSaltLen - case argonHash salt pass of - CErr.CryptoFailed e -> pure $ Left e - CErr.CryptoPassed v -> - pure $ - Right $ - RegisteredUser - { username = name, - hashedPassword = v, - saltUsed = salt - } - -validatePassword :: RegisteredUser -> T.Text -> T.Text -> Either CErr.CryptoError Bool -validatePassword savedUser name password = - if name /= username savedUser - then Right False - else case argonHash (saltUsed savedUser) password of - CErr.CryptoFailed e -> Left e - CErr.CryptoPassed v -> Right (hashedPassword savedUser == v) - --- / Insert the user's credentials. -createUser :: - HasqlPool.Pool -> - RegisteredUser -> - IO (Either HasqlPool.UsageError Bool) -createUser pool user = HasqlPool.use pool (Sessions.insertUser user) - --- / Validate the user credentials and generate a token for it if successful. -createToken :: HasqlPool.Pool -> T.Text -> T.Text -> IO (Either T.Text T.Text) -createToken pool name pass = do - validationResult <- HasqlPool.use pool (Sessions.validateUser validatePassword name pass) - either (pure . Left . Utils.toStrError) genToken validationResult - where - genToken :: Bool -> IO (Either T.Text T.Text) - genToken isUserValid = - if not isUserValid - then pure $ Left "Wrong username or password" - else do - -- The user has the non-encoded version of the UUID. The wakatime client - -- will encode it to Base64 before sending it. - token <- Utils.randomToken - -- We save the Base64 representation of the token in the - -- database for future comparisons. - -- - -- TODO: Encrypt the token - -- - tokenResult <- - HasqlPool.use - pool - ( Sessions.insertToken - (Utils.toBase64 token) - name - ) - either - (pure . Left . Utils.toStrError) - (\_ -> pure $ Right token) - tokenResult +import GHC.Generics +import Haka.AesonHelpers (noPrefixOptions) +import qualified Haka.DatabaseOperations as DbOps +import qualified Haka.Errors as Err +import Haka.Types (AppM, pool) +import Haka.Utils (getRefreshToken) +import Katip +import Polysemy (runM) +import Polysemy.Error (runError) +import Polysemy.IO (embedToMonadIO) +import Servant + +type API = CurrentUser + +type CurrentUser = + "auth" + :> "users" + :> "current" + -- The user is logged in if the refresh_token is still active. + :> Header "Cookie" Text + :> Get '[JSON] UserStatusResponse + +newtype UserStatusResponse = UserStatusResponse + { rData :: UserStatus + } + deriving (Generic) + +data UserStatus = UserStatus + { rFull_name :: Text, + rEmail :: Text, + -- TODO: Use generate letter icon. + rPhoto :: Text + } + deriving (Generic) + +defaultUserStatus :: Text -> UserStatusResponse +defaultUserStatus u = + UserStatusResponse + { rData = + UserStatus + { rFull_name = u, + rEmail = u <> "@hakatime.dev", + rPhoto = "" + } + } + +instance ToJSON UserStatusResponse where + toJSON = genericToJSON noPrefixOptions + +instance ToJSON UserStatus where + toJSON = genericToJSON noPrefixOptions + +instance FromJSON UserStatus where + parseJSON = genericParseJSON noPrefixOptions + +instance FromJSON UserStatusResponse where + parseJSON = genericParseJSON noPrefixOptions + +server :: Maybe Text -> AppM UserStatusResponse +server Nothing = throw Err.missingRefreshTokenCookie +server (Just cookies) = do + p <- asks pool + + let refreshTkn = + getRefreshToken (encodeUtf8 cookies) + + when (isNothing refreshTkn) (throw Err.missingRefreshTokenCookie) + + res <- + runM + . embedToMonadIO + . runError + $ DbOps.interpretDatabaseIO $ + DbOps.getUserByRefreshToken p (fromJust refreshTkn) + + case res of + Left e -> do + $(logTM) ErrorS (logStr $ show e) + throw (DbOps.toJSONError e) + Right userM -> do + case userM of + Nothing -> throw Err.expiredToken + Just u -> return $ defaultUserStatus u diff --git a/src/Haka/Utils.hs b/src/Haka/Utils.hs index b688c94..6221822 100644 --- a/src/Haka/Utils.hs +++ b/src/Haka/Utils.hs @@ -2,6 +2,7 @@ module Haka.Utils ( toStrError, + getRefreshToken, passwordInput, defaultLimit, randomToken, @@ -15,6 +16,7 @@ module Haka.Utils where import Control.Exception (bracket_) +import qualified Data.ByteString as Bs import Data.ByteString.Base64 (encode) import Data.Int (Int64) import Data.Text (Text, pack, splitOn) @@ -25,7 +27,9 @@ import qualified Data.UUID as UUID import Data.UUID.V4 (nextRandom) import Hasql.Pool (UsageError (..)) import qualified Hasql.Session as S +import Safe (headMay) import System.IO (hFlush, hGetEcho, hSetEcho, stdin, stdout) +import Web.Cookie defaultLimit :: Int64 defaultLimit = 15 @@ -70,7 +74,7 @@ data EditorInfo = EditorInfo } deriving (Show) --- / Parse the user agent string & extract the editor & plugin name/version pair. +-- | Parse the user agent string & extract the editor & plugin name/version pair. userAgentInfo :: Text -> EditorInfo userAgentInfo userAgent = EditorInfo @@ -137,3 +141,10 @@ toStrError ) ) = err toStrError err = pack $ show err + +getRefreshToken :: Bs.ByteString -> Maybe Text +getRefreshToken cookies = + let value = headMay $ map snd $ filter (\(k, _) -> k == "refresh_token") (parseCookies cookies) + in case value of + Just v -> Just $ decodeUtf8 v + Nothing -> Nothing