servant-auth-token 0.3.2.0 → 0.4.0.0

raw patch · 32 files changed

+1502/−657 lines, 32 filesdep ~servant-auth-token-apidep ~servant-serverPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: servant-auth-token-api, servant-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +9/−35
• example/acid/LICENSE +30/−0
• example/acid/Setup.hs +2/−0
• example/acid/config.yaml +3/−0
• example/acid/servant-auth-token-example-acid.cabal +70/−0
• example/acid/src/API.hs +10/−0
• example/acid/src/Config.hs +30/−0
• example/acid/src/DB.hs +30/−0
• example/acid/src/Main.hs +34/−0
• example/acid/src/Monad.hs +98/−0
• example/acid/src/Server.hs +49/−0
• example/persistent/LICENSE +30/−0
• example/persistent/Setup.hs +2/−0
• example/persistent/config.yaml +8/−0
• example/persistent/servant-auth-token-example-persistent.cabal +69/−0
• example/persistent/src/API.hs +10/−0
• example/persistent/src/Config.hs +58/−0
• example/persistent/src/Main.hs +34/−0
• example/persistent/src/Monad.hs +98/−0
• example/persistent/src/Server.hs +49/−0
• servant-auth-token.cabal +26/−3
• src/Servant/Server/Auth/Token.hs +197/−265
• src/Servant/Server/Auth/Token/Common.hs +13/−18
• src/Servant/Server/Auth/Token/Config.hs +22/−21
• src/Servant/Server/Auth/Token/Error.hs +6/−7
• src/Servant/Server/Auth/Token/Model.hs +340/−199
• src/Servant/Server/Auth/Token/Monad.hs +25/−35
• src/Servant/Server/Auth/Token/Pagination.hs +11/−10
• src/Servant/Server/Auth/Token/Restore.hs +24/−25
• src/Servant/Server/Auth/Token/SingleUse.hs +27/−39
• stack.yaml +83/−0

@@ -1,3 +1,8 @@+0.4.0.0+=======++* Abstract over storage: persistent and acid-state backends.+ 0.3.2.0 ======= 

@@ -2,52 +2,26 @@  [![Build Status](https://travis-ci.org/NCrashed/servant-auth-token.svg?branch=master)](https://travis-ci.org/NCrashed/servant-auth-token) -The repo contains server implementation of [servant-auth-toke-api](https://github.com/NCrashed/servant-auth-token-api).+The repo contains server implementation of [servant-auth-token-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-  -- ...-}+At the moment you have two options for backend storage: --- | 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)+- [persistent backend](https://github.com/NCrashed/servant-auth-token/tree/master/servant-auth-token-persistent) - [persistent](https://hackage.haskell.org/package/persistent) backend, simple to integrate with your app. --- | Now you can use authorisation API in your handler-instance AuthMonad App where -  getAuthConfig = asks authConfig-  liftAuthAction = App . lift+- [acid-state backend](https://github.com/NCrashed/servant-auth-token/tree/master/servant-auth-token-acid) - [acid-state](https://hackage.haskell.org/package/acid-state) backend is light solution for in memory storage, but it is more difficult to integrate it with your app. --- | 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" -```+- Possible candidates for other storage backends: VCache, leveldb, JSON files. To see how to implement them, see [HasStorage](https://github.com/NCrashed/servant-auth-token/blob/master/src/Servant/Server/Auth/Token/Model.hs#L220) type class. -Now you can use 'guardAuthToken' to check authorisation headers in endpoints of your server:+Now you can use 'guardAuthToken' to check authorization 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+  -> ServerM Customer -- ^ Customer data customerGet i token = do-  guardAuthToken token -  runDB404 "customer" $ getCustomer i +  guardAuthToken token+  runDB404 "customer" $ getCustomer i ```

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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,3 @@+host: localhost+port: 3000+db: "state"

@@ -0,0 +1,70 @@+name:                servant-auth-token-example-acid+version:             0.4.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+license:             BSD3+license-file:        LICENSE+author:              NCrashed+maintainer:          ncrashed@gmail.com+copyright:           2017 Anton Gushcha+category:            Web+build-type:          Simple+cabal-version:       >=1.10++executable servant-auth-token-example-acid+  hs-source-dirs:     src+  main-is:            Main.hs+  other-modules:+    API+    Config+    DB+    Monad+    Server+  default-language:   Haskell2010+  build-depends:+      base                          >= 4.7      && < 5+    , acid-state                    >= 0.14     && < 0.15+    , aeson                         >= 0.11     && < 0.12+    , aeson-injector                >= 1.0      && < 1.1+    , bytestring                    >= 0.10     && < 0.11+    , exceptions                    >= 0.8      && < 0.9+    , http-types                    >= 0.9      && < 0.10+    , monad-control                 >= 1.0      && < 1.1+    , monad-logger                  >= 0.3      && < 0.4+    , mtl                           >= 2.2      && < 2.3+    , optparse-applicative          >= 0.12     && < 0.13+    , safecopy                      >= 0.9      && < 0.10+    , servant                       >= 0.9      && < 0.10+    , 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.10+    , text                          >= 1.2      && < 1.3+    , time                          >= 1.6      && < 1.7+    , transformers-base             >= 0.4      && < 0.5+    , wai                           >= 3.2      && < 3.3+    , wai-extra                     >= 3.0      && < 3.1+    , warp                          >= 3.2      && < 3.3+    , yaml                          >= 0.8      && < 0.9+  default-extensions:+    BangPatterns+    DataKinds+    DeriveFunctor+    DeriveGeneric+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GeneralizedNewtypeDeriving+    MultiParamTypeClasses+    OverloadedStrings+    RecordWildCards+    RecursiveDo+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TypeFamilies+    TypeOperators+    UndecidableInstances++  ghc-options: -threaded

@@ -0,0 +1,10 @@+module API(+    ExampleAPI+  ) where++import Servant.API+import Servant.API.Auth.Token++type ExampleAPI = "test"+  :> TokenHeader' '["test-permission"]+  :> Get '[JSON] ()

@@ -0,0 +1,30 @@+module Config(+    ServerConfig(..)+  , readConfig+  ) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson+import Data.Text+import Data.Yaml.Config++-- | Startup configuration of server+data ServerConfig = ServerConfig {+  -- | Server host name+  serverHost   :: !Text+  -- | Server port number+, serverPort   :: !Int+  -- | Server db location+, serverDbPath :: !Text+}++instance FromJSON ServerConfig where+  parseJSON (Object o) = ServerConfig+    <$> o .: "host"+    <*> o .: "port"+    <*> o .: "db"+  parseJSON _ = mzero++readConfig :: MonadIO m => FilePath -> m ServerConfig+readConfig f = liftIO $ loadYamlSettings [f] [] useEnv

@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+module DB where++import Data.SafeCopy++import Servant.Server.Auth.Token.Acid.Schema as A++-- | Application global state for acid-state+data DB = DB {+  dbAuth :: A.Model -- ^ Storage for Auth state+, dbCustom :: () -- ^ Demo of custom state+}++-- | Generation of inital state+newDB :: DB+newDB = DB {+    dbAuth = A.newModel+  , dbCustom = ()+  }++instance HasModelRead DB where+  askModel = dbAuth++instance HasModelWrite DB where+  putModel db m = db { dbAuth = m }++deriveSafeCopy 0 'base ''DB++A.deriveQueries ''DB+A.makeModelAcidic ''DB

@@ -0,0 +1,34 @@+module Main where++import Options.Applicative++import Server++-- | Argument line options+data Options = Options {+  -- | Path to config, if not set, the app will not start+  configPath :: FilePath+}++-- | Command line parser+optionsParser :: Parser Options+optionsParser = Options+  <$> strOption (+         long "conf"+      <> metavar "CONFIG"+      <> help "Path to configuration file"+    )++-- | Execute server with given options+runServer :: Options -> IO ()+runServer Options{..} = do+  cfg <- readConfig configPath+  runExampleServer cfg++main :: IO ()+main = execParser opts >>= runServer+  where+    opts = info (helper <*> optionsParser)+      ( fullDesc+     <> progDesc "Example server for servant-auth-token"+     <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" )

@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Monad(+    ServerEnv(..)+  , ServerM+  , newServerEnv+  , runServerM+  , runServerMIO+  , serverMtoHandler+  , AuthM(..)+  , runAuth+  ) where++import Control.Monad.Base+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.Except+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Acid+import Data.Monoid+import Data.Text (unpack)+import Servant.Server+import Servant.Server.Auth.Token.Acid as A+import Servant.Server.Auth.Token.Config+import Servant.Server.Auth.Token.Model++import Config+import DB++-- | Server private environment+data ServerEnv = ServerEnv {+  -- | Configuration used to create the server+  envConfig      :: !ServerConfig+  -- | Configuration of auth server+, envAuthConfig  :: !AuthConfig+  -- | DB state+, envDB          :: !(AcidState DB)+}++-- | Create new server environment+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv+newServerEnv cfg = do+  let authConfig = defaultAuthConfig+  db <- liftIO $ openLocalStateFrom (unpack $ serverDbPath cfg) newDB+  -- ensure default admin if missing one+  _ <- runAcidBackendT authConfig db $ ensureAdmin 17 "admin" "123456" "admin@localhost"+  let env = ServerEnv {+        envConfig = cfg+      , envAuthConfig = authConfig+      , envDB = db+      }+  return env++-- | Server monad that holds internal environment+newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv+    , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)++newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }++instance MonadBaseControl IO ServerM where+    type StM ServerM a = StMServerM a+    liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)+    restoreM = ServerM . restoreM . unStMServerM++-- | Lift servant monad to server monad+liftHandler :: Handler a -> ServerM a+liftHandler = ServerM . lift . lift++-- | Execution of 'ServerM'+runServerM :: ServerEnv -> ServerM a -> Handler a+runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM++-- | Execution of 'ServerM' in IO monad+runServerMIO :: ServerEnv -> ServerM a -> IO a+runServerMIO env m = do+  ea <- runExceptT $ runServerM env m+  case ea of+    Left e -> fail $ "runServerMIO: " <> show e+    Right a -> return a++-- | Transformation to Servant 'Handler'+serverMtoHandler :: ServerEnv -> ServerM :~> Handler+serverMtoHandler e = Nat (runServerM e)++-- Derive HasStorage for 'AcidBackendT' with your 'DB'+deriveAcidHasStorage ''DB++-- | Special monad for authorisation actions+newtype AuthM a = AuthM { unAuthM :: AcidBackendT DB IO a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage)++-- | Execution of authorisation actions that require 'AuthHandler' context+runAuth :: AuthM a -> ServerM a+runAuth m = do+  cfg <- asks envAuthConfig+  db <- asks envDB+  liftHandler $ ExceptT $ runAcidBackendT cfg db $ unAuthM m

