module Web.Users.Types
(
UserStorageBackend (..)
, User(..), Password(..), makePassword, hidePassword
, PasswordPlain(..), verifyPassword
, UserField(..)
, PasswordResetToken(..), ActivationToken(..), SessionId(..)
, CreateUserError(..), UpdateUserError(..)
, TokenError(..)
, SortBy(..)
)
where
import Crypto.BCrypt
import Data.Aeson
import Data.Int
import Data.Maybe
import Data.String
import Data.Time.Clock
import Data.Typeable
import Web.PathPieces
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified System.IO.Unsafe as U
data CreateUserError
= InvalidPassword
| UsernameAlreadyTaken
| EmailAlreadyTaken
| UsernameAndEmailAlreadyTaken
deriving (Show, Eq)
data UpdateUserError
= UsernameAlreadyExists
| EmailAlreadyExists
| UserDoesntExist
deriving (Show, Eq)
data TokenError
= TokenInvalid
deriving (Show, Eq)
data SortBy t
= SortAsc t
| SortDesc t
type IsUserBackend b =
( Show (UserId b)
, Eq (UserId b)
, ToJSON (UserId b)
, FromJSON (UserId b)
, Typeable (UserId b)
, PathPiece (UserId b)
)
class IsUserBackend b => UserStorageBackend b where
type UserId b :: *
initUserBackend :: b -> IO ()
destroyUserBackend :: b -> IO ()
housekeepBackend :: b -> IO ()
getUserIdByName :: b -> T.Text -> IO (Maybe (UserId b))
getUserById :: b -> UserId b -> IO (Maybe User)
listUsers :: b -> Maybe (Int64, Int64) -> SortBy UserField -> IO [(UserId b, User)]
countUsers :: b -> IO Int64
createUser :: b -> User -> IO (Either CreateUserError (UserId b))
updateUser :: b -> UserId b -> (User -> User) -> IO (Either UpdateUserError ())
deleteUser :: b -> UserId b -> IO ()
authUser :: b -> T.Text -> PasswordPlain -> NominalDiffTime -> IO (Maybe SessionId)
withAuthUser :: b -> T.Text -> (User -> Bool) -> (UserId b -> IO r) -> IO (Maybe r)
verifySession :: b -> SessionId -> NominalDiffTime -> IO (Maybe (UserId b))
createSession :: b -> UserId b -> NominalDiffTime -> IO (Maybe SessionId)
destroySession :: b -> SessionId -> IO ()
requestPasswordReset :: b -> UserId b -> NominalDiffTime -> IO PasswordResetToken
verifyPasswordResetToken :: b -> PasswordResetToken -> IO (Maybe User)
applyNewPassword :: b -> PasswordResetToken -> Password -> IO (Either TokenError ())
requestActivationToken :: b -> UserId b -> NominalDiffTime -> IO ActivationToken
activateUser :: b -> ActivationToken -> IO (Either TokenError ())
newtype PasswordResetToken
= PasswordResetToken { unPasswordResetToken :: T.Text }
deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece)
newtype ActivationToken
= ActivationToken { unActivationToken :: T.Text }
deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece)
newtype SessionId
= SessionId { unSessionId :: T.Text }
deriving (Show, Eq, ToJSON, FromJSON, Typeable, PathPiece)
makePassword :: PasswordPlain -> Password
makePassword (PasswordPlain plainText) =
let hash =
T.decodeUtf8 $ fromJustPass $ U.unsafePerformIO $
hashPasswordUsingPolicy policy (T.encodeUtf8 plainText)
in PasswordHash hash
where
policy =
HashingPolicy
{ preferredHashCost = 8
, preferredHashAlgorithm = "$2b$"
}
fromJustPass =
fromMaybe (error "makePassword failed. This is probably a bcrypt library error")
verifyPassword :: PasswordPlain -> Password -> Bool
verifyPassword (PasswordPlain plainText) pwd =
case pwd of
PasswordHidden -> False
PasswordHash hash ->
validatePassword (T.encodeUtf8 hash) (T.encodeUtf8 plainText)
newtype PasswordPlain
= PasswordPlain { unPasswordPlain :: T.Text }
deriving (Show, Eq, Typeable, IsString)
data Password
= PasswordHash !T.Text
| PasswordHidden
deriving (Show, Eq, Typeable)
hidePassword :: User -> User
hidePassword user =
user { u_password = PasswordHidden }
data UserField
= UserFieldId
| UserFieldName
| UserFieldEmail
| UserFieldPassword
| UserFieldActive
deriving (Show, Eq)
data User
= User
{ u_name :: !T.Text
, u_email :: !T.Text
, u_password :: !Password
, u_active :: !Bool
} deriving (Show, Eq, Typeable)
instance ToJSON User where
toJSON (User name email _ active) =
object
[ "name" .= name
, "email" .= email
, "active" .= active
]
instance FromJSON User where
parseJSON =
withObject "User" $ \obj ->
User <$> obj .: "name"
<*> obj .: "email"
<*> (parsePassword <$> (obj .:? "password"))
<*> obj .: "active"
where
parsePassword maybePass =
case maybePass of
Nothing -> PasswordHidden
Just pwd -> makePassword (PasswordPlain pwd)