diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.1.0.0 +======= + +* Initial publication diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Anton Gushcha (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of NCrashed nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +# servant-auth-token + +The repo contains server implementation of [servant-auth-toke-api](https://github.com/NCrashed/servant-auth-token-api). + +# How to add to your server + +To use the server as constituent part, you need to provide customised 'AuthConfig' for +'authServer' function and implement 'AuthMonad' instance for your handler monad. + +``` haskell +import Servant.Server.Auth.Token as Auth + +-- | Example of user side configuration +data Config = Config { + -- | Authorisation specific configuration + authConfig :: AuthConfig + -- other fields + -- ... +} + +-- | Example of user side handler monad +newtype App a = App { + runApp :: ReaderT Config (ExceptT ServantErr IO) a + } deriving ( Functor, Applicative, Monad, MonadReader Config, + MonadError ServantErr, MonadIO) + +-- | Now you can use authorisation API in your handler +instance AuthMonad App where + getAuthConfig = asks authConfig + liftAuthAction = App . lift + +-- | Include auth 'migrateAll' function into your migration code +doMigrations :: SqlPersistT IO () +doMigrations = runMigrationUnsafe $ do + migrateAll -- other user migrations + Auth.migrateAll -- creation of authorisation entities + -- optional creation of default admin if db is empty + ensureAdmin 17 "admin" "123456" "admin@localhost" +``` + +Now you can use 'guardAuthToken' to check authorisation headers in endpoints of your server: + +``` haskell +-- | Read a single customer from DB +customerGet :: CustomerId -- ^ Customer unique id + -> MToken '["customer-read"] -- ^ Required permissions for auth token + -> App Customer -- ^ Customer data +customerGet i token = do + guardAuthToken token + runDB404 "customer" $ getCustomer i +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth-token.cabal b/servant-auth-token.cabal new file mode 100644 --- /dev/null +++ b/servant-auth-token.cabal @@ -0,0 +1,67 @@ +name: servant-auth-token +version: 0.1.0.0 +synopsis: Servant based API and server for token based authorisation +description: Please see README.md +homepage: https://github.com/ncrashed/servant-auth-token#readme +license: BSD3 +license-file: LICENSE +author: NCrashed +maintainer: ncrashed@gmail.com +copyright: 2016 Anton Gushcha +category: Web +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + Servant.Server.Auth.Token.Common + Servant.Server.Auth.Token.Config + Servant.Server.Auth.Token.Error + Servant.Server.Auth.Token.Model + Servant.Server.Auth.Token.Monad + Servant.Server.Auth.Token.Pagination + Servant.Server.Auth.Token.Patch + Servant.Server.Auth.Token.Restore + Servant.Server.Auth.Token + build-depends: + base >= 4.7 && < 5 + , aeson-injector >= 1.0.2 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , mtl >= 2.2 && < 2.3 + , persistent >= 2.2 && < 2.3 + , persistent-postgresql >= 2.2 && < 2.3 + , persistent-template >= 2.1 && < 2.2 + , pwstore-fast >= 2.4 && < 2.5 + , servant-auth-token-api >= 0.1.2 && < 0.2 + , servant-server >= 0.7 && < 0.9 + , text >= 1.2 && < 1.3 + , time >= 1.5 && < 1.7 + , transformers >= 0.4 && < 0.6 + , uuid >= 1.3 && < 1.4 + + default-language: Haskell2010 + default-extensions: + BangPatterns + DataKinds + DeriveGeneric + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + KindSignatures + MultiParamTypeClasses + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TupleSections + TypeFamilies + TypeOperators + +source-repository head + type: git + location: https://github.com/ncrashed/servant-auth-token diff --git a/src/Servant/Server/Auth/Token.hs b/src/Servant/Server/Auth/Token.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token.hs @@ -0,0 +1,447 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module : Servant.Server.Auth.Token +Description : Implementation of token authorisation API +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable + +The module is server side implementation of "Servant.API.Auth.Token" API and intended to be +used as drop in module for user servers or as external micro service. + +To use the server as constituent part, you need to provide customised 'AuthConfig' for +'authServer' function and implement 'AuthMonad' instance for your handler monad. + +@ +import Servant.Server.Auth.Token as Auth + +-- | Example of user side configuration +data Config = Config { + -- | Authorisation specific configuration + authConfig :: AuthConfig + -- other fields + -- ... +} + +-- | Example of user side handler monad +newtype App a = App { + runApp :: ReaderT Config (ExceptT ServantErr IO) a + } deriving ( Functor, Applicative, Monad, MonadReader Config, + MonadError ServantErr, MonadIO) + +-- | Now you can use authorisation API in your handler +instance AuthMonad App where + getAuthConfig = asks authConfig + liftAuthAction = App . lift + +-- | Include auth 'migrateAll' function into your migration code +doMigrations :: SqlPersistT IO () +doMigrations = runMigrationUnsafe $ do + migrateAll -- other user migrations + Auth.migrateAll -- creation of authorisation entities + -- optional creation of default admin if db is empty + ensureAdmin 17 "admin" "123456" "admin@localhost" +@ + +Now you can use 'guardAuthToken' to check authorisation headers in endpoints of your server: + +@ +-- | Read a single customer from DB +customerGet :: CustomerId -- ^ Customer unique id + -> MToken '["customer-read"] -- ^ Required permissions for auth token + -> App Customer -- ^ Customer data +customerGet i token = do + guardAuthToken token + runDB404 "customer" $ getCustomer i +@ + +-} +module Servant.Server.Auth.Token( + -- * Implementation + authServer + -- * Server API + , migrateAll + , AuthMonad(..) + -- * Helpers + , guardAuthToken + , ensureAdmin + , authUserByToken + ) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Crypto.PasswordStore +import Data.Aeson.WithField +import Data.Maybe +import Data.Monoid +import Data.Text.Encoding +import Data.Time.Clock +import Data.UUID +import Data.UUID.V4 +import Database.Persist.Postgresql +import Servant + +import Servant.API.Auth.Token +import Servant.API.Auth.Token.Pagination +import Servant.Server.Auth.Token.Common +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Model +import Servant.Server.Auth.Token.Monad +import Servant.Server.Auth.Token.Pagination +import Servant.Server.Auth.Token.Restore + +import qualified Data.ByteString.Lazy as BS + +-- | This function converts our 'AuthHandler' monad into the @ExceptT ServantErr +-- IO@ monad that Servant's 'enter' function needs in order to run the +-- application. The ':~>' type is a natural transformation, or, in +-- non-category theory terms, a function that converts two type +-- constructors without looking at the values in the types. +convertAuthHandler :: AuthConfig -> AuthHandler :~> ExceptT ServantErr IO +convertAuthHandler cfg = Nat (flip runReaderT cfg . runAuthHandler) + +-- | The interface your application should implement to be able to use +-- token aurhorisation API. +class Monad m => AuthMonad m where + getAuthConfig :: m AuthConfig + liftAuthAction :: ExceptT ServantErr IO a -> m a + +instance AuthMonad AuthHandler where + getAuthConfig = getConfig + liftAuthAction = AuthHandler . lift + +-- | Helper to run handler in 'AuthMonad' context +runAuth :: AuthMonad m => AuthHandler a -> m a +runAuth m = do + cfg <- getAuthConfig + let Nat conv = convertAuthHandler cfg + liftAuthAction $ conv m + +-- | Implementation of AuthAPI +authServer :: AuthConfig -> Server AuthAPI +authServer cfg = enter (convertAuthHandler cfg) ( + authSignin + :<|> authTouch + :<|> authToken + :<|> authSignout + :<|> authSignup + :<|> authUsersInfo + :<|> authUserInfo + :<|> authUserPatch + :<|> authUserPut + :<|> authUserDelete + :<|> authRestore + :<|> authGroupGet + :<|> authGroupPost + :<|> authGroupPut + :<|> authGroupPatch + :<|> authGroupDelete + :<|> authGroupList) + +-- | Implementation of "signin" method +authSignin :: Maybe Login -- ^ Login query parameter + -> Maybe Password -- ^ Password query parameter + -> Maybe Seconds -- ^ Expire query parameter, how many seconds the token is valid + -> AuthHandler (OnlyField "token" SimpleToken) -- ^ If everthing is OK, return token +authSignin mlogin mpass mexpire = do + login <- require "login" mlogin + pass <- require "pass" mpass + Entity uid UserImpl{..} <- guardLogin login pass + expire <- calcExpire mexpire + mt <- getExistingToken uid -- check whether there is already existing token + OnlyField <$> case mt of + Nothing -> createToken uid expire -- create new token + Just t -> touchToken t expire -- prolong token expiration time + where + guardLogin login pass = do -- check login and password, return passed user + muser <- runDB $ selectFirst [UserImplLogin ==. login] [] + let err = throw401 "Cannot find user with given combination of login and pass" + case muser of + Nothing -> err + Just user@(Entity _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword + then return user + else err + + getExistingToken uid = do -- return active token for specified user id + t <- liftIO getCurrentTime + runDB $ selectFirst [AuthTokenUser ==. uid, AuthTokenExpire >. t] [] + + createToken uid expire = do -- generate and save fresh token + token <- toText <$> liftIO nextRandom + _ <- runDB $ insert AuthToken { + authTokenValue = token + , authTokenUser = uid + , authTokenExpire = expire + } + return token + +-- | Calculate expiration timestamp for token +calcExpire :: Maybe Seconds -> AuthHandler UTCTime +calcExpire mexpire = do + t <- liftIO getCurrentTime + AuthConfig{..} <- getConfig + let requestedExpire = maybe defaultExpire fromIntegral mexpire + let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire + return $ boundedExpire `addUTCTime` t + +-- prolong token with new timestamp +touchToken :: Entity AuthToken -> UTCTime -> AuthHandler SimpleToken +touchToken (Entity tid tok) expire = do + runDB $ replace tid tok { + authTokenExpire = expire + } + return $ authTokenValue tok + +-- | Implementation of "touch" method +authTouch :: Maybe Seconds -- ^ Expire query parameter, how many seconds the token should be valid by now. 'Nothing' means default value defined in server config. + -> MToken '[] -- ^ Authorisation header with token + -> AuthHandler () +authTouch mexpire token = do + Entity i mt <- guardAuthToken' (fmap unToken token) [] + expire <- calcExpire mexpire + runDB $ replace i mt { authTokenExpire = expire } + +-- | Implementation of "token" method, return +-- info about user binded to the token +authToken :: MToken '[] -- ^ Authorisation header with token + -> AuthHandler RespUserInfo +authToken token = do + i <- authUserByToken token + runDB404 "user" . readUserInfo . fromKey $ i + +-- | Getting user id by token +authUserByToken :: AuthMonad m => MToken '[] -> m UserImplId +authUserByToken token = runAuth $ do + Entity _ mt <- guardAuthToken' (fmap unToken token) [] + return $ authTokenUser mt + +-- | Implementation of "signout" method +authSignout :: Maybe (Token '[]) -- ^ Authorisation header with token + -> AuthHandler () +authSignout token = do + Entity i mt <- guardAuthToken' (fmap unToken token) [] + expire <- liftIO getCurrentTime + runDB $ replace i mt { authTokenExpire = expire } + +-- | Checks given password and if it is invalid in terms of config +-- password validator, throws 400 error. +guardPassword :: Password -> AuthHandler () +guardPassword p = do + AuthConfig{..} <- getConfig + whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8 + +-- | Implementation of "signup" method +authSignup :: ReqRegister -- ^ Registration info + -> MToken '["auth-register"] -- ^ Authorisation header with token + -> AuthHandler (OnlyField "user" UserId) +authSignup ReqRegister{..} token = do + guardAuthToken token + guardUserInfo + guardPassword reqRegPassword + strength <- getsConfig passwordsStrength + i <- runDB $ do + i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions + whenJust reqRegGroups $ setUserGroups i + return i + return $ OnlyField . fromKey $ i + where + guardUserInfo = do + c <- runDB $ count [UserImplLogin ==. reqRegLogin] + when (c > 0) $ throw400 "User with specified id is already registered" + +-- | Implementation of get "users" method +authUsersInfo :: Maybe Page -- ^ Page num parameter + -> Maybe PageSize -- ^ Page size parameter + -> MToken '["auth-info"] -- ^ Authorisation header with token + -> AuthHandler RespUsersInfo +authUsersInfo mp msize token = do + guardAuthToken token + pagination mp msize $ \page size -> do + (users, total) <- runDB $ (,) + <$> (do + users <- selectList [] [Asc UserImplId, OffsetBy (fromIntegral $ page * size), LimitTo (fromIntegral size)] + perms <- mapM (getUserPermissions . entityKey) users + groups <- mapM (getUserGroups . entityKey) users + return $ zip3 users perms groups) + <*> count ([] :: [Filter UserImpl]) + return RespUsersInfo { + respUsersItems = (\(user, perms, groups) -> userToUserInfo user perms groups) <$> users + , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size + } + +-- | Implementation of get "user" method +authUserInfo :: UserId -- ^ User id + -> MToken '["auth-info"] -- ^ Authorisation header with token + -> AuthHandler RespUserInfo +authUserInfo uid' token = do + guardAuthToken token + runDB404 "user" $ readUserInfo uid' + +-- | Implementation of patch "user" method +authUserPatch :: UserId -- ^ User id + -> PatchUser -- ^ JSON with fields for patching + -> MToken '["auth-update"] -- ^ Authorisation header with token + -> AuthHandler () +authUserPatch uid' body token = do + guardAuthToken token + whenJust (patchUserPassword body) guardPassword + let uid = toSqlKey . fromIntegral $ uid' + user <- guardUser uid + strength <- getsConfig passwordsStrength + Entity _ user' <- runDB $ patchUser strength body $ Entity uid user + runDB $ replace uid user' + +-- | Implementation of put "user" method +authUserPut :: UserId -- ^ User id + -> ReqRegister -- ^ New user + -> MToken '["auth-update"] -- ^ Authorisation header with token + -> AuthHandler () +authUserPut uid' ReqRegister{..} token = do + guardAuthToken token + guardPassword reqRegPassword + let uid = toSqlKey . fromIntegral $ uid' + let user = UserImpl { + userImplLogin = reqRegLogin + , userImplPassword = "" + , userImplEmail = reqRegEmail + } + user' <- setUserPassword reqRegPassword user + runDB $ do + replace uid user' + setUserPermissions uid reqRegPermissions + whenJust reqRegGroups $ setUserGroups uid + +-- | Implementation of patch "user" method +authUserDelete :: UserId -- ^ User id + -> MToken '["auth-delete"] -- ^ Authorisation header with token + -> AuthHandler () +authUserDelete uid' token = do + guardAuthToken token + runDB $ deleteCascade (toKey uid' :: UserImplId) + +-- Generate new password for user. There is two phases, first, the method +-- is called without 'code' parameter. The system sends email with a restore code +-- to email. After that a call of the method with the code is needed to +-- change password. Need configured SMTP server. +authRestore :: UserId -- ^ User id + -> Maybe RestoreCode + -> Maybe Password + -> AuthHandler () +authRestore uid' mcode mpass = do + let uid = toKey uid' + user <- guardUser uid + case mcode of + Nothing -> do + dt <- getsConfig restoreExpire + t <- liftIO getCurrentTime + rc <- runDB $ getRestoreCode uid $ addUTCTime dt t + uinfo <- runDB404 "user" $ readUserInfo uid' + sendRestoreCode uinfo rc + Just code -> do + pass <- require "password" mpass + guardPassword pass + guardRestoreCode uid code + user' <- setUserPassword pass user + runDB $ replace uid user' + +-- | Getting user by id, throw 404 response if not found +guardUser :: UserImplId -> AuthHandler UserImpl +guardUser uid = do + muser <- runDB $ get uid + case muser of + Nothing -> throw404 "User not found" + Just user -> return user + +-- | If the token is missing or the user of the token +-- doesn't have needed permissions, throw 401 response +guardAuthToken :: forall perms m . (PermsList perms, AuthMonad m) => MToken perms -> m () +guardAuthToken mt = runAuth $ void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms) + +-- | Same as `guardAuthToken` but returns record about the token +guardAuthToken' :: Maybe SimpleToken -> [Permission] -> AuthHandler (Entity AuthToken) +guardAuthToken' Nothing _ = throw401 "Token required" +guardAuthToken' (Just token) perms = do + t <- liftIO getCurrentTime + mt <- runDB $ selectFirst [AuthTokenValue ==. token] [] + case mt of + Nothing -> throw401 "Token is not valid" + Just et@(Entity _ AuthToken{..}) -> do + when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" } + mu <- runDB $ get authTokenUser + case mu of + Nothing -> throw500 "User of the token doesn't exist" + Just UserImpl{..} -> do + isAdmin <- runDB $ hasPerm authTokenUser adminPerm + hasAllPerms <- runDB $ hasPerms authTokenUser perms + unless (isAdmin || hasAllPerms) $ throw401 $ + "User doesn't have all required permissions: " <> showb perms + return et + +-- | Rehash password for user +setUserPassword :: Password -> UserImpl -> AuthHandler UserImpl +setUserPassword pass user = do + strength <- getsConfig passwordsStrength + setUserPassword' strength pass user + +-- | Getting info about user group, requires 'authInfoPerm' for token +authGroupGet :: UserGroupId + -> MToken '["auth-info"] -- ^ Authorisation header with token + -> AuthHandler UserGroup +authGroupGet i token = do + guardAuthToken token + runDB404 "user group" $ readUserGroup i + +-- | Inserting new user group, requires 'authUpdatePerm' for token +authGroupPost :: UserGroup + -> MToken '["auth-update"] -- ^ Authorisation header with token + -> AuthHandler (OnlyId UserGroupId) +authGroupPost ug token = do + guardAuthToken token + runDB $ OnlyField <$> insertUserGroup ug + +-- | Replace info about given user group, requires 'authUpdatePerm' for token +authGroupPut :: UserGroupId + -> UserGroup + -> MToken '["auth-update"] -- ^ Authorisation header with token + -> AuthHandler () +authGroupPut i ug token = do + guardAuthToken token + runDB $ updateUserGroup i ug + +-- | Patch info about given user group, requires 'authUpdatePerm' for token +authGroupPatch :: UserGroupId + -> PatchUserGroup + -> MToken '["auth-update"] -- ^ Authorisation header with token + -> AuthHandler () +authGroupPatch i up token = do + guardAuthToken token + runDB $ patchUserGroup i up + +-- | Delete all info about given user group, requires 'authDeletePerm' for token +authGroupDelete :: UserGroupId + -> MToken '["auth-delete"] -- ^ Authorisation header with token + -> AuthHandler () +authGroupDelete i token = do + guardAuthToken token + runDB $ deleteUserGroup i + +-- | Get list of user groups, requires 'authInfoPerm' for token +authGroupList :: Maybe Page + -> Maybe PageSize + -> MToken '["auth-info"] -- ^ Authorisation header with token + -> AuthHandler (PagedList UserGroupId UserGroup) +authGroupList mp msize token = do + guardAuthToken token + pagination mp msize $ \page size -> do + (groups, total) <- runDB $ (,) + <$> (do + is <- selectKeysList [] [Asc AuthUserGroupId, OffsetBy (fromIntegral $ page * size), LimitTo (fromIntegral size)] + forM is $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey) + <*> count ([] :: [Filter AuthUserGroup]) + return PagedList { + pagedListItems = catMaybes groups + , pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size + } diff --git a/src/Servant/Server/Auth/Token/Common.hs b/src/Servant/Server/Auth/Token/Common.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Common.hs @@ -0,0 +1,43 @@ +{-| +Module : Servant.Server.Auth.Token.Common +Description : Internal utilities +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.Common where + +import Database.Persist.Sql + +import qualified Data.Text as T +import qualified Data.ByteString.Lazy.Char8 as BSL + +-- | Helper to print a value to lazy bytestring +showb :: Show a => a -> BSL.ByteString +showb = BSL.pack . show + +-- | Helper to print a value to text +showt :: Show a => a -> T.Text +showt = T.pack . show + +-- | Do something when first value is 'Nothing' +whenNothing :: Applicative m => Maybe a -> m () -> m () +whenNothing Nothing m = m +whenNothing (Just _) _ = pure () + +-- | Do something when first value is 'Just' +whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust Nothing _ = pure () +whenJust (Just x) m = m x + +-- | Shortcut to convert sql key +fromKey :: (Integral a, ToBackendKey SqlBackend record) + => Key record -> a +fromKey = fromIntegral . fromSqlKey + +-- | Shortcut to convert sql key +toKey :: (Integral a, ToBackendKey SqlBackend record) + => a -> Key record +toKey = toSqlKey . fromIntegral diff --git a/src/Servant/Server/Auth/Token/Config.hs b/src/Servant/Server/Auth/Token/Config.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Config.hs @@ -0,0 +1,69 @@ +{-| +Module : Servant.Server.Auth.Token.Config +Description : Configuration of auth server +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.Config( + AuthConfig(..) + , defaultAuthConfig + ) where + +import Data.Text (Text) +import Data.Time +import Database.Persist.Sql +import Servant.Server + +import Servant.API.Auth.Token + +-- | Configuration specific for authorisation system +data AuthConfig = AuthConfig { + -- | Get database connection pool + getPool :: ConnectionPool + -- | For authorisation, defines amounts of seconds + -- when token becomes invalid. + , defaultExpire :: !NominalDiffTime + -- | For password restore, defines amounts of seconds + -- when restore code becomes invalid. + , restoreExpire :: !NominalDiffTime + -- | Upper bound of expiration time that user can request + -- for a token. + , maximumExpire :: !(Maybe NominalDiffTime) + -- | For authorisation, defines amount of hashing + -- of new user passwords (should be greater or equal 14). + -- The passwords hashed 2^strength times. It is needed to + -- prevent almost all kinds of bruteforce attacks, rainbow + -- tables and dictionary attacks. + , passwordsStrength :: !Int + -- | Validates user password at registration / password change. + -- + -- If the function returns 'Just', then a 400 error is raised with + -- specified text. + -- + -- Default value doesn't validate passwords at all. + , passwordValidator :: !(Text -> Maybe Text) + -- | Transformation of errors produced by the auth server + , servantErrorFormer :: !(ServantErr -> ServantErr) + -- | Default size of page for pagination + , defaultPageSize :: !Word + -- | User specified implementation of restore code sending. It could + -- be a email sender or sms message or mobile application method, whatever + -- the implementation needs. + , restoreCodeSender :: !(RespUserInfo -> RestoreCode -> IO ()) + } + +defaultAuthConfig :: ConnectionPool -> AuthConfig +defaultAuthConfig pool = AuthConfig { + getPool = pool + , defaultExpire = fromIntegral (600 :: Int) + , restoreExpire = fromIntegral (3*24*3600 :: Int) -- 3 days + , maximumExpire = Nothing + , passwordsStrength = 17 + , passwordValidator = const Nothing + , servantErrorFormer = id + , defaultPageSize = 50 + , restoreCodeSender = const $ const $ return () + } diff --git a/src/Servant/Server/Auth/Token/Error.hs b/src/Servant/Server/Auth/Token/Error.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Error.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} +{-| +Module : Servant.Server.Auth.Token.Error +Description : Utilities to wrap errors +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.Error( + throw400 + , throw401 + , throw404 + , throw409 + , throw500 + ) where + +import Control.Monad.Except +import Control.Monad.Reader.Class +import Servant.Server +import Servant.Server.Auth.Token.Config + +import qualified Data.ByteString.Lazy as BS + +-- | Prepare error response +makeBody :: MonadReader AuthConfig m => ServantErr -> m ServantErr +makeBody e = do + f <- asks servantErrorFormer + return $ f e + +throw400, throw401, throw404, throw409, throw500 + :: (MonadError ServantErr m, MonadReader AuthConfig m) + => BS.ByteString -> m a +throw400 t = throwError =<< makeBody err400 { errBody = t } +throw401 t = throwError =<< makeBody err401 { errBody = t } +throw404 t = throwError =<< makeBody err404 { errBody = t } +throw409 t = throwError =<< makeBody err409 { errBody = t } +throw500 t = throwError =<< makeBody err500 { errBody = t } diff --git a/src/Servant/Server/Auth/Token/Model.hs b/src/Servant/Server/Auth/Token/Model.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Model.hs @@ -0,0 +1,355 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-| +Module : Servant.Server.Auth.Token.Model +Description : Internal operations with RDBMS +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.Model( + -- * DB entities + UserImpl(..) + , UserPerm(..) + , AuthToken(..) + , UserRestore(..) + , AuthUserGroup(..) + , AuthUserGroupUsers(..) + , AuthUserGroupPerms(..) + , EntityField(..) + -- * IDs of entities + , UserImplId + , UserPermId + , AuthTokenId + , UserRestoreId + , AuthUserGroupId + , AuthUserGroupUsersId + , AuthUserGroupPermsId + -- * Operations + , runDB + , migrateAll + , passToByteString + , byteStringToPass + -- ** User + , userToUserInfo + , readUserInfo + , getUserPermissions + , setUserPermissions + , createUser + , hasPerm + , hasPerms + , createAdmin + , ensureAdmin + , patchUser + , setUserPassword' + -- ** User groups + , getUserGroups + , setUserGroups + , validateGroups + , getGroupPermissions + , getUserGroupPermissions + , getUserAllPermissions + , readUserGroup + , toAuthUserGroup + , insertUserGroup + , updateUserGroup + , deleteUserGroup + , patchUserGroup + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Crypto.PasswordStore +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import Data.Time +import Database.Persist.Postgresql +import Database.Persist.TH +import GHC.Generics + +import qualified Data.ByteString as BS +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.Sequence as S +import qualified Data.Text.Encoding as TE + +import Servant.API.Auth.Token +import Servant.Server.Auth.Token.Common +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Patch + +share [mkPersist sqlSettings + , mkDeleteCascade sqlSettings + , mkMigrate "migrateAll"] [persistLowerCase| +UserImpl + login Login + password Password -- encrypted with salt + email Email + UniqueLogin login + deriving Generic Show + +UserPerm + user UserImplId + permission Permission + deriving Generic Show + +AuthToken + value SimpleToken + user UserImplId + expire UTCTime + deriving Generic Show + +UserRestore + value RestoreCode + user UserImplId + expire UTCTime + deriving Generic Show + +AuthUserGroup + name Text + parent AuthUserGroupId Maybe + deriving Generic Show + +AuthUserGroupUsers + group AuthUserGroupId + user UserImplId + deriving Generic Show + +AuthUserGroupPerms + group AuthUserGroupId + permission Permission + deriving Generic Show +|] + +-- | Execute database transaction +runDB :: (MonadReader AuthConfig m, MonadIO m) => SqlPersistT IO b -> m b +runDB query = do + pool <- asks getPool + liftIO $ runSqlPool query pool + +passToByteString :: Password -> BS.ByteString +passToByteString = TE.encodeUtf8 + +byteStringToPass :: BS.ByteString -> Password +byteStringToPass = TE.decodeUtf8 + +-- | Helper to convert user to response +userToUserInfo :: Entity UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo +userToUserInfo (Entity uid UserImpl{..}) perms groups = RespUserInfo { + respUserId = fromIntegral $ fromSqlKey uid + , respUserLogin = userImplLogin + , respUserEmail = userImplEmail + , respUserPermissions = perms + , respUserGroups = groups + } + +-- | Get user by id +readUserInfo :: UserId -> SqlPersistT IO (Maybe RespUserInfo) +readUserInfo uid' = do + let uid = toKey uid' + muser <- get uid + case muser of + Nothing -> return Nothing + Just user -> do + perms <- getUserPermissions uid + groups <- getUserGroups uid + return . Just $ + userToUserInfo (Entity uid user) perms groups + +-- | Return list of permissions for the given user (only permissions that are assigned to him directly) +getUserPermissions :: UserImplId -> SqlPersistT IO [Permission] +getUserPermissions uid = do + perms <- selectList [UserPermUser ==. uid] [Asc UserPermPermission] + return $ userPermPermission . entityVal <$> perms + +-- | Return list of permissions for the given user +setUserPermissions :: UserImplId -> [Permission] -> SqlPersistT IO () +setUserPermissions uid perms = do + deleteWhere [UserPermUser ==. uid] + forM_ perms $ void . insert . UserPerm uid + +-- | Creation of new user +createUser :: Int -> Login -> Password -> Email -> [Permission] -> SqlPersistT IO UserImplId +createUser strength login pass email perms = do + pass' <- liftIO $ makePassword (passToByteString pass) strength + i <- insert UserImpl { + userImplLogin = login + , userImplPassword = byteStringToPass pass' + , userImplEmail = email + } + forM_ perms $ void . insert . UserPerm i + return i + +-- | Check whether the user has particular permission +hasPerm :: UserImplId -> Permission -> SqlPersistT IO Bool +hasPerm i perm = do + c <- count [UserPermUser ==. i, UserPermPermission ==. perm] + return $ c > 0 + +-- | Check whether the user has particular permissions +hasPerms :: UserImplId -> [Permission] -> SqlPersistT IO Bool +hasPerms _ [] = return True +hasPerms i perms = do + perms' <- getUserAllPermissions i + return $ and $ (`elem` perms') <$> perms + +-- | Creates user with admin privileges +createAdmin :: Int -> Login -> Password -> Email -> SqlPersistT IO UserImplId +createAdmin strength login pass email = createUser strength login pass email [adminPerm] + +-- | Ensures that DB has at leas one admin, if not, creates a new one +-- with specified info. +ensureAdmin :: Int -> Login -> Password -> Email -> SqlPersistT IO () +ensureAdmin strength login pass email = do + madmin <- selectFirst [UserPermPermission ==. adminPerm] [] + whenNothing madmin $ void $ createAdmin strength login pass email + +patchUser :: Int -> PatchUser -> Entity UserImpl -> SqlPersistT IO (Entity UserImpl) +patchUser strength PatchUser{..} = + withPatch patchUserLogin (\l (Entity i u) -> pure $ Entity i u { userImplLogin = l }) + >=> withPatch patchUserPassword patchPassword + >=> withPatch patchUserEmail (\e (Entity i u) -> pure $ Entity i u { userImplEmail = e }) + >=> withPatch patchUserPermissions patchPerms + >=> withPatch patchUserGroups patchGroups + where + patchPassword ps (Entity i u) = Entity <$> pure i <*> setUserPassword' strength ps u + patchPerms ps (Entity i u) = do + setUserPermissions i ps + return $ Entity i u + patchGroups gs (Entity i u) = do + setUserGroups i gs + return $ Entity i u + +setUserPassword' :: MonadIO m => Int -> Password -> UserImpl -> m UserImpl +setUserPassword' strength pass user = do + pass' <- liftIO $ makePassword (passToByteString pass) strength + return $ user { userImplPassword = byteStringToPass pass' } + +-- | Get all groups the user belongs to +getUserGroups :: UserImplId -> SqlPersistT IO [UserGroupId] +getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . entityVal) + <$> selectList [AuthUserGroupUsersUser ==. i] [Asc AuthUserGroupUsersGroup] + +-- | Rewrite all user groups +setUserGroups :: UserImplId -> [UserGroupId] -> SqlPersistT IO () +setUserGroups i gs = do + deleteWhere [AuthUserGroupUsersUser ==. i] + gs' <- validateGroups gs + forM_ gs' $ \g -> void $ insert (AuthUserGroupUsers g i) + +-- | Leave only existing groups +validateGroups :: [UserGroupId] -> SqlPersistT IO [AuthUserGroupId] +validateGroups is = do + pairs <- mapM ((\i -> (i,) <$> get i) . toKey) is + return $ fmap fst . filter (isJust . snd) $ pairs + +-- | Getting permission of a group and all it parent groups +getGroupPermissions :: UserGroupId -> SqlPersistT IO [Permission] +getGroupPermissions = go S.empty S.empty . toKey + where + go !visited !perms !i = do + mg <- get i + case mg of + Nothing -> return $ F.toList perms + Just AuthUserGroup{..} -> do + curPerms <- fmap (authUserGroupPermsPermission . entityVal) <$> + selectList [AuthUserGroupPermsGroup ==. i] [Asc AuthUserGroupPermsPermission] + let perms' = perms <> S.fromList curPerms + case authUserGroupParent of + Nothing -> return $ F.toList perms' + Just pid -> if isJust $ pid `S.elemIndexL` visited + then fail $ "Recursive user group graph: " <> show (visited S.|> pid) + else go (visited S.|> pid) perms' pid + +-- | Get user permissions that are assigned to him/her via groups only +getUserGroupPermissions :: UserImplId -> SqlPersistT IO [Permission] +getUserGroupPermissions i = do + groups <- getUserGroups i + perms <- mapM getGroupPermissions groups + return $ L.sort . L.nub . concat $ perms + +-- | Get user permissions that are assigned to him/her either by direct +-- way or by his/her groups. +getUserAllPermissions :: UserImplId -> SqlPersistT IO [Permission] +getUserAllPermissions i = do + permsDr <- getUserPermissions i + permsGr <- getUserGroupPermissions i + return $ L.sort . L.nub $ permsDr <> permsGr + +-- | Collect full info about user group from RDBMS +readUserGroup :: UserGroupId -> SqlPersistT IO (Maybe UserGroup) +readUserGroup i = do + let i' = toKey $ i + mu <- get i' + case mu of + Nothing -> return Nothing + Just AuthUserGroup{..} -> do + users <- fmap (authUserGroupUsersUser . entityVal) <$> + selectList [AuthUserGroupUsersGroup ==. i'] [Asc AuthUserGroupUsersUser] + perms <- fmap (authUserGroupPermsPermission . entityVal) <$> + selectList [AuthUserGroupPermsGroup ==. i'] [Asc AuthUserGroupPermsPermission] + return $ Just UserGroup { + userGroupName = authUserGroupName + , userGroupUsers = fromKey <$> users + , userGroupPermissions = perms + , userGroupParent = fromKey <$> authUserGroupParent + } + +-- | Helper to convert user group into values of several tables +toAuthUserGroup :: UserGroup -> (AuthUserGroup, AuthUserGroupId -> [AuthUserGroupUsers], AuthUserGroupId -> [AuthUserGroupPerms]) +toAuthUserGroup UserGroup{..} = (ag, users, perms) + where + ag = AuthUserGroup { + authUserGroupName = userGroupName + , authUserGroupParent = toKey <$> userGroupParent + } + users i = (\ui -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers + perms i = (\perm -> AuthUserGroupPerms i perm) <$> userGroupPermissions + +-- | Insert user group into RDBMS +insertUserGroup :: UserGroup -> SqlPersistT IO UserGroupId +insertUserGroup u = do + let (ag, users, perms) = toAuthUserGroup u + i <- insert ag + forM_ (users i) $ void . insert + forM_ (perms i) $ void . insert + return $ fromKey $ i + +-- | Replace user group with new value +updateUserGroup :: UserGroupId -> UserGroup -> SqlPersistT IO () +updateUserGroup i u = do + let i' = toKey $ i + let (ag, users, perms) = toAuthUserGroup u + replace i' ag + deleteWhere [AuthUserGroupUsersGroup ==. i'] + deleteWhere [AuthUserGroupPermsGroup ==. i'] + forM_ (users i') $ void . insert + forM_ (perms i') $ void . insert + +-- | Erase user group from RDBMS, cascade +deleteUserGroup :: UserGroupId -> SqlPersistT IO () +deleteUserGroup i = do + let i' = toKey $ i + deleteWhere [AuthUserGroupUsersGroup ==. i'] + deleteWhere [AuthUserGroupPermsGroup ==. i'] + deleteCascade i' + +-- | Partial update of user group +patchUserGroup :: UserGroupId -> PatchUserGroup -> SqlPersistT IO () +patchUserGroup i PatchUserGroup{..} = do + let i' = toKey $ i + patchName = (\n -> AuthUserGroupName =. n) <$> patchUserGroupName + patchParent = case patchUserGroupNoParent of + Just True -> Just $ AuthUserGroupParent =. Nothing + _ -> (\p -> AuthUserGroupParent =. Just (toSqlKey .fromIntegral $ p)) <$> patchUserGroupParent + update i' $ catMaybes [patchName, patchParent] + whenJust patchUserGroupUsers $ \uids -> do + deleteWhere [AuthUserGroupUsersGroup ==. i'] + forM_ uids $ insert . AuthUserGroupUsers i' . toKey + whenJust patchUserGroupPermissions $ \perms -> do + deleteWhere [AuthUserGroupUsersGroup ==. i'] + forM_ perms $ insert . AuthUserGroupPerms i' diff --git a/src/Servant/Server/Auth/Token/Monad.hs b/src/Servant/Server/Auth/Token/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Monad.hs @@ -0,0 +1,64 @@ +{-| +Module : Servant.Server.Auth.Token.Monad +Description : Monad for auth server handler +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.Monad( + AuthHandler(..) + , require + , getConfig + , getsConfig + , runDB404 + , module Reexport + ) where + +import Control.Monad.Except (ExceptT, MonadError) +import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, ask, asks) +import Data.Monoid ((<>)) +import Database.Persist.Postgresql +import Servant + +import qualified Data.ByteString.Lazy as BS + +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Model + +import Servant.Server.Auth.Token.Error as Reexport + +-- | This type represents the effects we want to have for our application. +-- We wrap the standard Servant monad with 'ReaderT Config', which gives us +-- access to the application configuration using the 'MonadReader' +-- interface's 'ask' function. +-- +-- By encapsulating the effects in our newtype, we can add layers to the +-- monad stack without having to modify code that uses the current layout. +newtype AuthHandler a = AuthHandler { + runAuthHandler :: ReaderT AuthConfig (ExceptT ServantErr IO) a + } deriving ( Functor, Applicative, Monad, MonadReader AuthConfig, + MonadError ServantErr, MonadIO) + +-- | If the value is 'Nothing', throw 400 response +require :: BS.ByteString -> Maybe a -> AuthHandler a +require info Nothing = throw400 $ info <> " is required" +require _ (Just a) = return a + +-- | Getting config from global state +getConfig :: AuthHandler AuthConfig +getConfig = ask + +-- | Getting config part from global state +getsConfig :: (AuthConfig -> a) -> AuthHandler a +getsConfig = asks + +-- | Run RDBMS operation and throw 404 (not found) error if +-- the second arg returns 'Nothing' +runDB404 :: BS.ByteString -> SqlPersistT IO (Maybe a) -> AuthHandler a +runDB404 info ma = do + a <- runDB ma + case a of + Nothing -> throw404 $ "Cannot find " <> info + Just a' -> return a' diff --git a/src/Servant/Server/Auth/Token/Pagination.hs b/src/Servant/Server/Auth/Token/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Pagination.hs @@ -0,0 +1,30 @@ +{-| +Module : Servant.Server.Auth.Token.Monad +Description : Helpers for pagination implementation +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.Pagination( + pagination + ) where + +import Data.Maybe + +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Monad + +import Servant.API.Auth.Token.Pagination + +-- | Helper that implements pagination logic +pagination :: Maybe Page -- ^ Parameter of page + -> Maybe PageSize -- ^ Parameter of page size + -> (Page -> PageSize -> AuthHandler a) -- ^ Handler + -> AuthHandler a +pagination pageParam pageSizeParam f = do + ps <- getsConfig defaultPageSize + let page = fromMaybe 0 pageParam + pageSize = fromMaybe ps pageSizeParam + f page pageSize diff --git a/src/Servant/Server/Auth/Token/Patch.hs b/src/Servant/Server/Auth/Token/Patch.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Patch.hs @@ -0,0 +1,52 @@ +{-| +Module : Servant.Server.Auth.Token.Patch +Description : Helpers for patching entities +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.Patch( + withPatch + , withPatch' + , withNullPatch + , withNullPatch' + ) where + +-- | Helper for implementation of 'HasPatch' +withPatch :: Monad m => Maybe a -> (a -> b -> m b) -> b -> m b +withPatch v f b = case v of + Nothing -> return b + Just a -> f a b +{-# INLINE withPatch #-} + +-- | Helper for implementation of 'HasPatch' +withPatch' :: Maybe a -> (a -> b -> b) -> b -> b +withPatch' v f b = case v of + Nothing -> b + Just a -> f a b +{-# INLINE withPatch' #-} + +-- | Helper to implement patch with nullable flag +withNullPatch :: Monad m + => Maybe Bool -- ^ If this is 'Just true' then execute following updater + -> (b -> m b) -- ^ Updater when previous value is 'Just true' + -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater + -> (a -> b -> m b) -- ^ Main updater + -> b -> m b +withNullPatch mnull nullify ma updater b = case mnull of + Just True -> nullify b + _ -> withPatch ma updater b +{-# INLINE withNullPatch #-} + +-- | Helper to implement patch with nullable flag +withNullPatch' :: Maybe Bool -- ^ If this is 'Just true' then execute following updater + -> (b -> b) -- ^ Updater when previous value is 'Just true' + -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater + -> (a -> b -> b) -- ^ Main updater + -> b -> b +withNullPatch' mnull nullify ma updater b = case mnull of + Just True -> nullify b + _ -> withPatch' ma updater b +{-# INLINE withNullPatch' #-} diff --git a/src/Servant/Server/Auth/Token/Restore.hs b/src/Servant/Server/Auth/Token/Restore.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Restore.hs @@ -0,0 +1,58 @@ +{-| +Module : Servant.Server.Auth.Token.Restore +Description : Operations with restore codes +Copyright : (c) Anton Gushcha, 2016 +License : MIT +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : Portable +-} +module Servant.Server.Auth.Token.Restore( + getRestoreCode + , guardRestoreCode + , sendRestoreCode + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Time.Clock +import Data.UUID +import Data.UUID.V4 +import Database.Persist.Postgresql + +import Servant.API.Auth.Token +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Model +import Servant.Server.Auth.Token.Monad + +-- | Get current restore code for user or generate new +getRestoreCode :: UserImplId -> UTCTime -> SqlPersistT IO RestoreCode +getRestoreCode uid expire = do + t <- liftIO getCurrentTime + mcode <- selectFirst [UserRestoreUser ==. uid, UserRestoreExpire >. t] [Desc UserRestoreExpire] + case mcode of + Nothing -> do + code <- toText <$> liftIO nextRandom + void $ insert UserRestore { + userRestoreValue = code + , userRestoreUser = uid + , userRestoreExpire = expire + } + return code + Just code -> return $ userRestoreValue . entityVal $ code + +-- | Throw if the restore code isn't valid for given user, if valid, invalidates the code +guardRestoreCode :: UserImplId -> RestoreCode -> AuthHandler () +guardRestoreCode uid code = do + t <- liftIO getCurrentTime + mcode <- runDB $ selectFirst [UserRestoreUser ==. uid, UserRestoreValue ==. code + , UserRestoreExpire >. t] [Desc UserRestoreExpire] + case mcode of + Nothing -> throw400 "Invalid restore code" + Just (Entity i rc) -> runDB $ replace i rc { userRestoreExpire = t } + +-- | Send restore code to the user' email +sendRestoreCode :: RespUserInfo -> RestoreCode -> AuthHandler () +sendRestoreCode user code = do + AuthConfig{..} <- getConfig + liftIO $ restoreCodeSender user code