@@ -0,0 +1,49 @@+module Server(+  -- * Server config+    ServerConfig(..)+  , readConfig+  -- * Server environment+  , ServerEnv+  , newServerEnv+  -- * Execution of server+  , exampleServerApp+  , runExampleServer+  ) where++import Control.Monad.IO.Class+import Control.Monad.Logger+import Data.Proxy+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Middleware.RequestLogger+import Servant.API.Auth.Token+import Servant.Server+import Servant.Server.Auth.Token++import API+import Config+import Monad++-- | Enter infinite loop of processing requests for pdf-master-server.+--+-- Starts new Warp server with initialised threads for serving the master server.+runExampleServer :: MonadIO m => ServerConfig -> m ()+runExampleServer config = liftIO $ do+  env <- newServerEnv config+  liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env++-- | WAI application of server+exampleServerApp :: ServerEnv -> Application+exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl+  where+    apiImpl = enter (serverMtoHandler e) exampleServer++-- | Implementation of main server API+exampleServer :: ServerT ExampleAPI ServerM+exampleServer = testEndpoint++testEndpoint :: MToken' '["test-permission"] -> ServerM ()+testEndpoint token = do+  runAuth $ guardAuthToken token+  $logInfo "testEndpoint"+  return ()

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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,8 @@+host: localhost+port: 3000+db-host: localhost+db-port: 5432+db-user: postgres+db-pass: ""+db-base: auth-test+db-size: 10

@@ -0,0 +1,69 @@+name:                servant-auth-token-example-persistent+version:             0.4.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+license:             BSD3+license-file:        LICENSE+author:              NCrashed+maintainer:          ncrashed@gmail.com+copyright:           2017 Anton Gushcha+category:            Web+build-type:          Simple+cabal-version:       >=1.10++executable servant-auth-token-example-persistent+  hs-source-dirs:     src+  main-is:            Main.hs+  other-modules:+    API+    Config+    Monad+    Server+  default-language:   Haskell2010+  build-depends:+      base                          >= 4.7      && < 5+    , aeson                         >= 0.11     && < 0.12+    , aeson-injector                >= 1.0      && < 1.1+    , bytestring                    >= 0.10     && < 0.11+    , exceptions                    >= 0.8      && < 0.9+    , http-types                    >= 0.9      && < 0.10+    , monad-control                 >= 1.0      && < 1.1+    , monad-logger                  >= 0.3      && < 0.4+    , mtl                           >= 2.2      && < 2.3+    , optparse-applicative          >= 0.12     && < 0.13+    , persistent                    >= 2.6      && < 2.7+    , persistent-postgresql         >= 2.6      && < 2.7+    , servant                       >= 0.9      && < 0.10+    , servant-auth-token            >= 0.4      && < 0.5+    , servant-auth-token-api        >= 0.4      && < 0.5+    , servant-auth-token-persistent >= 0.4      && < 0.5+    , servant-server                >= 0.9      && < 0.10+    , text                          >= 1.2      && < 1.3+    , time                          >= 1.6      && < 1.7+    , transformers-base             >= 0.4      && < 0.5+    , wai                           >= 3.2      && < 3.3+    , wai-extra                     >= 3.0      && < 3.1+    , warp                          >= 3.2      && < 3.3+    , yaml                          >= 0.8      && < 0.9+  default-extensions:+    BangPatterns+    DataKinds+    DeriveFunctor+    DeriveGeneric+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GeneralizedNewtypeDeriving+    MultiParamTypeClasses+    OverloadedStrings+    RecordWildCards+    RecursiveDo+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TypeFamilies+    TypeOperators+    UndecidableInstances++  ghc-options: -threaded

@@ -0,0 +1,10 @@+module API(+    ExampleAPI+  ) where++import Servant.API+import Servant.API.Auth.Token++type ExampleAPI = "test"+  :> TokenHeader' '["test-permission"]+  :> Get '[JSON] ()

@@ -0,0 +1,58 @@+module Config(+    ServerConfig(..)+  , readConfig+  , createPool+  ) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Data.Aeson+import Data.Monoid+import Data.Text+import Data.Text.Encoding+import Data.Yaml.Config++import Database.Persist.Postgresql++-- | Startup configuration of server+data ServerConfig = ServerConfig {+  -- | Server host name+  serverHost                 :: !Text+  -- | Server port number+, serverPort                 :: !Int+  -- | DB host+, serverDBHost               :: !Text+  -- | DB port+, serverDBPort               :: !Int+  -- | DB user+, serverDBUser               :: !Text+  -- | DB user password+, serverDBPass               :: !Text+  -- | DB database+, serverDBBase               :: !Text+  -- | DB pool size+, serverDBSize               :: !Int+}++instance FromJSON ServerConfig where+  parseJSON (Object o) = ServerConfig+    <$> o .: "host"+    <*> o .: "port"+    <*> o .: "db-host"+    <*> o .: "db-port"+    <*> o .: "db-user"+    <*> o .: "db-pass"+    <*> o .: "db-base"+    <*> o .: "db-size"+  parseJSON _ = mzero++readConfig :: MonadIO m => FilePath -> m ServerConfig+readConfig f = liftIO $ loadYamlSettings [f] [] useEnv++-- | Create connection pool to postgres+createPool :: ServerConfig -> IO ConnectionPool+createPool ServerConfig{..} = runStdoutLoggingT $ createPostgresqlPool constr serverDBSize+  where+    constr = encodeUtf8 $ "host=" <> serverDBHost <> " port=" <> (pack . show $ serverDBPort)+      <> " user=" <> serverDBUser <> " password=" <> serverDBPass <> " database=" <> serverDBBase

@@ -0,0 +1,34 @@+module Main where++import Options.Applicative++import Server++-- | Argument line options+data Options = Options {+  -- | Path to config, if not set, the app will not start+  configPath :: FilePath+}++-- | Command line parser+optionsParser :: Parser Options+optionsParser = Options+  <$> strOption (+         long "conf"+      <> metavar "CONFIG"+      <> help "Path to configuration file"+    )++-- | Execute server with given options+runServer :: Options -> IO ()+runServer Options{..} = do+  cfg <- readConfig configPath+  runExampleServer cfg++main :: IO ()+main = execParser opts >>= runServer+  where+    opts = info (helper <*> optionsParser)+      ( fullDesc+     <> progDesc "Example server for servant-auth-token"+     <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" )

@@ -0,0 +1,98 @@+module Monad(+    ServerEnv(..)+  , ServerM+  , newServerEnv+  , runServerM+  , runServerMIO+  , serverMtoHandler+  , AuthM(..)+  , runAuth+  ) where++import Control.Monad.Base+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.Except+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Monoid+import Database.Persist.Sql+import Servant.Server+import Servant.Server.Auth.Token.Config+import Servant.Server.Auth.Token.Model+import Servant.Server.Auth.Token.Persistent++import qualified Servant.Server.Auth.Token.Persistent.Schema as S++import Config++-- | Server private environment+data ServerEnv = ServerEnv {+  -- | Configuration used to create the server+  envConfig      :: !ServerConfig+  -- | Configuration of auth server+, envAuthConfig  :: !AuthConfig+  -- | DB pool+, envPool        :: !ConnectionPool+}++-- | Create new server environment+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv+newServerEnv cfg = do+  let authConfig = defaultAuthConfig+  pool <- liftIO $ do+    pool <- createPool cfg+    -- run migrations+    flip runSqlPool pool $ runMigration S.migrateAll+    -- create default admin if missing one+    _ <- runPersistentBackendT authConfig pool $ ensureAdmin 17 "admin" "123456" "admin@localhost"+    return pool+  let env = ServerEnv {+        envConfig = cfg+      , envAuthConfig = authConfig+      , envPool = pool+      }+  return env++-- | Server monad that holds internal environment+newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv+    , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)++newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }++instance MonadBaseControl IO ServerM where+    type StM ServerM a = StMServerM a+    liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)+    restoreM = ServerM . restoreM . unStMServerM++-- | Lift servant monad to server monad+liftHandler :: Handler a -> ServerM a+liftHandler = ServerM . lift . lift++-- | Execution of 'ServerM'+runServerM :: ServerEnv -> ServerM a -> Handler a+runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM++-- | Execution of 'ServerM' in IO monad+runServerMIO :: ServerEnv -> ServerM a -> IO a+runServerMIO env m = do+  ea <- runExceptT $ runServerM env m+  case ea of+    Left e -> fail $ "runServerMIO: " <> show e+    Right a -> return a++-- | Transformation to Servant 'Handler'+serverMtoHandler :: ServerEnv -> ServerM :~> Handler+serverMtoHandler e = Nat (runServerM e)++-- | Special monad for authorisation actions+newtype AuthM a = AuthM { unAuthM :: PersistentBackendT IO a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasStorage, HasAuthConfig)++-- | Execution of authorisation actions that require 'AuthHandler' context+runAuth :: AuthM a -> ServerM a+runAuth m = do+  cfg <- asks envAuthConfig+  pool <- asks envPool+  liftHandler $ ExceptT $ runPersistentBackendT cfg pool $ unAuthM m

