diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +0.5.0.0 +======= + +* Fix typo in `invalidatePermanentCodes`. +* Servant combinator. +* Rename migration function. + 0.4.7.1 ======= diff --git a/example/acid/servant-auth-token-example-acid.cabal b/example/acid/servant-auth-token-example-acid.cabal --- a/example/acid/servant-auth-token-example-acid.cabal +++ b/example/acid/servant-auth-token-example-acid.cabal @@ -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 @@ -36,8 +36,8 @@ , optparse-applicative >= 0.12 && < 0.14 , 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 >= 0.5 && < 0.6 + , servant-auth-token-acid >= 0.5 && < 0.6 , servant-auth-token-api >= 0.4 && < 0.5 , servant-server >= 0.9 && < 0.12 , text >= 1.2 && < 1.3 diff --git a/example/leveldb/servant-auth-token-example-leveldb.cabal b/example/leveldb/servant-auth-token-example-leveldb.cabal --- a/example/leveldb/servant-auth-token-example-leveldb.cabal +++ b/example/leveldb/servant-auth-token-example-leveldb.cabal @@ -1,5 +1,5 @@ name: servant-auth-token-example-leveldb -version: 0.4.0.2 +version: 0.5.0.0 synopsis: Example server for token auth for leveldb backend description: Please see README.md homepage: https://github.com/ncrashed/servant-auth-token#readme @@ -36,9 +36,9 @@ , 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 >= 0.5 && < 0.6 , servant-auth-token-api >= 0.4 && < 0.5 - , servant-auth-token-leveldb >= 0.4 && < 0.5 + , servant-auth-token-leveldb >= 0.5 && < 0.6 , servant-server >= 0.9 && < 0.12 , text >= 1.2 && < 1.3 , time >= 1.6 && < 1.7 diff --git a/example/persistent/servant-auth-token-example-persistent.cabal b/example/persistent/servant-auth-token-example-persistent.cabal --- a/example/persistent/servant-auth-token-example-persistent.cabal +++ b/example/persistent/servant-auth-token-example-persistent.cabal @@ -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 @@ -35,9 +35,9 @@ , 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 >= 0.5 && < 0.6 , servant-auth-token-api >= 0.4 && < 0.5 - , servant-auth-token-persistent >= 0.4 && < 0.6 + , servant-auth-token-persistent >= 0.6 && < 0.7 , servant-server >= 0.9 && < 0.12 , text >= 1.2 && < 1.3 , time >= 1.6 && < 1.7 diff --git a/example/persistent/src/Monad.hs b/example/persistent/src/Monad.hs --- a/example/persistent/src/Monad.hs +++ b/example/persistent/src/Monad.hs @@ -43,7 +43,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 diff --git a/servant-auth-token.cabal b/servant-auth-token.cabal --- a/servant-auth-token.cabal +++ b/servant-auth-token.cabal @@ -1,5 +1,5 @@ name: servant-auth-token -version: 0.4.7.1 +version: 0.5.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 @@ -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 @@ -63,14 +64,17 @@ , aeson-injector >= 1.0.4 && < 1.1 , 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.12 + , servant-server >= 0.11 && < 0.12 , text >= 1.2 && < 1.3 , time >= 1.5 && < 1.7 , transformers >= 0.4 && < 0.6 , uuid >= 1.3 && < 1.4 + , wai >= 3.2 && < 3.3 default-language: Haskell2010 default-extensions: diff --git a/src/Servant/Server/Auth/Token.hs b/src/Servant/Server/Auth/Token.hs --- a/src/Servant/Server/Auth/Token.hs +++ b/src/Servant/Server/Auth/Token.hs @@ -34,9 +34,13 @@ , AuthHandler -- * Helpers , guardAuthToken + , guardAuthToken' , WithAuthToken(..) , ensureAdmin , authUserByToken + -- * Combinators + , AuthPerm + , AuthAction(..) -- * API methods , authSignin , authSigninGetCode @@ -86,6 +90,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 @@ -444,7 +449,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 diff --git a/src/Servant/Server/Auth/Token/Combinator.hs b/src/Servant/Server/Auth/Token/Combinator.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Auth/Token/Combinator.hs @@ -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 + , .. + } + diff --git a/src/Servant/Server/Auth/Token/Config.hs b/src/Servant/Server/Auth/Token/Config.hs --- a/src/Servant/Server/Auth/Token/Config.hs +++ b/src/Servant/Server/Auth/Token/Config.hs @@ -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 } diff --git a/src/Servant/Server/Auth/Token/Model.hs b/src/Servant/Server/Auth/Token/Model.hs --- a/src/Servant/Server/Auth/Token/Model.hs +++ b/src/Servant/Server/Auth/Token/Model.hs @@ -374,10 +374,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)) diff --git a/src/Servant/Server/Auth/Token/SingleUse.hs b/src/Servant/Server/Auth/Token/SingleUse.hs --- a/src/Servant/Server/Auth/Token/SingleUse.hs +++ b/src/Servant/Server/Auth/Token/SingleUse.hs @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -61,6 +61,7 @@ - aeson-injector-1.0.8.0 - cabal-doctest-1.0.2 - concurrent-extra-0.7.0.11 +- rocksdb-haskell-1.0.0 - safecopy-store-0.9.4 - servant-0.11 - servant-auth-token-api-0.4.2.2 @@ -73,6 +74,14 @@ # Extra package databases containing global packages extra-package-dbs: [] + +nix: + enable: false + packages: + - zlib + - postgresql96 + - rocksdb + - leveldb # Control whether we use the GHC we find on the path # system-ghc: true