packages feed

servant-auth-token 0.4.6.0 → 0.4.7.0

raw patch · 44 files changed

+3178/−3168 lines, 44 filesdep ~basesetup-changed

Dependency ranges changed: base

Files

CHANGELOG.md view
@@ -1,82 +1,87 @@-0.4.6.0-=======--* Add `withAuthToken` to guard groups of endpoints.--0.4.5.0-=======--* Auto deriving `HasAuthConfig` and `HasStorage` for transformers.--0.4.4.1-=======--* `persistent-postgresql` is not actually used--0.4.4.0-=======--* Add `signinByHashUnsafe` for internal usage.--0.4.3.0-=======--* Implementation for `AuthFindUserByLogin` endpoint.-* Feature to manipulate with hashes of passwords. For instance, now you can store-hashed admin password in config.--0.4.2.0-=======--* Add implementation for `AuthCheckPermissionsMethod` and `AuthGetUserIdMethod` endpoints.--0.4.1.1-=======--* Relax `aeson` and `opt-parse-applicative` bounds.-* Add `monad-control` instances.--0.4.1.0-=======--* Remove persistent dependencies from abstract package.--0.4.0.0-=======--* Abstract over storage: persistent and acid-state backends.--0.3.2.0-=======--* Support lts-7.1 (ghc 8 and persistent-0.6)--0.3.0.0-=======--* Add authorisation by single usage codes.--0.2.0.1-=======--* Relax boundaries for ghc 8.0.1.--0.2.0.0-=======--* Implement `servant-auth-token-0.2.0.0` API.--0.1.2.0-=======--* Expose implementation of API for embedding in complex servers.--0.1.1.0-=======--* Added `restoreCodeGenerator` to configuration--0.1.0.0-=======--* Initial publication+0.4.7.0
+=======
+
+* Make `withAuthToken` work properly.
+
+0.4.6.0
+=======
+
+* Add `withAuthToken` to guard groups of endpoints.
+
+0.4.5.0
+=======
+
+* Auto deriving `HasAuthConfig` and `HasStorage` for transformers.
+
+0.4.4.1
+=======
+
+* `persistent-postgresql` is not actually used
+
+0.4.4.0
+=======
+
+* Add `signinByHashUnsafe` for internal usage.
+
+0.4.3.0
+=======
+
+* Implementation for `AuthFindUserByLogin` endpoint.
+* Feature to manipulate with hashes of passwords. For instance, now you can store
+hashed admin password in config.
+
+0.4.2.0
+=======
+
+* Add implementation for `AuthCheckPermissionsMethod` and `AuthGetUserIdMethod` endpoints.
+
+0.4.1.1
+=======
+
+* Relax `aeson` and `opt-parse-applicative` bounds.
+* Add `monad-control` instances.
+
+0.4.1.0
+=======
+
+* Remove persistent dependencies from abstract package.
+
+0.4.0.0
+=======
+
+* Abstract over storage: persistent and acid-state backends.
+
+0.3.2.0
+=======
+
+* Support lts-7.1 (ghc 8 and persistent-0.6)
+
+0.3.0.0
+=======
+
+* Add authorisation by single usage codes.
+
+0.2.0.1
+=======
+
+* Relax boundaries for ghc 8.0.1.
+
+0.2.0.0
+=======
+
+* Implement `servant-auth-token-0.2.0.0` API.
+
+0.1.2.0
+=======
+
+* Expose implementation of API for embedding in complex servers.
+
+0.1.1.0
+=======
+
+* Added `restoreCodeGenerator` to configuration
+
+0.1.0.0
+=======
+
+* Initial publication
LICENSE view
@@ -1,30 +1,30 @@-Copyright Anton Gushcha (c) 2016-2017--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.+Copyright Anton Gushcha (c) 2016-2017
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of NCrashed nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,27 +1,27 @@-# servant-auth-token--[![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-token-api](https://github.com/NCrashed/servant-auth-token-api).--# How to add to your server--At the moment you have two options for backend storage:--- [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.--- [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.--- 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 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-  -> ServerM Customer -- ^ Customer data-customerGet i token = do-  guardAuthToken token-  runDB404 "customer" $ getCustomer i-```+# servant-auth-token
+
+[![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-token-api](https://github.com/NCrashed/servant-auth-token-api).
+
+# How to add to your server
+
+At the moment you have two options for backend storage:
+
+- [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.
+
+- [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.
+
+- 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 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
+  -> ServerM Customer -- ^ Customer data
+customerGet i token = do
+  guardAuthToken token
+  runDB404 "customer" $ getCustomer i
+```
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain
example/acid/LICENSE view
@@ -1,30 +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.+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.
example/acid/Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain
example/acid/config.yaml view
@@ -1,3 +1,3 @@-host: localhost-port: 3000-db: "state"+host: localhost
+port: 3000
+db: "state"
example/acid/servant-auth-token-example-acid.cabal view
@@ -1,70 +1,70 @@-name:                servant-auth-token-example-acid-version:             0.4.0.1-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     && < 1.1-    , 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.14-    , 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+name:                servant-auth-token-example-acid
+version:             0.4.0.1
+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     && < 1.1
+    , 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.14
+    , 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
example/acid/src/API.hs view
@@ -1,10 +1,10 @@-module API(-    ExampleAPI-  ) where--import Servant.API-import Servant.API.Auth.Token--type ExampleAPI = "test"-  :> TokenHeader' '["test-permission"]-  :> Get '[JSON] ()+module API(
+    ExampleAPI
+  ) where
+
+import Servant.API
+import Servant.API.Auth.Token
+
+type ExampleAPI = "test"
+  :> TokenHeader' '["test-permission"]
+  :> Get '[JSON] ()
example/acid/src/Config.hs view
@@ -1,30 +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+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
example/acid/src/DB.hs view
@@ -1,30 +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+{-# 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
example/acid/src/Main.hs view
@@ -1,35 +1,35 @@-module Main where--import Data.Monoid -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" )+module Main where
+
+import Data.Monoid 
+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" )
example/acid/src/Monad.hs view
@@ -1,98 +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+{-# 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
example/acid/src/Server.hs view
@@ -1,49 +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 ()+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 ()
example/leveldb/LICENSE view
@@ -1,30 +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.+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.
example/leveldb/Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain
example/leveldb/config.yaml view
@@ -1,3 +1,3 @@-host: localhost-port: 3000-db: "state"+host: localhost
+port: 3000
+db: "state"
example/leveldb/servant-auth-token-example-leveldb.cabal view
@@ -1,70 +1,70 @@-name:                servant-auth-token-example-leveldb-version:             0.4.0.1-synopsis:            Example server for token auth for leveldb 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-leveldb-  hs-source-dirs:     src-  main-is:            Main.hs-  other-modules:-    API-    Config-    Monad-    Server-  default-language:   Haskell2010-  build-depends:-      base                          >= 4.7      && < 5-    , acid-state                    >= 0.14     && < 0.15-    , aeson                         >= 0.11     && < 1.1-    , aeson-injector                >= 1.0      && < 1.1-    , bytestring                    >= 0.10     && < 0.11-    , exceptions                    >= 0.8      && < 0.9-    , http-types                    >= 0.9      && < 0.10-    , leveldb-haskell               >= 0.6      && < 0.7-    , monad-control                 >= 1.0      && < 1.1-    , monad-logger                  >= 0.3      && < 0.4-    , mtl                           >= 2.2      && < 2.3-    , optparse-applicative          >= 0.12     && < 0.14-    , safecopy-store                >= 0.9      && < 0.10-    , servant                       >= 0.9      && < 0.10-    , servant-auth-token            >= 0.4      && < 0.5-    , servant-auth-token-api        >= 0.4      && < 0.5-    , servant-auth-token-leveldb    >= 0.4      && < 0.5-    , servant-server                >= 0.9      && < 0.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+name:                servant-auth-token-example-leveldb
+version:             0.4.0.1
+synopsis:            Example server for token auth for leveldb 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-leveldb
+  hs-source-dirs:     src
+  main-is:            Main.hs
+  other-modules:
+    API
+    Config
+    Monad
+    Server
+  default-language:   Haskell2010
+  build-depends:
+      base                          >= 4.7      && < 5
+    , acid-state                    >= 0.14     && < 0.15
+    , aeson                         >= 0.11     && < 1.1
+    , aeson-injector                >= 1.0      && < 1.1
+    , bytestring                    >= 0.10     && < 0.11
+    , exceptions                    >= 0.8      && < 0.9
+    , http-types                    >= 0.9      && < 0.10
+    , leveldb-haskell               >= 0.6      && < 0.7
+    , monad-control                 >= 1.0      && < 1.1
+    , monad-logger                  >= 0.3      && < 0.4
+    , mtl                           >= 2.2      && < 2.3
+    , optparse-applicative          >= 0.12     && < 0.14
+    , safecopy-store                >= 0.9      && < 0.10
+    , servant                       >= 0.9      && < 0.10
+    , servant-auth-token            >= 0.4      && < 0.5
+    , servant-auth-token-api        >= 0.4      && < 0.5
+    , servant-auth-token-leveldb    >= 0.4      && < 0.5
+    , servant-server                >= 0.9      && < 0.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
example/leveldb/src/API.hs view
@@ -1,10 +1,10 @@-module API(-    ExampleAPI-  ) where--import Servant.API-import Servant.API.Auth.Token--type ExampleAPI = "test"-  :> TokenHeader' '["test-permission"]-  :> Get '[JSON] ()+module API(
+    ExampleAPI
+  ) where
+
+import Servant.API
+import Servant.API.Auth.Token
+
+type ExampleAPI = "test"
+  :> TokenHeader' '["test-permission"]
+  :> Get '[JSON] ()
example/leveldb/src/Config.hs view
@@ -1,30 +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+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
example/leveldb/src/Main.hs view
@@ -1,35 +1,35 @@-module Main where--import Data.Monoid -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" )+module Main where
+
+import Data.Monoid 
+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" )
example/leveldb/src/Monad.hs view
@@ -1,98 +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 Database.LevelDB.MonadResource-import Servant.Server-import Servant.Server.Auth.Token.Config-import Servant.Server.Auth.Token.LevelDB-import Servant.Server.Auth.Token.Model--import Config---- | Server private environment-data ServerEnv = ServerEnv {-  -- | Configuration used to create the server-  envConfig      :: !ServerConfig-  -- | Configuration of auth server-, envAuthConfig  :: !AuthConfig-  -- | DB state-, envDB          :: !LevelDBEnv-}---- | Create new server environment-newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv-newServerEnv cfg = do-  let authConfig = defaultAuthConfig-  dbEnv <- liftIO . runResourceT $ do-    db <- open (unpack $ serverDbPath cfg) defaultOptions { createIfMissing = True }-    dbEnv <- newLevelDBEnv db defaultReadOptions defaultWriteOptions-    -- ensure default admin if missing one-    _ <- runLevelDBBackendT authConfig dbEnv $ ensureAdmin 17 "admin" "123456" "admin@localhost"-    return dbEnv-  let env = ServerEnv {-        envConfig = cfg-      , envAuthConfig = authConfig-      , envDB = dbEnv-      }-  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 :: LevelDBBackendT 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 $ runLevelDBBackendT cfg db $ unAuthM m+{-# 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 Database.LevelDB.MonadResource
+import Servant.Server
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.LevelDB
+import Servant.Server.Auth.Token.Model
+
+import Config
+
+-- | Server private environment
+data ServerEnv = ServerEnv {
+  -- | Configuration used to create the server
+  envConfig      :: !ServerConfig
+  -- | Configuration of auth server
+, envAuthConfig  :: !AuthConfig
+  -- | DB state
+, envDB          :: !LevelDBEnv
+}
+
+-- | Create new server environment
+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
+newServerEnv cfg = do
+  let authConfig = defaultAuthConfig
+  dbEnv <- liftIO . runResourceT $ do
+    db <- open (unpack $ serverDbPath cfg) defaultOptions { createIfMissing = True }
+    dbEnv <- newLevelDBEnv db defaultReadOptions defaultWriteOptions
+    -- ensure default admin if missing one
+    _ <- runLevelDBBackendT authConfig dbEnv $ ensureAdmin 17 "admin" "123456" "admin@localhost"
+    return dbEnv
+  let env = ServerEnv {
+        envConfig = cfg
+      , envAuthConfig = authConfig
+      , envDB = dbEnv
+      }
+  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 :: LevelDBBackendT 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 $ runLevelDBBackendT cfg db $ unAuthM m
example/leveldb/src/Server.hs view
@@ -1,49 +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 ()+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 ()
example/persistent/LICENSE view
@@ -1,30 +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.+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.
example/persistent/Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain
example/persistent/config.yaml view
@@ -1,8 +1,8 @@-host: localhost-port: 3000-db-host: localhost-db-port: 5432-db-user: postgres-db-pass: ""-db-base: auth-test-db-size: 10+host: localhost
+port: 3000
+db-host: localhost
+db-port: 5432
+db-user: postgres
+db-pass: ""
+db-base: auth-test
+db-size: 10
example/persistent/servant-auth-token-example-persistent.cabal view
@@ -1,69 +1,69 @@-name:                servant-auth-token-example-persistent-version:             0.4.0.1-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     && < 1.1-    , 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.14-    , 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.6-    , 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+name:                servant-auth-token-example-persistent
+version:             0.4.0.1
+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     && < 1.1
+    , 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.14
+    , 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.6
+    , 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
example/persistent/src/API.hs view
@@ -1,10 +1,10 @@-module API(-    ExampleAPI-  ) where--import Servant.API-import Servant.API.Auth.Token--type ExampleAPI = "test"-  :> TokenHeader' '["test-permission"]-  :> Get '[JSON] ()+module API(
+    ExampleAPI
+  ) where
+
+import Servant.API
+import Servant.API.Auth.Token
+
+type ExampleAPI = "test"
+  :> TokenHeader' '["test-permission"]
+  :> Get '[JSON] ()
example/persistent/src/Config.hs view
@@ -1,58 +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+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
example/persistent/src/Main.hs view
@@ -1,35 +1,35 @@-module Main where--import Data.Monoid-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" )+module Main where
+
+import Data.Monoid
+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" )
example/persistent/src/Monad.hs view
@@ -1,98 +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+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
example/persistent/src/Server.hs view
@@ -1,49 +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 ()+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 ()
servant-auth-token.cabal view
@@ -1,97 +1,97 @@-name:                servant-auth-token-version:             0.4.6.0-synopsis:            Servant based API and server for token based authorisation-description:         Please see README.md-homepage:            https://github.com/ncrashed/servant-auth-token#readme-license:             BSD3-license-file:        LICENSE-author:               Anton Gushcha <ncrashed@gmail.com>-                    , Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>-maintainer:          ncrashed@gmail.com-copyright:           2016-2017 Anton Gushcha-category:            Web-build-type:          Simple-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-  example/leveldb/src/API.hs-  example/leveldb/src/Config.hs-  example/leveldb/src/Main.hs-  example/leveldb/src/Monad.hs-  example/leveldb/src/Server.hs-  example/leveldb/LICENSE-  example/leveldb/Setup.hs-  example/leveldb/config.yaml-  example/leveldb/servant-auth-token-example-leveldb.cabal-cabal-version:       >=1.10--library-  hs-source-dirs:      src-  exposed-modules:-    Servant.Server.Auth.Token-    Servant.Server.Auth.Token.Common-    Servant.Server.Auth.Token.Config-    Servant.Server.Auth.Token.Error-    Servant.Server.Auth.Token.Model-    Servant.Server.Auth.Token.Monad-    Servant.Server.Auth.Token.Pagination-    Servant.Server.Auth.Token.Patch-    Servant.Server.Auth.Token.Restore-    Servant.Server.Auth.Token.SingleUse-  build-depends:-      base                    >= 4.7    && < 5-    , aeson-injector          >= 1.0.4  && < 1.1-    , bytestring              >= 0.10   && < 0.11-    , containers              >= 0.5    && < 0.6-    , mtl                     >= 2.2    && < 2.3-    , pwstore-fast            >= 2.4    && < 2.5-    , servant-auth-token-api  >= 0.4.2  && < 0.5-    , servant-server          >= 0.9    && < 0.10-    , text                    >= 1.2    && < 1.3-    , time                    >= 1.5    && < 1.7-    , transformers            >= 0.4    && < 0.6-    , uuid                    >= 1.3    && < 1.4--  default-language:    Haskell2010-  default-extensions:-    BangPatterns-    ConstraintKinds-    DataKinds-    DeriveGeneric-    FlexibleContexts-    FlexibleInstances-    FunctionalDependencies-    GADTs-    GeneralizedNewtypeDeriving-    KindSignatures-    MultiParamTypeClasses-    OverloadedStrings-    RecordWildCards-    ScopedTypeVariables-    TupleSections-    TypeFamilies-    TypeOperators--source-repository head-  type:     git-  location: https://github.com/ncrashed/servant-auth-token+name:                servant-auth-token
+version:             0.4.7.0
+synopsis:            Servant based API and server for token based authorisation
+description:         Please see README.md
+homepage:            https://github.com/ncrashed/servant-auth-token#readme
+license:             BSD3
+license-file:        LICENSE
+author:               Anton Gushcha <ncrashed@gmail.com>
+                    , Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>
+maintainer:          ncrashed@gmail.com
+copyright:           2016-2017 Anton Gushcha
+category:            Web
+build-type:          Simple
+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
+  example/leveldb/src/API.hs
+  example/leveldb/src/Config.hs
+  example/leveldb/src/Main.hs
+  example/leveldb/src/Monad.hs
+  example/leveldb/src/Server.hs
+  example/leveldb/LICENSE
+  example/leveldb/Setup.hs
+  example/leveldb/config.yaml
+  example/leveldb/servant-auth-token-example-leveldb.cabal
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:
+    Servant.Server.Auth.Token
+    Servant.Server.Auth.Token.Common
+    Servant.Server.Auth.Token.Config
+    Servant.Server.Auth.Token.Error
+    Servant.Server.Auth.Token.Model
+    Servant.Server.Auth.Token.Monad
+    Servant.Server.Auth.Token.Pagination
+    Servant.Server.Auth.Token.Patch
+    Servant.Server.Auth.Token.Restore
+    Servant.Server.Auth.Token.SingleUse
+  build-depends:
+      base                    >= 4.8    && < 5
+    , aeson-injector          >= 1.0.4  && < 1.1
+    , bytestring              >= 0.10   && < 0.11
+    , containers              >= 0.5    && < 0.6
+    , mtl                     >= 2.2    && < 2.3
+    , pwstore-fast            >= 2.4    && < 2.5
+    , servant-auth-token-api  >= 0.4.2  && < 0.5
+    , servant-server          >= 0.9    && < 0.10
+    , text                    >= 1.2    && < 1.3
+    , time                    >= 1.5    && < 1.7
+    , transformers            >= 0.4    && < 0.6
+    , uuid                    >= 1.3    && < 1.4
+
+  default-language:    Haskell2010
+  default-extensions:
+    BangPatterns
+    ConstraintKinds
+    DataKinds
+    DeriveGeneric
+    FlexibleContexts
+    FlexibleInstances
+    FunctionalDependencies
+    GADTs
+    GeneralizedNewtypeDeriving
+    KindSignatures
+    MultiParamTypeClasses
+    OverloadedStrings
+    RecordWildCards
+    ScopedTypeVariables
+    TupleSections
+    TypeFamilies
+    TypeOperators
+
+source-repository head
+  type:     git
+  location: https://github.com/ncrashed/servant-auth-token
src/Servant/Server/Auth/Token.hs view
@@ -1,664 +1,664 @@-{-# LANGUAGE UndecidableInstances #-}-{-|-Module      : Servant.Server.Auth.Token-Description : Implementation of token authorisation API-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--The module is server side implementation of "Servant.API.Auth.Token" API and intended to be-used as drop in module for user servers or as external micro service.----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-  -> ServerM Customer -- ^ Customer data-customerGet i token = do-  guardAuthToken token-  guard404 "customer" $ getCustomer i-@---}-module Servant.Server.Auth.Token(-  -- * Implementation-    authServer-  -- * Server API-  , HasStorage(..)-  , AuthHandler-  -- * Helpers-  , guardAuthToken-  , WithAuthToken(..)-  , ensureAdmin-  , authUserByToken-  -- * API methods-  , authSignin-  , authSigninGetCode-  , authSigninPostCode-  , authTouch-  , authToken-  , authSignout-  , authSignup-  , authUsersInfo-  , authUserInfo-  , authUserPatch-  , authUserPut-  , authUserDelete-  , authRestore-  , authGetSingleUseCodes-  , authGroupGet-  , authGroupPost-  , authGroupPut-  , authGroupPatch-  , authGroupDelete-  , authGroupList-  , authCheckPermissionsMethod-  , authGetUserIdMethod-  , authFindUserByLogin-  -- * Low-level API-  , getAuthToken-  , hashPassword-  , setUserPasswordHash-  , ensureAdminHash-  , signinByHashUnsafe-  ) where--import Control.Monad-import Control.Monad.Except-import Crypto.PasswordStore-import Data.Aeson.Unit-import Data.Aeson.WithField-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import Data.Text.Encoding-import Data.Time.Clock-import Data.UUID-import Data.UUID.V4-import Servant--import Servant.API.Auth.Token-import Servant.API.Auth.Token.Pagination-import Servant.Server.Auth.Token.Common-import Servant.Server.Auth.Token.Config-import Servant.Server.Auth.Token.Model-import Servant.Server.Auth.Token.Monad-import Servant.Server.Auth.Token.Pagination-import Servant.Server.Auth.Token.Restore-import Servant.Server.Auth.Token.SingleUse--import qualified Data.ByteString.Lazy as BS---- | Implementation of AuthAPI-authServer :: AuthHandler m => ServerT AuthAPI m-authServer =-       authSignin-  :<|> authSigninGetCode-  :<|> authSigninPostCode-  :<|> authTouch-  :<|> authToken-  :<|> authSignout-  :<|> authSignup-  :<|> authUsersInfo-  :<|> authUserInfo-  :<|> authUserPatch-  :<|> authUserPut-  :<|> authUserDelete-  :<|> authRestore-  :<|> authGetSingleUseCodes-  :<|> authGroupGet-  :<|> authGroupPost-  :<|> authGroupPut-  :<|> authGroupPatch-  :<|> authGroupDelete-  :<|> authGroupList-  :<|> authCheckPermissionsMethod-  :<|> authGetUserIdMethod-  :<|> authFindUserByLogin---- | Implementation of "signin" method-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 = do-  login <- require "login" mlogin-  pass <- require "pass" mpass-  WithField uid UserImpl{..} <- guardLogin login pass-  OnlyField <$> getAuthToken uid mexpire-  where-  guardLogin login pass = do -- check login and password, return passed user-    muser <- getUserImplByLogin login-    let err = throw401 "Cannot find user with given combination of login and pass"-    case muser of-      Nothing -> err-      Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword-        then return user-        else err---- | Helper to get or generate new token for user-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 = do-  expire <- calcExpire mexpire-  mt <- getExistingToken  -- check whether there is already existing token-  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-    findAuthToken uid t--  createToken expire = do -- generate and save fresh token-    token <- toText <$> liftIO nextRandom-    _ <- insertAuthToken AuthToken {-        authTokenValue = token-      , authTokenUser = uid-      , authTokenExpire = expire-      }-    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---   SMS or email, defined in configuration by 'singleUseCodeSender' field.------ * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint------ * Server responds with auth token.------ * Client uses the token with other requests as authorisation--- header------ * Client can extend lifetime of token by periodically pinging--- of 'AuthTouchMethod' endpoint------ * Client can invalidate token instantly by 'AuthSignoutMethod'------ * Client can get info about user with 'AuthTokenInfoMethod' endpoint.------ See also: 'authSigninPostCode'-authSigninGetCode :: AuthHandler m-  => Maybe Login -- ^ User login, required-  -> m Unit-authSigninGetCode mlogin = do-  login <- require "login" mlogin-  uinfo <- guard404 "user" $ readUserInfoByLogin login-  let uid = toKey $ respUserId uinfo--  AuthConfig{..} <- getConfig-  code <- liftIO singleUseCodeGenerator-  expire <- makeSingleUseExpire singleUseCodeExpire-  registerSingleUseCode uid code (Just expire)-  liftIO $ singleUseCodeSender uinfo code--  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---   SMS or email, defined in configuration by 'singleUseCodeSender' field.------ * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint------ * Server responds with auth token.------ * Client uses the token with other requests as authorisation--- header------ * Client can extend lifetime of token by periodically pinging--- of 'AuthTouchMethod' endpoint------ * Client can invalidate token instantly by 'AuthSignoutMethod'------ * Client can get info about user with 'AuthTokenInfoMethod' endpoint.------ See also: 'authSigninGetCode'-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-  -- some default value-  -> m (OnlyField "token" SimpleToken)-authSigninPostCode mlogin mcode mexpire = do-  login <- require "login" mlogin-  code <- require "code" mcode--  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 :: AuthHandler m => Maybe Seconds -> m UTCTime-calcExpire mexpire = do-  t <- liftIO getCurrentTime-  AuthConfig{..} <- getConfig-  let requestedExpire = maybe defaultExpire fromIntegral mexpire-  let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire-  return $ boundedExpire `addUTCTime` t---- prolong token with new timestamp-touchToken :: 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 :: 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-  -> m Unit-authTouch mexpire token = do-  WithField i mt <- guardAuthToken' (fmap unToken token) []-  expire <- calcExpire mexpire-  replaceAuthToken i mt { authTokenExpire = expire }-  return Unit---- | Implementation of "token" method, return--- info about user binded to the token-authToken :: AuthHandler m-  => MToken '[] -- ^ Authorisation header with token-  -> m RespUserInfo-authToken token = do-  i <- authUserByToken token-  guard404 "user" . readUserInfo . fromKey $ i---- | Getting user id by token-authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId-authUserByToken token = do-  WithField _ mt <- guardAuthToken' (fmap unToken token) []-  return $ authTokenUser mt---- | Implementation of "signout" method-authSignout :: AuthHandler m-  => Maybe (Token '[]) -- ^ Authorisation header with token-  -> m Unit-authSignout token = do-  WithField i mt <- guardAuthToken' (fmap unToken token) []-  expire <- liftIO getCurrentTime-  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 :: AuthHandler m => Password -> m ()-guardPassword p = do-  AuthConfig{..} <- getConfig-  whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8---- | Implementation of "signup" method-authSignup :: AuthHandler m-  => ReqRegister -- ^ Registration info-  -> MToken' '["auth-register"] -- ^ Authorisation header with token-  -> m (OnlyField "user" UserId)-authSignup ReqRegister{..} token = do-  guardAuthToken token-  guardUserInfo-  guardPassword reqRegPassword-  strength <- getsConfig passwordsStrength-  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 :: 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 = do-  guardAuthToken token-  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, ps, grs) -> userToUserInfo user ps grs) <$> users-      , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size-      }---- | Implementation of get "user" method-authUserInfo :: AuthHandler m-  => UserId -- ^ User id-  -> MToken' '["auth-info"] -- ^ Authorisation header with token-  -> m RespUserInfo-authUserInfo uid' token = do-  guardAuthToken token-  guard404 "user" $ readUserInfo uid'---- | Implementation of patch "user" method-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 = do-  guardAuthToken token-  whenJust (patchUserPassword body) guardPassword-  let uid = toKey uid'-  user <- guardUser uid-  strength <- getsConfig passwordsStrength-  WithField _ user' <- patchUser strength body $ WithField uid user-  replaceUserImpl uid user'-  return Unit---- | Implementation of put "user" method-authUserPut :: AuthHandler m-  => UserId -- ^ User id-  -> ReqRegister -- ^ New user-  -> MToken' '["auth-update"] -- ^ Authorisation header with token-  -> m Unit-authUserPut uid' ReqRegister{..} token = do-  guardAuthToken token-  guardPassword reqRegPassword-  let uid = toKey uid'-  let user = UserImpl {-        userImplLogin = reqRegLogin-      , userImplPassword = ""-      , userImplEmail = reqRegEmail-      }-  user' <- setUserPassword reqRegPassword user-  replaceUserImpl uid user'-  setUserPermissions uid reqRegPermissions-  whenJust reqRegGroups $ setUserGroups uid-  return Unit---- | Implementation of patch "user" method-authUserDelete :: AuthHandler m-  => UserId -- ^ User id-  -> MToken' '["auth-delete"] -- ^ Authorisation header with token-  -> m Unit-authUserDelete uid' token = do-  guardAuthToken token-  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--- change password. Need configured SMTP server.-authRestore :: AuthHandler m-  => UserId -- ^ User id-  -> Maybe RestoreCode-  -> Maybe Password-  -> m Unit-authRestore uid' mcode mpass = do-  let uid = toKey uid'-  user <- guardUser uid-  case mcode of-    Nothing -> do-      dt <- getsConfig restoreExpire-      t <- liftIO getCurrentTime-      AuthConfig{..} <- getConfig-      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-      replaceUserImpl uid user'-  return Unit---- | Implementation of 'AuthGetSingleUseCodes' endpoint.-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 = do-  guardAuthToken token-  let uid' = toKey uid-  _ <- 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 :: AuthHandler m => UserImplId -> m UserImpl-guardUser uid = do-  muser <- getUserImpl uid-  case muser of-    Nothing -> throw404 "User not found"-    Just user -> return user---- | If the token is missing or the user of the token--- doesn't have needed permissions, throw 401 response-guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m ()-guardAuthToken mt = void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms)--class WithAuthToken a where--  -- | Authenticate an entire API rather than each individual-  -- endpoint.-  ---  -- As such, for a given 'HasServer' instance @api@, if you have:-  ---  -- @-  --   f :: 'ServerT' api m-  -- @-  ---  -- then:-  ---  -- @-  --   withAuthToken f :: (AuthHandler m) => ServerT ('TokenHeader' perms :> api) m-  -- @-  ---  -- (Note that the types don't reflect this, as it isn't possible to-  -- guarantee what all possible @ServerT@ instances might be.)-  withAuthToken :: (PermsList perms) => a -> MToken perms -> a--instance (AuthHandler m) => WithAuthToken (m a) where-  withAuthToken m mt = guardAuthToken mt *> m--instance (WithAuthToken r) => WithAuthToken (a -> r) where-  withAuthToken f mt = (`withAuthToken` mt) . f--instance (WithAuthToken a, WithAuthToken b) => WithAuthToken (a :<|> b) where-  withAuthToken (a :<|> b) mt = withAuthToken a mt :<|> withAuthToken b mt---- | Same as `guardAuthToken` but returns record about the token-guardAuthToken' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken)-guardAuthToken' Nothing _ = throw401 "Token required"-guardAuthToken' (Just token) perms = do-  t <- liftIO getCurrentTime-  mt <- findAuthTokenByValue token-  case mt of-    Nothing -> throw401 "Token is not valid"-    Just et@(WithField _ AuthToken{..}) -> do-      when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" }-      mu <- getUserImpl authTokenUser-      case mu of-        Nothing -> throw500 "User of the token doesn't exist"-        Just UserImpl{..} -> do-          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 :: AuthHandler m => Password -> UserImpl -> m UserImpl-setUserPassword pass user = do-  strength <- getsConfig passwordsStrength-  setUserPassword' strength pass user---- | Update password hash of user. Can be used to set direct hash for user password--- when it is taken from config file.-setUserPasswordHash :: AuthHandler m => Text -> UserId -> m ()-setUserPasswordHash hashedPassword i = do-  let i' = toKey i-  user <- guard404 "user" $ getUserImpl i'-  let user' = user { userImplPassword = hashedPassword }-  replaceUserImpl i' user'---- | Getting info about user group, requires 'authInfoPerm' for token-authGroupGet :: AuthHandler m-  => UserGroupId-  -> MToken' '["auth-info"] -- ^ Authorisation header with token-  -> m UserGroup-authGroupGet i token = do-  guardAuthToken token-  guard404 "user group" $ readUserGroup i---- | Inserting new user group, requires 'authUpdatePerm' for token-authGroupPost :: AuthHandler m-  => UserGroup-  -> MToken' '["auth-update"] -- ^ Authorisation header with token-  -> m (OnlyId UserGroupId)-authGroupPost ug token = do-  guardAuthToken token-  OnlyField <$> insertUserGroup ug---- | Replace info about given user group, requires 'authUpdatePerm' for token-authGroupPut :: AuthHandler m-  => UserGroupId-  -> UserGroup-  -> MToken' '["auth-update"] -- ^ Authorisation header with token-  -> m Unit-authGroupPut i ug token = do-  guardAuthToken token-  updateUserGroup i ug-  return Unit---- | Patch info about given user group, requires 'authUpdatePerm' for token-authGroupPatch :: AuthHandler m-  => UserGroupId-  -> PatchUserGroup-  -> MToken' '["auth-update"] -- ^ Authorisation header with token-  -> m Unit-authGroupPatch i up token = do-  guardAuthToken token-  patchUserGroup i up-  return Unit---- | Delete all info about given user group, requires 'authDeletePerm' for token-authGroupDelete :: AuthHandler m-  => UserGroupId-  -> MToken' '["auth-delete"] -- ^ Authorisation header with token-  -> m Unit-authGroupDelete i token = do-  guardAuthToken token-  deleteUserGroup i-  return Unit---- | 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 = do-  guardAuthToken token-  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-      }---- | Check that the token has required permissions and return 'False' if it doesn't.-authCheckPermissionsMethod :: AuthHandler m-  => MToken' '["auth-check"] -- ^ Authorisation header with token-  -> OnlyField "permissions" [Permission] -- ^ Body with permissions to check-  -> m Bool -- ^ 'True' if all permissions are OK, 'False' if some permissions are not set for token and 401 error if the token doesn't have 'auth-check' permission.-authCheckPermissionsMethod token (OnlyField perms) = do-  guardAuthToken token-  let check = const True <$> guardAuthToken' (unToken <$> token) perms-  check `catchError` (\e -> if errHTTPCode e == 401 then pure True else throwError e)---- | Get user ID for the owner of the speified token.-authGetUserIdMethod :: AuthHandler m-  => MToken' '["auth-userid"] -- ^ Authorisation header with token-  -> m (OnlyId UserId)-authGetUserIdMethod token = do-  guardAuthToken token-  OnlyField . respUserId <$> authToken (downgradeToken token)---- | Implementation of 'AuthFindUserByLogin'. Find user by login, throw 404 error--- if cannot find user by such login.-authFindUserByLogin :: AuthHandler m-  => Maybe Login -- ^ Login, 'Nothing' will cause 400 error.-  -> MToken' '["auth-info"]-  -> m RespUserInfo-authFindUserByLogin mlogin token = do-  login <- require "login" mlogin-  guardAuthToken token-  userWithId <- guard404 "user" $ getUserImplByLogin login-  makeUserInfo userWithId---- | Generate hash from given password and return it as text. May be useful if--- you don't like storing unencrypt passwords in config files.-hashPassword :: AuthHandler m => Password -> m Text-hashPassword pass = do-  strength <- getsConfig passwordsStrength-  hashed <- liftIO $ makePassword (passToByteString pass) strength-  return $ byteStringToPass hashed---- | Ensures that DB has at least one admin, if not, creates a new one--- with specified info and direct password hash. May be useful if--- you don't like storing unencrypt passwords in config files.-ensureAdminHash :: AuthHandler m => Int -> Login -> Text -> Email -> m ()-ensureAdminHash strength login passHash email = do-  madmin <- getFirstUserByPerm adminPerm-  whenNothing madmin $ do-    i <- createAdmin strength login "" email-    setUserPasswordHash passHash $ fromKey i---- | If you use password hash in configs, you cannot use them in signin--- method. This helper allows to get token by password hash and the function--- is not available for remote call (no endpoint).------ Throws 401 if cannot find user or authorisation is failed.------ WARNING: Do not expose the function to end user, never!-signinByHashUnsafe :: AuthHandler m => Login -- ^ User login-  -> Text -- ^ Hash of admin password-  -> Maybe Seconds -- ^ Expire-  -> m SimpleToken-signinByHashUnsafe login pass mexpire = do-  WithField uid UserImpl{..} <- guardLogin login pass-  getAuthToken uid mexpire-  where-  guardLogin login pass = do -- check login and password, return passed user-    muser <- getUserImplByLogin login-    let err = throw401 "Cannot find user with given combination of login and pass"-    case muser of-      Nothing -> err-      Just user@(WithField _ UserImpl{..}) -> if pass == userImplPassword-        then return user-        else err+{-# LANGUAGE UndecidableInstances #-}
+{-|
+Module      : Servant.Server.Auth.Token
+Description : Implementation of token authorisation API
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+
+The module is server side implementation of "Servant.API.Auth.Token" API and intended to be
+used as drop in module for user servers or as external micro service.
+
+
+
+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
+  -> ServerM Customer -- ^ Customer data
+customerGet i token = do
+  guardAuthToken token
+  guard404 "customer" $ getCustomer i
+@
+
+-}
+module Servant.Server.Auth.Token(
+  -- * Implementation
+    authServer
+  -- * Server API
+  , HasStorage(..)
+  , AuthHandler
+  -- * Helpers
+  , guardAuthToken
+  , WithAuthToken(..)
+  , ensureAdmin
+  , authUserByToken
+  -- * API methods
+  , authSignin
+  , authSigninGetCode
+  , authSigninPostCode
+  , authTouch
+  , authToken
+  , authSignout
+  , authSignup
+  , authUsersInfo
+  , authUserInfo
+  , authUserPatch
+  , authUserPut
+  , authUserDelete
+  , authRestore
+  , authGetSingleUseCodes
+  , authGroupGet
+  , authGroupPost
+  , authGroupPut
+  , authGroupPatch
+  , authGroupDelete
+  , authGroupList
+  , authCheckPermissionsMethod
+  , authGetUserIdMethod
+  , authFindUserByLogin
+  -- * Low-level API
+  , getAuthToken
+  , hashPassword
+  , setUserPasswordHash
+  , ensureAdminHash
+  , signinByHashUnsafe
+  ) where
+
+import Control.Monad
+import Control.Monad.Except
+import Crypto.PasswordStore
+import Data.Aeson.Unit
+import Data.Aeson.WithField
+import Data.Maybe
+import Data.Monoid
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Time.Clock
+import Data.UUID
+import Data.UUID.V4
+import Servant
+
+import Servant.API.Auth.Token
+import Servant.API.Auth.Token.Pagination
+import Servant.Server.Auth.Token.Common
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+import Servant.Server.Auth.Token.Monad
+import Servant.Server.Auth.Token.Pagination
+import Servant.Server.Auth.Token.Restore
+import Servant.Server.Auth.Token.SingleUse
+
+import qualified Data.ByteString.Lazy as BS
+
+-- | Implementation of AuthAPI
+authServer :: AuthHandler m => ServerT AuthAPI m
+authServer =
+       authSignin
+  :<|> authSigninGetCode
+  :<|> authSigninPostCode
+  :<|> authTouch
+  :<|> authToken
+  :<|> authSignout
+  :<|> authSignup
+  :<|> authUsersInfo
+  :<|> authUserInfo
+  :<|> authUserPatch
+  :<|> authUserPut
+  :<|> authUserDelete
+  :<|> authRestore
+  :<|> authGetSingleUseCodes
+  :<|> authGroupGet
+  :<|> authGroupPost
+  :<|> authGroupPut
+  :<|> authGroupPatch
+  :<|> authGroupDelete
+  :<|> authGroupList
+  :<|> authCheckPermissionsMethod
+  :<|> authGetUserIdMethod
+  :<|> authFindUserByLogin
+
+-- | Implementation of "signin" method
+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 = do
+  login <- require "login" mlogin
+  pass <- require "pass" mpass
+  WithField uid UserImpl{..} <- guardLogin login pass
+  OnlyField <$> getAuthToken uid mexpire
+  where
+  guardLogin login pass = do -- check login and password, return passed user
+    muser <- getUserImplByLogin login
+    let err = throw401 "Cannot find user with given combination of login and pass"
+    case muser of
+      Nothing -> err
+      Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword
+        then return user
+        else err
+
+-- | Helper to get or generate new token for user
+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 = do
+  expire <- calcExpire mexpire
+  mt <- getExistingToken  -- check whether there is already existing token
+  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
+    findAuthToken uid t
+
+  createToken expire = do -- generate and save fresh token
+    token <- toText <$> liftIO nextRandom
+    _ <- insertAuthToken AuthToken {
+        authTokenValue = token
+      , authTokenUser = uid
+      , authTokenExpire = expire
+      }
+    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
+--   SMS or email, defined in configuration by 'singleUseCodeSender' field.
+--
+-- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint
+--
+-- * Server responds with auth token.
+--
+-- * Client uses the token with other requests as authorisation
+-- header
+--
+-- * Client can extend lifetime of token by periodically pinging
+-- of 'AuthTouchMethod' endpoint
+--
+-- * Client can invalidate token instantly by 'AuthSignoutMethod'
+--
+-- * Client can get info about user with 'AuthTokenInfoMethod' endpoint.
+--
+-- See also: 'authSigninPostCode'
+authSigninGetCode :: AuthHandler m
+  => Maybe Login -- ^ User login, required
+  -> m Unit
+authSigninGetCode mlogin = do
+  login <- require "login" mlogin
+  uinfo <- guard404 "user" $ readUserInfoByLogin login
+  let uid = toKey $ respUserId uinfo
+
+  AuthConfig{..} <- getConfig
+  code <- liftIO singleUseCodeGenerator
+  expire <- makeSingleUseExpire singleUseCodeExpire
+  registerSingleUseCode uid code (Just expire)
+  liftIO $ singleUseCodeSender uinfo code
+
+  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
+--   SMS or email, defined in configuration by 'singleUseCodeSender' field.
+--
+-- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint
+--
+-- * Server responds with auth token.
+--
+-- * Client uses the token with other requests as authorisation
+-- header
+--
+-- * Client can extend lifetime of token by periodically pinging
+-- of 'AuthTouchMethod' endpoint
+--
+-- * Client can invalidate token instantly by 'AuthSignoutMethod'
+--
+-- * Client can get info about user with 'AuthTokenInfoMethod' endpoint.
+--
+-- See also: 'authSigninGetCode'
+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
+  -- some default value
+  -> m (OnlyField "token" SimpleToken)
+authSigninPostCode mlogin mcode mexpire = do
+  login <- require "login" mlogin
+  code <- require "code" mcode
+
+  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 :: AuthHandler m => Maybe Seconds -> m UTCTime
+calcExpire mexpire = do
+  t <- liftIO getCurrentTime
+  AuthConfig{..} <- getConfig
+  let requestedExpire = maybe defaultExpire fromIntegral mexpire
+  let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire
+  return $ boundedExpire `addUTCTime` t
+
+-- prolong token with new timestamp
+touchToken :: 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 :: 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
+  -> m Unit
+authTouch mexpire token = do
+  WithField i mt <- guardAuthToken' (fmap unToken token) []
+  expire <- calcExpire mexpire
+  replaceAuthToken i mt { authTokenExpire = expire }
+  return Unit
+
+-- | Implementation of "token" method, return
+-- info about user binded to the token
+authToken :: AuthHandler m
+  => MToken '[] -- ^ Authorisation header with token
+  -> m RespUserInfo
+authToken token = do
+  i <- authUserByToken token
+  guard404 "user" . readUserInfo . fromKey $ i
+
+-- | Getting user id by token
+authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId
+authUserByToken token = do
+  WithField _ mt <- guardAuthToken' (fmap unToken token) []
+  return $ authTokenUser mt
+
+-- | Implementation of "signout" method
+authSignout :: AuthHandler m
+  => Maybe (Token '[]) -- ^ Authorisation header with token
+  -> m Unit
+authSignout token = do
+  WithField i mt <- guardAuthToken' (fmap unToken token) []
+  expire <- liftIO getCurrentTime
+  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 :: AuthHandler m => Password -> m ()
+guardPassword p = do
+  AuthConfig{..} <- getConfig
+  whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8
+
+-- | Implementation of "signup" method
+authSignup :: AuthHandler m
+  => ReqRegister -- ^ Registration info
+  -> MToken' '["auth-register"] -- ^ Authorisation header with token
+  -> m (OnlyField "user" UserId)
+authSignup ReqRegister{..} token = do
+  guardAuthToken token
+  guardUserInfo
+  guardPassword reqRegPassword
+  strength <- getsConfig passwordsStrength
+  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 :: 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 = do
+  guardAuthToken token
+  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, ps, grs) -> userToUserInfo user ps grs) <$> users
+      , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
+      }
+
+-- | Implementation of get "user" method
+authUserInfo :: AuthHandler m
+  => UserId -- ^ User id
+  -> MToken' '["auth-info"] -- ^ Authorisation header with token
+  -> m RespUserInfo
+authUserInfo uid' token = do
+  guardAuthToken token
+  guard404 "user" $ readUserInfo uid'
+
+-- | Implementation of patch "user" method
+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 = do
+  guardAuthToken token
+  whenJust (patchUserPassword body) guardPassword
+  let uid = toKey uid'
+  user <- guardUser uid
+  strength <- getsConfig passwordsStrength
+  WithField _ user' <- patchUser strength body $ WithField uid user
+  replaceUserImpl uid user'
+  return Unit
+
+-- | Implementation of put "user" method
+authUserPut :: AuthHandler m
+  => UserId -- ^ User id
+  -> ReqRegister -- ^ New user
+  -> MToken' '["auth-update"] -- ^ Authorisation header with token
+  -> m Unit
+authUserPut uid' ReqRegister{..} token = do
+  guardAuthToken token
+  guardPassword reqRegPassword
+  let uid = toKey uid'
+  let user = UserImpl {
+        userImplLogin = reqRegLogin
+      , userImplPassword = ""
+      , userImplEmail = reqRegEmail
+      }
+  user' <- setUserPassword reqRegPassword user
+  replaceUserImpl uid user'
+  setUserPermissions uid reqRegPermissions
+  whenJust reqRegGroups $ setUserGroups uid
+  return Unit
+
+-- | Implementation of patch "user" method
+authUserDelete :: AuthHandler m
+  => UserId -- ^ User id
+  -> MToken' '["auth-delete"] -- ^ Authorisation header with token
+  -> m Unit
+authUserDelete uid' token = do
+  guardAuthToken token
+  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
+-- change password. Need configured SMTP server.
+authRestore :: AuthHandler m
+  => UserId -- ^ User id
+  -> Maybe RestoreCode
+  -> Maybe Password
+  -> m Unit
+authRestore uid' mcode mpass = do
+  let uid = toKey uid'
+  user <- guardUser uid
+  case mcode of
+    Nothing -> do
+      dt <- getsConfig restoreExpire
+      t <- liftIO getCurrentTime
+      AuthConfig{..} <- getConfig
+      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
+      replaceUserImpl uid user'
+  return Unit
+
+-- | Implementation of 'AuthGetSingleUseCodes' endpoint.
+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 = do
+  guardAuthToken token
+  let uid' = toKey uid
+  _ <- 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 :: AuthHandler m => UserImplId -> m UserImpl
+guardUser uid = do
+  muser <- getUserImpl uid
+  case muser of
+    Nothing -> throw404 "User not found"
+    Just user -> return user
+
+-- | If the token is missing or the user of the token
+-- doesn't have needed permissions, throw 401 response
+guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m ()
+guardAuthToken mt = void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms)
+
+class WithAuthToken a where
+
+  -- | Authenticate an entire API rather than each individual
+  -- endpoint.
+  --
+  -- As such, for a given 'HasServer' instance @api@, if you have:
+  --
+  -- @
+  --   f :: 'ServerT' api m
+  -- @
+  --
+  -- then:
+  --
+  -- @
+  --   withAuthToken f :: (AuthHandler m) => ServerT ('TokenHeader' perms :> api) m
+  -- @
+  --
+  -- (Note that the types don't reflect this, as it isn't possible to
+  -- guarantee what all possible @ServerT@ instances might be.)
+  withAuthToken :: (PermsList perms) => a -> MToken perms -> a
+
+instance (AuthHandler m) => WithAuthToken (m a) where
+  withAuthToken m mt = guardAuthToken mt *> m
+
+instance {-# OVERLAPPING #-} (WithAuthToken r) => WithAuthToken (a -> r) where
+  withAuthToken f mt = (`withAuthToken` mt) . f
+
+instance (WithAuthToken a, WithAuthToken b) => WithAuthToken (a :<|> b) where
+  withAuthToken (a :<|> b) mt = withAuthToken a mt :<|> withAuthToken b mt
+
+-- | Same as `guardAuthToken` but returns record about the token
+guardAuthToken' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken)
+guardAuthToken' Nothing _ = throw401 "Token required"
+guardAuthToken' (Just token) perms = do
+  t <- liftIO getCurrentTime
+  mt <- findAuthTokenByValue token
+  case mt of
+    Nothing -> throw401 "Token is not valid"
+    Just et@(WithField _ AuthToken{..}) -> do
+      when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" }
+      mu <- getUserImpl authTokenUser
+      case mu of
+        Nothing -> throw500 "User of the token doesn't exist"
+        Just UserImpl{..} -> do
+          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 :: AuthHandler m => Password -> UserImpl -> m UserImpl
+setUserPassword pass user = do
+  strength <- getsConfig passwordsStrength
+  setUserPassword' strength pass user
+
+-- | Update password hash of user. Can be used to set direct hash for user password
+-- when it is taken from config file.
+setUserPasswordHash :: AuthHandler m => Text -> UserId -> m ()
+setUserPasswordHash hashedPassword i = do
+  let i' = toKey i
+  user <- guard404 "user" $ getUserImpl i'
+  let user' = user { userImplPassword = hashedPassword }
+  replaceUserImpl i' user'
+
+-- | Getting info about user group, requires 'authInfoPerm' for token
+authGroupGet :: AuthHandler m
+  => UserGroupId
+  -> MToken' '["auth-info"] -- ^ Authorisation header with token
+  -> m UserGroup
+authGroupGet i token = do
+  guardAuthToken token
+  guard404 "user group" $ readUserGroup i
+
+-- | Inserting new user group, requires 'authUpdatePerm' for token
+authGroupPost :: AuthHandler m
+  => UserGroup
+  -> MToken' '["auth-update"] -- ^ Authorisation header with token
+  -> m (OnlyId UserGroupId)
+authGroupPost ug token = do
+  guardAuthToken token
+  OnlyField <$> insertUserGroup ug
+
+-- | Replace info about given user group, requires 'authUpdatePerm' for token
+authGroupPut :: AuthHandler m
+  => UserGroupId
+  -> UserGroup
+  -> MToken' '["auth-update"] -- ^ Authorisation header with token
+  -> m Unit
+authGroupPut i ug token = do
+  guardAuthToken token
+  updateUserGroup i ug
+  return Unit
+
+-- | Patch info about given user group, requires 'authUpdatePerm' for token
+authGroupPatch :: AuthHandler m
+  => UserGroupId
+  -> PatchUserGroup
+  -> MToken' '["auth-update"] -- ^ Authorisation header with token
+  -> m Unit
+authGroupPatch i up token = do
+  guardAuthToken token
+  patchUserGroup i up
+  return Unit
+
+-- | Delete all info about given user group, requires 'authDeletePerm' for token
+authGroupDelete :: AuthHandler m
+  => UserGroupId
+  -> MToken' '["auth-delete"] -- ^ Authorisation header with token
+  -> m Unit
+authGroupDelete i token = do
+  guardAuthToken token
+  deleteUserGroup i
+  return Unit
+
+-- | 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 = do
+  guardAuthToken token
+  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
+      }
+
+-- | Check that the token has required permissions and return 'False' if it doesn't.
+authCheckPermissionsMethod :: AuthHandler m
+  => MToken' '["auth-check"] -- ^ Authorisation header with token
+  -> OnlyField "permissions" [Permission] -- ^ Body with permissions to check
+  -> m Bool -- ^ 'True' if all permissions are OK, 'False' if some permissions are not set for token and 401 error if the token doesn't have 'auth-check' permission.
+authCheckPermissionsMethod token (OnlyField perms) = do
+  guardAuthToken token
+  let check = const True <$> guardAuthToken' (unToken <$> token) perms
+  check `catchError` (\e -> if errHTTPCode e == 401 then pure True else throwError e)
+
+-- | Get user ID for the owner of the speified token.
+authGetUserIdMethod :: AuthHandler m
+  => MToken' '["auth-userid"] -- ^ Authorisation header with token
+  -> m (OnlyId UserId)
+authGetUserIdMethod token = do
+  guardAuthToken token
+  OnlyField . respUserId <$> authToken (downgradeToken token)
+
+-- | Implementation of 'AuthFindUserByLogin'. Find user by login, throw 404 error
+-- if cannot find user by such login.
+authFindUserByLogin :: AuthHandler m
+  => Maybe Login -- ^ Login, 'Nothing' will cause 400 error.
+  -> MToken' '["auth-info"]
+  -> m RespUserInfo
+authFindUserByLogin mlogin token = do
+  login <- require "login" mlogin
+  guardAuthToken token
+  userWithId <- guard404 "user" $ getUserImplByLogin login
+  makeUserInfo userWithId
+
+-- | Generate hash from given password and return it as text. May be useful if
+-- you don't like storing unencrypt passwords in config files.
+hashPassword :: AuthHandler m => Password -> m Text
+hashPassword pass = do
+  strength <- getsConfig passwordsStrength
+  hashed <- liftIO $ makePassword (passToByteString pass) strength
+  return $ byteStringToPass hashed
+
+-- | Ensures that DB has at least one admin, if not, creates a new one
+-- with specified info and direct password hash. May be useful if
+-- you don't like storing unencrypt passwords in config files.
+ensureAdminHash :: AuthHandler m => Int -> Login -> Text -> Email -> m ()
+ensureAdminHash strength login passHash email = do
+  madmin <- getFirstUserByPerm adminPerm
+  whenNothing madmin $ do
+    i <- createAdmin strength login "" email
+    setUserPasswordHash passHash $ fromKey i
+
+-- | If you use password hash in configs, you cannot use them in signin
+-- method. This helper allows to get token by password hash and the function
+-- is not available for remote call (no endpoint).
+--
+-- Throws 401 if cannot find user or authorisation is failed.
+--
+-- WARNING: Do not expose the function to end user, never!
+signinByHashUnsafe :: AuthHandler m => Login -- ^ User login
+  -> Text -- ^ Hash of admin password
+  -> Maybe Seconds -- ^ Expire
+  -> m SimpleToken
+signinByHashUnsafe login pass mexpire = do
+  WithField uid UserImpl{..} <- guardLogin login pass
+  getAuthToken uid mexpire
+  where
+  guardLogin login pass = do -- check login and password, return passed user
+    muser <- getUserImplByLogin login
+    let err = throw401 "Cannot find user with given combination of login and pass"
+    case muser of
+      Nothing -> err
+      Just user@(WithField _ UserImpl{..}) -> if pass == userImplPassword
+        then return user
+        else err
src/Servant/Server/Auth/Token/Common.hs view
@@ -1,38 +1,38 @@-{-|-Module      : Servant.Server.Auth.Token.Common-Description : Internal utilities-Copyright   : (c) Anton Gushcha, 2016-2017-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.Common where--import qualified Data.Text as T-import qualified Data.ByteString.Lazy.Char8 as BSL---- | Helper to print a value to lazy bytestring-showb :: Show a => a -> BSL.ByteString-showb = BSL.pack . show---- | Helper to print a value to text-showt :: Show a => a -> T.Text-showt = T.pack . show---- | Do something when first value is 'Nothing'-whenNothing :: Applicative m => Maybe a -> m () -> m ()-whenNothing Nothing m = m-whenNothing (Just _) _ = pure ()---- | Do something when first value is 'Just'-whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()-whenJust Nothing _ = pure ()-whenJust (Just x) m = m x--class ConvertableKey a where-  -- | Shortcut to convert sql key-  fromKey :: Integral b => a -> b--  -- | Shortcut to convert sql key-  toKey :: Integral b => b -> a+{-|
+Module      : Servant.Server.Auth.Token.Common
+Description : Internal utilities
+Copyright   : (c) Anton Gushcha, 2016-2017
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Common where
+
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy.Char8 as BSL
+
+-- | Helper to print a value to lazy bytestring
+showb :: Show a => a -> BSL.ByteString
+showb = BSL.pack . show
+
+-- | Helper to print a value to text
+showt :: Show a => a -> T.Text
+showt = T.pack . show
+
+-- | Do something when first value is 'Nothing'
+whenNothing :: Applicative m => Maybe a -> m () -> m ()
+whenNothing Nothing m = m
+whenNothing (Just _) _ = pure ()
+
+-- | Do something when first value is 'Just'
+whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
+whenJust Nothing _ = pure ()
+whenJust (Just x) m = m x
+
+class ConvertableKey a where
+  -- | Shortcut to convert sql key
+  fromKey :: Integral b => a -> b
+
+  -- | Shortcut to convert sql key
+  toKey :: Integral b => b -> a
src/Servant/Server/Auth/Token/Config.hs view
@@ -1,138 +1,138 @@-{-# LANGUAGE DefaultSignatures #-}--{-|-Module      : Servant.Server.Auth.Token.Config-Description : Configuration of auth server-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.Config(-    AuthConfig(..)-  , HasAuthConfig(..)-  , defaultAuthConfig-  ) where--import Control.Monad.Cont (ContT)-import Control.Monad.Except (ExceptT)-import Control.Monad.IO.Class-import Control.Monad.Reader (ReaderT)-import qualified Control.Monad.RWS.Lazy as LRWS-import qualified Control.Monad.RWS.Strict as SRWS-import qualified Control.Monad.State.Lazy as LS-import qualified Control.Monad.State.Strict as SS-import qualified Control.Monad.Writer.Lazy as LW-import qualified Control.Monad.Writer.Strict as SW-import Control.Monad.Trans.Class (MonadTrans(lift))-import Data.Text (Text)-import Data.Time-import Data.UUID-import Data.UUID.V4-import Servant.Server--import Servant.API.Auth.Token---- | Monad that can read an auth config-class Monad m => HasAuthConfig m where-  getAuthConfig :: m AuthConfig-  default getAuthConfig :: (m ~ t n, MonadTrans t, HasAuthConfig n) => m AuthConfig-  getAuthConfig = lift getAuthConfig--instance HasAuthConfig m => HasAuthConfig (ContT r m)-instance HasAuthConfig m => HasAuthConfig (ExceptT e m)-instance HasAuthConfig m => HasAuthConfig (ReaderT r m)-instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LRWS.RWST r w s m)-instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SRWS.RWST r w s m)-instance HasAuthConfig m => HasAuthConfig (LS.StateT s m)-instance HasAuthConfig m => HasAuthConfig (SS.StateT s m)-instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LW.WriterT w m)-instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SW.WriterT w m)---- | Configuration specific for authorisation system-data AuthConfig = AuthConfig {-  -- | For authorisation, defines amounts of seconds-  -- when token becomes invalid.-    defaultExpire :: !NominalDiffTime-  -- | For password restore, defines amounts of seconds-  -- when restore code becomes invalid.-  , restoreExpire :: !NominalDiffTime-  -- | User specified implementation of restore code sending. It could-  -- be a email sender or SMS message or mobile application method, whatever-  -- the implementation needs.-  , restoreCodeSender :: !(RespUserInfo -> RestoreCode -> IO ())-  -- | User specified generator for restore codes. By default the server-  -- generates UUID that can be unacceptable for SMS restoration routine.-  , restoreCodeGenerator :: !(IO RestoreCode)-  -- | Upper bound of expiration time that user can request-  -- for a token.-  , maximumExpire :: !(Maybe NominalDiffTime)-  -- | For authorisation, defines amount of hashing-  -- of new user passwords (should be greater or equal 14).-  -- The passwords hashed 2^strength times. It is needed to-  -- prevent almost all kinds of 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.-  ---  -- Default value doesn't validate passwords at all.-  , passwordValidator :: !(Text -> Maybe Text)-  -- | Transformation of errors produced by the auth server-  , servantErrorFormer :: !(ServantErr -> ServantErr)-  -- | Default size of page for pagination-  , defaultPageSize :: !Word-  -- | User specified method of sending single usage code for authorisation.-  ---  -- See also: endpoints 'AuthSigninGetCodeMethod' and 'AuthSigninPostCodeMethod'.-  ---  -- By default does nothing.-  , singleUseCodeSender :: !(RespUserInfo -> SingleUseCode -> IO ())-  -- | Time the generated single usage code expires after.-  ---  -- By default 1 hour.-  , singleUseCodeExpire :: !NominalDiffTime-  -- | 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-  -- specify the value.-  ---  -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 20.-  , singleUseCodeDefaultCount :: !Word-  }---- | Default configuration for authorisation server-defaultAuthConfig :: AuthConfig-defaultAuthConfig = AuthConfig {-    defaultExpire = fromIntegral (600 :: Int)-  , restoreExpire = fromIntegral (3*24*3600 :: Int) -- 3 days-  , restoreCodeSender = const $ const $ return ()-  , restoreCodeGenerator = uuidCodeGenerate-  , maximumExpire = Nothing-  , passwordsStrength = 17-  , passwordValidator = const Nothing-  , servantErrorFormer = id-  , defaultPageSize = 50-  , singleUseCodeSender = const $ const $ return ()-  , singleUseCodeExpire = fromIntegral (60 * 60 :: Int) -- 1 hour-  , singleUseCodeGenerator = uuidSingleUseCodeGenerate-  , singleUseCodePermamentMaximum = 100-  , singleUseCodeDefaultCount = 20-  }---- | Default generator of restore codes-uuidCodeGenerate :: IO RestoreCode-uuidCodeGenerate = toText <$> liftIO nextRandom---- | Default generator of restore codes-uuidSingleUseCodeGenerate :: IO RestoreCode-uuidSingleUseCodeGenerate = toText <$> liftIO nextRandom+{-# LANGUAGE DefaultSignatures #-}
+
+{-|
+Module      : Servant.Server.Auth.Token.Config
+Description : Configuration of auth server
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Config(
+    AuthConfig(..)
+  , HasAuthConfig(..)
+  , defaultAuthConfig
+  ) where
+
+import Control.Monad.Cont (ContT)
+import Control.Monad.Except (ExceptT)
+import Control.Monad.IO.Class
+import Control.Monad.Reader (ReaderT)
+import qualified Control.Monad.RWS.Lazy as LRWS
+import qualified Control.Monad.RWS.Strict as SRWS
+import qualified Control.Monad.State.Lazy as LS
+import qualified Control.Monad.State.Strict as SS
+import qualified Control.Monad.Writer.Lazy as LW
+import qualified Control.Monad.Writer.Strict as SW
+import Control.Monad.Trans.Class (MonadTrans(lift))
+import Data.Text (Text)
+import Data.Time
+import Data.UUID
+import Data.UUID.V4
+import Servant.Server
+
+import Servant.API.Auth.Token
+
+-- | Monad that can read an auth config
+class Monad m => HasAuthConfig m where
+  getAuthConfig :: m AuthConfig
+  default getAuthConfig :: (m ~ t n, MonadTrans t, HasAuthConfig n) => m AuthConfig
+  getAuthConfig = lift getAuthConfig
+
+instance HasAuthConfig m => HasAuthConfig (ContT r m)
+instance HasAuthConfig m => HasAuthConfig (ExceptT e m)
+instance HasAuthConfig m => HasAuthConfig (ReaderT r m)
+instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LRWS.RWST r w s m)
+instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SRWS.RWST r w s m)
+instance HasAuthConfig m => HasAuthConfig (LS.StateT s m)
+instance HasAuthConfig m => HasAuthConfig (SS.StateT s m)
+instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LW.WriterT w m)
+instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SW.WriterT w m)
+
+-- | Configuration specific for authorisation system
+data AuthConfig = AuthConfig {
+  -- | For authorisation, defines amounts of seconds
+  -- when token becomes invalid.
+    defaultExpire :: !NominalDiffTime
+  -- | For password restore, defines amounts of seconds
+  -- when restore code becomes invalid.
+  , restoreExpire :: !NominalDiffTime
+  -- | User specified implementation of restore code sending. It could
+  -- be a email sender or SMS message or mobile application method, whatever
+  -- the implementation needs.
+  , restoreCodeSender :: !(RespUserInfo -> RestoreCode -> IO ())
+  -- | User specified generator for restore codes. By default the server
+  -- generates UUID that can be unacceptable for SMS restoration routine.
+  , restoreCodeGenerator :: !(IO RestoreCode)
+  -- | Upper bound of expiration time that user can request
+  -- for a token.
+  , maximumExpire :: !(Maybe NominalDiffTime)
+  -- | For authorisation, defines amount of hashing
+  -- of new user passwords (should be greater or equal 14).
+  -- The passwords hashed 2^strength times. It is needed to
+  -- prevent almost all kinds of 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.
+  --
+  -- Default value doesn't validate passwords at all.
+  , passwordValidator :: !(Text -> Maybe Text)
+  -- | Transformation of errors produced by the auth server
+  , servantErrorFormer :: !(ServantErr -> ServantErr)
+  -- | Default size of page for pagination
+  , defaultPageSize :: !Word
+  -- | User specified method of sending single usage code for authorisation.
+  --
+  -- See also: endpoints 'AuthSigninGetCodeMethod' and 'AuthSigninPostCodeMethod'.
+  --
+  -- By default does nothing.
+  , singleUseCodeSender :: !(RespUserInfo -> SingleUseCode -> IO ())
+  -- | Time the generated single usage code expires after.
+  --
+  -- By default 1 hour.
+  , singleUseCodeExpire :: !NominalDiffTime
+  -- | 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
+  -- specify the value.
+  --
+  -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 20.
+  , singleUseCodeDefaultCount :: !Word
+  }
+
+-- | Default configuration for authorisation server
+defaultAuthConfig :: AuthConfig
+defaultAuthConfig = AuthConfig {
+    defaultExpire = fromIntegral (600 :: Int)
+  , restoreExpire = fromIntegral (3*24*3600 :: Int) -- 3 days
+  , restoreCodeSender = const $ const $ return ()
+  , restoreCodeGenerator = uuidCodeGenerate
+  , maximumExpire = Nothing
+  , passwordsStrength = 17
+  , passwordValidator = const Nothing
+  , servantErrorFormer = id
+  , defaultPageSize = 50
+  , singleUseCodeSender = const $ const $ return ()
+  , singleUseCodeExpire = fromIntegral (60 * 60 :: Int) -- 1 hour
+  , singleUseCodeGenerator = uuidSingleUseCodeGenerate
+  , singleUseCodePermamentMaximum = 100
+  , singleUseCodeDefaultCount = 20
+  }
+
+-- | Default generator of restore codes
+uuidCodeGenerate :: IO RestoreCode
+uuidCodeGenerate = toText <$> liftIO nextRandom
+
+-- | Default generator of restore codes
+uuidSingleUseCodeGenerate :: IO RestoreCode
+uuidSingleUseCodeGenerate = toText <$> liftIO nextRandom
src/Servant/Server/Auth/Token/Error.hs view
@@ -1,39 +1,39 @@-{-# LANGUAGE TemplateHaskell #-}-{-|-Module      : Servant.Server.Auth.Token.Error-Description : Utilities to wrap errors-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.Error(-    throw400-  , throw401-  , throw404-  , throw409-  , throw500-  ) where--import Control.Monad.Except-import Servant.Server-import Servant.Server.Auth.Token.Config--import qualified Data.ByteString.Lazy as BS---- | Prepare error response-makeBody :: HasAuthConfig m => ServantErr -> m ServantErr-makeBody e = do-  f <- fmap servantErrorFormer getAuthConfig-  return $ f e---- | Wrappers to throw corresponding servant errors-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 }-throw404 t = throwError =<< makeBody err404 { errBody = t }-throw409 t = throwError =<< makeBody err409 { errBody = t }-throw500 t = throwError =<< makeBody err500 { errBody = t }+{-# LANGUAGE TemplateHaskell #-}
+{-|
+Module      : Servant.Server.Auth.Token.Error
+Description : Utilities to wrap errors
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Error(
+    throw400
+  , throw401
+  , throw404
+  , throw409
+  , throw500
+  ) where
+
+import Control.Monad.Except
+import Servant.Server
+import Servant.Server.Auth.Token.Config
+
+import qualified Data.ByteString.Lazy as BS
+
+-- | Prepare error response
+makeBody :: HasAuthConfig m => ServantErr -> m ServantErr
+makeBody e = do
+  f <- fmap servantErrorFormer getAuthConfig
+  return $ f e
+
+-- | Wrappers to throw corresponding servant errors
+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 }
+throw404 t = throwError =<< makeBody err404 { errBody = t }
+throw409 t = throwError =<< makeBody err409 { errBody = t }
+throw500 t = throwError =<< makeBody err500 { errBody = t }
src/Servant/Server/Auth/Token/Model.hs view
@@ -1,654 +1,654 @@-{-# LANGUAGE DefaultSignatures #-}-{-|-Module      : Servant.Server.Auth.Token.Model-Description : Internal operations with RDBMS-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.Model(-  -- * DB entities-    UserImpl(..)-  , UserPerm(..)-  , AuthToken(..)-  , UserRestore(..)-  , AuthUserGroup(..)-  , AuthUserGroupUsers(..)-  , AuthUserGroupPerms(..)-  , UserSingleUseCode(..)-  -- * IDs of entities-  , UserImplId-  , UserPermId-  , AuthTokenId-  , UserRestoreId-  , AuthUserGroupId-  , AuthUserGroupUsersId-  , AuthUserGroupPermsId-  , UserSingleUseCodeId-  -- * DB interface-  , HasStorage(..)-  -- * Operations-  , passToByteString-  , byteStringToPass-  -- ** User-  , userToUserInfo-  , readUserInfo-  , readUserInfoByLogin-  , getUserPermissions-  , setUserPermissions-  , createUser-  , hasPerms-  , createAdmin-  , ensureAdmin-  , patchUser-  , setUserPassword'-  -- ** User groups-  , getUserGroups-  , setUserGroups-  , validateGroups-  , getGroupPermissions-  , getUserGroupPermissions-  , getUserAllPermissions-  , readUserGroup-  , toAuthUserGroup-  , insertUserGroup-  , updateUserGroup-  , deleteUserGroup-  , patchUserGroup-  -- * Low-level-  , makeUserInfo-  ) where--import Control.Monad-import Control.Monad.Cont (ContT)-import Control.Monad.Except (ExceptT)-import Control.Monad.IO.Class-import Control.Monad.Reader (ReaderT)-import qualified Control.Monad.RWS.Lazy as LRWS-import qualified Control.Monad.RWS.Strict as SRWS-import qualified Control.Monad.State.Lazy as LS-import qualified Control.Monad.State.Strict as SS-import qualified Control.Monad.Writer.Lazy as LW-import qualified Control.Monad.Writer.Strict as SW-import Control.Monad.Trans.Class (MonadTrans(lift))-import Crypto.PasswordStore-import Data.Aeson.WithField-import Data.Int-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import Data.Time-import GHC.Generics--import qualified Data.ByteString as BS-import qualified Data.Foldable as F-import qualified Data.List as L-import qualified Data.Sequence as S-import qualified Data.Text.Encoding as TE--import Servant.API.Auth.Token-import Servant.API.Auth.Token.Pagination-import Servant.Server.Auth.Token.Common-import Servant.Server.Auth.Token.Patch---- | ID of user-newtype UserImplId = UserImplId { unUserImplId :: Int64 }-  deriving (Generic, Show, Eq, Ord)--instance ConvertableKey UserImplId where-  toKey = UserImplId . fromIntegral-  fromKey = fromIntegral . unUserImplId-  {-# INLINE toKey #-}-  {-# INLINE fromKey #-}---- | Internal user implementation-data UserImpl = UserImpl {-  userImplLogin    :: !Login -- ^ Unique user login-, userImplPassword :: !Password -- ^ Password encrypted with salt-, userImplEmail    :: !Email -- ^ User email-} deriving (Generic, Show)---- | ID of user permission-newtype UserPermId = UserPermId { unUserPermId :: Int64 }-  deriving (Generic, Show, Eq, Ord)--instance ConvertableKey UserPermId where-  toKey = UserPermId . fromIntegral-  fromKey = fromIntegral . unUserPermId-  {-# INLINE toKey #-}-  {-# INLINE fromKey #-}---- | Internal implementation of permission (1-M)-data UserPerm = UserPerm {-  userPermUser       :: !UserImplId -- ^ Reference to user-, userPermPermission :: !Permission -- ^ Permission tag-} deriving (Generic, Show)---- | ID of authorisation token-newtype AuthTokenId = AuthTokenId { unAuthTokenId :: Int64 }-  deriving (Generic, Show, Eq, Ord)--instance ConvertableKey AuthTokenId where-  toKey = AuthTokenId . fromIntegral-  fromKey = fromIntegral . unAuthTokenId-  {-# INLINE toKey #-}-  {-# INLINE fromKey #-}---- | 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)-  default getUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m (Maybe UserImpl)-  getUserImpl = lift . getUserImpl--  -- | Getting user from storage by login-  getUserImplByLogin :: Login -> m (Maybe (WithId UserImplId UserImpl))-  default getUserImplByLogin :: (m ~ t n, MonadTrans t, HasStorage n) => Login -> m (Maybe (WithId UserImplId UserImpl))-  getUserImplByLogin = lift . getUserImplByLogin--  -- | Get paged list of users and total count of users-  listUsersPaged :: Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)-  default listUsersPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)-  listUsersPaged = (lift .) . listUsersPaged--  -- | Get user permissions, ascending by tag-  getUserImplPermissions :: UserImplId -> m [WithId UserPermId UserPerm]-  default getUserImplPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId UserPermId UserPerm]-  getUserImplPermissions = lift . getUserImplPermissions--  -- | Delete user permissions-  deleteUserPermissions :: UserImplId -> m ()-  default deleteUserPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()-  deleteUserPermissions = lift . deleteUserPermissions--  -- | Insertion of new user permission-  insertUserPerm :: UserPerm -> m UserPermId-  default insertUserPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserPerm -> m UserPermId-  insertUserPerm = lift . insertUserPerm--  -- | Insertion of new user-  insertUserImpl :: UserImpl -> m UserImplId-  default insertUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImpl -> m UserImplId-  insertUserImpl = lift . insertUserImpl--  -- | Replace user with new value-  replaceUserImpl :: UserImplId -> UserImpl -> m ()-  default replaceUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UserImpl -> m ()-  replaceUserImpl = (lift .) . replaceUserImpl--  -- | Delete user by id-  deleteUserImpl :: UserImplId -> m ()-  default deleteUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()-  deleteUserImpl = lift . deleteUserImpl--  -- | Check whether the user has particular permission-  hasPerm :: UserImplId -> Permission -> m Bool-  default hasPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> Permission -> m Bool-  hasPerm = (lift .) . hasPerm--  -- | Get any user with given permission-  getFirstUserByPerm :: Permission -> m (Maybe (WithId UserImplId UserImpl))-  default getFirstUserByPerm :: (m ~ t n, MonadTrans t, HasStorage n) => Permission -> m (Maybe (WithId UserImplId UserImpl))-  getFirstUserByPerm = lift . getFirstUserByPerm--  -- | Select user groups and sort them by ascending name-  selectUserImplGroups :: UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]-  default selectUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]-  selectUserImplGroups = lift . selectUserImplGroups--  -- | Remove user from all groups-  clearUserImplGroups :: UserImplId -> m ()-  default clearUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()-  clearUserImplGroups = lift . clearUserImplGroups--  -- | Add new user group-  insertAuthUserGroup :: AuthUserGroup -> m AuthUserGroupId-  default insertAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroup -> m AuthUserGroupId-  insertAuthUserGroup = lift . insertAuthUserGroup--  -- | Add user to given group-  insertAuthUserGroupUsers :: AuthUserGroupUsers -> m AuthUserGroupUsersId-  default insertAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupUsers -> m AuthUserGroupUsersId-  insertAuthUserGroupUsers = lift . insertAuthUserGroupUsers--  -- | Add permission to given group-  insertAuthUserGroupPerms :: AuthUserGroupPerms -> m AuthUserGroupPermsId-  default insertAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupPerms -> m AuthUserGroupPermsId-  insertAuthUserGroupPerms = lift . insertAuthUserGroupPerms--  -- | Find user group by id-  getAuthUserGroup :: AuthUserGroupId -> m (Maybe AuthUserGroup)-  default getAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m (Maybe AuthUserGroup)-  getAuthUserGroup = lift . getAuthUserGroup--  -- | Get list of permissions of given group-  listAuthUserGroupPermissions :: AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]-  default listAuthUserGroupPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]-  listAuthUserGroupPermissions = lift . listAuthUserGroupPermissions--  -- | Get list of all users of the group-  listAuthUserGroupUsers :: AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]-  default listAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]-  listAuthUserGroupUsers = lift . listAuthUserGroupUsers--  -- | Replace record of user group-  replaceAuthUserGroup :: AuthUserGroupId -> AuthUserGroup -> m ()-  default replaceAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> AuthUserGroup -> m ()-  replaceAuthUserGroup = (lift .) . replaceAuthUserGroup--  -- | Remove all users from group-  clearAuthUserGroupUsers :: AuthUserGroupId -> m ()-  default clearAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()-  clearAuthUserGroupUsers = lift . clearAuthUserGroupUsers--  -- | Remove all permissions from group-  clearAuthUserGroupPerms :: AuthUserGroupId -> m ()-  default clearAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()-  clearAuthUserGroupPerms = lift . clearAuthUserGroupPerms--  -- | Delete user group from storage-  deleteAuthUserGroup :: AuthUserGroupId -> m ()-  default deleteAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()-  deleteAuthUserGroup = lift . deleteAuthUserGroup--  -- | Get paged list of user groups with total count-  listGroupsPaged :: Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)-  default listGroupsPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)-  listGroupsPaged = (lift .) . listGroupsPaged--  -- | Set group name-  setAuthUserGroupName :: AuthUserGroupId -> Text -> m ()-  default setAuthUserGroupName :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Text -> m ()-  setAuthUserGroupName = (lift .) . setAuthUserGroupName--  -- | Set group parent-  setAuthUserGroupParent :: AuthUserGroupId -> Maybe AuthUserGroupId -> m ()-  default setAuthUserGroupParent :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Maybe AuthUserGroupId -> m ()-  setAuthUserGroupParent = (lift .) . setAuthUserGroupParent--  -- | Add new single use code-  insertSingleUseCode :: UserSingleUseCode -> m UserSingleUseCodeId-  default insertSingleUseCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCode -> m UserSingleUseCodeId-  insertSingleUseCode = lift . insertSingleUseCode--  -- | Set usage time of the single use code-  setSingleUseCodeUsed :: UserSingleUseCodeId -> Maybe UTCTime -> m ()-  default setSingleUseCodeUsed :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCodeId -> Maybe UTCTime -> m ()-  setSingleUseCodeUsed = (lift .) . setSingleUseCodeUsed--  -- | Find unused code for the user and expiration time greater than the given time-  getUnusedCode :: SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))-  default getUnusedCode :: (m ~ t n, MonadTrans t, HasStorage n) => SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))-  getUnusedCode suc = (lift .) . getUnusedCode suc--  -- | Invalidate all permament codes for user and set use time for them-  invalidatePermamentCodes :: UserImplId -> UTCTime -> m ()-  default invalidatePermamentCodes :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m ()-  invalidatePermamentCodes = (lift .) . invalidatePermamentCodes--  -- | Select last valid restoration code by the given current time-  selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))-  default selectLastRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))-  selectLastRestoreCode = (lift .) . selectLastRestoreCode--  -- | Insert new restore code-  insertUserRestore :: UserRestore -> m UserRestoreId-  default insertUserRestore :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestore -> m UserRestoreId-  insertUserRestore = lift . insertUserRestore--  -- | Find unexpired by the time restore code-  findRestoreCode :: UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))-  default findRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))-  findRestoreCode uid = (lift .) . findRestoreCode uid--  -- | Replace restore code with new value-  replaceRestoreCode :: UserRestoreId -> UserRestore -> m ()-  default replaceRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestoreId -> UserRestore -> m ()-  replaceRestoreCode = (lift .) . replaceRestoreCode--  -- | Find first non-expired by the time token for user-  findAuthToken :: UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))-  default findAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))-  findAuthToken = (lift .) . findAuthToken--  -- | Find token by value-  findAuthTokenByValue :: SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))-  default findAuthTokenByValue :: (m ~ t n, MonadTrans t, HasStorage n) => SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))-  findAuthTokenByValue = lift . findAuthTokenByValue--  -- | Insert new token-  insertAuthToken :: AuthToken -> m AuthTokenId-  default insertAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthToken -> m AuthTokenId-  insertAuthToken = lift . insertAuthToken--  -- | Replace auth token with new value-  replaceAuthToken :: AuthTokenId -> AuthToken -> m ()-  default replaceAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthTokenId -> AuthToken -> m ()-  replaceAuthToken = (lift .) . replaceAuthToken--instance HasStorage m => HasStorage (ContT r m)-instance HasStorage m => HasStorage (ExceptT e m)-instance HasStorage m => HasStorage (ReaderT r m)-instance (HasStorage m, Monoid w) => HasStorage (LRWS.RWST r w s m)-instance (HasStorage m, Monoid w) => HasStorage (SRWS.RWST r w s m)-instance HasStorage m => HasStorage (LS.StateT s m)-instance HasStorage m => HasStorage (SS.StateT s m)-instance (HasStorage m, Monoid w) => HasStorage (LW.WriterT w m)-instance (HasStorage m, Monoid w) => HasStorage (SW.WriterT w m)---- | Convert password to bytestring-passToByteString :: Password -> BS.ByteString-passToByteString = TE.encodeUtf8---- | Convert bytestring into password-byteStringToPass :: BS.ByteString -> Password-byteStringToPass = TE.decodeUtf8---- | Helper to convert user to response-userToUserInfo :: WithId UserImplId UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo-userToUserInfo (WithField uid UserImpl{..}) perms groups = RespUserInfo {-      respUserId = fromKey uid-    , respUserLogin = userImplLogin-    , respUserEmail = userImplEmail-    , respUserPermissions = perms-    , respUserGroups = groups-  }---- | Low level operation for collecting info about user-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 :: HasStorage m => UserId -> m (Maybe RespUserInfo)-readUserInfo uid' = do-  let uid = toKey uid'-  muser <- getUserImpl uid-  maybe (return Nothing) (fmap Just . makeUserInfo . WithField uid) $ muser---- | Get user by 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 :: 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 :: HasStorage m => UserImplId -> [Permission] -> m ()-setUserPermissions uid perms = do-  deleteUserPermissions uid-  forM_ perms $ void . insertUserPerm . UserPerm uid---- | Creation of new user-createUser :: HasStorage m => Int -> Login -> Password -> Email -> [Permission] -> m UserImplId-createUser strength login pass email perms = do-  pass' <- liftIO $ makePassword (passToByteString pass) strength-  i <- insertUserImpl UserImpl {-      userImplLogin = login-    , userImplPassword = byteStringToPass pass'-    , userImplEmail = email-    }-  forM_ perms $ void . insertUserPerm . UserPerm i-  return i---- | Check whether the user has particular permissions-hasPerms :: HasStorage m => UserImplId -> [Permission] -> m Bool-hasPerms _ [] = return True-hasPerms i perms = do-  perms' <- getUserAllPermissions i-  return $ and $ (`elem` perms') <$> perms---- | Creates user with admin privileges-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 :: 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 :: 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 (WithField i u) -> pure $ WithField i u { userImplEmail = e })-    >=> withPatch patchUserPermissions patchPerms-    >=> withPatch patchUserGroups patchGroups-    where-      patchPassword ps (WithField i u) = WithField <$> pure i <*> setUserPassword' strength ps u-      patchPerms ps (WithField i u) = do-        setUserPermissions i ps-        return $ WithField i u-      patchGroups gs (WithField i u) = do-        setUserGroups i gs-        return $ WithField i u---- | Update password of user-setUserPassword' :: MonadIO m => Int -- ^ Password strength-  -> Password -> UserImpl -> m UserImpl-setUserPassword' strength pass user = do-  pass' <- liftIO $ makePassword (passToByteString pass) strength-  return $ user { userImplPassword = byteStringToPass pass' }---- | Get all groups the user belongs to-getUserGroups :: HasStorage m => UserImplId -> m [UserGroupId]-getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . (\(WithField _ v) -> v)) <$> selectUserImplGroups i---- | Rewrite all user groups-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 :: HasStorage m => [UserGroupId] -> m [AuthUserGroupId]-validateGroups is = do-  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 :: HasStorage m => UserGroupId -> m [Permission]-getGroupPermissions = go S.empty S.empty . toKey-  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-          Nothing -> return $ F.toList perms'-          Just pid -> if isJust $ pid `S.elemIndexL` visited-            then fail $ "Recursive user group graph: " <> show (visited S.|> pid)-            else go (visited S.|> pid) perms' pid---- | Get user permissions that are assigned to him/her via groups only-getUserGroupPermissions :: 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 :: 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 :: 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-        , userGroupParent = fromKey <$> authUserGroupParent-        }---- | Helper to convert user group into values of several tables-toAuthUserGroup :: UserGroup -> (AuthUserGroup, AuthUserGroupId -> [AuthUserGroupUsers], AuthUserGroupId -> [AuthUserGroupPerms])-toAuthUserGroup UserGroup{..} = (ag, users, perms)-  where-  ag = AuthUserGroup {-      authUserGroupName = userGroupName-    , authUserGroupParent = toKey <$> userGroupParent-    }-  users i = (\ui   -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers-  perms i = (\perm -> AuthUserGroupPerms i perm) <$> userGroupPermissions---- | Insert user group into RDBMS-insertUserGroup :: HasStorage m => UserGroup -> m UserGroupId-insertUserGroup u = do-  let (ag, users, perms) = toAuthUserGroup u-  i <- insertAuthUserGroup ag-  forM_ (users i) $ void . insertAuthUserGroupUsers-  forM_ (perms i) $ void . insertAuthUserGroupPerms-  return $ fromKey $ i---- | Replace user group with new value-updateUserGroup :: HasStorage m => UserGroupId -> UserGroup -> m ()-updateUserGroup i u = do-  let i' = toKey $ i-  let (ag, users, perms) = toAuthUserGroup u-  replaceAuthUserGroup i' ag-  clearAuthUserGroupUsers i'-  clearAuthUserGroupPerms i'-  forM_ (users i') $ void . insertAuthUserGroupUsers-  forM_ (perms i') $ void . insertAuthUserGroupPerms---- | Erase user group from RDBMS, cascade-deleteUserGroup :: HasStorage m => UserGroupId -> m ()-deleteUserGroup i = do-  let i' = toKey $ i-  clearAuthUserGroupUsers i'-  clearAuthUserGroupPerms i'-  deleteAuthUserGroup i'---- | Partial update of user group-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-    clearAuthUserGroupUsers i'-    forM_ uids $ insertAuthUserGroupUsers . AuthUserGroupUsers i' . toKey-  whenJust patchUserGroupPermissions $ \perms -> do-    clearAuthUserGroupPerms i'-    forM_ perms $ insertAuthUserGroupPerms . AuthUserGroupPerms i'+{-# LANGUAGE DefaultSignatures #-}
+{-|
+Module      : Servant.Server.Auth.Token.Model
+Description : Internal operations with RDBMS
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Model(
+  -- * DB entities
+    UserImpl(..)
+  , UserPerm(..)
+  , AuthToken(..)
+  , UserRestore(..)
+  , AuthUserGroup(..)
+  , AuthUserGroupUsers(..)
+  , AuthUserGroupPerms(..)
+  , UserSingleUseCode(..)
+  -- * IDs of entities
+  , UserImplId
+  , UserPermId
+  , AuthTokenId
+  , UserRestoreId
+  , AuthUserGroupId
+  , AuthUserGroupUsersId
+  , AuthUserGroupPermsId
+  , UserSingleUseCodeId
+  -- * DB interface
+  , HasStorage(..)
+  -- * Operations
+  , passToByteString
+  , byteStringToPass
+  -- ** User
+  , userToUserInfo
+  , readUserInfo
+  , readUserInfoByLogin
+  , getUserPermissions
+  , setUserPermissions
+  , createUser
+  , hasPerms
+  , createAdmin
+  , ensureAdmin
+  , patchUser
+  , setUserPassword'
+  -- ** User groups
+  , getUserGroups
+  , setUserGroups
+  , validateGroups
+  , getGroupPermissions
+  , getUserGroupPermissions
+  , getUserAllPermissions
+  , readUserGroup
+  , toAuthUserGroup
+  , insertUserGroup
+  , updateUserGroup
+  , deleteUserGroup
+  , patchUserGroup
+  -- * Low-level
+  , makeUserInfo
+  ) where
+
+import Control.Monad
+import Control.Monad.Cont (ContT)
+import Control.Monad.Except (ExceptT)
+import Control.Monad.IO.Class
+import Control.Monad.Reader (ReaderT)
+import qualified Control.Monad.RWS.Lazy as LRWS
+import qualified Control.Monad.RWS.Strict as SRWS
+import qualified Control.Monad.State.Lazy as LS
+import qualified Control.Monad.State.Strict as SS
+import qualified Control.Monad.Writer.Lazy as LW
+import qualified Control.Monad.Writer.Strict as SW
+import Control.Monad.Trans.Class (MonadTrans(lift))
+import Crypto.PasswordStore
+import Data.Aeson.WithField
+import Data.Int
+import Data.Maybe
+import Data.Monoid
+import Data.Text (Text)
+import Data.Time
+import GHC.Generics
+
+import qualified Data.ByteString as BS
+import qualified Data.Foldable as F
+import qualified Data.List as L
+import qualified Data.Sequence as S
+import qualified Data.Text.Encoding as TE
+
+import Servant.API.Auth.Token
+import Servant.API.Auth.Token.Pagination
+import Servant.Server.Auth.Token.Common
+import Servant.Server.Auth.Token.Patch
+
+-- | ID of user
+newtype UserImplId = UserImplId { unUserImplId :: Int64 }
+  deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey UserImplId where
+  toKey = UserImplId . fromIntegral
+  fromKey = fromIntegral . unUserImplId
+  {-# INLINE toKey #-}
+  {-# INLINE fromKey #-}
+
+-- | Internal user implementation
+data UserImpl = UserImpl {
+  userImplLogin    :: !Login -- ^ Unique user login
+, userImplPassword :: !Password -- ^ Password encrypted with salt
+, userImplEmail    :: !Email -- ^ User email
+} deriving (Generic, Show)
+
+-- | ID of user permission
+newtype UserPermId = UserPermId { unUserPermId :: Int64 }
+  deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey UserPermId where
+  toKey = UserPermId . fromIntegral
+  fromKey = fromIntegral . unUserPermId
+  {-# INLINE toKey #-}
+  {-# INLINE fromKey #-}
+
+-- | Internal implementation of permission (1-M)
+data UserPerm = UserPerm {
+  userPermUser       :: !UserImplId -- ^ Reference to user
+, userPermPermission :: !Permission -- ^ Permission tag
+} deriving (Generic, Show)
+
+-- | ID of authorisation token
+newtype AuthTokenId = AuthTokenId { unAuthTokenId :: Int64 }
+  deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey AuthTokenId where
+  toKey = AuthTokenId . fromIntegral
+  fromKey = fromIntegral . unAuthTokenId
+  {-# INLINE toKey #-}
+  {-# INLINE fromKey #-}
+
+-- | 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)
+  default getUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m (Maybe UserImpl)
+  getUserImpl = lift . getUserImpl
+
+  -- | Getting user from storage by login
+  getUserImplByLogin :: Login -> m (Maybe (WithId UserImplId UserImpl))
+  default getUserImplByLogin :: (m ~ t n, MonadTrans t, HasStorage n) => Login -> m (Maybe (WithId UserImplId UserImpl))
+  getUserImplByLogin = lift . getUserImplByLogin
+
+  -- | Get paged list of users and total count of users
+  listUsersPaged :: Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
+  default listUsersPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
+  listUsersPaged = (lift .) . listUsersPaged
+
+  -- | Get user permissions, ascending by tag
+  getUserImplPermissions :: UserImplId -> m [WithId UserPermId UserPerm]
+  default getUserImplPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId UserPermId UserPerm]
+  getUserImplPermissions = lift . getUserImplPermissions
+
+  -- | Delete user permissions
+  deleteUserPermissions :: UserImplId -> m ()
+  default deleteUserPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
+  deleteUserPermissions = lift . deleteUserPermissions
+
+  -- | Insertion of new user permission
+  insertUserPerm :: UserPerm -> m UserPermId
+  default insertUserPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserPerm -> m UserPermId
+  insertUserPerm = lift . insertUserPerm
+
+  -- | Insertion of new user
+  insertUserImpl :: UserImpl -> m UserImplId
+  default insertUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImpl -> m UserImplId
+  insertUserImpl = lift . insertUserImpl
+
+  -- | Replace user with new value
+  replaceUserImpl :: UserImplId -> UserImpl -> m ()
+  default replaceUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UserImpl -> m ()
+  replaceUserImpl = (lift .) . replaceUserImpl
+
+  -- | Delete user by id
+  deleteUserImpl :: UserImplId -> m ()
+  default deleteUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
+  deleteUserImpl = lift . deleteUserImpl
+
+  -- | Check whether the user has particular permission
+  hasPerm :: UserImplId -> Permission -> m Bool
+  default hasPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> Permission -> m Bool
+  hasPerm = (lift .) . hasPerm
+
+  -- | Get any user with given permission
+  getFirstUserByPerm :: Permission -> m (Maybe (WithId UserImplId UserImpl))
+  default getFirstUserByPerm :: (m ~ t n, MonadTrans t, HasStorage n) => Permission -> m (Maybe (WithId UserImplId UserImpl))
+  getFirstUserByPerm = lift . getFirstUserByPerm
+
+  -- | Select user groups and sort them by ascending name
+  selectUserImplGroups :: UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
+  default selectUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
+  selectUserImplGroups = lift . selectUserImplGroups
+
+  -- | Remove user from all groups
+  clearUserImplGroups :: UserImplId -> m ()
+  default clearUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
+  clearUserImplGroups = lift . clearUserImplGroups
+
+  -- | Add new user group
+  insertAuthUserGroup :: AuthUserGroup -> m AuthUserGroupId
+  default insertAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroup -> m AuthUserGroupId
+  insertAuthUserGroup = lift . insertAuthUserGroup
+
+  -- | Add user to given group
+  insertAuthUserGroupUsers :: AuthUserGroupUsers -> m AuthUserGroupUsersId
+  default insertAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupUsers -> m AuthUserGroupUsersId
+  insertAuthUserGroupUsers = lift . insertAuthUserGroupUsers
+
+  -- | Add permission to given group
+  insertAuthUserGroupPerms :: AuthUserGroupPerms -> m AuthUserGroupPermsId
+  default insertAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupPerms -> m AuthUserGroupPermsId
+  insertAuthUserGroupPerms = lift . insertAuthUserGroupPerms
+
+  -- | Find user group by id
+  getAuthUserGroup :: AuthUserGroupId -> m (Maybe AuthUserGroup)
+  default getAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m (Maybe AuthUserGroup)
+  getAuthUserGroup = lift . getAuthUserGroup
+
+  -- | Get list of permissions of given group
+  listAuthUserGroupPermissions :: AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
+  default listAuthUserGroupPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
+  listAuthUserGroupPermissions = lift . listAuthUserGroupPermissions
+
+  -- | Get list of all users of the group
+  listAuthUserGroupUsers :: AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
+  default listAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
+  listAuthUserGroupUsers = lift . listAuthUserGroupUsers
+
+  -- | Replace record of user group
+  replaceAuthUserGroup :: AuthUserGroupId -> AuthUserGroup -> m ()
+  default replaceAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> AuthUserGroup -> m ()
+  replaceAuthUserGroup = (lift .) . replaceAuthUserGroup
+
+  -- | Remove all users from group
+  clearAuthUserGroupUsers :: AuthUserGroupId -> m ()
+  default clearAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
+  clearAuthUserGroupUsers = lift . clearAuthUserGroupUsers
+
+  -- | Remove all permissions from group
+  clearAuthUserGroupPerms :: AuthUserGroupId -> m ()
+  default clearAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
+  clearAuthUserGroupPerms = lift . clearAuthUserGroupPerms
+
+  -- | Delete user group from storage
+  deleteAuthUserGroup :: AuthUserGroupId -> m ()
+  default deleteAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
+  deleteAuthUserGroup = lift . deleteAuthUserGroup
+
+  -- | Get paged list of user groups with total count
+  listGroupsPaged :: Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
+  default listGroupsPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
+  listGroupsPaged = (lift .) . listGroupsPaged
+
+  -- | Set group name
+  setAuthUserGroupName :: AuthUserGroupId -> Text -> m ()
+  default setAuthUserGroupName :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Text -> m ()
+  setAuthUserGroupName = (lift .) . setAuthUserGroupName
+
+  -- | Set group parent
+  setAuthUserGroupParent :: AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
+  default setAuthUserGroupParent :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
+  setAuthUserGroupParent = (lift .) . setAuthUserGroupParent
+
+  -- | Add new single use code
+  insertSingleUseCode :: UserSingleUseCode -> m UserSingleUseCodeId
+  default insertSingleUseCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCode -> m UserSingleUseCodeId
+  insertSingleUseCode = lift . insertSingleUseCode
+
+  -- | Set usage time of the single use code
+  setSingleUseCodeUsed :: UserSingleUseCodeId -> Maybe UTCTime -> m ()
+  default setSingleUseCodeUsed :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCodeId -> Maybe UTCTime -> m ()
+  setSingleUseCodeUsed = (lift .) . setSingleUseCodeUsed
+
+  -- | Find unused code for the user and expiration time greater than the given time
+  getUnusedCode :: SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
+  default getUnusedCode :: (m ~ t n, MonadTrans t, HasStorage n) => SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
+  getUnusedCode suc = (lift .) . getUnusedCode suc
+
+  -- | Invalidate all permament codes for user and set use time for them
+  invalidatePermamentCodes :: UserImplId -> UTCTime -> m ()
+  default invalidatePermamentCodes :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m ()
+  invalidatePermamentCodes = (lift .) . invalidatePermamentCodes
+
+  -- | Select last valid restoration code by the given current time
+  selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
+  default selectLastRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
+  selectLastRestoreCode = (lift .) . selectLastRestoreCode
+
+  -- | Insert new restore code
+  insertUserRestore :: UserRestore -> m UserRestoreId
+  default insertUserRestore :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestore -> m UserRestoreId
+  insertUserRestore = lift . insertUserRestore
+
+  -- | Find unexpired by the time restore code
+  findRestoreCode :: UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
+  default findRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
+  findRestoreCode uid = (lift .) . findRestoreCode uid
+
+  -- | Replace restore code with new value
+  replaceRestoreCode :: UserRestoreId -> UserRestore -> m ()
+  default replaceRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestoreId -> UserRestore -> m ()
+  replaceRestoreCode = (lift .) . replaceRestoreCode
+
+  -- | Find first non-expired by the time token for user
+  findAuthToken :: UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
+  default findAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
+  findAuthToken = (lift .) . findAuthToken
+
+  -- | Find token by value
+  findAuthTokenByValue :: SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
+  default findAuthTokenByValue :: (m ~ t n, MonadTrans t, HasStorage n) => SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
+  findAuthTokenByValue = lift . findAuthTokenByValue
+
+  -- | Insert new token
+  insertAuthToken :: AuthToken -> m AuthTokenId
+  default insertAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthToken -> m AuthTokenId
+  insertAuthToken = lift . insertAuthToken
+
+  -- | Replace auth token with new value
+  replaceAuthToken :: AuthTokenId -> AuthToken -> m ()
+  default replaceAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthTokenId -> AuthToken -> m ()
+  replaceAuthToken = (lift .) . replaceAuthToken
+
+instance HasStorage m => HasStorage (ContT r m)
+instance HasStorage m => HasStorage (ExceptT e m)
+instance HasStorage m => HasStorage (ReaderT r m)
+instance (HasStorage m, Monoid w) => HasStorage (LRWS.RWST r w s m)
+instance (HasStorage m, Monoid w) => HasStorage (SRWS.RWST r w s m)
+instance HasStorage m => HasStorage (LS.StateT s m)
+instance HasStorage m => HasStorage (SS.StateT s m)
+instance (HasStorage m, Monoid w) => HasStorage (LW.WriterT w m)
+instance (HasStorage m, Monoid w) => HasStorage (SW.WriterT w m)
+
+-- | Convert password to bytestring
+passToByteString :: Password -> BS.ByteString
+passToByteString = TE.encodeUtf8
+
+-- | Convert bytestring into password
+byteStringToPass :: BS.ByteString -> Password
+byteStringToPass = TE.decodeUtf8
+
+-- | Helper to convert user to response
+userToUserInfo :: WithId UserImplId UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo
+userToUserInfo (WithField uid UserImpl{..}) perms groups = RespUserInfo {
+      respUserId = fromKey uid
+    , respUserLogin = userImplLogin
+    , respUserEmail = userImplEmail
+    , respUserPermissions = perms
+    , respUserGroups = groups
+  }
+
+-- | Low level operation for collecting info about user
+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 :: HasStorage m => UserId -> m (Maybe RespUserInfo)
+readUserInfo uid' = do
+  let uid = toKey uid'
+  muser <- getUserImpl uid
+  maybe (return Nothing) (fmap Just . makeUserInfo . WithField uid) $ muser
+
+-- | Get user by 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 :: 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 :: HasStorage m => UserImplId -> [Permission] -> m ()
+setUserPermissions uid perms = do
+  deleteUserPermissions uid
+  forM_ perms $ void . insertUserPerm . UserPerm uid
+
+-- | Creation of new user
+createUser :: HasStorage m => Int -> Login -> Password -> Email -> [Permission] -> m UserImplId
+createUser strength login pass email perms = do
+  pass' <- liftIO $ makePassword (passToByteString pass) strength
+  i <- insertUserImpl UserImpl {
+      userImplLogin = login
+    , userImplPassword = byteStringToPass pass'
+    , userImplEmail = email
+    }
+  forM_ perms $ void . insertUserPerm . UserPerm i
+  return i
+
+-- | Check whether the user has particular permissions
+hasPerms :: HasStorage m => UserImplId -> [Permission] -> m Bool
+hasPerms _ [] = return True
+hasPerms i perms = do
+  perms' <- getUserAllPermissions i
+  return $ and $ (`elem` perms') <$> perms
+
+-- | Creates user with admin privileges
+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 :: 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 :: 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 (WithField i u) -> pure $ WithField i u { userImplEmail = e })
+    >=> withPatch patchUserPermissions patchPerms
+    >=> withPatch patchUserGroups patchGroups
+    where
+      patchPassword ps (WithField i u) = WithField <$> pure i <*> setUserPassword' strength ps u
+      patchPerms ps (WithField i u) = do
+        setUserPermissions i ps
+        return $ WithField i u
+      patchGroups gs (WithField i u) = do
+        setUserGroups i gs
+        return $ WithField i u
+
+-- | Update password of user
+setUserPassword' :: MonadIO m => Int -- ^ Password strength
+  -> Password -> UserImpl -> m UserImpl
+setUserPassword' strength pass user = do
+  pass' <- liftIO $ makePassword (passToByteString pass) strength
+  return $ user { userImplPassword = byteStringToPass pass' }
+
+-- | Get all groups the user belongs to
+getUserGroups :: HasStorage m => UserImplId -> m [UserGroupId]
+getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . (\(WithField _ v) -> v)) <$> selectUserImplGroups i
+
+-- | Rewrite all user groups
+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 :: HasStorage m => [UserGroupId] -> m [AuthUserGroupId]
+validateGroups is = do
+  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 :: HasStorage m => UserGroupId -> m [Permission]
+getGroupPermissions = go S.empty S.empty . toKey
+  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
+          Nothing -> return $ F.toList perms'
+          Just pid -> if isJust $ pid `S.elemIndexL` visited
+            then fail $ "Recursive user group graph: " <> show (visited S.|> pid)
+            else go (visited S.|> pid) perms' pid
+
+-- | Get user permissions that are assigned to him/her via groups only
+getUserGroupPermissions :: 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 :: 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 :: 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
+        , userGroupParent = fromKey <$> authUserGroupParent
+        }
+
+-- | Helper to convert user group into values of several tables
+toAuthUserGroup :: UserGroup -> (AuthUserGroup, AuthUserGroupId -> [AuthUserGroupUsers], AuthUserGroupId -> [AuthUserGroupPerms])
+toAuthUserGroup UserGroup{..} = (ag, users, perms)
+  where
+  ag = AuthUserGroup {
+      authUserGroupName = userGroupName
+    , authUserGroupParent = toKey <$> userGroupParent
+    }
+  users i = (\ui   -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers
+  perms i = (\perm -> AuthUserGroupPerms i perm) <$> userGroupPermissions
+
+-- | Insert user group into RDBMS
+insertUserGroup :: HasStorage m => UserGroup -> m UserGroupId
+insertUserGroup u = do
+  let (ag, users, perms) = toAuthUserGroup u
+  i <- insertAuthUserGroup ag
+  forM_ (users i) $ void . insertAuthUserGroupUsers
+  forM_ (perms i) $ void . insertAuthUserGroupPerms
+  return $ fromKey $ i
+
+-- | Replace user group with new value
+updateUserGroup :: HasStorage m => UserGroupId -> UserGroup -> m ()
+updateUserGroup i u = do
+  let i' = toKey $ i
+  let (ag, users, perms) = toAuthUserGroup u
+  replaceAuthUserGroup i' ag
+  clearAuthUserGroupUsers i'
+  clearAuthUserGroupPerms i'
+  forM_ (users i') $ void . insertAuthUserGroupUsers
+  forM_ (perms i') $ void . insertAuthUserGroupPerms
+
+-- | Erase user group from RDBMS, cascade
+deleteUserGroup :: HasStorage m => UserGroupId -> m ()
+deleteUserGroup i = do
+  let i' = toKey $ i
+  clearAuthUserGroupUsers i'
+  clearAuthUserGroupPerms i'
+  deleteAuthUserGroup i'
+
+-- | Partial update of user group
+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
+    clearAuthUserGroupUsers i'
+    forM_ uids $ insertAuthUserGroupUsers . AuthUserGroupUsers i' . toKey
+  whenJust patchUserGroupPermissions $ \perms -> do
+    clearAuthUserGroupPerms i'
+    forM_ perms $ insertAuthUserGroupPerms . AuthUserGroupPerms i'
src/Servant/Server/Auth/Token/Monad.hs view
@@ -1,54 +1,54 @@-{-|-Module      : Servant.Server.Auth.Token.Monad-Description : Monad for auth server handler-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.Monad(-    AuthHandler-  , HasAuthConfig(..)-  , require-  , getConfig-  , getsConfig-  , guard404-  , module Reexport-  ) where--import Control.Monad.Except                 (MonadError)-import Control.Monad.IO.Class-import Data.Monoid                          ((<>))-import Servant--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---- | 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 :: AuthHandler m => BS.ByteString -> Maybe a -> m a-require info Nothing = throw400 $ info <> " is required"-require _ (Just a) = return a---- | Getting config from global state-getConfig :: AuthHandler m => m AuthConfig-getConfig = getAuthConfig---- | Getting config part from global state-getsConfig :: AuthHandler m => (AuthConfig -> a) -> m a-getsConfig f = fmap f getAuthConfig---- | Run RDBMS operation and throw 404 (not found) error if--- the second arg returns 'Nothing'-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'+{-|
+Module      : Servant.Server.Auth.Token.Monad
+Description : Monad for auth server handler
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Monad(
+    AuthHandler
+  , HasAuthConfig(..)
+  , require
+  , getConfig
+  , getsConfig
+  , guard404
+  , module Reexport
+  ) where
+
+import Control.Monad.Except                 (MonadError)
+import Control.Monad.IO.Class
+import Data.Monoid                          ((<>))
+import Servant
+
+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
+
+-- | 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 :: AuthHandler m => BS.ByteString -> Maybe a -> m a
+require info Nothing = throw400 $ info <> " is required"
+require _ (Just a) = return a
+
+-- | Getting config from global state
+getConfig :: AuthHandler m => m AuthConfig
+getConfig = getAuthConfig
+
+-- | Getting config part from global state
+getsConfig :: AuthHandler m => (AuthConfig -> a) -> m a
+getsConfig f = fmap f getAuthConfig
+
+-- | Run RDBMS operation and throw 404 (not found) error if
+-- the second arg returns 'Nothing'
+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'
src/Servant/Server/Auth/Token/Pagination.hs view
@@ -1,31 +1,31 @@-{-|-Module      : Servant.Server.Auth.Token.Monad-Description : Helpers for pagination implementation-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.Pagination(-    pagination-  ) where--import Data.Maybe--import Servant.Server.Auth.Token.Config-import Servant.Server.Auth.Token.Monad--import Servant.API.Auth.Token.Pagination---- | Helper that implements pagination logic-pagination :: AuthHandler m-  => Maybe Page -- ^ Parameter of page-  -> Maybe PageSize -- ^ Parameter of page size-  -> (Page -> PageSize -> m a) -- ^ Handler-  -> m a-pagination pageParam pageSizeParam f = do-  ps <- getsConfig defaultPageSize-  let page = fromMaybe 0 pageParam-      pageSize = fromMaybe ps pageSizeParam-  f page pageSize+{-|
+Module      : Servant.Server.Auth.Token.Monad
+Description : Helpers for pagination implementation
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Pagination(
+    pagination
+  ) where
+
+import Data.Maybe
+
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Monad
+
+import Servant.API.Auth.Token.Pagination
+
+-- | Helper that implements pagination logic
+pagination :: AuthHandler m
+  => Maybe Page -- ^ Parameter of page
+  -> Maybe PageSize -- ^ Parameter of page size
+  -> (Page -> PageSize -> m a) -- ^ Handler
+  -> m a
+pagination pageParam pageSizeParam f = do
+  ps <- getsConfig defaultPageSize
+  let page = fromMaybe 0 pageParam
+      pageSize = fromMaybe ps pageSizeParam
+  f page pageSize
src/Servant/Server/Auth/Token/Patch.hs view
@@ -1,52 +1,52 @@-{-|-Module      : Servant.Server.Auth.Token.Patch-Description : Helpers for patching entities-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.Patch(-    withPatch-  , withPatch'-  , withNullPatch-  , withNullPatch'-  ) where ---- | Helper for implementation of 'HasPatch'-withPatch :: Monad m => Maybe a -> (a -> b -> m b) -> b -> m b -withPatch v f b = case v of -  Nothing -> return b -  Just a -> f a b-{-# INLINE withPatch #-}---- | Helper for implementation of 'HasPatch'-withPatch' :: Maybe a -> (a -> b -> b) -> b -> b -withPatch' v f b = case v of -  Nothing -> b -  Just a -> f a b-{-# INLINE withPatch' #-}---- | Helper to implement patch with nullable flag-withNullPatch :: Monad m-  => Maybe Bool -- ^ If this is 'Just true' then execute following updater-  -> (b -> m b) -- ^ Updater when previous value is 'Just true'-  -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater-  -> (a -> b -> m b) -- ^ Main updater-  -> b -> m b-withNullPatch mnull nullify ma updater b = case mnull of -  Just True -> nullify b -  _ -> withPatch ma updater b-{-# INLINE withNullPatch #-}---- | Helper to implement patch with nullable flag-withNullPatch' :: Maybe Bool -- ^ If this is 'Just true' then execute following updater-  -> (b -> b) -- ^ Updater when previous value is 'Just true'-  -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater-  -> (a -> b -> b) -- ^ Main updater-  -> b -> b-withNullPatch' mnull nullify ma updater b = case mnull of -  Just True -> nullify b -  _ -> withPatch' ma updater b+{-|
+Module      : Servant.Server.Auth.Token.Patch
+Description : Helpers for patching entities
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Patch(
+    withPatch
+  , withPatch'
+  , withNullPatch
+  , withNullPatch'
+  ) where 
+
+-- | Helper for implementation of 'HasPatch'
+withPatch :: Monad m => Maybe a -> (a -> b -> m b) -> b -> m b 
+withPatch v f b = case v of 
+  Nothing -> return b 
+  Just a -> f a b
+{-# INLINE withPatch #-}
+
+-- | Helper for implementation of 'HasPatch'
+withPatch' :: Maybe a -> (a -> b -> b) -> b -> b 
+withPatch' v f b = case v of 
+  Nothing -> b 
+  Just a -> f a b
+{-# INLINE withPatch' #-}
+
+-- | Helper to implement patch with nullable flag
+withNullPatch :: Monad m
+  => Maybe Bool -- ^ If this is 'Just true' then execute following updater
+  -> (b -> m b) -- ^ Updater when previous value is 'Just true'
+  -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater
+  -> (a -> b -> m b) -- ^ Main updater
+  -> b -> m b
+withNullPatch mnull nullify ma updater b = case mnull of 
+  Just True -> nullify b 
+  _ -> withPatch ma updater b
+{-# INLINE withNullPatch #-}
+
+-- | Helper to implement patch with nullable flag
+withNullPatch' :: Maybe Bool -- ^ If this is 'Just true' then execute following updater
+  -> (b -> b) -- ^ Updater when previous value is 'Just true'
+  -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater
+  -> (a -> b -> b) -- ^ Main updater
+  -> b -> b
+withNullPatch' mnull nullify ma updater b = case mnull of 
+  Just True -> nullify b 
+  _ -> withPatch' ma updater b
 {-# INLINE withNullPatch' #-}
src/Servant/Server/Auth/Token/Restore.hs view
@@ -1,55 +1,55 @@-{-|-Module      : Servant.Server.Auth.Token.Restore-Description : Operations with restore codes-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.Restore(-    getRestoreCode-  , guardRestoreCode-  , sendRestoreCode-  ) where--import Control.Monad-import Control.Monad.IO.Class-import Data.Aeson.WithField-import Data.Time.Clock--import Servant.API.Auth.Token-import Servant.Server.Auth.Token.Config-import Servant.Server.Auth.Token.Model-import Servant.Server.Auth.Token.Monad---- | Get current restore code for user or generate new-getRestoreCode :: HasStorage m => IO RestoreCode -> UserImplId -> UTCTime -> m RestoreCode-getRestoreCode generator uid expire = do-  t <- liftIO getCurrentTime-  mcode <- selectLastRestoreCode uid t-  case mcode of-    Nothing -> do-      code <- liftIO generator-      void $ insertUserRestore UserRestore {-          userRestoreValue = code-        , userRestoreUser = uid-        , userRestoreExpire = expire-        }-      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 :: AuthHandler m => UserImplId -> RestoreCode -> m ()-guardRestoreCode uid code = do-  t <- liftIO getCurrentTime-  mcode <- findRestoreCode uid code t-  case mcode of-    Nothing -> throw400 "Invalid restore code"-    Just (WithField i rc) -> replaceRestoreCode i rc { userRestoreExpire = t }---- | Send restore code to the user' email-sendRestoreCode :: AuthHandler m => RespUserInfo -> RestoreCode -> m ()-sendRestoreCode user code = do-  AuthConfig{..} <- getConfig-  liftIO $ restoreCodeSender user code+{-|
+Module      : Servant.Server.Auth.Token.Restore
+Description : Operations with restore codes
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Restore(
+    getRestoreCode
+  , guardRestoreCode
+  , sendRestoreCode
+  ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson.WithField
+import Data.Time.Clock
+
+import Servant.API.Auth.Token
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+import Servant.Server.Auth.Token.Monad
+
+-- | Get current restore code for user or generate new
+getRestoreCode :: HasStorage m => IO RestoreCode -> UserImplId -> UTCTime -> m RestoreCode
+getRestoreCode generator uid expire = do
+  t <- liftIO getCurrentTime
+  mcode <- selectLastRestoreCode uid t
+  case mcode of
+    Nothing -> do
+      code <- liftIO generator
+      void $ insertUserRestore UserRestore {
+          userRestoreValue = code
+        , userRestoreUser = uid
+        , userRestoreExpire = expire
+        }
+      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 :: AuthHandler m => UserImplId -> RestoreCode -> m ()
+guardRestoreCode uid code = do
+  t <- liftIO getCurrentTime
+  mcode <- findRestoreCode uid code t
+  case mcode of
+    Nothing -> throw400 "Invalid restore code"
+    Just (WithField i rc) -> replaceRestoreCode i rc { userRestoreExpire = t }
+
+-- | Send restore code to the user' email
+sendRestoreCode :: AuthHandler m => RespUserInfo -> RestoreCode -> m ()
+sendRestoreCode user code = do
+  AuthConfig{..} <- getConfig
+  liftIO $ restoreCodeSender user code
src/Servant/Server/Auth/Token/SingleUse.hs view
@@ -1,73 +1,73 @@-{-|-Module      : Servant.Server.Auth.Token.SingleUse-Description : Specific functions to work with single usage codes.-Copyright   : (c) Anton Gushcha, 2016-License     : MIT-Maintainer  : ncrashed@gmail.com-Stability   : experimental-Portability : Portable--}-module Servant.Server.Auth.Token.SingleUse(-    makeSingleUseExpire-  , registerSingleUseCode-  , invalidateSingleUseCode-  , validateSingleUseCode-  , generateSingleUsedCodes-  ) where--import Control.Monad-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---- | Calculate expire date for single usage code-makeSingleUseExpire :: MonadIO m => NominalDiffTime -- ^ Duration of code-  -> m UTCTime -- ^ Time when the code expires-makeSingleUseExpire dt = do-  t <- liftIO getCurrentTime-  return $ dt `addUTCTime` t---- | Register single use code in DB-registerSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user-  -> SingleUseCode -- ^ Single usage code-  -> Maybe UTCTime -- ^ Time when the code expires, 'Nothing' is never expiring code-  -> m ()-registerSingleUseCode uid code expire = void $ insertSingleUseCode-  $ UserSingleUseCode code uid expire Nothing---- | Marks single use code that it cannot be used again-invalidateSingleUseCode :: HasStorage m => UserSingleUseCodeId -- ^ Id of code-  -> m ()-invalidateSingleUseCode i = do-  t <- liftIO getCurrentTime-  setSingleUseCodeUsed i $ Just t---- | Check single use code and return 'True' on success.------ On success invalidates single use code.-validateSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user-  -> SingleUseCode -- ^ Single usage code-  -> m Bool-validateSingleUseCode uid code = do-  t <- liftIO getCurrentTime-  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 :: HasStorage m => UserImplId -- ^ Id of user-  -> IO SingleUseCode -- ^ Generator of codes-  -> Word -- Count of codes-  -> m [SingleUseCode]-generateSingleUsedCodes uid gen n = do-  t <- liftIO getCurrentTime-  invalidatePermamentCodes uid t-  replicateM (fromIntegral n) $ do-    code <- liftIO gen-    _ <- insertSingleUseCode $ UserSingleUseCode code uid Nothing Nothing-    return code+{-|
+Module      : Servant.Server.Auth.Token.SingleUse
+Description : Specific functions to work with single usage codes.
+Copyright   : (c) Anton Gushcha, 2016
+License     : MIT
+Maintainer  : ncrashed@gmail.com
+Stability   : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.SingleUse(
+    makeSingleUseExpire
+  , registerSingleUseCode
+  , invalidateSingleUseCode
+  , validateSingleUseCode
+  , generateSingleUsedCodes
+  ) where
+
+import Control.Monad
+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
+
+-- | Calculate expire date for single usage code
+makeSingleUseExpire :: MonadIO m => NominalDiffTime -- ^ Duration of code
+  -> m UTCTime -- ^ Time when the code expires
+makeSingleUseExpire dt = do
+  t <- liftIO getCurrentTime
+  return $ dt `addUTCTime` t
+
+-- | Register single use code in DB
+registerSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user
+  -> SingleUseCode -- ^ Single usage code
+  -> Maybe UTCTime -- ^ Time when the code expires, 'Nothing' is never expiring code
+  -> m ()
+registerSingleUseCode uid code expire = void $ insertSingleUseCode
+  $ UserSingleUseCode code uid expire Nothing
+
+-- | Marks single use code that it cannot be used again
+invalidateSingleUseCode :: HasStorage m => UserSingleUseCodeId -- ^ Id of code
+  -> m ()
+invalidateSingleUseCode i = do
+  t <- liftIO getCurrentTime
+  setSingleUseCodeUsed i $ Just t
+
+-- | Check single use code and return 'True' on success.
+--
+-- On success invalidates single use code.
+validateSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user
+  -> SingleUseCode -- ^ Single usage code
+  -> m Bool
+validateSingleUseCode uid code = do
+  t <- liftIO getCurrentTime
+  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 :: HasStorage m => UserImplId -- ^ Id of user
+  -> IO SingleUseCode -- ^ Generator of codes
+  -> Word -- Count of codes
+  -> m [SingleUseCode]
+generateSingleUsedCodes uid gen n = do
+  t <- liftIO getCurrentTime
+  invalidatePermamentCodes uid t
+  replicateM (fromIntegral n) $ do
+    code <- liftIO gen
+    _ <- insertSingleUseCode $ UserSingleUseCode code uid Nothing Nothing
+    return code
stack.yaml view
@@ -1,90 +1,95 @@-# 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-8.8--# 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'-- 'servant-auth-token-leveldb'-- 'example/acid'-- 'example/persistent'-- 'example/leveldb'-# - 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-- concurrent-extra-0.7.0.10-- http-api-data-0.3.5-- natural-transformation-0.4-- safecopy-store-0.9.2-- servant-0.9-- servant-auth-token-api-0.4.2.0-- servant-docs-0.9-- servant-server-0.9-- store-0.3.1-- store-core-0.3-- th-utilities-0.2.0.1--# 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+# 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-8.14
+
+# 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'
+- 'servant-auth-token-leveldb'
+- 'servant-auth-token-rocksdb'
+- 'example/acid'
+- 'example/persistent'
+- 'example/leveldb'
+# - location:
+#     git: https://github.com/NCrashed/servant-auth-token-api.git
+#     commit: d011f7bfecd18d07ff67ce9f67f8741e110a2719
+#   extra-dep: true
+# - '../servant-auth-token-api'
+- location:
+    git: https://github.com/serokell/rocksdb-haskell.git
+    commit: 325427fc709183c8fdf777ad5ea09f8d92bf8585
+  extra-dep: true
+
+# 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
+- concurrent-extra-0.7.0.10
+- http-api-data-0.3.5
+- natural-transformation-0.4
+- safecopy-store-0.9.3
+- servant-0.9
+- servant-auth-token-api-0.4.2.0
+- servant-docs-0.9
+- servant-server-0.9
+#- store-0.3.1
+#- store-core-0.3
+- th-utilities-0.2.0.1
+
+# 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