@@ -0,0 +1,49 @@+module Server(+  -- * Server config+    ServerConfig(..)+  , readConfig+  -- * Server environment+  , ServerEnv+  , newServerEnv+  -- * Execution of server+  , exampleServerApp+  , runExampleServer+  ) where++import Control.Monad.IO.Class+import Control.Monad.Logger+import Data.Proxy+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Middleware.RequestLogger+import Servant.API.Auth.Token+import Servant.Server+import Servant.Server.Auth.Token++import API+import Config+import Monad++-- | Enter infinite loop of processing requests for pdf-master-server.+--+-- Starts new Warp server with initialised threads for serving the master server.+runExampleServer :: MonadIO m => ServerConfig -> m ()+runExampleServer config = liftIO $ do+  env <- newServerEnv config+  liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env++-- | WAI application of server+exampleServerApp :: ServerEnv -> Application+exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl+  where+    apiImpl = enter (serverMtoHandler e) exampleServer++-- | Implementation of main server API+exampleServer :: ServerT ExampleAPI ServerM+exampleServer = testEndpoint++testEndpoint :: MToken' '["test-permission"] -> ServerM ()+testEndpoint token = do+  runAuth $ guardAuthToken token+  $logInfo "testEndpoint"+  return ()

@@ -1,5 +1,5 @@ name:                servant-auth-token-version:             0.3.2.0+version:             0.4.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@@ -13,6 +13,26 @@ extra-source-files:   README.md   CHANGELOG.md+  stack.yaml+  example/acid/src/API.hs+  example/acid/src/Config.hs+  example/acid/src/DB.hs+  example/acid/src/Main.hs+  example/acid/src/Monad.hs+  example/acid/src/Server.hs+  example/acid/LICENSE+  example/acid/Setup.hs+  example/acid/config.yaml+  example/acid/servant-auth-token-example-acid.cabal+  example/persistent/src/API.hs+  example/persistent/src/Config.hs+  example/persistent/src/Main.hs+  example/persistent/src/Monad.hs+  example/persistent/src/Server.hs+  example/persistent/LICENSE+  example/persistent/Setup.hs+  example/persistent/config.yaml+  example/persistent/servant-auth-token-example-persistent.cabal cabal-version:       >=1.10  library@@ -38,8 +58,8 @@     , persistent-postgresql   >= 2.2    && < 2.7     , persistent-template     >= 2.1    && < 2.7     , pwstore-fast            >= 2.4    && < 2.5-    , servant-auth-token-api  >= 0.3.1  && < 0.4-    , servant-server          >= 0.7    && < 0.9+    , servant-auth-token-api  >= 0.4    && < 0.5+    , servant-server          >= 0.9    && < 0.10     , text                    >= 1.2    && < 1.3     , time                    >= 1.5    && < 1.7     , transformers            >= 0.4    && < 0.6@@ -48,10 +68,12 @@   default-language:    Haskell2010   default-extensions:     BangPatterns+    ConstraintKinds     DataKinds     DeriveGeneric     FlexibleContexts     FlexibleInstances+    FunctionalDependencies     GADTs     GeneralizedNewtypeDeriving     KindSignatures@@ -66,3 +88,4 @@ source-repository head   type:     git   location: https://github.com/ncrashed/servant-auth-token+

