module Web.Users.Types
(
UserStorageBackend (..)
, User(..), Password(..), makePassword, hidePassword
, PasswordPlain(..), verifyPassword
, PasswordResetToken(..), ActivationToken(..), SessionId(..)
, CreateUserError(..), UpdateUserError(..)
, TokenError(..)
)
where
import Control.Applicative
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
= UsernameOrEmailAlreadyTaken
| InvalidPassword
deriving (Show, Eq)
data UpdateUserError
= UsernameOrEmailAlreadyExists
| UserDoesntExit
deriving (Show, Eq)
data TokenError
= TokenInvalid
deriving (Show, Eq)
class (Show (UserId b), Eq (UserId b), ToJSON (UserId b), FromJSON (UserId b), Typeable (UserId b), PathPiece (UserId b)) => UserStorageBackend b where
type UserId b :: *
initUserBackend :: b -> IO ()
destroyUserBackend :: b -> IO ()
housekeepBackend :: b -> IO ()
getUserById :: (FromJSON a, ToJSON a) => b -> UserId b -> IO (Maybe (User a))
listUsers :: (FromJSON a, ToJSON a) => b -> Maybe (Int64, Int64) -> IO [(UserId b, User a)]
countUsers :: b -> IO Int64
createUser :: (FromJSON a, ToJSON a) => b -> User a -> IO (Either CreateUserError (UserId b))
updateUser :: (FromJSON a, ToJSON a) => b -> UserId b -> (User a -> User a) -> IO (Either UpdateUserError ())
updateUserDetails :: (FromJSON a, ToJSON a) => b -> UserId b -> (a -> a) -> IO ()
updateUserDetails backend userId f =
do _ <-
updateUser backend userId $
\user ->
user
{ u_more = f (u_more user)
}
return ()
deleteUser :: b -> UserId b -> IO ()
authUser :: b -> T.Text -> PasswordPlain -> NominalDiffTime -> IO (Maybe SessionId)
verifySession :: b -> SessionId -> NominalDiffTime -> IO (Maybe (UserId b))
destroySession :: b -> SessionId -> IO ()
requestPasswordReset :: b -> UserId b -> NominalDiffTime -> IO PasswordResetToken
verifyPasswordResetToken :: (FromJSON a, ToJSON a) => b -> PasswordResetToken -> IO (Maybe (User a))
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 a -> User a
hidePassword user =
user { u_password = PasswordHidden }
data User a
= User
{ u_name :: !T.Text
, u_email :: !T.Text
, u_password :: !Password
, u_active :: !Bool
, u_more :: !a
} deriving (Show, Eq, Typeable)
instance ToJSON a => ToJSON (User a) where
toJSON (User name email _ active more) =
object
[ "name" .= name
, "email" .= email
, "active" .= active
, "more" .= more
]
instance FromJSON a => FromJSON (User a) where
parseJSON =
withObject "User" $ \obj ->
User <$> obj .: "name"
<*> obj .: "email"
<*> (parsePassword <$> (obj .:? "password"))
<*> obj .: "active"
<*> obj .: "more"
where
parsePassword maybePass =
case maybePass of
Nothing -> PasswordHidden
Just pwd -> makePassword (PasswordPlain pwd)