servant-auth-token 0.4.7.1 → 0.5.6.0
raw patch · 18 files changed
Files
- CHANGELOG.md +37/−0
- example/acid/servant-auth-token-example-acid.cabal +12/−12
- example/acid/src/API.hs +11/−3
- example/acid/src/Monad.hs +0/−5
- example/acid/src/Server.hs +19/−2
- example/leveldb/servant-auth-token-example-leveldb.cabal +13/−13
- example/leveldb/src/Monad.hs +0/−5
- example/leveldb/src/Server.hs +3/−2
- example/persistent/servant-auth-token-example-persistent.cabal +14/−14
- example/persistent/src/Monad.hs +1/−6
- example/persistent/src/Server.hs +3/−2
- servant-auth-token.cabal +10/−5
- src/Servant/Server/Auth/Token.hs +45/−3
- src/Servant/Server/Auth/Token/Combinator.hs +69/−0
- src/Servant/Server/Auth/Token/Config.hs +2/−2
- src/Servant/Server/Auth/Token/Model.hs +38/−14
- src/Servant/Server/Auth/Token/SingleUse.hs +1/−1
- stack.yaml +21/−16
CHANGELOG.md view
@@ -1,3 +1,40 @@+0.5.6.0+=======++* Allow passing client side hashed passwords for signup and restore.++0.5.5.0+=======++* Allow passing client side hashed password to signin endpoint.++0.5.4.0+=======++* Bump versions for `lts-12.9`.++0.5.3.0+=======++* Support `servant-0.13`.++0.5.2.0+=======++* Support `servant-0.12`.++0.5.1.0+=======++* Versions bounds are relaxed.++0.5.0.0+=======++* Fix typo in `invalidatePermanentCodes`.+* Servant combinator.+* Rename migration function.+ 0.4.7.1 =======
example/acid/servant-auth-token-example-acid.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-token-example-acid-version: 0.4.0.2+version: 0.5.0.0 synopsis: Example server for token auth for acid-state backend description: Please see README.md homepage: https://github.com/ncrashed/servant-auth-token#readme@@ -25,23 +25,23 @@ build-depends: base >= 4.7 && < 5 , acid-state >= 0.14 && < 0.15- , aeson >= 0.11 && < 1.3- , aeson-injector >= 1.0 && < 1.1+ , aeson >= 0.11 && < 1.4+ , aeson-injector >= 1.1 && < 1.2 , bytestring >= 0.10 && < 0.11- , exceptions >= 0.8 && < 0.9- , http-types >= 0.9 && < 0.10+ , exceptions >= 0.8 && < 0.11+ , http-types >= 0.9 && < 0.13 , monad-control >= 1.0 && < 1.1 , monad-logger >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3- , optparse-applicative >= 0.12 && < 0.14+ , optparse-applicative >= 0.12 && < 0.15 , safecopy >= 0.9 && < 0.10- , servant >= 0.9 && < 0.12- , servant-auth-token >= 0.4 && < 0.5- , servant-auth-token-acid >= 0.4 && < 0.5- , servant-auth-token-api >= 0.4 && < 0.5- , servant-server >= 0.9 && < 0.12+ , servant >= 0.9 && < 0.15+ , servant-auth-token >= 0.5 && < 0.6+ , servant-auth-token-acid >= 0.5 && < 0.6+ , servant-auth-token-api >= 0.5 && < 0.6+ , servant-server >= 0.12 && < 0.15 , text >= 1.2 && < 1.3- , time >= 1.6 && < 1.7+ , time >= 1.6 && < 1.9 , transformers-base >= 0.4 && < 0.5 , wai >= 3.2 && < 3.3 , wai-extra >= 3.0 && < 3.1
example/acid/src/API.hs view
@@ -5,6 +5,14 @@ import Servant.API import Servant.API.Auth.Token -type ExampleAPI = "test"- :> TokenHeader' '["test-permission"]- :> Get '[JSON] ()+-- Your application endpoints+type ExampleEndpoint = "test"+ :> TokenHeader' '["test-permission"]+ :> Get '[JSON] ()++type ExampleAPI =+ ExampleEndpoint+ -- This is required for actual testing+ :<|> AuthSigninPostMethod+ :<|> AuthTouchMethod+ :<|> AuthSignoutMethod
example/acid/src/Monad.hs view
@@ -5,7 +5,6 @@ , newServerEnv , runServerM , runServerMIO- , serverMtoHandler , AuthM(..) , runAuth ) where@@ -78,10 +77,6 @@ case ea of Left e -> fail $ "runServerMIO: " <> show e Right a -> return a---- | Transformation to Servant 'Handler'-serverMtoHandler :: ServerEnv -> ServerM :~> Handler-serverMtoHandler e = NT (runServerM e) -- Derive HasStorage for 'AcidBackendT' with your 'DB' deriveAcidHasStorage ''DB
example/acid/src/Server.hs view
@@ -12,10 +12,13 @@ import Control.Monad.IO.Class import Control.Monad.Logger+import Data.Aeson.Unit+import Data.Aeson.WithField import Data.Proxy import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Middleware.RequestLogger+import Servant.API import Servant.API.Auth.Token import Servant.Server import Servant.Server.Auth.Token@@ -34,16 +37,30 @@ -- | WAI application of server exampleServerApp :: ServerEnv -> Application-exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl+exampleServerApp e = serve api apiImpl where- apiImpl = enter (serverMtoHandler e) exampleServer+ api = Proxy :: Proxy ExampleAPI+ apiImpl = hoistServer api (runServerM e) exampleServer -- | Implementation of main server API exampleServer :: ServerT ExampleAPI ServerM exampleServer = testEndpoint+ -- Pass though requests directly to the library in these endpoints+ :<|> authSigninPostProxy+ :<|> authTouchProxy+ :<|> authSignoutProxy testEndpoint :: MToken' '["test-permission"] -> ServerM () testEndpoint token = do runAuth $ guardAuthToken token $logInfo "testEndpoint" return ()++authSigninPostProxy :: AuthSigninPostBody -> ServerM (OnlyField "token" SimpleToken)+authSigninPostProxy AuthSigninPostBody{..} = runAuth $ authSignin (Just authSigninBodyLogin) (Just authSigninBodyPassword) authSigninBodySeconds++authTouchProxy :: Maybe Seconds -> MToken' '[] -> ServerM Unit+authTouchProxy mexpire token = runAuth $ authTouch mexpire token++authSignoutProxy :: MToken' '[] -> ServerM Unit+authSignoutProxy mtoken = runAuth $ authSignout mtoken
example/leveldb/servant-auth-token-example-leveldb.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-token-example-leveldb-version: 0.4.0.2+version: 0.5.1.0 synopsis: Example server for token auth for leveldb backend description: Please see README.md homepage: https://github.com/ncrashed/servant-auth-token#readme@@ -24,24 +24,24 @@ build-depends: base >= 4.7 && < 5 , acid-state >= 0.14 && < 0.15- , aeson >= 0.11 && < 1.3- , aeson-injector >= 1.0 && < 1.1+ , aeson >= 0.11 && < 1.4+ , aeson-injector >= 1.1 && < 1.2 , bytestring >= 0.10 && < 0.11- , exceptions >= 0.8 && < 0.9- , http-types >= 0.9 && < 0.10+ , exceptions >= 0.8 && < 0.11+ , http-types >= 0.9 && < 0.13 , leveldb-haskell >= 0.6 && < 0.7 , monad-control >= 1.0 && < 1.1 , monad-logger >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3- , optparse-applicative >= 0.12 && < 0.14- , safecopy-store >= 0.9 && < 0.10- , servant >= 0.11 && < 0.12- , servant-auth-token >= 0.4 && < 0.5- , servant-auth-token-api >= 0.4 && < 0.5- , servant-auth-token-leveldb >= 0.4 && < 0.5- , servant-server >= 0.9 && < 0.12+ , optparse-applicative >= 0.12 && < 0.15+ , safecopy >= 0.9 && < 0.10+ , servant >= 0.12 && < 0.15+ , servant-auth-token >= 0.5 && < 0.6+ , servant-auth-token-api >= 0.5 && < 0.6+ , servant-auth-token-leveldb >= 0.6 && < 0.7+ , servant-server >= 0.12 && < 0.15 , text >= 1.2 && < 1.3- , time >= 1.6 && < 1.7+ , time >= 1.6 && < 1.9 , transformers-base >= 0.4 && < 0.5 , wai >= 3.2 && < 3.3 , wai-extra >= 3.0 && < 3.1
example/leveldb/src/Monad.hs view
@@ -5,7 +5,6 @@ , newServerEnv , runServerM , runServerMIO- , serverMtoHandler , AuthM(..) , runAuth ) where@@ -81,10 +80,6 @@ case ea of Left e -> fail $ "runServerMIO: " <> show e Right a -> return a---- | Transformation to Servant 'Handler'-serverMtoHandler :: ServerEnv -> ServerM :~> Handler-serverMtoHandler e = NT (runServerM e) -- | Special monad for authorisation actions newtype AuthM a = AuthM { unAuthM :: LevelDBBackendT IO a }
example/leveldb/src/Server.hs view
@@ -34,9 +34,10 @@ -- | WAI application of server exampleServerApp :: ServerEnv -> Application-exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl+exampleServerApp e = serve api apiImpl where- apiImpl = enter (serverMtoHandler e) exampleServer+ api = Proxy :: Proxy ExampleAPI+ apiImpl = hoistServer api (runServerM e) exampleServer -- | Implementation of main server API exampleServer :: ServerT ExampleAPI ServerM
example/persistent/servant-auth-token-example-persistent.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-token-example-persistent-version: 0.4.0.2+version: 0.5.0.0 synopsis: Example server for token auth for persistent backend description: Please see README.md homepage: https://github.com/ncrashed/servant-auth-token#readme@@ -23,24 +23,24 @@ default-language: Haskell2010 build-depends: base >= 4.7 && < 5- , aeson >= 0.11 && < 1.3- , aeson-injector >= 1.0 && < 1.1+ , aeson >= 0.11 && < 1.4+ , aeson-injector >= 1.1 && < 1.2 , bytestring >= 0.10 && < 0.11- , exceptions >= 0.8 && < 0.9- , http-types >= 0.9 && < 0.10+ , exceptions >= 0.8 && < 0.11+ , http-types >= 0.9 && < 0.13 , monad-control >= 1.0 && < 1.1 , monad-logger >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3- , optparse-applicative >= 0.12 && < 0.14- , persistent >= 2.6 && < 2.7- , persistent-postgresql >= 2.6 && < 2.7- , servant >= 0.11 && < 0.12- , servant-auth-token >= 0.4 && < 0.5- , servant-auth-token-api >= 0.4 && < 0.5- , servant-auth-token-persistent >= 0.4 && < 0.6- , servant-server >= 0.9 && < 0.12+ , optparse-applicative >= 0.12 && < 0.15+ , persistent >= 2.6 && < 2.9+ , persistent-postgresql >= 2.6 && < 2.9+ , servant >= 0.12 && < 0.15+ , servant-auth-token >= 0.5 && < 0.6+ , servant-auth-token-api >= 0.5 && < 0.6+ , servant-auth-token-persistent >= 0.7 && < 0.8+ , servant-server >= 0.12 && < 0.15 , text >= 1.2 && < 1.3- , time >= 1.6 && < 1.7+ , time >= 1.6 && < 1.9 , transformers-base >= 0.4 && < 0.5 , wai >= 3.2 && < 3.3 , wai-extra >= 3.0 && < 3.1
example/persistent/src/Monad.hs view
@@ -4,7 +4,6 @@ , newServerEnv , runServerM , runServerMIO- , serverMtoHandler , AuthM(..) , runAuth ) where@@ -43,7 +42,7 @@ pool <- liftIO $ do pool <- createPool cfg -- run migrations- flip runSqlPool pool $ runMigration S.migrateAll+ flip runSqlPool pool $ runMigration S.migrateAllAuth -- create default admin if missing one _ <- runPersistentBackendT authConfig pool $ ensureAdmin 17 "admin" "123456" "admin@localhost" return pool@@ -81,10 +80,6 @@ case ea of Left e -> fail $ "runServerMIO: " <> show e Right a -> return a---- | Transformation to Servant 'Handler'-serverMtoHandler :: ServerEnv -> ServerM :~> Handler-serverMtoHandler e = NT (runServerM e) -- | Special monad for authorisation actions newtype AuthM a = AuthM { unAuthM :: PersistentBackendT IO a }
example/persistent/src/Server.hs view
@@ -34,9 +34,10 @@ -- | WAI application of server exampleServerApp :: ServerEnv -> Application-exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl+exampleServerApp e = serve api apiImpl where- apiImpl = enter (serverMtoHandler e) exampleServer+ api = Proxy :: Proxy ExampleAPI+ apiImpl = hoistServer api (runServerM e) exampleServer -- | Implementation of main server API exampleServer :: ServerT ExampleAPI ServerM
servant-auth-token.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-token-version: 0.4.7.1+version: 0.5.6.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@@ -50,6 +50,7 @@ exposed-modules: Servant.Server.Auth.Token Servant.Server.Auth.Token.Common+ Servant.Server.Auth.Token.Combinator Servant.Server.Auth.Token.Config Servant.Server.Auth.Token.Error Servant.Server.Auth.Token.Model@@ -60,17 +61,21 @@ Servant.Server.Auth.Token.SingleUse build-depends: base >= 4.8 && < 5- , aeson-injector >= 1.0.4 && < 1.1+ , aeson-injector >= 1.1 && < 1.2+ , byteable >= 0.1 && < 0.2 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6+ , http-api-data >= 0.3.5 && < 0.4 , mtl >= 2.2 && < 2.3 , pwstore-fast >= 2.4 && < 2.5- , servant-auth-token-api >= 0.4.2 && < 0.5- , servant-server >= 0.9 && < 0.12+ , servant >= 0.11 && < 0.15+ , servant-auth-token-api >= 0.5 && < 0.6+ , servant-server >= 0.11 && < 0.15 , text >= 1.2 && < 1.3- , time >= 1.5 && < 1.7+ , time >= 1.5 && < 1.9 , transformers >= 0.4 && < 0.6 , uuid >= 1.3 && < 1.4+ , wai >= 3.2 && < 3.3 default-language: Haskell2010 default-extensions:
src/Servant/Server/Auth/Token.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE UndecidableInstances #-} {-| Module : Servant.Server.Auth.Token@@ -34,9 +35,13 @@ , AuthHandler -- * Helpers , guardAuthToken+ , guardAuthToken' , WithAuthToken(..) , ensureAdmin , authUserByToken+ -- * Combinators+ , AuthPerm+ , AuthAction(..) -- * API methods , authSignin , authSigninGetCode@@ -74,6 +79,7 @@ import Crypto.PasswordStore import Data.Aeson.Unit import Data.Aeson.WithField+import Data.Byteable (Byteable, toBytes, constEqBytes) import Data.Maybe import Data.Monoid import Data.Text (Text)@@ -86,6 +92,7 @@ import Servant.API.Auth.Token import Servant.API.Auth.Token.Pagination import Servant.Server.Auth.Token.Common+import Servant.Server.Auth.Token.Combinator import Servant.Server.Auth.Token.Config import Servant.Server.Auth.Token.Model import Servant.Server.Auth.Token.Monad@@ -93,12 +100,14 @@ import Servant.Server.Auth.Token.Restore import Servant.Server.Auth.Token.SingleUse +import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BS -- | Implementation of AuthAPI authServer :: AuthHandler m => ServerT AuthAPI m authServer = authSignin+ :<|> authSigninPost :<|> authSigninGetCode :<|> authSigninPostCode :<|> authTouch@@ -122,7 +131,18 @@ :<|> authGetUserIdMethod :<|> authFindUserByLogin --- | Implementation of "signin" method+-- | Implementation of "signin" method.+--+-- You can pass hashed password in format of `pwstore`. The library will+-- strengthen the hash and compare with hash in DB in this case. The feature+-- allow you to previously hash on client side to not pass the password as plain+-- text to server. Note that you should have the same salt in the passwords.+--+-- Also avoid having strength of hashed password less that is passed from client side.+--+-- Format of hashed password: "sha256|strength|salt|hash", where strength is an unsigned int, salt+-- is a base64-encoded 16-byte random number, and hash is a base64-encoded hash+-- value. authSignin :: AuthHandler m => Maybe Login -- ^ Login query parameter -> Maybe Password -- ^ Password query parameter@@ -134,15 +154,37 @@ WithField uid UserImpl{..} <- guardLogin login pass OnlyField <$> getAuthToken uid mexpire where+ checkPassword pass uimpl@UserImpl{..} = case readPwHash pass of+ Nothing -> pass `verifyPassword` passToByteString userImplPassword+ Just (passedStrength, passedSalt, passedHash) -> case readPwHash $ passToByteString userImplPassword of+ Nothing -> False+ Just (storedStrength, storedSalt, storedHash) -> if+ | not (passedSalt `constEqBytes` storedSalt) -> False+ | passedStrength == storedStrength -> passedHash `constEqBytes` storedHash+ | passedStrength < storedStrength -> let+ newPass = strengthenPassword pass storedStrength+ in checkPassword newPass uimpl+ | otherwise -> let+ newUserPass = strengthenPassword (passToByteString userImplPassword) passedStrength+ in checkPassword pass uimpl { userImplPassword = byteStringToPass newUserPass } guardLogin login pass = do -- check login and password, return passed user muser <- getUserImplByLogin login let err = throw401 "Cannot find user with given combination of login and pass" case muser of Nothing -> err- Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword+ Just user@(WithField _ uimpl) -> if checkPassword (passToByteString pass) uimpl then return user else err +-- | Implementation of "signin" method+authSigninPost :: AuthHandler m+ => AuthSigninPostBody -- ^ Holds login, password and token lifetime+ -> m (OnlyField "token" SimpleToken) -- ^ If everything is OK, return token+authSigninPost AuthSigninPostBody{..} = authSignin+ (Just authSigninBodyLogin)+ (Just authSigninBodyPassword)+ authSigninBodySeconds+ -- | Helper to get or generate new token for user getAuthToken :: AuthHandler m => UserImplId -- ^ User for whom we want token@@ -444,7 +486,7 @@ let uid' = toKey uid _ <- guard404 "user" $ readUserInfo uid AuthConfig{..} <- getConfig- let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount+ let n = min singleUseCodePermanentMaximum $ fromMaybe singleUseCodeDefaultCount mcount OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n -- | Getting user by id, throw 404 response if not found
+ src/Servant/Server/Auth/Token/Combinator.hs view
@@ -0,0 +1,69 @@+{-# language DataKinds #-}+{-# language MultiParamTypeClasses #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language KindSignatures #-}+{-# language RecordWildCards #-}+{-# language RankNTypes #-}++module Servant.Server.Auth.Token.Combinator+ ( AuthPerm+ , AuthAction(..)+ ) where++import Control.Monad.IO.Class+import GHC.TypeLits (Symbol)+import Data.Proxy+import Network.Wai (Request, requestHeaders)+import Servant.API+import Servant.Server+import Servant.Server.Internal (Delayed(..), DelayedIO(..), withRequest,+ delayedFailFatal)+import Servant.API.Auth.Token (SimpleToken(..), Permission(..),+ Token(..), PlainPerms, PermsList(..))+import Web.HttpApiData (parseHeaderMaybe)+import qualified Data.Text as T+++-- | An authentication combinator.+--+-- TODO maybe move in the servant-auth-api library+data AuthPerm (perms :: [Symbol])++-- | An authentication handler.+newtype AuthAction = AuthAction+ { unAuthAction :: Maybe SimpleToken -> [Permission] -> Handler () }++instance ( HasServer api context+ , PermsList (PlainPerms perms)+ , HasContextEntry context AuthAction+ )+ => HasServer (AuthPerm perms :> api) context where++ type ServerT (AuthPerm perms :> api) m = ServerT api m++ route Proxy context subserver+ = route (Proxy :: Proxy api) context+ (subserver `addAuthPermCheck` withRequest (authCheck (Proxy :: Proxy perms)))+ where+ authHandler :: Proxy perms -> Request -> Handler ()+ authHandler pperms req =+ let authAction = getContextEntry context+ mHeader = parseHeaderMaybe+ =<< lookup "Authorization" (requestHeaders req)+ in unAuthAction authAction mHeader+ $ unliftPerms (Proxy :: Proxy (PlainPerms perms))++ authCheck :: Proxy perms -> Request -> DelayedIO ()+ authCheck pperms = (>>= either delayedFailFatal pure) . liftIO+ . runHandler . authHandler pperms++ addAuthPermCheck :: Delayed env b -> DelayedIO a -> Delayed env b+ addAuthPermCheck Delayed{..} new = Delayed+ { authD = (,) <$> authD <*> new+ , serverD = \ c p h (y, v) b req -> serverD c p h y b req+ , ..+ }+
src/Servant/Server/Auth/Token/Config.hs view
@@ -102,7 +102,7 @@ -- | Number of not expiring single use codes that user can have at once. -- -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 100.- , singleUseCodePermamentMaximum :: !Word+ , singleUseCodePermanentMaximum :: !Word -- | Number of not expiring single use codes that generated by default when client doesn't -- specify the value. --@@ -125,7 +125,7 @@ , singleUseCodeSender = const $ const $ return () , singleUseCodeExpire = fromIntegral (60 * 60 :: Int) -- 1 hour , singleUseCodeGenerator = uuidSingleUseCodeGenerate- , singleUseCodePermamentMaximum = 100+ , singleUseCodePermanentMaximum = 100 , singleUseCodeDefaultCount = 20 }
src/Servant/Server/Auth/Token/Model.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE MultiWayIf #-} {-| Module : Servant.Server.Auth.Token.Model Description : Internal operations with RDBMS@@ -59,6 +60,7 @@ , patchUserGroup -- * Low-level , makeUserInfo+ , readPwHash ) where import Control.Monad@@ -66,15 +68,10 @@ import Control.Monad.Except (ExceptT) import Control.Monad.IO.Class import Control.Monad.Reader (ReaderT)-import qualified Control.Monad.RWS.Lazy as LRWS-import qualified Control.Monad.RWS.Strict as SRWS-import qualified Control.Monad.State.Lazy as LS-import qualified Control.Monad.State.Strict as SS-import qualified Control.Monad.Writer.Lazy as LW-import qualified Control.Monad.Writer.Strict as SW import Control.Monad.Trans.Class (MonadTrans(lift)) import Crypto.PasswordStore import Data.Aeson.WithField+import Data.ByteString (ByteString) import Data.Int import Data.Maybe import Data.Monoid@@ -82,7 +79,14 @@ import Data.Time import GHC.Generics +import qualified Control.Monad.RWS.Lazy as LRWS+import qualified Control.Monad.RWS.Strict as SRWS+import qualified Control.Monad.State.Lazy as LS+import qualified Control.Monad.State.Strict as SS+import qualified Control.Monad.Writer.Lazy as LW+import qualified Control.Monad.Writer.Strict as SW import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BC import qualified Data.Foldable as F import qualified Data.List as L import qualified Data.Sequence as S@@ -374,10 +378,10 @@ default getUnusedCode :: (m ~ t n, MonadTrans t, HasStorage n) => SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode)) getUnusedCode suc = (lift .) . getUnusedCode suc - -- | Invalidate all permament codes for user and set use time for them- invalidatePermamentCodes :: UserImplId -> UTCTime -> m ()- default invalidatePermamentCodes :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m ()- invalidatePermamentCodes = (lift .) . invalidatePermamentCodes+ -- | Invalidate all permanent codes for user and set use time for them+ invalidatePermanentCodes :: UserImplId -> UTCTime -> m ()+ default invalidatePermanentCodes :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m ()+ invalidatePermanentCodes = (lift .) . invalidatePermanentCodes -- | Select last valid restoration code by the given current time selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))@@ -479,13 +483,33 @@ deleteUserPermissions uid forM_ perms $ void . insertUserPerm . UserPerm uid +-- | Try to parse a password hash.+readPwHash :: BC.ByteString -> Maybe (Int, BC.ByteString, BC.ByteString)+readPwHash pw | length broken /= 4+ || algorithm /= "sha256"+ || BC.length hash /= 44 = Nothing+ | otherwise = case BC.readInt strBS of+ Just (strength, _) -> Just (strength, salt, hash)+ Nothing -> Nothing+ where broken = BC.split '|' pw+ [algorithm, strBS, salt, hash] = broken++-- | Hash password with given strengh, you can pass already hashed password+-- to specified strength+makeHashedPassword :: MonadIO m => Int -> Password -> m Password+makeHashedPassword strength pass =liftIO $ case readPwHash . passToByteString $ pass of+ Nothing -> fmap byteStringToPass $ makePassword (passToByteString pass) strength+ Just (passStrength, passSalt, passHash) -> if+ | passStrength >= strength -> pure pass+ | otherwise -> pure $ byteStringToPass $ strengthenPassword (passToByteString pass) strength+ -- | Creation of new user createUser :: HasStorage m => Int -> Login -> Password -> Email -> [Permission] -> m UserImplId createUser strength login pass email perms = do- pass' <- liftIO $ makePassword (passToByteString pass) strength+ pass' <- makeHashedPassword strength pass i <- insertUserImpl UserImpl { userImplLogin = login- , userImplPassword = byteStringToPass pass'+ , userImplPassword = pass' , userImplEmail = email } forM_ perms $ void . insertUserPerm . UserPerm i@@ -531,8 +555,8 @@ setUserPassword' :: MonadIO m => Int -- ^ Password strength -> Password -> UserImpl -> m UserImpl setUserPassword' strength pass user = do- pass' <- liftIO $ makePassword (passToByteString pass) strength- return $ user { userImplPassword = byteStringToPass pass' }+ pass' <- makeHashedPassword strength pass+ return $ user { userImplPassword = pass' } -- | Get all groups the user belongs to getUserGroups :: HasStorage m => UserImplId -> m [UserGroupId]
src/Servant/Server/Auth/Token/SingleUse.hs view
@@ -66,7 +66,7 @@ -> m [SingleUseCode] generateSingleUsedCodes uid gen n = do t <- liftIO getCurrentTime- invalidatePermamentCodes uid t+ invalidatePermanentCodes uid t replicateM (fromIntegral n) $ do code <- liftIO gen _ <- insertSingleUseCode $ UserSingleUseCode code uid Nothing Nothing
stack.yaml view
@@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml"-resolver: lts-8.19+resolver: lts-12.9 # User packages to be built. # Various formats can be used as shown in the example below.@@ -40,39 +40,44 @@ - 'servant-auth-token-acid' - 'servant-auth-token-persistent' - 'servant-auth-token-leveldb'-- 'servant-auth-token-rocksdb'+#- 'servant-auth-token-rocksdb' - 'example/acid' - 'example/persistent' - 'example/leveldb'+#- '../servant-auth-token-api' # - location: # git: https://github.com/NCrashed/servant-auth-token-api.git # commit: d011f7bfecd18d07ff67ce9f67f8741e110a2719 # extra-dep: true # - '../servant-auth-token-api'-- location:- git: https://github.com/serokell/rocksdb-haskell.git- commit: 325427fc709183c8fdf777ad5ea09f8d92bf8585- extra-dep: true+#- location:+# git: https://github.com/serokell/rocksdb-haskell.git+# commit: 325427fc709183c8fdf777ad5ea09f8d92bf8585+# extra-dep: true # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) extra-deps:-- aeson-1.2.1.0-- aeson-injector-1.0.8.0-- cabal-doctest-1.0.2-- concurrent-extra-0.7.0.11-- safecopy-store-0.9.4-- servant-0.11-- servant-auth-token-api-0.4.2.2-- servant-docs-0.10.0.1-- servant-server-0.11-- servant-swagger-1.1.3+- acid-state-0.14.3+- aeson-injector-1.1.1.0+- pwstore-fast-2.4.4+- rocksdb-haskell-1.0.1+- servant-auth-token-api-0.5.3.0 # Override default flag values for local packages and extra-deps flags: {} # Extra package databases containing global packages extra-package-dbs: []++nix:+ packages:+ - zlib+ - postgresql96+ - rocksdb+ - leveldb+#nix:+# shell-file: shell.nix # Control whether we use the GHC we find on the path # system-ghc: true