@@ -11,50 +11,18 @@ 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:+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+  -> ServerM Customer -- ^ Customer data customerGet i token = do-  guardAuthToken token -  runDB404 "customer" $ getCustomer i +  guardAuthToken token+  guard404 "customer" $ getCustomer i @  -}@@ -62,10 +30,10 @@   -- * Implementation     authServer   -- * Server API-  , migrateAll-  , AuthMonad(..)+  , HasStorage(..)+  , AuthHandler   -- * Helpers-  , guardAuthToken +  , guardAuthToken   , ensureAdmin   , authUserByToken   -- * API methods@@ -91,11 +59,10 @@   , authGroupList   -- * Low-level API   , getAuthToken-  ) where +  ) where -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader+import Control.Monad+import Control.Monad.Except import Crypto.PasswordStore import Data.Aeson.Unit import Data.Aeson.WithField@@ -105,8 +72,7 @@ import Data.Time.Clock import Data.UUID import Data.UUID.V4-import Database.Persist.Postgresql-import Servant +import Servant  import Servant.API.Auth.Token import Servant.API.Auth.Token.Pagination@@ -118,41 +84,16 @@ import Servant.Server.Auth.Token.Restore import Servant.Server.Auth.Token.SingleUse -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 authorisation 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 +import qualified Data.ByteString.Lazy as BS  -- | Implementation of AuthAPI-authServer :: AuthConfig -> Server AuthAPI-authServer cfg = enter (convertAuthHandler cfg) (+authServer :: AuthHandler m => ServerT AuthAPI m+authServer =        authSignin   :<|> authSigninGetCode   :<|> authSigninPostCode   :<|> authTouch-  :<|> authToken +  :<|> authToken   :<|> authSignout   :<|> authSignup   :<|> authUsersInfo@@ -162,65 +103,65 @@   :<|> authUserDelete   :<|> authRestore   :<|> authGetSingleUseCodes-  :<|> authGroupGet +  :<|> authGroupGet   :<|> authGroupPost-  :<|> authGroupPut +  :<|> authGroupPut   :<|> authGroupPatch   :<|> authGroupDelete-  :<|> authGroupList)+  :<|> authGroupList  -- | Implementation of "signin" method-authSignin :: AuthMonad m+authSignin :: AuthHandler m   => Maybe Login -- ^ Login query parameter   -> Maybe Password -- ^ Password query parameter   -> Maybe Seconds -- ^ Expire query parameter, how many seconds the token is valid   -> m (OnlyField "token" SimpleToken) -- ^ If everything is OK, return token-authSignin mlogin mpass mexpire = runAuth $ do-  login <- require "login" mlogin -  pass <- require "pass" mpass -  Entity uid UserImpl{..} <- guardLogin login pass+authSignin mlogin mpass mexpire = do+  login <- require "login" mlogin+  pass <- require "pass" mpass+  WithField uid UserImpl{..} <- guardLogin login pass   OnlyField <$> getAuthToken uid mexpire-  where +  where   guardLogin login pass = do -- check login and password, return passed user-    muser <- runDB $ selectFirst [UserImplLogin ==. login] []+    muser <- getUserImplByLogin login     let err = throw401 "Cannot find user with given combination of login and pass"-    case muser of +    case muser of       Nothing -> err-      Just user@(Entity _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword +      Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword         then return user         else err  -- | Helper to get or generate new token for user-getAuthToken :: AuthMonad m+getAuthToken :: AuthHandler m   => UserImplId -- ^ User for whom we want token   -> Maybe Seconds -- ^ Expiration duration, 'Nothing' means default   -> m SimpleToken -- ^ Old token (if it doesn't expire) or new one-getAuthToken uid mexpire = runAuth $ do +getAuthToken uid mexpire = do   expire <- calcExpire mexpire   mt <- getExistingToken  -- check whether there is already existing token-  case mt of +  case mt of     Nothing -> createToken expire -- create new token     Just t -> touchToken t expire -- prolong token expiration time   where   getExistingToken = do -- return active token for specified user id-    t <- liftIO getCurrentTime -    runDB $ selectFirst [AuthTokenUser ==. uid, AuthTokenExpire >. t] []+    t <- liftIO getCurrentTime+    findAuthToken uid t -  createToken expire = do -- generate and save fresh token +  createToken expire = do -- generate and save fresh token     token <- toText <$> liftIO nextRandom-    _ <- runDB $ insert AuthToken {-        authTokenValue = token -      , authTokenUser = uid -      , authTokenExpire = expire +    _ <- insertAuthToken AuthToken {+        authTokenValue = token+      , authTokenUser = uid+      , authTokenExpire = expire       }-    return token +    return token  -- | Authorisation via code of single usage. -- -- Implementation of 'AuthSigninGetCodeMethod' endpoint. -- -- Logic of authorisation via this method is:--- +-- -- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint -- -- * Server generates single use token and sends it via@@ -241,26 +182,26 @@ -- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. -- -- See also: 'authSigninPostCode'-authSigninGetCode :: AuthMonad m +authSigninGetCode :: AuthHandler m   => Maybe Login -- ^ User login, required-  -> m Unit -authSigninGetCode mlogin = runAuth $ do -  login <- require "login" mlogin -  uinfo <- runDB404 "user" $ readUserInfoByLogin login-  let uid = toKey $ respUserId uinfo +  -> m Unit+authSigninGetCode mlogin = do+  login <- require "login" mlogin+  uinfo <- guard404 "user" $ readUserInfoByLogin login+  let uid = toKey $ respUserId uinfo    AuthConfig{..} <- getConfig-  code <- liftIO singleUseCodeGenerator +  code <- liftIO singleUseCodeGenerator   expire <- makeSingleUseExpire singleUseCodeExpire-  runDB $ registerSingleUseCode uid code (Just expire)-  liftIO $ singleUseCodeSender uinfo code +  registerSingleUseCode uid code (Just expire)+  liftIO $ singleUseCodeSender uinfo code -  return Unit +  return Unit  -- | Authorisation via code of single usage. -- -- Logic of authorisation via this method is:--- +-- -- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint -- -- * Server generates single use token and sends it via@@ -281,328 +222,319 @@ -- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. -- -- See also: 'authSigninGetCode'-authSigninPostCode :: AuthMonad m +authSigninPostCode :: AuthHandler m   => Maybe Login -- ^ User login, required   -> Maybe SingleUseCode -- ^ Received single usage code, required-  -> Maybe Seconds -  -- ^ Time interval after which the token expires, 'Nothing' means +  -> Maybe Seconds+  -- ^ Time interval after which the token expires, 'Nothing' means   -- some default value   -> m (OnlyField "token" SimpleToken)-authSigninPostCode mlogin mcode mexpire = runAuth $ do -  login <- require "login" mlogin +authSigninPostCode mlogin mcode mexpire = do+  login <- require "login" mlogin   code <- require "code" mcode -  uinfo <- runDB404 "user" $ readUserInfoByLogin login-  let uid = toKey $ respUserId uinfo -  isValid <- runDB $ validateSingleUseCode uid code +  uinfo <- guard404 "user" $ readUserInfoByLogin login+  let uid = toKey $ respUserId uinfo+  isValid <- validateSingleUseCode uid code   unless isValid $ throw401 "Single usage code doesn't match"    OnlyField <$> getAuthToken uid mexpire  -- | Calculate expiration timestamp for token-calcExpire :: Maybe Seconds -> AuthHandler UTCTime-calcExpire mexpire = do +calcExpire :: AuthHandler m => Maybe Seconds -> m UTCTime+calcExpire mexpire = do   t <- liftIO getCurrentTime   AuthConfig{..} <- getConfig-  let requestedExpire = maybe defaultExpire fromIntegral mexpire +  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 +touchToken :: AuthHandler m => WithId AuthTokenId AuthToken -> UTCTime -> m SimpleToken+touchToken (WithField tid tok) expire = do+  replaceAuthToken tid tok {+      authTokenExpire = expire     }   return $ authTokenValue tok  -- | Implementation of "touch" method-authTouch :: AuthMonad m+authTouch :: AuthHandler m   => 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 +  -> MToken '[] -- ^ Authorisation header with token   -> m Unit-authTouch mexpire token = runAuth $ do -  Entity i mt <- guardAuthToken' (fmap unToken token) []+authTouch mexpire token = do+  WithField i mt <- guardAuthToken' (fmap unToken token) []   expire <- calcExpire mexpire-  runDB $ replace i mt { authTokenExpire = expire }-  return Unit +  replaceAuthToken i mt { authTokenExpire = expire }+  return Unit --- | Implementation of "token" method, return +-- | Implementation of "token" method, return -- info about user binded to the token-authToken :: AuthMonad m-  => MToken '[] -- ^ Authorisation header with token -  -> m RespUserInfo -authToken token = runAuth $ do +authToken :: AuthHandler m+  => MToken '[] -- ^ Authorisation header with token+  -> m RespUserInfo+authToken token = do   i <- authUserByToken token-  runDB404 "user" . readUserInfo . fromKey $ i+  guard404 "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 +authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId+authUserByToken token = do+  WithField _ mt <- guardAuthToken' (fmap unToken token) []+  return $ authTokenUser mt  -- | Implementation of "signout" method-authSignout :: AuthMonad m-  => Maybe (Token '[]) -- ^ Authorisation header with token +authSignout :: AuthHandler m+  => Maybe (Token '[]) -- ^ Authorisation header with token   -> m Unit-authSignout token = runAuth $ do -  Entity i mt <- guardAuthToken' (fmap unToken token) []+authSignout token = do+  WithField i mt <- guardAuthToken' (fmap unToken token) []   expire <- liftIO getCurrentTime-  runDB $ replace i mt { authTokenExpire = expire }-  return Unit -  +  replaceAuthToken i mt { authTokenExpire = expire }+  return Unit+ -- | Checks given password and if it is invalid in terms of config -- password validator, throws 400 error.-guardPassword :: Password -> AuthHandler ()-guardPassword p = do +guardPassword :: AuthHandler m => Password -> m ()+guardPassword p = do   AuthConfig{..} <- getConfig   whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8  -- | Implementation of "signup" method-authSignup :: AuthMonad m+authSignup :: AuthHandler m   => ReqRegister -- ^ Registration info-  -> MToken' '["auth-register"] -- ^ Authorisation header with token +  -> MToken' '["auth-register"] -- ^ Authorisation header with token   -> m (OnlyField "user" UserId)-authSignup ReqRegister{..} token = runAuth $ do +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"+  i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions+  whenJust reqRegGroups $ setUserGroups i+  return $ OnlyField . fromKey $ i+  where+    guardUserInfo = do+      mu <- getUserImplByLogin reqRegLogin+      whenJust mu $ const $ throw400 "User with specified id is already registered"  -- | Implementation of get "users" method-authUsersInfo :: AuthMonad m+authUsersInfo :: AuthHandler m   => Maybe Page -- ^ Page num parameter   -> Maybe PageSize -- ^ Page size parameter   -> MToken' '["auth-info"] -- ^ Authorisation header with token   -> m RespUsersInfo-authUsersInfo mp msize token = runAuth $ do +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])+  pagination mp msize $ \page size -> do+    (users', total) <- listUsersPaged page size+    perms <- mapM (getUserPermissions . (\(WithField i _) -> i)) users'+    groups <- mapM (getUserGroups . (\(WithField i _) -> i)) users'+    let users = zip3 users' perms groups     return RespUsersInfo {-        respUsersItems = (\(user, perms, groups) -> userToUserInfo user perms groups) <$> users +        respUsersItems = (\(user, ps, grs) -> userToUserInfo user ps grs) <$> users       , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size       }  -- | Implementation of get "user" method-authUserInfo :: AuthMonad m-  => UserId -- ^ User id +authUserInfo :: AuthHandler m+  => UserId -- ^ User id   -> MToken' '["auth-info"] -- ^ Authorisation header with token   -> m RespUserInfo-authUserInfo uid' token = runAuth $ do +authUserInfo uid' token = do   guardAuthToken token-  runDB404 "user" $ readUserInfo uid'+  guard404 "user" $ readUserInfo uid'  -- | Implementation of patch "user" method-authUserPatch :: AuthMonad m-  => UserId -- ^ User id +authUserPatch :: AuthHandler m+  => UserId -- ^ User id   -> PatchUser -- ^ JSON with fields for patching   -> MToken' '["auth-update"] -- ^ Authorisation header with token   -> m Unit-authUserPatch uid' body token = runAuth $ do +authUserPatch uid' body token = do   guardAuthToken token-  whenJust (patchUserPassword body) guardPassword -  let uid = toSqlKey . fromIntegral $ uid'-  user <- guardUser uid +  whenJust (patchUserPassword body) guardPassword+  let uid = toKey uid'+  user <- guardUser uid   strength <- getsConfig passwordsStrength-  Entity _ user' <- runDB $ patchUser strength body $ Entity uid user -  runDB $ replace uid user'+  WithField _ user' <- patchUser strength body $ WithField uid user+  replaceUserImpl uid user'   return Unit  -- | Implementation of put "user" method-authUserPut :: AuthMonad m-  => UserId -- ^ User id +authUserPut :: AuthHandler m+  => UserId -- ^ User id   -> ReqRegister -- ^ New user   -> MToken' '["auth-update"] -- ^ Authorisation header with token   -> m Unit-authUserPut uid' ReqRegister{..} token = runAuth $ do +authUserPut uid' ReqRegister{..} token = do   guardAuthToken token   guardPassword reqRegPassword-  let uid = toSqlKey . fromIntegral $ uid'+  let uid = toKey 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-  return Unit +  user' <- setUserPassword reqRegPassword user+  replaceUserImpl uid user'+  setUserPermissions uid reqRegPermissions+  whenJust reqRegGroups $ setUserGroups uid+  return Unit  -- | Implementation of patch "user" method-authUserDelete :: AuthMonad m-  => UserId -- ^ User id +authUserDelete :: AuthHandler m+  => UserId -- ^ User id   -> MToken' '["auth-delete"] -- ^ Authorisation header with token   -> m Unit-authUserDelete uid' token = runAuth $ do +authUserDelete uid' token = do   guardAuthToken token-  runDB $ deleteCascade (toKey uid' :: UserImplId)-  return Unit +  deleteUserImpl $ toKey uid'+  return Unit  -- 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 +-- to email. After that a call of the method with the code is needed to -- change password. Need configured SMTP server.-authRestore :: AuthMonad m-  => UserId -- ^ User id +authRestore :: AuthHandler m+  => UserId -- ^ User id   -> Maybe RestoreCode   -> Maybe Password   -> m Unit-authRestore uid' mcode mpass = runAuth $ do +authRestore uid' mcode mpass = do   let uid = toKey uid'-  user <- guardUser uid -  case mcode of -    Nothing -> do +  user <- guardUser uid+  case mcode of+    Nothing -> do       dt <- getsConfig restoreExpire       t <- liftIO getCurrentTime       AuthConfig{..} <- getConfig-      rc <- runDB $ getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t -      uinfo <- runDB404 "user" $ readUserInfo uid'-      sendRestoreCode uinfo rc -    Just code -> do +      rc <- getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t+      uinfo <- guard404 "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'-  return Unit +      replaceUserImpl uid user'+  return Unit  -- | Implementation of 'AuthGetSingleUseCodes' endpoint.-authGetSingleUseCodes :: AuthMonad m +authGetSingleUseCodes :: AuthHandler m   => UserId -- ^ Id of user   -> Maybe Word -- ^ Number of codes. 'Nothing' means that server generates some default count of codes.   -- And server can define maximum count of codes that user can have at once.   -> MToken' '["auth-single-codes"]   -> m (OnlyField "codes" [SingleUseCode])-authGetSingleUseCodes uid mcount token = runAuth $ do -  guardAuthToken token +authGetSingleUseCodes uid mcount token = do+  guardAuthToken token   let uid' = toKey uid-  _ <- runDB404 "user" $ readUserInfo uid-  AuthConfig{..} <- getConfig -  let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount -  runDB $ OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n +  _ <- guard404 "user" $ readUserInfo uid+  AuthConfig{..} <- getConfig+  let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount+  OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n  -- | Getting user by id, throw 404 response if not found-guardUser :: UserImplId -> AuthHandler UserImpl-guardUser uid = do -  muser <- runDB $ get uid -  case muser of +guardUser :: AuthHandler m => UserImplId -> m UserImpl+guardUser uid = do+  muser <- getUserImpl uid+  case muser of     Nothing -> throw404 "User not found"-    Just user -> return user +    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)+guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m ()+guardAuthToken mt = 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' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken) guardAuthToken' Nothing _ = throw401 "Token required"-guardAuthToken' (Just token) perms = do +guardAuthToken' (Just token) perms = do   t <- liftIO getCurrentTime-  mt <- runDB $ selectFirst [AuthTokenValue ==. token] []-  case mt of +  mt <- findAuthTokenByValue token+  case mt of     Nothing -> throw401 "Token is not valid"-    Just et@(Entity _ AuthToken{..}) -> do +    Just et@(WithField _ AuthToken{..}) -> do       when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" }-      mu <- runDB $ get authTokenUser-      case mu of +      mu <- getUserImpl 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 +          isAdmin <- hasPerm authTokenUser adminPerm+          hasAllPerms <- 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 +setUserPassword :: AuthHandler m => Password -> UserImpl -> m UserImpl+setUserPassword pass user = do+  strength <- getsConfig passwordsStrength+  setUserPassword' strength pass user  -- | Getting info about user group, requires 'authInfoPerm' for token-authGroupGet :: AuthMonad m+authGroupGet :: AuthHandler m   => UserGroupId   -> MToken' '["auth-info"] -- ^ Authorisation header with token   -> m UserGroup-authGroupGet i token = runAuth $ do +authGroupGet i token = do   guardAuthToken token-  runDB404 "user group" $ readUserGroup i +  guard404 "user group" $ readUserGroup i  -- | Inserting new user group, requires 'authUpdatePerm' for token-authGroupPost :: AuthMonad m+authGroupPost :: AuthHandler m   => UserGroup   -> MToken' '["auth-update"] -- ^ Authorisation header with token   -> m (OnlyId UserGroupId)-authGroupPost ug token = runAuth $ do +authGroupPost ug token = do   guardAuthToken token-  runDB $ OnlyField <$> insertUserGroup ug+  OnlyField <$> insertUserGroup ug  -- | Replace info about given user group, requires 'authUpdatePerm' for token-authGroupPut :: AuthMonad m+authGroupPut :: AuthHandler m   => UserGroupId   -> UserGroup   -> MToken' '["auth-update"] -- ^ Authorisation header with token   -> m Unit-authGroupPut i ug token = runAuth $ do +authGroupPut i ug token = do   guardAuthToken token-  runDB $ updateUserGroup i ug +  updateUserGroup i ug   return Unit  -- | Patch info about given user group, requires 'authUpdatePerm' for token-authGroupPatch :: AuthMonad m+authGroupPatch :: AuthHandler m   => UserGroupId   -> PatchUserGroup   -> MToken' '["auth-update"] -- ^ Authorisation header with token   -> m Unit-authGroupPatch i up token = runAuth $ do +authGroupPatch i up token = do   guardAuthToken token-  runDB $ patchUserGroup i up -  return Unit +  patchUserGroup i up+  return Unit  -- | Delete all info about given user group, requires 'authDeletePerm' for token-authGroupDelete :: AuthMonad m+authGroupDelete :: AuthHandler m   => UserGroupId   -> MToken' '["auth-delete"] -- ^ Authorisation header with token   -> m Unit-authGroupDelete i token = runAuth $ do +authGroupDelete i token = do   guardAuthToken token-  runDB $ deleteUserGroup i -  return Unit +  deleteUserGroup i+  return Unit --- | Get list of user groups, requires 'authInfoPerm' for token -authGroupList :: AuthMonad m+-- | Get list of user groups, requires 'authInfoPerm' for token+authGroupList :: AuthHandler m   => Maybe Page   -> Maybe PageSize   -> MToken' '["auth-info"] -- ^ Authorisation header with token   -> m (PagedList UserGroupId UserGroup)-authGroupList mp msize token = runAuth $ do +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])+  pagination mp msize $ \page size -> do+    (groups', total) <- listGroupsPaged page size+    groups <- forM groups' $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey . (\(WithField i _) -> i)     return PagedList {         pagedListItems = catMaybes groups       , pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size

