packages feed

servant-auth-token 0.4.7.0 → 0.4.7.1

raw patch · 44 files changed

+3181/−3178 lines, 44 filesdep ~servant-serversetup-changed

Dependency ranges changed: servant-server

Files

CHANGELOG.md view
@@ -1,87 +1,92 @@-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
+0.4.7.1+=======++* Relax `servant` and `servant-server` versions.++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.2+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.3+    , 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.12+    , servant-auth-token            >= 0.4      && < 0.5+    , servant-auth-token-acid       >= 0.4      && < 0.5+    , servant-auth-token-api        >= 0.4      && < 0.5+    , servant-server                >= 0.9      && < 0.12+    , 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 <- runHandler $ 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 = NT (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 $ Handler. 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.2+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.3+    , 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.11     && < 0.12+    , servant-auth-token            >= 0.4      && < 0.5+    , servant-auth-token-api        >= 0.4      && < 0.5+    , servant-auth-token-leveldb    >= 0.4      && < 0.5+    , servant-server                >= 0.9      && < 0.12+    , 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 <- runHandler $ 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 = NT (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 $ Handler . 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.2+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.3+    , 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.11     && < 0.12+    , servant-auth-token            >= 0.4      && < 0.5+    , servant-auth-token-api        >= 0.4      && < 0.5+    , servant-auth-token-persistent >= 0.4      && < 0.6+    , servant-server                >= 0.9      && < 0.12+    , 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 <- runHandler $ 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 = NT (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 $ Handler . 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.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
+name:                servant-auth-token+version:             0.4.7.1+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.12+    , 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 {-# 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
+{-# 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,95 +1,93 @@-# 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
+# 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.19++# 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-1.2.1.0+- aeson-injector-1.0.8.0+- cabal-doctest-1.0.2+- concurrent-extra-0.7.0.11+- safecopy-store-0.9.4+- servant-0.11+- servant-auth-token-api-0.4.2.2+- servant-docs-0.10.0.1+- servant-server-0.11+- servant-swagger-1.1.3++# 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