Add /auth/users/current endpoint for chrome-wakatime compatibility (#6)

hakatime.cabal

@@ -64,6 +64,7 @@ library libhaka
                      , Haka.Stats
                      , Haka.Users
                      , Haka.Utils
+                     , Haka.PasswordUtils
                      , Paths_hakatime
 
   autogen-modules:     Paths_hakatime

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)

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

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

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

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