@@ -1,43 +1,38 @@ {-| Module      : Servant.Server.Auth.Token.Common Description : Internal utilities-Copyright   : (c) Anton Gushcha, 2016+Copyright   : (c) Anton Gushcha, 2016-2017 License     : MIT Maintainer  : ncrashed@gmail.com Stability   : experimental Portability : Portable -}-module Servant.Server.Auth.Token.Common where --import Database.Persist.Sql +module Servant.Server.Auth.Token.Common where -import qualified Data.Text as T -import qualified Data.ByteString.Lazy.Char8 as BSL +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 +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 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 +whenJust (Just x) m = m x --- | Shortcut to convert sql key-fromKey :: (Integral a, ToBackendKey SqlBackend record) -  => Key record -> a -fromKey = fromIntegral . fromSqlKey+class ConvertableKey a where+  -- | Shortcut to convert sql key+  fromKey :: Integral b => a -> b --- | Shortcut to convert sql key-toKey :: (Integral a, ToBackendKey SqlBackend record) -  => a -> Key record -toKey = toSqlKey . fromIntegral+  -- | Shortcut to convert sql key+  toKey :: Integral b => b -> a

@@ -9,26 +9,28 @@ -} module Servant.Server.Auth.Token.Config(     AuthConfig(..)+  , HasAuthConfig(..)   , defaultAuthConfig-  ) where +  ) where -import Control.Monad.IO.Class +import Control.Monad.IO.Class import Data.Text (Text)-import Data.Time +import Data.Time import Data.UUID import Data.UUID.V4-import Database.Persist.Sql -import Servant.Server +import Servant.Server -import Servant.API.Auth.Token +import Servant.API.Auth.Token +-- | Monad that can read an auth config+class Monad m => HasAuthConfig m where+  getAuthConfig :: m AuthConfig+ -- | 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+    defaultExpire :: !NominalDiffTime   -- | For password restore, defines amounts of seconds   -- when restore code becomes invalid.   , restoreExpire :: !NominalDiffTime@@ -44,12 +46,12 @@   , 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 +  -- The passwords hashed 2^strength times. It is needed to   -- prevent almost all kinds of brute force 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.   --@@ -58,9 +60,9 @@   -- | Transformation of errors produced by the auth server   , servantErrorFormer :: !(ServantErr -> ServantErr)   -- | Default size of page for pagination-  , defaultPageSize :: !Word +  , defaultPageSize :: !Word   -- | User specified method of sending single usage code for authorisation.-  -- +  --   -- See also: endpoints 'AuthSigninGetCodeMethod' and 'AuthSigninPostCodeMethod'.   --   -- By default does nothing.@@ -69,26 +71,25 @@   --   -- By default 1 hour.   , singleUseCodeExpire :: !NominalDiffTime-  -- | User specified generator for single use codes. +  -- | User specified generator for single use codes.   --   -- By default the server generates UUID that can be unacceptable for SMS way of sending.   , singleUseCodeGenerator :: !(IO SingleUseCode)   -- | Number of not expiring single use codes that user can have at once.   --   -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 100.-  , singleUseCodePermamentMaximum :: !Word -  -- | Number of not expiring single use codes that generated by default when client doesn't +  , singleUseCodePermamentMaximum :: !Word+  -- | Number of not expiring single use codes that generated by default when client doesn't   -- specify the value.   --   -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 20.-  , singleUseCodeDefaultCount :: !Word +  , singleUseCodeDefaultCount :: !Word   }  -- | Default configuration for authorisation server-defaultAuthConfig :: ConnectionPool -> AuthConfig -defaultAuthConfig pool = AuthConfig {-    getPool = pool-  , defaultExpire = fromIntegral (600 :: Int)+defaultAuthConfig :: AuthConfig+defaultAuthConfig = AuthConfig {+    defaultExpire = fromIntegral (600 :: Int)   , restoreExpire = fromIntegral (3*24*3600 :: Int) -- 3 days   , restoreCodeSender = const $ const $ return ()   , restoreCodeGenerator = uuidCodeGenerate

@@ -14,24 +14,23 @@   , throw404   , throw409   , throw500-  ) where +  ) 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 +import qualified Data.ByteString.Lazy as BS  -- | Prepare error response-makeBody :: MonadReader AuthConfig m => ServantErr -> m ServantErr+makeBody :: HasAuthConfig m => ServantErr -> m ServantErr makeBody e = do-  f <- asks servantErrorFormer+  f <- fmap servantErrorFormer getAuthConfig   return $ f e  -- | Wrappers to throw corresponding servant errors-throw400, throw401, throw404, throw409, throw500 -  :: (MonadError ServantErr m, MonadReader AuthConfig m) +throw400, throw401, throw404, throw409, throw500+  :: (MonadError ServantErr m, HasAuthConfig m)   => BS.ByteString -> m a throw400 t = throwError =<< makeBody err400 { errBody = t } throw401 t = throwError =<< makeBody err401 { errBody = t }

