packages feed

servant-auth-token (empty) → 0.1.0.0

raw patch · 14 files changed

+1311/−0 lines, 14 filesdep +aeson-injectordep +basedep +bytestringsetup-changed

Dependencies added: aeson-injector, base, bytestring, containers, mtl, persistent, persistent-postgresql, persistent-template, pwstore-fast, servant-auth-token-api, servant-server, text, time, transformers, uuid

Files

+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1.0.0+=======++* Initial publication
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 +```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-auth-token.cabal view
@@ -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
+ src/Servant/Server/Auth/Token.hs view
@@ -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+      }
+ src/Servant/Server/Auth/Token/Common.hs view
@@ -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
+ src/Servant/Server/Auth/Token/Config.hs view
@@ -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 ()+  }
+ src/Servant/Server/Auth/Token/Error.hs view
@@ -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 }
+ src/Servant/Server/Auth/Token/Model.hs view
@@ -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'
+ src/Servant/Server/Auth/Token/Monad.hs view
@@ -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'
+ src/Servant/Server/Auth/Token/Pagination.hs view
@@ -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
+ src/Servant/Server/Auth/Token/Patch.hs view
@@ -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' #-}
+ src/Servant/Server/Auth/Token/Restore.hs view
@@ -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