servant-auth-token 0.4.7.1 → 0.5.0.0

raw patch · 12 files changed

+114/−20 lines, 12 filesdep +http-api-datadep +servantdep +waidep ~servant-serverPVP ok

version bump matches the API change (PVP)

Dependencies added: http-api-data, servant, wai

Dependency ranges changed: servant-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• example/acid/servant-auth-token-example-acid.cabal +3/−3
• example/leveldb/servant-auth-token-example-leveldb.cabal +3/−3
• example/persistent/servant-auth-token-example-persistent.cabal +3/−3
• example/persistent/src/Monad.hs +1/−1
• servant-auth-token.cabal +6/−2
• src/Servant/Server/Auth/Token.hs +6/−1
• 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 +4/−4
• src/Servant/Server/Auth/Token/SingleUse.hs +1/−1
• stack.yaml +9/−0

@@ -1,3 +1,10 @@+0.5.0.0+=======++* Fix typo in `invalidatePermanentCodes`.+* Servant combinator.+* Rename migration function.+ 0.4.7.1 ======= 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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:

@@ -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

@@ -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+          , ..+          }+

@@ -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   } 

@@ -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))

@@ -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

@@ -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