@@ -18,7 +18,6 @@   , AuthUserGroup(..)   , AuthUserGroupUsers(..)   , AuthUserGroupPerms(..)-  , EntityField(..)   , UserSingleUseCode(..)   -- * IDs of entities   , UserImplId@@ -29,9 +28,9 @@   , AuthUserGroupUsersId   , AuthUserGroupPermsId   , UserSingleUseCodeId+  -- * DB interface+  , HasStorage(..)   -- * Operations-  , runDB-  , migrateAll   , passToByteString   , byteStringToPass   -- ** User@@ -41,7 +40,6 @@   , getUserPermissions   , setUserPermissions   , createUser-  , hasPerm   , hasPerms   , createAdmin   , ensureAdmin@@ -60,87 +58,243 @@   , updateUserGroup   , deleteUserGroup   , patchUserGroup-  ) where +  ) where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Reader +import Control.Monad+import Control.Monad.IO.Class import Crypto.PasswordStore+import Data.Aeson.WithField+import Data.Int 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 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 +import Servant.API.Auth.Token.Pagination+import Servant.Server.Auth.Token.Common+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+-- | ID of user+newtype UserImplId = UserImplId { unUserImplId :: Int64 }+  deriving (Generic, Show, Eq, Ord) -UserPerm -  user        UserImplId -  permission  Permission-  deriving Generic Show+instance ConvertableKey UserImplId where+  toKey = UserImplId . fromIntegral+  fromKey = fromIntegral . unUserImplId+  {-# INLINE toKey #-}+  {-# INLINE fromKey #-} -AuthToken-  value       SimpleToken -  user        UserImplId-  expire      UTCTime-  deriving Generic Show+-- | Internal user implementation+data UserImpl = UserImpl {+  userImplLogin    :: !Login -- ^ Unique user login+, userImplPassword :: !Password -- ^ Password encrypted with salt+, userImplEmail    :: !Email -- ^ User email+} deriving (Generic, Show) -UserRestore-  value       RestoreCode-  user        UserImplId -  expire      UTCTime -  deriving Generic Show +-- | ID of user permission+newtype UserPermId = UserPermId { unUserPermId :: Int64 }+  deriving (Generic, Show, Eq, Ord) -UserSingleUseCode-  value     SingleUseCode -  user      UserImplId -  expire    UTCTime Maybe -- Nothing is code that never expires-  used      UTCTime Maybe-  deriving Generic Show+instance ConvertableKey UserPermId where+  toKey = UserPermId . fromIntegral+  fromKey = fromIntegral . unUserPermId+  {-# INLINE toKey #-}+  {-# INLINE fromKey #-} -AuthUserGroup-  name        Text -  parent      AuthUserGroupId Maybe-  deriving Generic Show +-- | Internal implementation of permission (1-M)+data UserPerm = UserPerm {+  userPermUser       :: !UserImplId -- ^ Reference to user+, userPermPermission :: !Permission -- ^ Permission tag+} deriving (Generic, Show) -AuthUserGroupUsers-  group       AuthUserGroupId -  user        UserImplId -  deriving Generic Show +-- | ID of authorisation token+newtype AuthTokenId = AuthTokenId { unAuthTokenId :: Int64 }+  deriving (Generic, Show, Eq, Ord) -AuthUserGroupPerms-  group       AuthUserGroupId -  permission  Permission-  deriving Generic Show -|]+instance ConvertableKey AuthTokenId where+  toKey = AuthTokenId . fromIntegral+  fromKey = fromIntegral . unAuthTokenId+  {-# INLINE toKey #-}+  {-# INLINE fromKey #-} --- | Execute database transaction-runDB :: (MonadReader AuthConfig m, MonadIO m) => SqlPersistT IO b -> m b-runDB query = do-  pool <- asks getPool-  liftIO $ runSqlPool query pool+-- | Internal implementation of authorisation token+data AuthToken = AuthToken {+  authTokenValue  :: !SimpleToken -- ^ Value of token+, authTokenUser   :: !UserImplId -- ^ Reference to user of the token+, authTokenExpire :: !UTCTime -- ^ When the token expires+} deriving (Generic, Show) +-- | ID of restoration code+newtype UserRestoreId = UserRestoreId { unUserRestoreId :: Int64 }+  deriving (Generic, Show, Eq, Ord)++instance ConvertableKey UserRestoreId where+  toKey = UserRestoreId . fromIntegral+  fromKey = fromIntegral . unUserRestoreId+  {-# INLINE toKey #-}+  {-# INLINE fromKey #-}++-- | Internal implementation of restoration code+data UserRestore = UserRestore {+  userRestoreValue  :: !RestoreCode -- ^ Code value+, userRestoreUser   :: !UserImplId -- ^ Reference to user that the code restores+, userRestoreExpire :: !UTCTime -- ^ When the code expires+} deriving (Generic, Show)++-- | ID of single use code+newtype UserSingleUseCodeId = UserSingleUseCodeId { unUserSingleUseCodeId :: Int64 }+  deriving (Generic, Show, Eq, Ord)++instance ConvertableKey UserSingleUseCodeId where+  toKey = UserSingleUseCodeId . fromIntegral+  fromKey = fromIntegral . unUserSingleUseCodeId+  {-# INLINE toKey #-}+  {-# INLINE fromKey #-}++-- | Internal implementation of single use code+data UserSingleUseCode = UserSingleUseCode {+  userSingleUseCodeValue  :: !SingleUseCode -- ^ Value of single use code+, userSingleUseCodeUser   :: !UserImplId -- ^ Reference to user the code is owned by+, userSingleUseCodeExpire :: !(Maybe UTCTime) -- ^ When the code expires, 'Nothing' is code that never expires+, userSingleUseCodeUsed   :: !(Maybe UTCTime) -- ^ When the code was used+} deriving (Generic, Show)++-- | ID of user group+newtype AuthUserGroupId = AuthUserGroupId { unAuthUserGroupId :: Int64 }+  deriving (Generic, Show, Eq, Ord)++instance ConvertableKey AuthUserGroupId where+  toKey = AuthUserGroupId . fromIntegral+  fromKey = fromIntegral . unAuthUserGroupId+  {-# INLINE toKey #-}+  {-# INLINE fromKey #-}++-- | Internal implementation of user group+data AuthUserGroup = AuthUserGroup {+  authUserGroupName   :: !Text -- ^ Name of group+, authUserGroupParent :: !(Maybe AuthUserGroupId) -- ^ Can be a child of another group+} deriving (Generic, Show)++-- | ID of user-group binding+newtype AuthUserGroupUsersId = AuthUserGroupUsersId { unAuthUserGroupUsersId :: Int64 }+  deriving (Generic, Show, Eq, Ord)++instance ConvertableKey AuthUserGroupUsersId where+  toKey = AuthUserGroupUsersId . fromIntegral+  fromKey = fromIntegral . unAuthUserGroupUsersId+  {-# INLINE toKey #-}+  {-# INLINE fromKey #-}++-- | Implementation of M-M between user and group+data AuthUserGroupUsers = AuthUserGroupUsers {+  authUserGroupUsersGroup :: !AuthUserGroupId+, authUserGroupUsersUser  :: !UserImplId+} deriving (Generic, Show)++-- | ID of permission-group binding+newtype AuthUserGroupPermsId = AuthUserGroupPermsId { unAuthUserGroupPermsId :: Int64 }+  deriving (Generic, Show, Eq, Ord)++instance ConvertableKey AuthUserGroupPermsId where+  toKey = AuthUserGroupPermsId . fromIntegral+  fromKey = fromIntegral . unAuthUserGroupPermsId+  {-# INLINE toKey #-}+  {-# INLINE fromKey #-}++-- | Implementation of M-M between permission and group+data AuthUserGroupPerms = AuthUserGroupPerms {+  authUserGroupPermsGroup      :: AuthUserGroupId+, authUserGroupPermsPermission :: Permission+} deriving (Generic, Show)++-- | Abstract storage interface. External libraries can implement this in terms+-- of PostgreSQL or acid-state.+class MonadIO m => HasStorage m where+  -- | Getting user from storage+  getUserImpl :: UserImplId -> m (Maybe UserImpl)+  -- | Getting user from storage by login+  getUserImplByLogin :: Login -> m (Maybe (WithId UserImplId UserImpl))+  -- | Get paged list of users and total count of users+  listUsersPaged :: Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)+  -- | Get user permissions, ascending by tag+  getUserImplPermissions :: UserImplId -> m [WithId UserPermId UserPerm]+  -- | Delete user permissions+  deleteUserPermissions :: UserImplId -> m ()+  -- | Insertion of new user permission+  insertUserPerm :: UserPerm -> m UserPermId+  -- | Insertion of new user+  insertUserImpl :: UserImpl -> m UserImplId+  -- | Replace user with new value+  replaceUserImpl :: UserImplId -> UserImpl -> m ()+  -- | Delete user by id+  deleteUserImpl :: UserImplId -> m ()+  -- | Check whether the user has particular permission+  hasPerm :: UserImplId -> Permission -> m Bool+  -- | Get any user with given permission+  getFirstUserByPerm :: Permission -> m (Maybe (WithId UserImplId UserImpl))+  -- | Select user groups and sort them by ascending name+  selectUserImplGroups :: UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]+  -- | Remove user from all groups+  clearUserImplGroups :: UserImplId -> m ()+  -- | Add new user group+  insertAuthUserGroup :: AuthUserGroup -> m AuthUserGroupId+  -- | Add user to given group+  insertAuthUserGroupUsers :: AuthUserGroupUsers -> m AuthUserGroupUsersId+  -- | Add permission to given group+  insertAuthUserGroupPerms :: AuthUserGroupPerms -> m AuthUserGroupPermsId+  -- | Find user group by id+  getAuthUserGroup :: AuthUserGroupId -> m (Maybe AuthUserGroup)+  -- | Get list of permissions of given group+  listAuthUserGroupPermissions :: AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]+  -- | Get list of all users of the group+  listAuthUserGroupUsers :: AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]+  -- | Replace record of user group+  replaceAuthUserGroup :: AuthUserGroupId -> AuthUserGroup -> m ()+  -- | Remove all users from group+  clearAuthUserGroupUsers :: AuthUserGroupId -> m ()+  -- | Remove all permissions from group+  clearAuthUserGroupPerms :: AuthUserGroupId -> m ()+  -- | Delete user group from storage+  deleteAuthUserGroup :: AuthUserGroupId -> m ()+  -- | Get paged list of user groups with total count+  listGroupsPaged :: Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)+  -- | Set group name+  setAuthUserGroupName :: AuthUserGroupId -> Text -> m ()+  -- | Set group parent+  setAuthUserGroupParent :: AuthUserGroupId -> Maybe AuthUserGroupId -> m ()+  -- | Add new single use code+  insertSingleUseCode :: UserSingleUseCode -> m UserSingleUseCodeId+  -- | Set usage time of the single use code+  setSingleUseCodeUsed :: UserSingleUseCodeId -> Maybe UTCTime -> m ()+  -- | Find unused code for the user and expiration time greater than the given time+  getUnusedCode :: SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))+  -- | Invalidate all permament codes for user and set use time for them+  invalidatePermamentCodes :: UserImplId -> UTCTime -> m ()+  -- | Select last valid restoration code by the given current time+  selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))+  -- | Insert new restore code+  insertUserRestore :: UserRestore -> m UserRestoreId+  -- | Find unexpired by the time restore code+  findRestoreCode :: UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))+  -- | Replace restore code with new value+  replaceRestoreCode :: UserRestoreId -> UserRestore -> m ()+  -- | Find first non-expired by the time token for user+  findAuthToken :: UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))+  -- | Find token by value+  findAuthTokenByValue :: SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))+  -- | Insert new token+  insertAuthToken :: AuthToken -> m AuthTokenId+  -- | Replace auth token with new value+  replaceAuthToken :: AuthTokenId -> AuthToken -> m ()+ -- | Convert password to bytestring passToByteString :: Password -> BS.ByteString passToByteString = TE.encodeUtf8@@ -150,103 +304,96 @@ 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+userToUserInfo :: WithId UserImplId UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo+userToUserInfo (WithField uid UserImpl{..}) perms groups = RespUserInfo {+      respUserId = fromKey uid     , respUserLogin = userImplLogin     , respUserEmail = userImplEmail-    , respUserPermissions = perms +    , respUserPermissions = perms     , respUserGroups = groups   }  -- | Low level operation for collecting info about user-makeUserInfo :: Entity UserImpl -> SqlPersistT IO RespUserInfo-makeUserInfo euser = do -  let uid = entityKey euser-  perms <- getUserPermissions uid -  groups <- getUserGroups uid +makeUserInfo :: HasStorage m => WithId UserImplId UserImpl -> m RespUserInfo+makeUserInfo euser@(WithField uid _) = do+  perms <- getUserPermissions uid+  groups <- getUserGroups uid   return $ userToUserInfo euser perms groups  -- | Get user by id-readUserInfo :: UserId -> SqlPersistT IO (Maybe RespUserInfo)-readUserInfo uid' = do +readUserInfo :: HasStorage m => UserId -> m (Maybe RespUserInfo)+readUserInfo uid' = do   let uid = toKey uid'-  muser <- get uid -  maybe (return Nothing) (fmap Just . makeUserInfo . Entity uid) $ muser+  muser <- getUserImpl uid+  maybe (return Nothing) (fmap Just . makeUserInfo . WithField uid) $ muser  -- | Get user by login-readUserInfoByLogin :: Login -> SqlPersistT IO (Maybe RespUserInfo)-readUserInfoByLogin login = do -  muser <- getBy $ UniqueLogin login +readUserInfoByLogin :: HasStorage m => Login -> m (Maybe RespUserInfo)+readUserInfoByLogin login = do+  muser <- getUserImplByLogin login   maybe (return Nothing) (fmap Just . makeUserInfo) muser  -- | 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+getUserPermissions :: HasStorage m => UserImplId -> m [Permission]+getUserPermissions uid = do+  perms <- getUserImplPermissions uid+  return $ userPermPermission . (\(WithField _ v) -> v) <$> 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+setUserPermissions :: HasStorage m => UserImplId -> [Permission] -> m ()+setUserPermissions uid perms = do+  deleteUserPermissions uid+  forM_ perms $ void . insertUserPerm . UserPerm uid  -- | Creation of new user-createUser :: Int -> Login -> Password -> Email -> [Permission] -> SqlPersistT IO UserImplId +createUser :: HasStorage m => Int -> Login -> Password -> Email -> [Permission] -> m UserImplId createUser strength login pass email perms = do   pass' <- liftIO $ makePassword (passToByteString pass) strength-  i <- insert UserImpl {+  i <- insertUserImpl UserImpl {       userImplLogin = login     , userImplPassword = byteStringToPass pass'-    , userImplEmail = email +    , userImplEmail = email     }-  forM_ perms $ void . insert . UserPerm i +  forM_ perms $ void . insertUserPerm . 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 :: HasStorage m => UserImplId -> [Permission] -> m Bool hasPerms _ [] = return True-hasPerms i perms = do -  perms' <- getUserAllPermissions i -  return $ and $ (`elem` perms') <$> perms +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 :: HasStorage m => Int -> Login -> Password -> Email -> m 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 +ensureAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m ()+ensureAdmin strength login pass email = do+  madmin <- getFirstUserByPerm adminPerm+  whenNothing madmin $ void $ createAdmin strength login pass email  -- | Apply patches for user-patchUser :: Int -- ^ Password strength-  -> PatchUser -> Entity UserImpl -> SqlPersistT IO (Entity UserImpl)-patchUser strength PatchUser{..} =  -        withPatch patchUserLogin (\l (Entity i u) -> pure $ Entity i u { userImplLogin = l })+patchUser :: HasStorage m => Int -- ^ Password strength+  -> PatchUser -> WithId UserImplId UserImpl -> m (WithId UserImplId UserImpl)+patchUser strength PatchUser{..} =+        withPatch patchUserLogin (\l (WithField i u) -> pure $ WithField i u { userImplLogin = l })     >=> withPatch patchUserPassword patchPassword-    >=> withPatch patchUserEmail (\e (Entity i u) -> pure $ Entity i u { userImplEmail = e })+    >=> withPatch patchUserEmail (\e (WithField i u) -> pure $ WithField 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 +    where+      patchPassword ps (WithField i u) = WithField <$> pure i <*> setUserPassword' strength ps u+      patchPerms ps (WithField i u) = do         setUserPermissions i ps-        return $ Entity i u-      patchGroups gs (Entity i u) = do +        return $ WithField i u+      patchGroups gs (WithField i u) = do         setUserGroups i gs-        return $ Entity i u+        return $ WithField i u --- | Update password of user +-- | Update password of user setUserPassword' :: MonadIO m => Int -- ^ Password strength   -> Password -> UserImpl -> m UserImpl setUserPassword' strength pass user = do@@ -254,126 +401,120 @@   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]+getUserGroups :: HasStorage m => UserImplId -> m [UserGroupId]+getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . (\(WithField _ v) -> v)) <$> selectUserImplGroups i  -- | 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)+setUserGroups :: HasStorage m => UserImplId -> [UserGroupId] -> m ()+setUserGroups i gs = do+  clearUserImplGroups i+  gs' <- validateGroups gs+  forM_ gs' $ \g -> void $ insertAuthUserGroupUsers $ AuthUserGroupUsers g i  -- | Leave only existing groups-validateGroups :: [UserGroupId] -> SqlPersistT IO [AuthUserGroupId]+validateGroups :: HasStorage m => [UserGroupId] -> m [AuthUserGroupId] validateGroups is = do-  pairs <- mapM ((\i -> (i,) <$> get i) . toKey) is +  pairs <- mapM ((\i -> (i,) <$> getAuthUserGroup 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 :: HasStorage m => UserGroupId -> m [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]+  where+  go !visited !perms !i = do+    mg <- getAuthUserGroup i+    case mg of+      Nothing -> return $ F.toList perms+      Just AuthUserGroup{..} -> do+        curPerms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i         let perms' = perms <> S.fromList curPerms-        case authUserGroupParent of +        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 +            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 +getUserGroupPermissions :: HasStorage m => UserImplId -> m [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 +getUserAllPermissions :: HasStorage m => UserImplId -> m [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]+readUserGroup :: HasStorage m => UserGroupId -> m (Maybe UserGroup)+readUserGroup i = do+  let i' = toKey $ i+  mu <- getAuthUserGroup i'+  case mu of+    Nothing -> return Nothing+    Just AuthUserGroup{..} -> do+      users <- fmap (authUserGroupUsersUser . (\(WithField _ v) -> v)) <$> listAuthUserGroupUsers i'+      perms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i'       return $ Just UserGroup {-          userGroupName = authUserGroupName -        , userGroupUsers = fromKey <$> users -        , userGroupPermissions = perms +          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 +  where   ag = AuthUserGroup {-      authUserGroupName = userGroupName +      authUserGroupName = userGroupName     , authUserGroupParent = toKey <$> userGroupParent     }-  users i = (\ui   -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers +  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 +insertUserGroup :: HasStorage m => UserGroup -> m 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 +  i <- insertAuthUserGroup ag+  forM_ (users i) $ void . insertAuthUserGroupUsers+  forM_ (perms i) $ void . insertAuthUserGroupPerms+  return $ fromKey $ i  -- | Replace user group with new value-updateUserGroup :: UserGroupId -> UserGroup -> SqlPersistT IO ()-updateUserGroup i u = do -  let i' = toKey $ i +updateUserGroup :: HasStorage m => UserGroupId -> UserGroup -> m ()+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+  replaceAuthUserGroup i' ag+  clearAuthUserGroupUsers i'+  clearAuthUserGroupPerms i'+  forM_ (users i') $ void . insertAuthUserGroupUsers+  forM_ (perms i') $ void . insertAuthUserGroupPerms  -- | 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'+deleteUserGroup :: HasStorage m => UserGroupId -> m ()+deleteUserGroup i = do+  let i' = toKey $ i+  clearAuthUserGroupUsers i'+  clearAuthUserGroupPerms i'+  deleteAuthUserGroup 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]+patchUserGroup :: HasStorage m => UserGroupId -> PatchUserGroup -> m ()+patchUserGroup i PatchUserGroup{..} = do+  let i' = toKey i+  whenJust patchUserGroupName $ setAuthUserGroupName i'+  whenJust patchUserGroupParent $ setAuthUserGroupParent i' . Just . toKey+  whenJust patchUserGroupNoParent $ const $ setAuthUserGroupParent i' Nothing   whenJust patchUserGroupUsers $ \uids -> do-    deleteWhere [AuthUserGroupUsersGroup ==. i'] -    forM_ uids $ insert . AuthUserGroupUsers i' . toKey  +    clearAuthUserGroupUsers i'+    forM_ uids $ insertAuthUserGroupUsers . AuthUserGroupUsers i' . toKey   whenJust patchUserGroupPermissions $ \perms -> do-    deleteWhere [AuthUserGroupUsersGroup ==. i'] -    forM_ perms $ insert . AuthUserGroupPerms i'+    clearAuthUserGroupPerms i'+    forM_ perms $ insertAuthUserGroupPerms . AuthUserGroupPerms i'

@@ -8,57 +8,47 @@ Portability : Portable -} module Servant.Server.Auth.Token.Monad(-    AuthHandler(..)+    AuthHandler+  , HasAuthConfig(..)   , require   , getConfig   , getsConfig-  , runDB404+  , guard404   , module Reexport-  ) where +  ) where -import Control.Monad.Except                 (ExceptT, MonadError)-import Control.Monad.Reader                 (MonadIO, MonadReader, ReaderT, ask, asks)+import Control.Monad.Except                 (MonadError)+import Control.Monad.IO.Class import Data.Monoid                          ((<>))-import Database.Persist.Postgresql          -import Servant                              --import qualified Data.ByteString.Lazy as BS +import Servant -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Model +import qualified Data.ByteString.Lazy as BS +import Servant.Server.Auth.Token.Config import Servant.Server.Auth.Token.Error as Reexport+import Servant.Server.Auth.Token.Model --- | 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)+-- | Context that is needed to run the auth server+type AuthHandler m = (HasAuthConfig m, MonadError ServantErr m, MonadIO m, HasStorage m)  -- | If the value is 'Nothing', throw 400 response-require :: BS.ByteString -> Maybe a -> AuthHandler a+require :: AuthHandler m => BS.ByteString -> Maybe a -> m a require info Nothing = throw400 $ info <> " is required"-require _ (Just a) = return a +require _ (Just a) = return a  -- | Getting config from global state-getConfig :: AuthHandler AuthConfig -getConfig = ask+getConfig :: AuthHandler m => m AuthConfig+getConfig = getAuthConfig  -- | Getting config part from global state-getsConfig :: (AuthConfig -> a) -> AuthHandler a -getsConfig = asks +getsConfig :: AuthHandler m => (AuthConfig -> a) -> m a+getsConfig f = fmap f getAuthConfig --- | Run RDBMS operation and throw 404 (not found) error if +-- | 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' +guard404 :: AuthHandler m => BS.ByteString -> m (Maybe a) -> m a+guard404 info ma = do+  a <- ma+  case a of+    Nothing -> throw404 $ "Cannot find " <> info+    Just a' -> return a'

