start-os/agent/src/Lib/Password.hs

module Lib.Password where

import           Startlude
import           Yesod.Auth.Util.PasswordStore  ( makePassword
                                                , verifyPassword
                                                , passwordStrength
                                                )
import qualified Data.ByteString.Char8         as BS
                                                ( pack
                                                , unpack
                                                )
import           Data.Text                      ( pack
                                                , unpack
                                                )

import           Model

-- Root account identifier
rootAccountName :: Text
rootAccountName = "embassy-root"


-- | Default strength used for passwords (see "Yesod.Auth.Util.PasswordStore"
--   for details).
defaultStrength :: Int
defaultStrength = 17

-- | The type representing account information stored in the database should
--   be an instance of this class.  It just provides the getter and setter
--   used by the functions in this module.
class HasPasswordHash account where
    getPasswordHash :: account -> Text
    setPasswordHash :: Text -> account -> account

    {-# MINIMAL getPasswordHash, setPasswordHash #-}


-- | Calculate a new-style password hash using "Yesod.Auth.Util.PasswordStore".
passwordHash :: MonadIO m => Int -> Text -> m Text
passwordHash strength pwd = do
    h <- liftIO $ makePassword (BS.pack $ unpack pwd) strength
    return $ pack $ BS.unpack h

-- | Set password for account, using the given strength setting. Use this
--   function, or 'setPassword', to produce a account record containing the
--   hashed password.  Unlike previous versions of this module, no separate
--   salt field is required for new passwords (but it may still be required
--   for compatibility while old password hashes remain in the database).
--
--   This function does not change the database; the calling application
--   is responsible for saving the data which is returned.
setPasswordStrength :: (MonadIO m, HasPasswordHash account) => Int -> Text -> account -> m account
setPasswordStrength strength pwd u = do
    hashed <- passwordHash strength pwd
    return $ setPasswordHash hashed u

-- | As 'setPasswordStrength', but using the 'defaultStrength'
setPassword :: (MonadIO m, HasPasswordHash account) => Text -> account -> m account
setPassword = setPasswordStrength defaultStrength

validatePass :: HasPasswordHash u => u -> Text -> Bool
validatePass account password = do
    let h = getPasswordHash account
    -- NB plaintext password characters are truncated to 8 bits here,
    -- and also in passwordHash above (the hash is already 8 bit).
    -- This is for historical compatibility, but in practice it is
    -- unlikely to reduce the entropy of most users' alphabets by much.
    let hash'     = BS.pack $ unpack h
        password' = BS.pack $ unpack password
    if passwordStrength hash' > 0
        -- Will give >0 for valid hash format, else treat as if wrong password
        then verifyPassword password' hash'
        else False

instance HasPasswordHash Account where
    getPasswordHash = accountPassword
    setPasswordHash h u = u { accountPassword = h }