@@ -9,22 +9,23 @@ -} module Servant.Server.Auth.Token.Pagination(     pagination-  ) where +  ) where -import Data.Maybe +import Data.Maybe -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Monad +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+pagination :: AuthHandler m+  => Maybe Page -- ^ Parameter of page   -> Maybe PageSize -- ^ Parameter of page size-  -> (Page -> PageSize -> AuthHandler a) -- ^ Handler-  -> AuthHandler a-pagination pageParam pageSizeParam f = do +  -> (Page -> PageSize -> m a) -- ^ Handler+  -> m a+pagination pageParam pageSizeParam f = do   ps <- getsConfig defaultPageSize-  let page = fromMaybe 0 pageParam +  let page = fromMaybe 0 pageParam       pageSize = fromMaybe ps pageSizeParam-  f page pageSize +  f page pageSize

@@ -11,46 +11,45 @@     getRestoreCode   , guardRestoreCode   , sendRestoreCode-  ) where +  ) where -import Control.Monad -import Control.Monad.IO.Class +import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson.WithField import Data.Time.Clock-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 +import Servant.Server.Auth.Token.Model+import Servant.Server.Auth.Token.Monad  -- | Get current restore code for user or generate new-getRestoreCode :: IO RestoreCode -> UserImplId -> UTCTime -> SqlPersistT IO RestoreCode-getRestoreCode generator uid expire = do +getRestoreCode :: HasStorage m => IO RestoreCode -> UserImplId -> UTCTime -> m RestoreCode+getRestoreCode generator uid expire = do   t <- liftIO getCurrentTime-  mcode <- selectFirst [UserRestoreUser ==. uid, UserRestoreExpire >. t] [Desc UserRestoreExpire]-  case mcode of -    Nothing -> do +  mcode <- selectLastRestoreCode uid t+  case mcode of+    Nothing -> do       code <- liftIO generator-      void $ insert UserRestore {-          userRestoreValue = code +      void $ insertUserRestore UserRestore {+          userRestoreValue = code         , userRestoreUser = uid-        , userRestoreExpire = expire +        , userRestoreExpire = expire         }-      return code -    Just code -> return $ userRestoreValue . entityVal $ code +      return code+    Just code -> return $ userRestoreValue . (\(WithField _ v) -> v) $ 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 +guardRestoreCode :: AuthHandler m => UserImplId -> RestoreCode -> m ()+guardRestoreCode uid code = do   t <- liftIO getCurrentTime-  mcode <- runDB $ selectFirst [UserRestoreUser ==. uid, UserRestoreValue ==. code-    , UserRestoreExpire >. t] [Desc UserRestoreExpire]-  case mcode of +  mcode <- findRestoreCode uid code t+  case mcode of     Nothing -> throw400 "Invalid restore code"-    Just (Entity i rc) -> runDB $ replace i rc { userRestoreExpire = t }+    Just (WithField i rc) -> replaceRestoreCode i rc { userRestoreExpire = t }  -- | Send restore code to the user' email-sendRestoreCode :: RespUserInfo -> RestoreCode -> AuthHandler ()-sendRestoreCode user code = do +sendRestoreCode :: AuthHandler m => RespUserInfo -> RestoreCode -> m ()+sendRestoreCode user code = do   AuthConfig{..} <- getConfig-  liftIO $ restoreCodeSender user code +  liftIO $ restoreCodeSender user code

@@ -10,76 +10,64 @@ module Servant.Server.Auth.Token.SingleUse(     makeSingleUseExpire   , registerSingleUseCode-  , invalideSingleUseCode+  , invalidateSingleUseCode   , validateSingleUseCode   , generateSingleUsedCodes-  ) where +  ) where  import Control.Monad-import Control.Monad.IO.Class -import Data.Time -import Database.Persist.Sql +import Control.Monad.IO.Class+import Data.Aeson.WithField+import Data.Time import Servant.API.Auth.Token import Servant.Server.Auth.Token.Common-import Servant.Server.Auth.Token.Model +import Servant.Server.Auth.Token.Model  -- | Calculate expire date for single usage code makeSingleUseExpire :: MonadIO m => NominalDiffTime -- ^ Duration of code   -> m UTCTime -- ^ Time when the code expires-makeSingleUseExpire dt = do +makeSingleUseExpire dt = do   t <- liftIO getCurrentTime   return $ dt `addUTCTime` t  -- | Register single use code in DB-registerSingleUseCode :: MonadIO m => UserImplId -- ^ Id of user+registerSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user   -> SingleUseCode -- ^ Single usage code   -> Maybe UTCTime -- ^ Time when the code expires, 'Nothing' is never expiring code-  -> SqlPersistT m () -registerSingleUseCode uid code expire = void $ insert +  -> m ()+registerSingleUseCode uid code expire = void $ insertSingleUseCode   $ UserSingleUseCode code uid expire Nothing  -- | Marks single use code that it cannot be used again-invalideSingleUseCode :: MonadIO m => UserSingleUseCodeId -- ^ Id of code-  -> SqlPersistT m ()-invalideSingleUseCode i = do+invalidateSingleUseCode :: HasStorage m => UserSingleUseCodeId -- ^ Id of code+  -> m ()+invalidateSingleUseCode i = do   t <- liftIO getCurrentTime-  update i [UserSingleUseCodeUsed =. Just t] +  setSingleUseCodeUsed i $ Just t  -- | Check single use code and return 'True' on success. -- -- On success invalidates single use code.-validateSingleUseCode :: MonadIO m => UserImplId -- ^ Id of user -  -> SingleUseCode -- ^ Single usage code -  -> SqlPersistT m Bool-validateSingleUseCode uid code = do +validateSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user+  -> SingleUseCode -- ^ Single usage code+  -> m Bool+validateSingleUseCode uid code = do   t <- liftIO getCurrentTime-  mcode <- selectFirst ([-      UserSingleUseCodeValue ==. code-    , UserSingleUseCodeUser ==. uid-    , UserSingleUseCodeUsed ==. Nothing-    ] ++ (-        [UserSingleUseCodeExpire ==. Nothing]-    ||. [UserSingleUseCodeExpire >=. Just t]-    )) [Desc UserSingleUseCodeExpire]-  whenJust mcode $ invalideSingleUseCode . entityKey+  mcode <- getUnusedCode code uid t+  whenJust mcode $ invalidateSingleUseCode . (\(WithField i _) -> i)   return $ maybe False (const True) mcode  -- | Generates a set single use codes that doesn't expire. -- -- Note: previous codes without expiration are invalidated.-generateSingleUsedCodes :: MonadIO m => UserImplId -- ^ Id of user+generateSingleUsedCodes :: HasStorage m => UserImplId -- ^ Id of user   -> IO SingleUseCode -- ^ Generator of codes   -> Word -- Count of codes-  -> SqlPersistT m [SingleUseCode]-generateSingleUsedCodes uid gen n = do +  -> m [SingleUseCode]+generateSingleUsedCodes uid gen n = do   t <- liftIO getCurrentTime-  updateWhere [-      UserSingleUseCodeUser ==. uid-    , UserSingleUseCodeUsed ==. Nothing-    , UserSingleUseCodeExpire ==. Nothing -    ] -    [UserSingleUseCodeUsed =. Just t]-  replicateM (fromIntegral n) $ do -    code <- liftIO gen -    _ <- insert $ UserSingleUseCode code uid Nothing Nothing+  invalidatePermamentCodes uid t+  replicateM (fromIntegral n) $ do+    code <- liftIO gen+    _ <- insertSingleUseCode $ UserSingleUseCode code uid Nothing Nothing     return code

@@ -0,0 +1,83 @@+# This file was automatically generated by 'stack init'+#+# Some commonly used options have been documented as comments in this file.+# For advanced use and comprehensive documentation of the format, please see:+# http://docs.haskellstack.org/en/stable/yaml_configuration/++# Resolver to choose a 'specific' stackage snapshot or a compiler version.+# A snapshot resolver dictates the compiler version and the set of packages+# to be used for project dependencies. For example:+#+# resolver: lts-3.5+# resolver: nightly-2015-09-21+# resolver: ghc-7.10.2+# resolver: ghcjs-0.1.0_ghc-7.10.2+# resolver:+#  name: custom-snapshot+#  location: "./custom-snapshot.yaml"+resolver: lts-7.16++# User packages to be built.+# Various formats can be used as shown in the example below.+#+# packages:+# - some-directory+# - https://example.com/foo/bar/baz-0.0.2.tar.gz+# - location:+#    git: https://github.com/commercialhaskell/stack.git+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a+#   extra-dep: true+#  subdirs:+#  - auto-update+#  - wai+#+# A package marked 'extra-dep: true' will only be built if demanded by a+# non-dependency (i.e. a user package), and its test suites and benchmarks+# will not be run. This is useful for tweaking upstream packages.+packages:+- '.'+- 'servant-auth-token-acid'+- 'servant-auth-token-persistent'+- 'example/acid'+- 'example/persistent'+# - location:+#     git: https://github.com/NCrashed/servant-auth-token-api.git+#     commit: d011f7bfecd18d07ff67ce9f67f8741e110a2719+#   extra-dep: true+- '../servant-auth-token-api'++# Dependency packages to be pulled from upstream that are not in the resolver+# (e.g., acme-missiles-0.3)+extra-deps:+- aeson-injector-1.0.7.0+- http-api-data-0.3.5+- natural-transformation-0.4+- servant-0.9+- servant-docs-0.9+- servant-auth-token-api-0.3.1.0+- servant-server-0.9++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true+#+# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: ">=1.1"+#+# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64+#+# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]+#+# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor