diff options
| author | NCrashed <> | 2017-05-19 10:21:00 (GMT) |
|---|---|---|
| committer | hdiff <hdiff@hdiff.luite.com> | 2017-05-19 10:21:00 (GMT) |
| commit | 1ba5ad2c9bd2fb4ea5dad709f301a4a4367c20dd (patch) | |
| tree | b59d9211782e1dba6fde08145449622736c6f7c2 | |
| parent | e1a92cd5149f4d520f9de33e7667302bb56b0867 (diff) | |
version 0.4.7.00.4.7.0
44 files changed, 3178 insertions, 3168 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 6f5ff39..b5bc303 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,82 +1,87 @@ -0.4.6.0 -======= - -* Add `withAuthToken` to guard groups of endpoints. - -0.4.5.0 -======= - -* Auto deriving `HasAuthConfig` and `HasStorage` for transformers. - -0.4.4.1 -======= - -* `persistent-postgresql` is not actually used - -0.4.4.0 -======= - -* Add `signinByHashUnsafe` for internal usage. - -0.4.3.0 -======= - -* Implementation for `AuthFindUserByLogin` endpoint. -* Feature to manipulate with hashes of passwords. For instance, now you can store -hashed admin password in config. - -0.4.2.0 -======= - -* Add implementation for `AuthCheckPermissionsMethod` and `AuthGetUserIdMethod` endpoints. - -0.4.1.1 -======= - -* Relax `aeson` and `opt-parse-applicative` bounds. -* Add `monad-control` instances. - -0.4.1.0 -======= - -* Remove persistent dependencies from abstract package. - -0.4.0.0 -======= - -* Abstract over storage: persistent and acid-state backends. - -0.3.2.0 -======= - -* Support lts-7.1 (ghc 8 and persistent-0.6) - -0.3.0.0 -======= - -* Add authorisation by single usage codes. - -0.2.0.1 -======= - -* Relax boundaries for ghc 8.0.1. - -0.2.0.0 -======= - -* Implement `servant-auth-token-0.2.0.0` API. - -0.1.2.0 -======= - -* Expose implementation of API for embedding in complex servers. - -0.1.1.0 -======= - -* Added `restoreCodeGenerator` to configuration - -0.1.0.0 -======= - -* Initial publication +0.4.7.0
+=======
+
+* Make `withAuthToken` work properly.
+
+0.4.6.0
+=======
+
+* Add `withAuthToken` to guard groups of endpoints.
+
+0.4.5.0
+=======
+
+* Auto deriving `HasAuthConfig` and `HasStorage` for transformers.
+
+0.4.4.1
+=======
+
+* `persistent-postgresql` is not actually used
+
+0.4.4.0
+=======
+
+* Add `signinByHashUnsafe` for internal usage.
+
+0.4.3.0
+=======
+
+* Implementation for `AuthFindUserByLogin` endpoint.
+* Feature to manipulate with hashes of passwords. For instance, now you can store
+hashed admin password in config.
+
+0.4.2.0
+=======
+
+* Add implementation for `AuthCheckPermissionsMethod` and `AuthGetUserIdMethod` endpoints.
+
+0.4.1.1
+=======
+
+* Relax `aeson` and `opt-parse-applicative` bounds.
+* Add `monad-control` instances.
+
+0.4.1.0
+=======
+
+* Remove persistent dependencies from abstract package.
+
+0.4.0.0
+=======
+
+* Abstract over storage: persistent and acid-state backends.
+
+0.3.2.0
+=======
+
+* Support lts-7.1 (ghc 8 and persistent-0.6)
+
+0.3.0.0
+=======
+
+* Add authorisation by single usage codes.
+
+0.2.0.1
+=======
+
+* Relax boundaries for ghc 8.0.1.
+
+0.2.0.0
+=======
+
+* Implement `servant-auth-token-0.2.0.0` API.
+
+0.1.2.0
+=======
+
+* Expose implementation of API for embedding in complex servers.
+
+0.1.1.0
+=======
+
+* Added `restoreCodeGenerator` to configuration
+
+0.1.0.0
+=======
+
+* Initial publication
@@ -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.
@@ -1,27 +1,27 @@ -# servant-auth-token - -[](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
+
+[](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
+```
@@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple
+main = defaultMain
diff --git a/example/acid/LICENSE b/example/acid/LICENSE index e1a0e52..18d524c 100644 --- a/example/acid/LICENSE +++ b/example/acid/LICENSE @@ -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.
diff --git a/example/acid/Setup.hs b/example/acid/Setup.hs index 9a994af..833b4c6 100644 --- a/example/acid/Setup.hs +++ b/example/acid/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple
+main = defaultMain
diff --git a/example/acid/config.yaml b/example/acid/config.yaml index ec3852f..2423477 100644 --- a/example/acid/config.yaml +++ b/example/acid/config.yaml @@ -1,3 +1,3 @@ -host: localhost -port: 3000 -db: "state" +host: localhost
+port: 3000
+db: "state"
diff --git a/example/acid/servant-auth-token-example-acid.cabal b/example/acid/servant-auth-token-example-acid.cabal index cca67bb..865ab9b 100644 --- a/example/acid/servant-auth-token-example-acid.cabal +++ b/example/acid/servant-auth-token-example-acid.cabal @@ -1,70 +1,70 @@ -name: servant-auth-token-example-acid -version: 0.4.0.1 -synopsis: Example server for token auth for acid-state backend -description: Please see README.md -homepage: https://github.com/ncrashed/servant-auth-token#readme -license: BSD3 -license-file: LICENSE -author: NCrashed -maintainer: ncrashed@gmail.com -copyright: 2017 Anton Gushcha -category: Web -build-type: Simple -cabal-version: >=1.10 - -executable servant-auth-token-example-acid - hs-source-dirs: src - main-is: Main.hs - other-modules: - API - Config - DB - Monad - Server - default-language: Haskell2010 - build-depends: - base >= 4.7 && < 5 - , acid-state >= 0.14 && < 0.15 - , aeson >= 0.11 && < 1.1 - , aeson-injector >= 1.0 && < 1.1 - , bytestring >= 0.10 && < 0.11 - , exceptions >= 0.8 && < 0.9 - , http-types >= 0.9 && < 0.10 - , monad-control >= 1.0 && < 1.1 - , monad-logger >= 0.3 && < 0.4 - , mtl >= 2.2 && < 2.3 - , optparse-applicative >= 0.12 && < 0.14 - , safecopy >= 0.9 && < 0.10 - , servant >= 0.9 && < 0.10 - , servant-auth-token >= 0.4 && < 0.5 - , servant-auth-token-acid >= 0.4 && < 0.5 - , servant-auth-token-api >= 0.4 && < 0.5 - , servant-server >= 0.9 && < 0.10 - , text >= 1.2 && < 1.3 - , time >= 1.6 && < 1.7 - , transformers-base >= 0.4 && < 0.5 - , wai >= 3.2 && < 3.3 - , wai-extra >= 3.0 && < 3.1 - , warp >= 3.2 && < 3.3 - , yaml >= 0.8 && < 0.9 - default-extensions: - BangPatterns - DataKinds - DeriveFunctor - DeriveGeneric - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GeneralizedNewtypeDeriving - MultiParamTypeClasses - OverloadedStrings - RecordWildCards - RecursiveDo - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TypeFamilies - TypeOperators - UndecidableInstances - - ghc-options: -threaded +name: servant-auth-token-example-acid
+version: 0.4.0.1
+synopsis: Example server for token auth for acid-state backend
+description: Please see README.md
+homepage: https://github.com/ncrashed/servant-auth-token#readme
+license: BSD3
+license-file: LICENSE
+author: NCrashed
+maintainer: ncrashed@gmail.com
+copyright: 2017 Anton Gushcha
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+
+executable servant-auth-token-example-acid
+ hs-source-dirs: src
+ main-is: Main.hs
+ other-modules:
+ API
+ Config
+ DB
+ Monad
+ Server
+ default-language: Haskell2010
+ build-depends:
+ base >= 4.7 && < 5
+ , acid-state >= 0.14 && < 0.15
+ , aeson >= 0.11 && < 1.1
+ , aeson-injector >= 1.0 && < 1.1
+ , bytestring >= 0.10 && < 0.11
+ , exceptions >= 0.8 && < 0.9
+ , http-types >= 0.9 && < 0.10
+ , monad-control >= 1.0 && < 1.1
+ , monad-logger >= 0.3 && < 0.4
+ , mtl >= 2.2 && < 2.3
+ , optparse-applicative >= 0.12 && < 0.14
+ , safecopy >= 0.9 && < 0.10
+ , servant >= 0.9 && < 0.10
+ , servant-auth-token >= 0.4 && < 0.5
+ , servant-auth-token-acid >= 0.4 && < 0.5
+ , servant-auth-token-api >= 0.4 && < 0.5
+ , servant-server >= 0.9 && < 0.10
+ , text >= 1.2 && < 1.3
+ , time >= 1.6 && < 1.7
+ , transformers-base >= 0.4 && < 0.5
+ , wai >= 3.2 && < 3.3
+ , wai-extra >= 3.0 && < 3.1
+ , warp >= 3.2 && < 3.3
+ , yaml >= 0.8 && < 0.9
+ default-extensions:
+ BangPatterns
+ DataKinds
+ DeriveFunctor
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ RecursiveDo
+ ScopedTypeVariables
+ StandaloneDeriving
+ TemplateHaskell
+ TypeFamilies
+ TypeOperators
+ UndecidableInstances
+
+ ghc-options: -threaded
diff --git a/example/acid/src/API.hs b/example/acid/src/API.hs index 33faeb0..a962619 100644 --- a/example/acid/src/API.hs +++ b/example/acid/src/API.hs @@ -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] ()
diff --git a/example/acid/src/Config.hs b/example/acid/src/Config.hs index 732538f..d1b46e8 100644 --- a/example/acid/src/Config.hs +++ b/example/acid/src/Config.hs @@ -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
diff --git a/example/acid/src/DB.hs b/example/acid/src/DB.hs index 315842b..e2cbda1 100644 --- a/example/acid/src/DB.hs +++ b/example/acid/src/DB.hs @@ -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
diff --git a/example/acid/src/Main.hs b/example/acid/src/Main.hs index ffab7ed..c36307c 100644 --- a/example/acid/src/Main.hs +++ b/example/acid/src/Main.hs @@ -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" )
diff --git a/example/acid/src/Monad.hs b/example/acid/src/Monad.hs index b1b57ba..4142449 100644 --- a/example/acid/src/Monad.hs +++ b/example/acid/src/Monad.hs @@ -1,98 +1,98 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Monad( - ServerEnv(..) - , ServerM - , newServerEnv - , runServerM - , runServerMIO - , serverMtoHandler - , AuthM(..) - , runAuth - ) where - -import Control.Monad.Base -import Control.Monad.Catch (MonadCatch, MonadThrow) -import Control.Monad.Except -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Control -import Data.Acid -import Data.Monoid -import Data.Text (unpack) -import Servant.Server -import Servant.Server.Auth.Token.Acid as A -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Model - -import Config -import DB - --- | Server private environment -data ServerEnv = ServerEnv { - -- | Configuration used to create the server - envConfig :: !ServerConfig - -- | Configuration of auth server -, envAuthConfig :: !AuthConfig - -- | DB state -, envDB :: !(AcidState DB) -} - --- | Create new server environment -newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv -newServerEnv cfg = do - let authConfig = defaultAuthConfig - db <- liftIO $ openLocalStateFrom (unpack $ serverDbPath cfg) newDB - -- ensure default admin if missing one - _ <- runAcidBackendT authConfig db $ ensureAdmin 17 "admin" "123456" "admin@localhost" - let env = ServerEnv { - envConfig = cfg - , envAuthConfig = authConfig - , envDB = db - } - return env - --- | Server monad that holds internal environment -newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv - , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr) - -newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a } - -instance MonadBaseControl IO ServerM where - type StM ServerM a = StMServerM a - liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM) - restoreM = ServerM . restoreM . unStMServerM - --- | Lift servant monad to server monad -liftHandler :: Handler a -> ServerM a -liftHandler = ServerM . lift . lift - --- | Execution of 'ServerM' -runServerM :: ServerEnv -> ServerM a -> Handler a -runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM - --- | Execution of 'ServerM' in IO monad -runServerMIO :: ServerEnv -> ServerM a -> IO a -runServerMIO env m = do - ea <- runExceptT $ runServerM env m - case ea of - Left e -> fail $ "runServerMIO: " <> show e - Right a -> return a - --- | Transformation to Servant 'Handler' -serverMtoHandler :: ServerEnv -> ServerM :~> Handler -serverMtoHandler e = Nat (runServerM e) - --- Derive HasStorage for 'AcidBackendT' with your 'DB' -deriveAcidHasStorage ''DB - --- | Special monad for authorisation actions -newtype AuthM a = AuthM { unAuthM :: AcidBackendT DB IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage) - --- | Execution of authorisation actions that require 'AuthHandler' context -runAuth :: AuthM a -> ServerM a -runAuth m = do - cfg <- asks envAuthConfig - db <- asks envDB - liftHandler $ ExceptT $ runAcidBackendT cfg db $ unAuthM m +{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Monad(
+ ServerEnv(..)
+ , ServerM
+ , newServerEnv
+ , runServerM
+ , runServerMIO
+ , serverMtoHandler
+ , AuthM(..)
+ , runAuth
+ ) where
+
+import Control.Monad.Base
+import Control.Monad.Catch (MonadCatch, MonadThrow)
+import Control.Monad.Except
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Acid
+import Data.Monoid
+import Data.Text (unpack)
+import Servant.Server
+import Servant.Server.Auth.Token.Acid as A
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+
+import Config
+import DB
+
+-- | Server private environment
+data ServerEnv = ServerEnv {
+ -- | Configuration used to create the server
+ envConfig :: !ServerConfig
+ -- | Configuration of auth server
+, envAuthConfig :: !AuthConfig
+ -- | DB state
+, envDB :: !(AcidState DB)
+}
+
+-- | Create new server environment
+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
+newServerEnv cfg = do
+ let authConfig = defaultAuthConfig
+ db <- liftIO $ openLocalStateFrom (unpack $ serverDbPath cfg) newDB
+ -- ensure default admin if missing one
+ _ <- runAcidBackendT authConfig db $ ensureAdmin 17 "admin" "123456" "admin@localhost"
+ let env = ServerEnv {
+ envConfig = cfg
+ , envAuthConfig = authConfig
+ , envDB = db
+ }
+ return env
+
+-- | Server monad that holds internal environment
+newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
+ , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
+
+newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
+
+instance MonadBaseControl IO ServerM where
+ type StM ServerM a = StMServerM a
+ liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
+ restoreM = ServerM . restoreM . unStMServerM
+
+-- | Lift servant monad to server monad
+liftHandler :: Handler a -> ServerM a
+liftHandler = ServerM . lift . lift
+
+-- | Execution of 'ServerM'
+runServerM :: ServerEnv -> ServerM a -> Handler a
+runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
+
+-- | Execution of 'ServerM' in IO monad
+runServerMIO :: ServerEnv -> ServerM a -> IO a
+runServerMIO env m = do
+ ea <- runExceptT $ runServerM env m
+ case ea of
+ Left e -> fail $ "runServerMIO: " <> show e
+ Right a -> return a
+
+-- | Transformation to Servant 'Handler'
+serverMtoHandler :: ServerEnv -> ServerM :~> Handler
+serverMtoHandler e = Nat (runServerM e)
+
+-- Derive HasStorage for 'AcidBackendT' with your 'DB'
+deriveAcidHasStorage ''DB
+
+-- | Special monad for authorisation actions
+newtype AuthM a = AuthM { unAuthM :: AcidBackendT DB IO a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage)
+
+-- | Execution of authorisation actions that require 'AuthHandler' context
+runAuth :: AuthM a -> ServerM a
+runAuth m = do
+ cfg <- asks envAuthConfig
+ db <- asks envDB
+ liftHandler $ ExceptT $ runAcidBackendT cfg db $ unAuthM m
diff --git a/example/acid/src/Server.hs b/example/acid/src/Server.hs index 41a9e85..9fc3be0 100644 --- a/example/acid/src/Server.hs +++ b/example/acid/src/Server.hs @@ -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 ()
diff --git a/example/leveldb/LICENSE b/example/leveldb/LICENSE index e1a0e52..18d524c 100644 --- a/example/leveldb/LICENSE +++ b/example/leveldb/LICENSE @@ -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.
diff --git a/example/leveldb/Setup.hs b/example/leveldb/Setup.hs index 9a994af..833b4c6 100644 --- a/example/leveldb/Setup.hs +++ b/example/leveldb/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple
+main = defaultMain
diff --git a/example/leveldb/config.yaml b/example/leveldb/config.yaml index ec3852f..2423477 100644 --- a/example/leveldb/config.yaml +++ b/example/leveldb/config.yaml @@ -1,3 +1,3 @@ -host: localhost -port: 3000 -db: "state" +host: localhost
+port: 3000
+db: "state"
diff --git a/example/leveldb/servant-auth-token-example-leveldb.cabal b/example/leveldb/servant-auth-token-example-leveldb.cabal index 4ead172..dc4e57f 100644 --- a/example/leveldb/servant-auth-token-example-leveldb.cabal +++ b/example/leveldb/servant-auth-token-example-leveldb.cabal @@ -1,70 +1,70 @@ -name: servant-auth-token-example-leveldb -version: 0.4.0.1 -synopsis: Example server for token auth for leveldb backend -description: Please see README.md -homepage: https://github.com/ncrashed/servant-auth-token#readme -license: BSD3 -license-file: LICENSE -author: NCrashed -maintainer: ncrashed@gmail.com -copyright: 2017 Anton Gushcha -category: Web -build-type: Simple -cabal-version: >=1.10 - -executable servant-auth-token-example-leveldb - hs-source-dirs: src - main-is: Main.hs - other-modules: - API - Config - Monad - Server - default-language: Haskell2010 - build-depends: - base >= 4.7 && < 5 - , acid-state >= 0.14 && < 0.15 - , aeson >= 0.11 && < 1.1 - , aeson-injector >= 1.0 && < 1.1 - , bytestring >= 0.10 && < 0.11 - , exceptions >= 0.8 && < 0.9 - , http-types >= 0.9 && < 0.10 - , leveldb-haskell >= 0.6 && < 0.7 - , monad-control >= 1.0 && < 1.1 - , monad-logger >= 0.3 && < 0.4 - , mtl >= 2.2 && < 2.3 - , optparse-applicative >= 0.12 && < 0.14 - , safecopy-store >= 0.9 && < 0.10 - , servant >= 0.9 && < 0.10 - , servant-auth-token >= 0.4 && < 0.5 - , servant-auth-token-api >= 0.4 && < 0.5 - , servant-auth-token-leveldb >= 0.4 && < 0.5 - , servant-server >= 0.9 && < 0.10 - , text >= 1.2 && < 1.3 - , time >= 1.6 && < 1.7 - , transformers-base >= 0.4 && < 0.5 - , wai >= 3.2 && < 3.3 - , wai-extra >= 3.0 && < 3.1 - , warp >= 3.2 && < 3.3 - , yaml >= 0.8 && < 0.9 - default-extensions: - BangPatterns - DataKinds - DeriveFunctor - DeriveGeneric - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GeneralizedNewtypeDeriving - MultiParamTypeClasses - OverloadedStrings - RecordWildCards - RecursiveDo - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TypeFamilies - TypeOperators - UndecidableInstances - - ghc-options: -threaded +name: servant-auth-token-example-leveldb
+version: 0.4.0.1
+synopsis: Example server for token auth for leveldb backend
+description: Please see README.md
+homepage: https://github.com/ncrashed/servant-auth-token#readme
+license: BSD3
+license-file: LICENSE
+author: NCrashed
+maintainer: ncrashed@gmail.com
+copyright: 2017 Anton Gushcha
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+
+executable servant-auth-token-example-leveldb
+ hs-source-dirs: src
+ main-is: Main.hs
+ other-modules:
+ API
+ Config
+ Monad
+ Server
+ default-language: Haskell2010
+ build-depends:
+ base >= 4.7 && < 5
+ , acid-state >= 0.14 && < 0.15
+ , aeson >= 0.11 && < 1.1
+ , aeson-injector >= 1.0 && < 1.1
+ , bytestring >= 0.10 && < 0.11
+ , exceptions >= 0.8 && < 0.9
+ , http-types >= 0.9 && < 0.10
+ , leveldb-haskell >= 0.6 && < 0.7
+ , monad-control >= 1.0 && < 1.1
+ , monad-logger >= 0.3 && < 0.4
+ , mtl >= 2.2 && < 2.3
+ , optparse-applicative >= 0.12 && < 0.14
+ , safecopy-store >= 0.9 && < 0.10
+ , servant >= 0.9 && < 0.10
+ , servant-auth-token >= 0.4 && < 0.5
+ , servant-auth-token-api >= 0.4 && < 0.5
+ , servant-auth-token-leveldb >= 0.4 && < 0.5
+ , servant-server >= 0.9 && < 0.10
+ , text >= 1.2 && < 1.3
+ , time >= 1.6 && < 1.7
+ , transformers-base >= 0.4 && < 0.5
+ , wai >= 3.2 && < 3.3
+ , wai-extra >= 3.0 && < 3.1
+ , warp >= 3.2 && < 3.3
+ , yaml >= 0.8 && < 0.9
+ default-extensions:
+ BangPatterns
+ DataKinds
+ DeriveFunctor
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ RecursiveDo
+ ScopedTypeVariables
+ StandaloneDeriving
+ TemplateHaskell
+ TypeFamilies
+ TypeOperators
+ UndecidableInstances
+
+ ghc-options: -threaded
diff --git a/example/leveldb/src/API.hs b/example/leveldb/src/API.hs index 33faeb0..a962619 100644 --- a/example/leveldb/src/API.hs +++ b/example/leveldb/src/API.hs @@ -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] ()
diff --git a/example/leveldb/src/Config.hs b/example/leveldb/src/Config.hs index 732538f..d1b46e8 100644 --- a/example/leveldb/src/Config.hs +++ b/example/leveldb/src/Config.hs @@ -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
diff --git a/example/leveldb/src/Main.hs b/example/leveldb/src/Main.hs index ffab7ed..c36307c 100644 --- a/example/leveldb/src/Main.hs +++ b/example/leveldb/src/Main.hs @@ -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" )
diff --git a/example/leveldb/src/Monad.hs b/example/leveldb/src/Monad.hs index b1f867d..bc9422b 100644 --- a/example/leveldb/src/Monad.hs +++ b/example/leveldb/src/Monad.hs @@ -1,98 +1,98 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Monad( - ServerEnv(..) - , ServerM - , newServerEnv - , runServerM - , runServerMIO - , serverMtoHandler - , AuthM(..) - , runAuth - ) where - -import Control.Monad.Base -import Control.Monad.Catch (MonadCatch, MonadThrow) -import Control.Monad.Except -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Control -import Data.Acid -import Data.Monoid -import Data.Text (unpack) -import Database.LevelDB.MonadResource -import Servant.Server -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.LevelDB -import Servant.Server.Auth.Token.Model - -import Config - --- | Server private environment -data ServerEnv = ServerEnv { - -- | Configuration used to create the server - envConfig :: !ServerConfig - -- | Configuration of auth server -, envAuthConfig :: !AuthConfig - -- | DB state -, envDB :: !LevelDBEnv -} - --- | Create new server environment -newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv -newServerEnv cfg = do - let authConfig = defaultAuthConfig - dbEnv <- liftIO . runResourceT $ do - db <- open (unpack $ serverDbPath cfg) defaultOptions { createIfMissing = True } - dbEnv <- newLevelDBEnv db defaultReadOptions defaultWriteOptions - -- ensure default admin if missing one - _ <- runLevelDBBackendT authConfig dbEnv $ ensureAdmin 17 "admin" "123456" "admin@localhost" - return dbEnv - let env = ServerEnv { - envConfig = cfg - , envAuthConfig = authConfig - , envDB = dbEnv - } - return env - --- | Server monad that holds internal environment -newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv - , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr) - -newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a } - -instance MonadBaseControl IO ServerM where - type StM ServerM a = StMServerM a - liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM) - restoreM = ServerM . restoreM . unStMServerM - --- | Lift servant monad to server monad -liftHandler :: Handler a -> ServerM a -liftHandler = ServerM . lift . lift - --- | Execution of 'ServerM' -runServerM :: ServerEnv -> ServerM a -> Handler a -runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM - --- | Execution of 'ServerM' in IO monad -runServerMIO :: ServerEnv -> ServerM a -> IO a -runServerMIO env m = do - ea <- runExceptT $ runServerM env m - case ea of - Left e -> fail $ "runServerMIO: " <> show e - Right a -> return a - --- | Transformation to Servant 'Handler' -serverMtoHandler :: ServerEnv -> ServerM :~> Handler -serverMtoHandler e = Nat (runServerM e) - --- | Special monad for authorisation actions -newtype AuthM a = AuthM { unAuthM :: LevelDBBackendT IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage) - --- | Execution of authorisation actions that require 'AuthHandler' context -runAuth :: AuthM a -> ServerM a -runAuth m = do - cfg <- asks envAuthConfig - db <- asks envDB - liftHandler $ ExceptT $ runLevelDBBackendT cfg db $ unAuthM m +{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Monad(
+ ServerEnv(..)
+ , ServerM
+ , newServerEnv
+ , runServerM
+ , runServerMIO
+ , serverMtoHandler
+ , AuthM(..)
+ , runAuth
+ ) where
+
+import Control.Monad.Base
+import Control.Monad.Catch (MonadCatch, MonadThrow)
+import Control.Monad.Except
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Acid
+import Data.Monoid
+import Data.Text (unpack)
+import Database.LevelDB.MonadResource
+import Servant.Server
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.LevelDB
+import Servant.Server.Auth.Token.Model
+
+import Config
+
+-- | Server private environment
+data ServerEnv = ServerEnv {
+ -- | Configuration used to create the server
+ envConfig :: !ServerConfig
+ -- | Configuration of auth server
+, envAuthConfig :: !AuthConfig
+ -- | DB state
+, envDB :: !LevelDBEnv
+}
+
+-- | Create new server environment
+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
+newServerEnv cfg = do
+ let authConfig = defaultAuthConfig
+ dbEnv <- liftIO . runResourceT $ do
+ db <- open (unpack $ serverDbPath cfg) defaultOptions { createIfMissing = True }
+ dbEnv <- newLevelDBEnv db defaultReadOptions defaultWriteOptions
+ -- ensure default admin if missing one
+ _ <- runLevelDBBackendT authConfig dbEnv $ ensureAdmin 17 "admin" "123456" "admin@localhost"
+ return dbEnv
+ let env = ServerEnv {
+ envConfig = cfg
+ , envAuthConfig = authConfig
+ , envDB = dbEnv
+ }
+ return env
+
+-- | Server monad that holds internal environment
+newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
+ , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
+
+newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
+
+instance MonadBaseControl IO ServerM where
+ type StM ServerM a = StMServerM a
+ liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
+ restoreM = ServerM . restoreM . unStMServerM
+
+-- | Lift servant monad to server monad
+liftHandler :: Handler a -> ServerM a
+liftHandler = ServerM . lift . lift
+
+-- | Execution of 'ServerM'
+runServerM :: ServerEnv -> ServerM a -> Handler a
+runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
+
+-- | Execution of 'ServerM' in IO monad
+runServerMIO :: ServerEnv -> ServerM a -> IO a
+runServerMIO env m = do
+ ea <- runExceptT $ runServerM env m
+ case ea of
+ Left e -> fail $ "runServerMIO: " <> show e
+ Right a -> return a
+
+-- | Transformation to Servant 'Handler'
+serverMtoHandler :: ServerEnv -> ServerM :~> Handler
+serverMtoHandler e = Nat (runServerM e)
+
+-- | Special monad for authorisation actions
+newtype AuthM a = AuthM { unAuthM :: LevelDBBackendT IO a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage)
+
+-- | Execution of authorisation actions that require 'AuthHandler' context
+runAuth :: AuthM a -> ServerM a
+runAuth m = do
+ cfg <- asks envAuthConfig
+ db <- asks envDB
+ liftHandler $ ExceptT $ runLevelDBBackendT cfg db $ unAuthM m
diff --git a/example/leveldb/src/Server.hs b/example/leveldb/src/Server.hs index 41a9e85..9fc3be0 100644 --- a/example/leveldb/src/Server.hs +++ b/example/leveldb/src/Server.hs @@ -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 ()
diff --git a/example/persistent/LICENSE b/example/persistent/LICENSE index e1a0e52..18d524c 100644 --- a/example/persistent/LICENSE +++ b/example/persistent/LICENSE @@ -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.
diff --git a/example/persistent/Setup.hs b/example/persistent/Setup.hs index 9a994af..833b4c6 100644 --- a/example/persistent/Setup.hs +++ b/example/persistent/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple
+main = defaultMain
diff --git a/example/persistent/config.yaml b/example/persistent/config.yaml index 83392be..71262b7 100644 --- a/example/persistent/config.yaml +++ b/example/persistent/config.yaml @@ -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
diff --git a/example/persistent/servant-auth-token-example-persistent.cabal b/example/persistent/servant-auth-token-example-persistent.cabal index eb1d969..eda2cd6 100644 --- a/example/persistent/servant-auth-token-example-persistent.cabal +++ b/example/persistent/servant-auth-token-example-persistent.cabal @@ -1,69 +1,69 @@ -name: servant-auth-token-example-persistent -version: 0.4.0.1 -synopsis: Example server for token auth for persistent backend -description: Please see README.md -homepage: https://github.com/ncrashed/servant-auth-token#readme -license: BSD3 -license-file: LICENSE -author: NCrashed -maintainer: ncrashed@gmail.com -copyright: 2017 Anton Gushcha -category: Web -build-type: Simple -cabal-version: >=1.10 - -executable servant-auth-token-example-persistent - hs-source-dirs: src - main-is: Main.hs - other-modules: - API - Config - Monad - Server - default-language: Haskell2010 - build-depends: - base >= 4.7 && < 5 - , aeson >= 0.11 && < 1.1 - , aeson-injector >= 1.0 && < 1.1 - , bytestring >= 0.10 && < 0.11 - , exceptions >= 0.8 && < 0.9 - , http-types >= 0.9 && < 0.10 - , monad-control >= 1.0 && < 1.1 - , monad-logger >= 0.3 && < 0.4 - , mtl >= 2.2 && < 2.3 - , optparse-applicative >= 0.12 && < 0.14 - , persistent >= 2.6 && < 2.7 - , persistent-postgresql >= 2.6 && < 2.7 - , servant >= 0.9 && < 0.10 - , servant-auth-token >= 0.4 && < 0.5 - , servant-auth-token-api >= 0.4 && < 0.5 - , servant-auth-token-persistent >= 0.4 && < 0.6 - , servant-server >= 0.9 && < 0.10 - , text >= 1.2 && < 1.3 - , time >= 1.6 && < 1.7 - , transformers-base >= 0.4 && < 0.5 - , wai >= 3.2 && < 3.3 - , wai-extra >= 3.0 && < 3.1 - , warp >= 3.2 && < 3.3 - , yaml >= 0.8 && < 0.9 - default-extensions: - BangPatterns - DataKinds - DeriveFunctor - DeriveGeneric - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GeneralizedNewtypeDeriving - MultiParamTypeClasses - OverloadedStrings - RecordWildCards - RecursiveDo - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TypeFamilies - TypeOperators - UndecidableInstances - - ghc-options: -threaded +name: servant-auth-token-example-persistent
+version: 0.4.0.1
+synopsis: Example server for token auth for persistent backend
+description: Please see README.md
+homepage: https://github.com/ncrashed/servant-auth-token#readme
+license: BSD3
+license-file: LICENSE
+author: NCrashed
+maintainer: ncrashed@gmail.com
+copyright: 2017 Anton Gushcha
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+
+executable servant-auth-token-example-persistent
+ hs-source-dirs: src
+ main-is: Main.hs
+ other-modules:
+ API
+ Config
+ Monad
+ Server
+ default-language: Haskell2010
+ build-depends:
+ base >= 4.7 && < 5
+ , aeson >= 0.11 && < 1.1
+ , aeson-injector >= 1.0 && < 1.1
+ , bytestring >= 0.10 && < 0.11
+ , exceptions >= 0.8 && < 0.9
+ , http-types >= 0.9 && < 0.10
+ , monad-control >= 1.0 && < 1.1
+ , monad-logger >= 0.3 && < 0.4
+ , mtl >= 2.2 && < 2.3
+ , optparse-applicative >= 0.12 && < 0.14
+ , persistent >= 2.6 && < 2.7
+ , persistent-postgresql >= 2.6 && < 2.7
+ , servant >= 0.9 && < 0.10
+ , servant-auth-token >= 0.4 && < 0.5
+ , servant-auth-token-api >= 0.4 && < 0.5
+ , servant-auth-token-persistent >= 0.4 && < 0.6
+ , servant-server >= 0.9 && < 0.10
+ , text >= 1.2 && < 1.3
+ , time >= 1.6 && < 1.7
+ , transformers-base >= 0.4 && < 0.5
+ , wai >= 3.2 && < 3.3
+ , wai-extra >= 3.0 && < 3.1
+ , warp >= 3.2 && < 3.3
+ , yaml >= 0.8 && < 0.9
+ default-extensions:
+ BangPatterns
+ DataKinds
+ DeriveFunctor
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ RecursiveDo
+ ScopedTypeVariables
+ StandaloneDeriving
+ TemplateHaskell
+ TypeFamilies
+ TypeOperators
+ UndecidableInstances
+
+ ghc-options: -threaded
diff --git a/example/persistent/src/API.hs b/example/persistent/src/API.hs index 33faeb0..a962619 100644 --- a/example/persistent/src/API.hs +++ b/example/persistent/src/API.hs @@ -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] ()
diff --git a/example/persistent/src/Config.hs b/example/persistent/src/Config.hs index 972508d..28cac60 100644 --- a/example/persistent/src/Config.hs +++ b/example/persistent/src/Config.hs @@ -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
diff --git a/example/persistent/src/Main.hs b/example/persistent/src/Main.hs index 98354a5..bb2a30e 100644 --- a/example/persistent/src/Main.hs +++ b/example/persistent/src/Main.hs @@ -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" )
diff --git a/example/persistent/src/Monad.hs b/example/persistent/src/Monad.hs index 46ea401..4cef7d7 100644 --- a/example/persistent/src/Monad.hs +++ b/example/persistent/src/Monad.hs @@ -1,98 +1,98 @@ -module Monad( - ServerEnv(..) - , ServerM - , newServerEnv - , runServerM - , runServerMIO - , serverMtoHandler - , AuthM(..) - , runAuth - ) where - -import Control.Monad.Base -import Control.Monad.Catch (MonadCatch, MonadThrow) -import Control.Monad.Except -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Control -import Data.Monoid -import Database.Persist.Sql -import Servant.Server -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Model -import Servant.Server.Auth.Token.Persistent - -import qualified Servant.Server.Auth.Token.Persistent.Schema as S - -import Config - --- | Server private environment -data ServerEnv = ServerEnv { - -- | Configuration used to create the server - envConfig :: !ServerConfig - -- | Configuration of auth server -, envAuthConfig :: !AuthConfig - -- | DB pool -, envPool :: !ConnectionPool -} - --- | Create new server environment -newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv -newServerEnv cfg = do - let authConfig = defaultAuthConfig - pool <- liftIO $ do - pool <- createPool cfg - -- run migrations - flip runSqlPool pool $ runMigration S.migrateAll - -- create default admin if missing one - _ <- runPersistentBackendT authConfig pool $ ensureAdmin 17 "admin" "123456" "admin@localhost" - return pool - let env = ServerEnv { - envConfig = cfg - , envAuthConfig = authConfig - , envPool = pool - } - return env - --- | Server monad that holds internal environment -newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv - , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr) - -newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a } - -instance MonadBaseControl IO ServerM where - type StM ServerM a = StMServerM a - liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM) - restoreM = ServerM . restoreM . unStMServerM - --- | Lift servant monad to server monad -liftHandler :: Handler a -> ServerM a -liftHandler = ServerM . lift . lift - --- | Execution of 'ServerM' -runServerM :: ServerEnv -> ServerM a -> Handler a -runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM - --- | Execution of 'ServerM' in IO monad -runServerMIO :: ServerEnv -> ServerM a -> IO a -runServerMIO env m = do - ea <- runExceptT $ runServerM env m - case ea of - Left e -> fail $ "runServerMIO: " <> show e - Right a -> return a - --- | Transformation to Servant 'Handler' -serverMtoHandler :: ServerEnv -> ServerM :~> Handler -serverMtoHandler e = Nat (runServerM e) - --- | Special monad for authorisation actions -newtype AuthM a = AuthM { unAuthM :: PersistentBackendT IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasStorage, HasAuthConfig) - --- | Execution of authorisation actions that require 'AuthHandler' context -runAuth :: AuthM a -> ServerM a -runAuth m = do - cfg <- asks envAuthConfig - pool <- asks envPool - liftHandler $ ExceptT $ runPersistentBackendT cfg pool $ unAuthM m +module Monad(
+ ServerEnv(..)
+ , ServerM
+ , newServerEnv
+ , runServerM
+ , runServerMIO
+ , serverMtoHandler
+ , AuthM(..)
+ , runAuth
+ ) where
+
+import Control.Monad.Base
+import Control.Monad.Catch (MonadCatch, MonadThrow)
+import Control.Monad.Except
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Monoid
+import Database.Persist.Sql
+import Servant.Server
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+import Servant.Server.Auth.Token.Persistent
+
+import qualified Servant.Server.Auth.Token.Persistent.Schema as S
+
+import Config
+
+-- | Server private environment
+data ServerEnv = ServerEnv {
+ -- | Configuration used to create the server
+ envConfig :: !ServerConfig
+ -- | Configuration of auth server
+, envAuthConfig :: !AuthConfig
+ -- | DB pool
+, envPool :: !ConnectionPool
+}
+
+-- | Create new server environment
+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
+newServerEnv cfg = do
+ let authConfig = defaultAuthConfig
+ pool <- liftIO $ do
+ pool <- createPool cfg
+ -- run migrations
+ flip runSqlPool pool $ runMigration S.migrateAll
+ -- create default admin if missing one
+ _ <- runPersistentBackendT authConfig pool $ ensureAdmin 17 "admin" "123456" "admin@localhost"
+ return pool
+ let env = ServerEnv {
+ envConfig = cfg
+ , envAuthConfig = authConfig
+ , envPool = pool
+ }
+ return env
+
+-- | Server monad that holds internal environment
+newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
+ , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
+
+newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
+
+instance MonadBaseControl IO ServerM where
+ type StM ServerM a = StMServerM a
+ liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
+ restoreM = ServerM . restoreM . unStMServerM
+
+-- | Lift servant monad to server monad
+liftHandler :: Handler a -> ServerM a
+liftHandler = ServerM . lift . lift
+
+-- | Execution of 'ServerM'
+runServerM :: ServerEnv -> ServerM a -> Handler a
+runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
+
+-- | Execution of 'ServerM' in IO monad
+runServerMIO :: ServerEnv -> ServerM a -> IO a
+runServerMIO env m = do
+ ea <- runExceptT $ runServerM env m
+ case ea of
+ Left e -> fail $ "runServerMIO: " <> show e
+ Right a -> return a
+
+-- | Transformation to Servant 'Handler'
+serverMtoHandler :: ServerEnv -> ServerM :~> Handler
+serverMtoHandler e = Nat (runServerM e)
+
+-- | Special monad for authorisation actions
+newtype AuthM a = AuthM { unAuthM :: PersistentBackendT IO a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasStorage, HasAuthConfig)
+
+-- | Execution of authorisation actions that require 'AuthHandler' context
+runAuth :: AuthM a -> ServerM a
+runAuth m = do
+ cfg <- asks envAuthConfig
+ pool <- asks envPool
+ liftHandler $ ExceptT $ runPersistentBackendT cfg pool $ unAuthM m
diff --git a/example/persistent/src/Server.hs b/example/persistent/src/Server.hs index 41a9e85..9fc3be0 100644 --- a/example/persistent/src/Server.hs +++ b/example/persistent/src/Server.hs @@ -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 ()
diff --git a/servant-auth-token.cabal b/servant-auth-token.cabal index bb68f66..bd55c1a 100644 --- a/servant-auth-token.cabal +++ b/servant-auth-token.cabal @@ -1,97 +1,97 @@ -name: servant-auth-token -version: 0.4.6.0 -synopsis: Servant based API and server for token based authorisation -description: Please see README.md -homepage: https://github.com/ncrashed/servant-auth-token#readme -license: BSD3 -license-file: LICENSE -author: Anton Gushcha <ncrashed@gmail.com> - , Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> -maintainer: ncrashed@gmail.com -copyright: 2016-2017 Anton Gushcha -category: Web -build-type: Simple -extra-source-files: - README.md - CHANGELOG.md - stack.yaml - example/acid/src/API.hs - example/acid/src/Config.hs - example/acid/src/DB.hs - example/acid/src/Main.hs - example/acid/src/Monad.hs - example/acid/src/Server.hs - example/acid/LICENSE - example/acid/Setup.hs - example/acid/config.yaml - example/acid/servant-auth-token-example-acid.cabal - example/persistent/src/API.hs - example/persistent/src/Config.hs - example/persistent/src/Main.hs - example/persistent/src/Monad.hs - example/persistent/src/Server.hs - example/persistent/LICENSE - example/persistent/Setup.hs - example/persistent/config.yaml - example/persistent/servant-auth-token-example-persistent.cabal - example/leveldb/src/API.hs - example/leveldb/src/Config.hs - example/leveldb/src/Main.hs - example/leveldb/src/Monad.hs - example/leveldb/src/Server.hs - example/leveldb/LICENSE - example/leveldb/Setup.hs - example/leveldb/config.yaml - example/leveldb/servant-auth-token-example-leveldb.cabal -cabal-version: >=1.10 - -library - hs-source-dirs: src - exposed-modules: - Servant.Server.Auth.Token - Servant.Server.Auth.Token.Common - Servant.Server.Auth.Token.Config - Servant.Server.Auth.Token.Error - Servant.Server.Auth.Token.Model - Servant.Server.Auth.Token.Monad - Servant.Server.Auth.Token.Pagination - Servant.Server.Auth.Token.Patch - Servant.Server.Auth.Token.Restore - Servant.Server.Auth.Token.SingleUse - build-depends: - base >= 4.7 && < 5 - , aeson-injector >= 1.0.4 && < 1.1 - , bytestring >= 0.10 && < 0.11 - , containers >= 0.5 && < 0.6 - , mtl >= 2.2 && < 2.3 - , pwstore-fast >= 2.4 && < 2.5 - , servant-auth-token-api >= 0.4.2 && < 0.5 - , servant-server >= 0.9 && < 0.10 - , text >= 1.2 && < 1.3 - , time >= 1.5 && < 1.7 - , transformers >= 0.4 && < 0.6 - , uuid >= 1.3 && < 1.4 - - default-language: Haskell2010 - default-extensions: - BangPatterns - ConstraintKinds - DataKinds - DeriveGeneric - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - KindSignatures - MultiParamTypeClasses - OverloadedStrings - RecordWildCards - ScopedTypeVariables - TupleSections - TypeFamilies - TypeOperators - -source-repository head - type: git - location: https://github.com/ncrashed/servant-auth-token +name: servant-auth-token
+version: 0.4.7.0
+synopsis: Servant based API and server for token based authorisation
+description: Please see README.md
+homepage: https://github.com/ncrashed/servant-auth-token#readme
+license: BSD3
+license-file: LICENSE
+author: Anton Gushcha <ncrashed@gmail.com>
+ , Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>
+maintainer: ncrashed@gmail.com
+copyright: 2016-2017 Anton Gushcha
+category: Web
+build-type: Simple
+extra-source-files:
+ README.md
+ CHANGELOG.md
+ stack.yaml
+ example/acid/src/API.hs
+ example/acid/src/Config.hs
+ example/acid/src/DB.hs
+ example/acid/src/Main.hs
+ example/acid/src/Monad.hs
+ example/acid/src/Server.hs
+ example/acid/LICENSE
+ example/acid/Setup.hs
+ example/acid/config.yaml
+ example/acid/servant-auth-token-example-acid.cabal
+ example/persistent/src/API.hs
+ example/persistent/src/Config.hs
+ example/persistent/src/Main.hs
+ example/persistent/src/Monad.hs
+ example/persistent/src/Server.hs
+ example/persistent/LICENSE
+ example/persistent/Setup.hs
+ example/persistent/config.yaml
+ example/persistent/servant-auth-token-example-persistent.cabal
+ example/leveldb/src/API.hs
+ example/leveldb/src/Config.hs
+ example/leveldb/src/Main.hs
+ example/leveldb/src/Monad.hs
+ example/leveldb/src/Server.hs
+ example/leveldb/LICENSE
+ example/leveldb/Setup.hs
+ example/leveldb/config.yaml
+ example/leveldb/servant-auth-token-example-leveldb.cabal
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ exposed-modules:
+ Servant.Server.Auth.Token
+ Servant.Server.Auth.Token.Common
+ Servant.Server.Auth.Token.Config
+ Servant.Server.Auth.Token.Error
+ Servant.Server.Auth.Token.Model
+ Servant.Server.Auth.Token.Monad
+ Servant.Server.Auth.Token.Pagination
+ Servant.Server.Auth.Token.Patch
+ Servant.Server.Auth.Token.Restore
+ Servant.Server.Auth.Token.SingleUse
+ build-depends:
+ base >= 4.8 && < 5
+ , aeson-injector >= 1.0.4 && < 1.1
+ , bytestring >= 0.10 && < 0.11
+ , containers >= 0.5 && < 0.6
+ , mtl >= 2.2 && < 2.3
+ , pwstore-fast >= 2.4 && < 2.5
+ , servant-auth-token-api >= 0.4.2 && < 0.5
+ , servant-server >= 0.9 && < 0.10
+ , text >= 1.2 && < 1.3
+ , time >= 1.5 && < 1.7
+ , transformers >= 0.4 && < 0.6
+ , uuid >= 1.3 && < 1.4
+
+ default-language: Haskell2010
+ default-extensions:
+ BangPatterns
+ ConstraintKinds
+ DataKinds
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GADTs
+ GeneralizedNewtypeDeriving
+ KindSignatures
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ ScopedTypeVariables
+ TupleSections
+ TypeFamilies
+ TypeOperators
+
+source-repository head
+ type: git
+ location: https://github.com/ncrashed/servant-auth-token
diff --git a/src/Servant/Server/Auth/Token.hs b/src/Servant/Server/Auth/Token.hs index 233f1e8..81f7b31 100644 --- a/src/Servant/Server/Auth/Token.hs +++ b/src/Servant/Server/Auth/Token.hs @@ -1,664 +1,664 @@ -{-# LANGUAGE UndecidableInstances #-} -{-| -Module : Servant.Server.Auth.Token -Description : Implementation of token authorisation API -Copyright : (c) Anton Gushcha, 2016 -License : MIT -Maintainer : ncrashed@gmail.com -Stability : experimental -Portability : Portable - -The module is server side implementation of "Servant.API.Auth.Token" API and intended to be -used as drop in module for user servers or as external micro service. - - - -Use 'guardAuthToken' to check authorisation headers in endpoints of your server: - -@ --- | Read a single customer from DB -customerGet :: CustomerId -- ^ Customer unique id - -> MToken' '["customer-read"] -- ^ Required permissions for auth token - -> ServerM Customer -- ^ Customer data -customerGet i token = do - guardAuthToken token - guard404 "customer" $ getCustomer i -@ - --} -module Servant.Server.Auth.Token( - -- * Implementation - authServer - -- * Server API - , HasStorage(..) - , AuthHandler - -- * Helpers - , guardAuthToken - , WithAuthToken(..) - , ensureAdmin - , authUserByToken - -- * API methods - , authSignin - , authSigninGetCode - , authSigninPostCode - , authTouch - , authToken - , authSignout - , authSignup - , authUsersInfo - , authUserInfo - , authUserPatch - , authUserPut - , authUserDelete - , authRestore - , authGetSingleUseCodes - , authGroupGet - , authGroupPost - , authGroupPut - , authGroupPatch - , authGroupDelete - , authGroupList - , authCheckPermissionsMethod - , authGetUserIdMethod - , authFindUserByLogin - -- * Low-level API - , getAuthToken - , hashPassword - , setUserPasswordHash - , ensureAdminHash - , signinByHashUnsafe - ) where - -import Control.Monad -import Control.Monad.Except -import Crypto.PasswordStore -import Data.Aeson.Unit -import Data.Aeson.WithField -import Data.Maybe -import Data.Monoid -import Data.Text (Text) -import Data.Text.Encoding -import Data.Time.Clock -import Data.UUID -import Data.UUID.V4 -import Servant - -import Servant.API.Auth.Token -import Servant.API.Auth.Token.Pagination -import Servant.Server.Auth.Token.Common -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Model -import Servant.Server.Auth.Token.Monad -import Servant.Server.Auth.Token.Pagination -import Servant.Server.Auth.Token.Restore -import Servant.Server.Auth.Token.SingleUse - -import qualified Data.ByteString.Lazy as BS - --- | Implementation of AuthAPI -authServer :: AuthHandler m => ServerT AuthAPI m -authServer = - authSignin - :<|> authSigninGetCode - :<|> authSigninPostCode - :<|> authTouch - :<|> authToken - :<|> authSignout - :<|> authSignup - :<|> authUsersInfo - :<|> authUserInfo - :<|> authUserPatch - :<|> authUserPut - :<|> authUserDelete - :<|> authRestore - :<|> authGetSingleUseCodes - :<|> authGroupGet - :<|> authGroupPost - :<|> authGroupPut - :<|> authGroupPatch - :<|> authGroupDelete - :<|> authGroupList - :<|> authCheckPermissionsMethod - :<|> authGetUserIdMethod - :<|> authFindUserByLogin - --- | Implementation of "signin" method -authSignin :: AuthHandler m - => Maybe Login -- ^ Login query parameter - -> Maybe Password -- ^ Password query parameter - -> Maybe Seconds -- ^ Expire query parameter, how many seconds the token is valid - -> m (OnlyField "token" SimpleToken) -- ^ If everything is OK, return token -authSignin mlogin mpass mexpire = do - login <- require "login" mlogin - pass <- require "pass" mpass - WithField uid UserImpl{..} <- guardLogin login pass - OnlyField <$> getAuthToken uid mexpire - where - guardLogin login pass = do -- check login and password, return passed user - muser <- getUserImplByLogin login - let err = throw401 "Cannot find user with given combination of login and pass" - case muser of - Nothing -> err - Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword - then return user - else err - --- | Helper to get or generate new token for user -getAuthToken :: AuthHandler m - => UserImplId -- ^ User for whom we want token - -> Maybe Seconds -- ^ Expiration duration, 'Nothing' means default - -> m SimpleToken -- ^ Old token (if it doesn't expire) or new one -getAuthToken uid mexpire = do - expire <- calcExpire mexpire - mt <- getExistingToken -- check whether there is already existing token - case mt of - Nothing -> createToken expire -- create new token - Just t -> touchToken t expire -- prolong token expiration time - where - getExistingToken = do -- return active token for specified user id - t <- liftIO getCurrentTime - findAuthToken uid t - - createToken expire = do -- generate and save fresh token - token <- toText <$> liftIO nextRandom - _ <- insertAuthToken AuthToken { - authTokenValue = token - , authTokenUser = uid - , authTokenExpire = expire - } - return token - --- | Authorisation via code of single usage. --- --- Implementation of 'AuthSigninGetCodeMethod' endpoint. --- --- Logic of authorisation via this method is: --- --- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint --- --- * Server generates single use token and sends it via --- SMS or email, defined in configuration by 'singleUseCodeSender' field. --- --- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint --- --- * Server responds with auth token. --- --- * Client uses the token with other requests as authorisation --- header --- --- * Client can extend lifetime of token by periodically pinging --- of 'AuthTouchMethod' endpoint --- --- * Client can invalidate token instantly by 'AuthSignoutMethod' --- --- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. --- --- See also: 'authSigninPostCode' -authSigninGetCode :: AuthHandler m - => Maybe Login -- ^ User login, required - -> m Unit -authSigninGetCode mlogin = do - login <- require "login" mlogin - uinfo <- guard404 "user" $ readUserInfoByLogin login - let uid = toKey $ respUserId uinfo - - AuthConfig{..} <- getConfig - code <- liftIO singleUseCodeGenerator - expire <- makeSingleUseExpire singleUseCodeExpire - registerSingleUseCode uid code (Just expire) - liftIO $ singleUseCodeSender uinfo code - - return Unit - --- | Authorisation via code of single usage. --- --- Logic of authorisation via this method is: --- --- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint --- --- * Server generates single use token and sends it via --- SMS or email, defined in configuration by 'singleUseCodeSender' field. --- --- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint --- --- * Server responds with auth token. --- --- * Client uses the token with other requests as authorisation --- header --- --- * Client can extend lifetime of token by periodically pinging --- of 'AuthTouchMethod' endpoint --- --- * Client can invalidate token instantly by 'AuthSignoutMethod' --- --- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. --- --- See also: 'authSigninGetCode' -authSigninPostCode :: AuthHandler m - => Maybe Login -- ^ User login, required - -> Maybe SingleUseCode -- ^ Received single usage code, required - -> Maybe Seconds - -- ^ Time interval after which the token expires, 'Nothing' means - -- some default value - -> m (OnlyField "token" SimpleToken) -authSigninPostCode mlogin mcode mexpire = do - login <- require "login" mlogin - code <- require "code" mcode - - uinfo <- guard404 "user" $ readUserInfoByLogin login - let uid = toKey $ respUserId uinfo - isValid <- validateSingleUseCode uid code - unless isValid $ throw401 "Single usage code doesn't match" - - OnlyField <$> getAuthToken uid mexpire - --- | Calculate expiration timestamp for token -calcExpire :: AuthHandler m => Maybe Seconds -> m UTCTime -calcExpire mexpire = do - t <- liftIO getCurrentTime - AuthConfig{..} <- getConfig - let requestedExpire = maybe defaultExpire fromIntegral mexpire - let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire - return $ boundedExpire `addUTCTime` t - --- prolong token with new timestamp -touchToken :: AuthHandler m => WithId AuthTokenId AuthToken -> UTCTime -> m SimpleToken -touchToken (WithField tid tok) expire = do - replaceAuthToken tid tok { - authTokenExpire = expire - } - return $ authTokenValue tok - --- | Implementation of "touch" method -authTouch :: AuthHandler m - => Maybe Seconds -- ^ Expire query parameter, how many seconds the token should be valid by now. 'Nothing' means default value defined in server config. - -> MToken '[] -- ^ Authorisation header with token - -> m Unit -authTouch mexpire token = do - WithField i mt <- guardAuthToken' (fmap unToken token) [] - expire <- calcExpire mexpire - replaceAuthToken i mt { authTokenExpire = expire } - return Unit - --- | Implementation of "token" method, return --- info about user binded to the token -authToken :: AuthHandler m - => MToken '[] -- ^ Authorisation header with token - -> m RespUserInfo -authToken token = do - i <- authUserByToken token - guard404 "user" . readUserInfo . fromKey $ i - --- | Getting user id by token -authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId -authUserByToken token = do - WithField _ mt <- guardAuthToken' (fmap unToken token) [] - return $ authTokenUser mt - --- | Implementation of "signout" method -authSignout :: AuthHandler m - => Maybe (Token '[]) -- ^ Authorisation header with token - -> m Unit -authSignout token = do - WithField i mt <- guardAuthToken' (fmap unToken token) [] - expire <- liftIO getCurrentTime - replaceAuthToken i mt { authTokenExpire = expire } - return Unit - --- | Checks given password and if it is invalid in terms of config --- password validator, throws 400 error. -guardPassword :: AuthHandler m => Password -> m () -guardPassword p = do - AuthConfig{..} <- getConfig - whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8 - --- | Implementation of "signup" method -authSignup :: AuthHandler m - => ReqRegister -- ^ Registration info - -> MToken' '["auth-register"] -- ^ Authorisation header with token - -> m (OnlyField "user" UserId) -authSignup ReqRegister{..} token = do - guardAuthToken token - guardUserInfo - guardPassword reqRegPassword - strength <- getsConfig passwordsStrength - i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions - whenJust reqRegGroups $ setUserGroups i - return $ OnlyField . fromKey $ i - where - guardUserInfo = do - mu <- getUserImplByLogin reqRegLogin - whenJust mu $ const $ throw400 "User with specified id is already registered" - --- | Implementation of get "users" method -authUsersInfo :: AuthHandler m - => Maybe Page -- ^ Page num parameter - -> Maybe PageSize -- ^ Page size parameter - -> MToken' '["auth-info"] -- ^ Authorisation header with token - -> m RespUsersInfo -authUsersInfo mp msize token = do - guardAuthToken token - pagination mp msize $ \page size -> do - (users', total) <- listUsersPaged page size - perms <- mapM (getUserPermissions . (\(WithField i _) -> i)) users' - groups <- mapM (getUserGroups . (\(WithField i _) -> i)) users' - let users = zip3 users' perms groups - return RespUsersInfo { - respUsersItems = (\(user, ps, grs) -> userToUserInfo user ps grs) <$> users - , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size - } - --- | Implementation of get "user" method -authUserInfo :: AuthHandler m - => UserId -- ^ User id - -> MToken' '["auth-info"] -- ^ Authorisation header with token - -> m RespUserInfo -authUserInfo uid' token = do - guardAuthToken token - guard404 "user" $ readUserInfo uid' - --- | Implementation of patch "user" method -authUserPatch :: AuthHandler m - => UserId -- ^ User id - -> PatchUser -- ^ JSON with fields for patching - -> MToken' '["auth-update"] -- ^ Authorisation header with token - -> m Unit -authUserPatch uid' body token = do - guardAuthToken token - whenJust (patchUserPassword body) guardPassword - let uid = toKey uid' - user <- guardUser uid - strength <- getsConfig passwordsStrength - WithField _ user' <- patchUser strength body $ WithField uid user - replaceUserImpl uid user' - return Unit - --- | Implementation of put "user" method -authUserPut :: AuthHandler m - => UserId -- ^ User id - -> ReqRegister -- ^ New user - -> MToken' '["auth-update"] -- ^ Authorisation header with token - -> m Unit -authUserPut uid' ReqRegister{..} token = do - guardAuthToken token - guardPassword reqRegPassword - let uid = toKey uid' - let user = UserImpl { - userImplLogin = reqRegLogin - , userImplPassword = "" - , userImplEmail = reqRegEmail - } - user' <- setUserPassword reqRegPassword user - replaceUserImpl uid user' - setUserPermissions uid reqRegPermissions - whenJust reqRegGroups $ setUserGroups uid - return Unit - --- | Implementation of patch "user" method -authUserDelete :: AuthHandler m - => UserId -- ^ User id - -> MToken' '["auth-delete"] -- ^ Authorisation header with token - -> m Unit -authUserDelete uid' token = do - guardAuthToken token - deleteUserImpl $ toKey uid' - return Unit - --- Generate new password for user. There is two phases, first, the method --- is called without 'code' parameter. The system sends email with a restore code --- to email. After that a call of the method with the code is needed to --- change password. Need configured SMTP server. -authRestore :: AuthHandler m - => UserId -- ^ User id - -> Maybe RestoreCode - -> Maybe Password - -> m Unit -authRestore uid' mcode mpass = do - let uid = toKey uid' - user <- guardUser uid - case mcode of - Nothing -> do - dt <- getsConfig restoreExpire - t <- liftIO getCurrentTime - AuthConfig{..} <- getConfig - rc <- getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t - uinfo <- guard404 "user" $ readUserInfo uid' - sendRestoreCode uinfo rc - Just code -> do - pass <- require "password" mpass - guardPassword pass - guardRestoreCode uid code - user' <- setUserPassword pass user - replaceUserImpl uid user' - return Unit - --- | Implementation of 'AuthGetSingleUseCodes' endpoint. -authGetSingleUseCodes :: AuthHandler m - => UserId -- ^ Id of user - -> Maybe Word -- ^ Number of codes. 'Nothing' means that server generates some default count of codes. - -- And server can define maximum count of codes that user can have at once. - -> MToken' '["auth-single-codes"] - -> m (OnlyField "codes" [SingleUseCode]) -authGetSingleUseCodes uid mcount token = do - guardAuthToken token - let uid' = toKey uid - _ <- guard404 "user" $ readUserInfo uid - AuthConfig{..} <- getConfig - let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount - OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n - --- | Getting user by id, throw 404 response if not found -guardUser :: AuthHandler m => UserImplId -> m UserImpl -guardUser uid = do - muser <- getUserImpl uid - case muser of - Nothing -> throw404 "User not found" - Just user -> return user - --- | If the token is missing or the user of the token --- doesn't have needed permissions, throw 401 response -guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m () -guardAuthToken mt = void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms) - -class WithAuthToken a where - - -- | Authenticate an entire API rather than each individual - -- endpoint. - -- - -- As such, for a given 'HasServer' instance @api@, if you have: - -- - -- @ - -- f :: 'ServerT' api m - -- @ - -- - -- then: - -- - -- @ - -- withAuthToken f :: (AuthHandler m) => ServerT ('TokenHeader' perms :> api) m - -- @ - -- - -- (Note that the types don't reflect this, as it isn't possible to - -- guarantee what all possible @ServerT@ instances might be.) - withAuthToken :: (PermsList perms) => a -> MToken perms -> a - -instance (AuthHandler m) => WithAuthToken (m a) where - withAuthToken m mt = guardAuthToken mt *> m - -instance (WithAuthToken r) => WithAuthToken (a -> r) where - withAuthToken f mt = (`withAuthToken` mt) . f - -instance (WithAuthToken a, WithAuthToken b) => WithAuthToken (a :<|> b) where - withAuthToken (a :<|> b) mt = withAuthToken a mt :<|> withAuthToken b mt - --- | Same as `guardAuthToken` but returns record about the token -guardAuthToken' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken) -guardAuthToken' Nothing _ = throw401 "Token required" -guardAuthToken' (Just token) perms = do - t <- liftIO getCurrentTime - mt <- findAuthTokenByValue token - case mt of - Nothing -> throw401 "Token is not valid" - Just et@(WithField _ AuthToken{..}) -> do - when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" } - mu <- getUserImpl authTokenUser - case mu of - Nothing -> throw500 "User of the token doesn't exist" - Just UserImpl{..} -> do - isAdmin <- hasPerm authTokenUser adminPerm - hasAllPerms <- hasPerms authTokenUser perms - unless (isAdmin || hasAllPerms) $ throw401 $ - "User doesn't have all required permissions: " <> showb perms - return et - --- | Rehash password for user -setUserPassword :: AuthHandler m => Password -> UserImpl -> m UserImpl -setUserPassword pass user = do - strength <- getsConfig passwordsStrength - setUserPassword' strength pass user - --- | Update password hash of user. Can be used to set direct hash for user password --- when it is taken from config file. -setUserPasswordHash :: AuthHandler m => Text -> UserId -> m () -setUserPasswordHash hashedPassword i = do - let i' = toKey i - user <- guard404 "user" $ getUserImpl i' - let user' = user { userImplPassword = hashedPassword } - replaceUserImpl i' user' - --- | Getting info about user group, requires 'authInfoPerm' for token -authGroupGet :: AuthHandler m - => UserGroupId - -> MToken' '["auth-info"] -- ^ Authorisation header with token - -> m UserGroup -authGroupGet i token = do - guardAuthToken token - guard404 "user group" $ readUserGroup i - --- | Inserting new user group, requires 'authUpdatePerm' for token -authGroupPost :: AuthHandler m - => UserGroup - -> MToken' '["auth-update"] -- ^ Authorisation header with token - -> m (OnlyId UserGroupId) -authGroupPost ug token = do - guardAuthToken token - OnlyField <$> insertUserGroup ug - --- | Replace info about given user group, requires 'authUpdatePerm' for token -authGroupPut :: AuthHandler m - => UserGroupId - -> UserGroup - -> MToken' '["auth-update"] -- ^ Authorisation header with token - -> m Unit -authGroupPut i ug token = do - guardAuthToken token - updateUserGroup i ug - return Unit - --- | Patch info about given user group, requires 'authUpdatePerm' for token -authGroupPatch :: AuthHandler m - => UserGroupId - -> PatchUserGroup - -> MToken' '["auth-update"] -- ^ Authorisation header with token - -> m Unit -authGroupPatch i up token = do - guardAuthToken token - patchUserGroup i up - return Unit - --- | Delete all info about given user group, requires 'authDeletePerm' for token -authGroupDelete :: AuthHandler m - => UserGroupId - -> MToken' '["auth-delete"] -- ^ Authorisation header with token - -> m Unit -authGroupDelete i token = do - guardAuthToken token - deleteUserGroup i - return Unit - --- | Get list of user groups, requires 'authInfoPerm' for token -authGroupList :: AuthHandler m - => Maybe Page - -> Maybe PageSize - -> MToken' '["auth-info"] -- ^ Authorisation header with token - -> m (PagedList UserGroupId UserGroup) -authGroupList mp msize token = do - guardAuthToken token - pagination mp msize $ \page size -> do - (groups', total) <- listGroupsPaged page size - groups <- forM groups' $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey . (\(WithField i _) -> i) - return PagedList { - pagedListItems = catMaybes groups - , pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size - } - --- | Check that the token has required permissions and return 'False' if it doesn't. -authCheckPermissionsMethod :: AuthHandler m - => MToken' '["auth-check"] -- ^ Authorisation header with token - -> OnlyField "permissions" [Permission] -- ^ Body with permissions to check - -> m Bool -- ^ 'True' if all permissions are OK, 'False' if some permissions are not set for token and 401 error if the token doesn't have 'auth-check' permission. -authCheckPermissionsMethod token (OnlyField perms) = do - guardAuthToken token - let check = const True <$> guardAuthToken' (unToken <$> token) perms - check `catchError` (\e -> if errHTTPCode e == 401 then pure True else throwError e) - --- | Get user ID for the owner of the speified token. -authGetUserIdMethod :: AuthHandler m - => MToken' '["auth-userid"] -- ^ Authorisation header with token - -> m (OnlyId UserId) -authGetUserIdMethod token = do - guardAuthToken token - OnlyField . respUserId <$> authToken (downgradeToken token) - --- | Implementation of 'AuthFindUserByLogin'. Find user by login, throw 404 error --- if cannot find user by such login. -authFindUserByLogin :: AuthHandler m - => Maybe Login -- ^ Login, 'Nothing' will cause 400 error. - -> MToken' '["auth-info"] - -> m RespUserInfo -authFindUserByLogin mlogin token = do - login <- require "login" mlogin - guardAuthToken token - userWithId <- guard404 "user" $ getUserImplByLogin login - makeUserInfo userWithId - --- | Generate hash from given password and return it as text. May be useful if --- you don't like storing unencrypt passwords in config files. -hashPassword :: AuthHandler m => Password -> m Text -hashPassword pass = do - strength <- getsConfig passwordsStrength - hashed <- liftIO $ makePassword (passToByteString pass) strength - return $ byteStringToPass hashed - --- | Ensures that DB has at least one admin, if not, creates a new one --- with specified info and direct password hash. May be useful if --- you don't like storing unencrypt passwords in config files. -ensureAdminHash :: AuthHandler m => Int -> Login -> Text -> Email -> m () -ensureAdminHash strength login passHash email = do - madmin <- getFirstUserByPerm adminPerm - whenNothing madmin $ do - i <- createAdmin strength login "" email - setUserPasswordHash passHash $ fromKey i - --- | If you use password hash in configs, you cannot use them in signin --- method. This helper allows to get token by password hash and the function --- is not available for remote call (no endpoint). --- --- Throws 401 if cannot find user or authorisation is failed. --- --- WARNING: Do not expose the function to end user, never! -signinByHashUnsafe :: AuthHandler m => Login -- ^ User login - -> Text -- ^ Hash of admin password - -> Maybe Seconds -- ^ Expire - -> m SimpleToken -signinByHashUnsafe login pass mexpire = do - WithField uid UserImpl{..} <- guardLogin login pass - getAuthToken uid mexpire - where - guardLogin login pass = do -- check login and password, return passed user - muser <- getUserImplByLogin login - let err = throw401 "Cannot find user with given combination of login and pass" - case muser of - Nothing -> err - Just user@(WithField _ UserImpl{..}) -> if pass == userImplPassword - then return user - else err +{-# LANGUAGE UndecidableInstances #-}
+{-|
+Module : Servant.Server.Auth.Token
+Description : Implementation of token authorisation API
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+
+The module is server side implementation of "Servant.API.Auth.Token" API and intended to be
+used as drop in module for user servers or as external micro service.
+
+
+
+Use 'guardAuthToken' to check authorisation headers in endpoints of your server:
+
+@
+-- | Read a single customer from DB
+customerGet :: CustomerId -- ^ Customer unique id
+ -> MToken' '["customer-read"] -- ^ Required permissions for auth token
+ -> ServerM Customer -- ^ Customer data
+customerGet i token = do
+ guardAuthToken token
+ guard404 "customer" $ getCustomer i
+@
+
+-}
+module Servant.Server.Auth.Token(
+ -- * Implementation
+ authServer
+ -- * Server API
+ , HasStorage(..)
+ , AuthHandler
+ -- * Helpers
+ , guardAuthToken
+ , WithAuthToken(..)
+ , ensureAdmin
+ , authUserByToken
+ -- * API methods
+ , authSignin
+ , authSigninGetCode
+ , authSigninPostCode
+ , authTouch
+ , authToken
+ , authSignout
+ , authSignup
+ , authUsersInfo
+ , authUserInfo
+ , authUserPatch
+ , authUserPut
+ , authUserDelete
+ , authRestore
+ , authGetSingleUseCodes
+ , authGroupGet
+ , authGroupPost
+ , authGroupPut
+ , authGroupPatch
+ , authGroupDelete
+ , authGroupList
+ , authCheckPermissionsMethod
+ , authGetUserIdMethod
+ , authFindUserByLogin
+ -- * Low-level API
+ , getAuthToken
+ , hashPassword
+ , setUserPasswordHash
+ , ensureAdminHash
+ , signinByHashUnsafe
+ ) where
+
+import Control.Monad
+import Control.Monad.Except
+import Crypto.PasswordStore
+import Data.Aeson.Unit
+import Data.Aeson.WithField
+import Data.Maybe
+import Data.Monoid
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Time.Clock
+import Data.UUID
+import Data.UUID.V4
+import Servant
+
+import Servant.API.Auth.Token
+import Servant.API.Auth.Token.Pagination
+import Servant.Server.Auth.Token.Common
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+import Servant.Server.Auth.Token.Monad
+import Servant.Server.Auth.Token.Pagination
+import Servant.Server.Auth.Token.Restore
+import Servant.Server.Auth.Token.SingleUse
+
+import qualified Data.ByteString.Lazy as BS
+
+-- | Implementation of AuthAPI
+authServer :: AuthHandler m => ServerT AuthAPI m
+authServer =
+ authSignin
+ :<|> authSigninGetCode
+ :<|> authSigninPostCode
+ :<|> authTouch
+ :<|> authToken
+ :<|> authSignout
+ :<|> authSignup
+ :<|> authUsersInfo
+ :<|> authUserInfo
+ :<|> authUserPatch
+ :<|> authUserPut
+ :<|> authUserDelete
+ :<|> authRestore
+ :<|> authGetSingleUseCodes
+ :<|> authGroupGet
+ :<|> authGroupPost
+ :<|> authGroupPut
+ :<|> authGroupPatch
+ :<|> authGroupDelete
+ :<|> authGroupList
+ :<|> authCheckPermissionsMethod
+ :<|> authGetUserIdMethod
+ :<|> authFindUserByLogin
+
+-- | Implementation of "signin" method
+authSignin :: AuthHandler m
+ => Maybe Login -- ^ Login query parameter
+ -> Maybe Password -- ^ Password query parameter
+ -> Maybe Seconds -- ^ Expire query parameter, how many seconds the token is valid
+ -> m (OnlyField "token" SimpleToken) -- ^ If everything is OK, return token
+authSignin mlogin mpass mexpire = do
+ login <- require "login" mlogin
+ pass <- require "pass" mpass
+ WithField uid UserImpl{..} <- guardLogin login pass
+ OnlyField <$> getAuthToken uid mexpire
+ where
+ guardLogin login pass = do -- check login and password, return passed user
+ muser <- getUserImplByLogin login
+ let err = throw401 "Cannot find user with given combination of login and pass"
+ case muser of
+ Nothing -> err
+ Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword
+ then return user
+ else err
+
+-- | Helper to get or generate new token for user
+getAuthToken :: AuthHandler m
+ => UserImplId -- ^ User for whom we want token
+ -> Maybe Seconds -- ^ Expiration duration, 'Nothing' means default
+ -> m SimpleToken -- ^ Old token (if it doesn't expire) or new one
+getAuthToken uid mexpire = do
+ expire <- calcExpire mexpire
+ mt <- getExistingToken -- check whether there is already existing token
+ case mt of
+ Nothing -> createToken expire -- create new token
+ Just t -> touchToken t expire -- prolong token expiration time
+ where
+ getExistingToken = do -- return active token for specified user id
+ t <- liftIO getCurrentTime
+ findAuthToken uid t
+
+ createToken expire = do -- generate and save fresh token
+ token <- toText <$> liftIO nextRandom
+ _ <- insertAuthToken AuthToken {
+ authTokenValue = token
+ , authTokenUser = uid
+ , authTokenExpire = expire
+ }
+ return token
+
+-- | Authorisation via code of single usage.
+--
+-- Implementation of 'AuthSigninGetCodeMethod' endpoint.
+--
+-- Logic of authorisation via this method is:
+--
+-- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint
+--
+-- * Server generates single use token and sends it via
+-- SMS or email, defined in configuration by 'singleUseCodeSender' field.
+--
+-- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint
+--
+-- * Server responds with auth token.
+--
+-- * Client uses the token with other requests as authorisation
+-- header
+--
+-- * Client can extend lifetime of token by periodically pinging
+-- of 'AuthTouchMethod' endpoint
+--
+-- * Client can invalidate token instantly by 'AuthSignoutMethod'
+--
+-- * Client can get info about user with 'AuthTokenInfoMethod' endpoint.
+--
+-- See also: 'authSigninPostCode'
+authSigninGetCode :: AuthHandler m
+ => Maybe Login -- ^ User login, required
+ -> m Unit
+authSigninGetCode mlogin = do
+ login <- require "login" mlogin
+ uinfo <- guard404 "user" $ readUserInfoByLogin login
+ let uid = toKey $ respUserId uinfo
+
+ AuthConfig{..} <- getConfig
+ code <- liftIO singleUseCodeGenerator
+ expire <- makeSingleUseExpire singleUseCodeExpire
+ registerSingleUseCode uid code (Just expire)
+ liftIO $ singleUseCodeSender uinfo code
+
+ return Unit
+
+-- | Authorisation via code of single usage.
+--
+-- Logic of authorisation via this method is:
+--
+-- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint
+--
+-- * Server generates single use token and sends it via
+-- SMS or email, defined in configuration by 'singleUseCodeSender' field.
+--
+-- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint
+--
+-- * Server responds with auth token.
+--
+-- * Client uses the token with other requests as authorisation
+-- header
+--
+-- * Client can extend lifetime of token by periodically pinging
+-- of 'AuthTouchMethod' endpoint
+--
+-- * Client can invalidate token instantly by 'AuthSignoutMethod'
+--
+-- * Client can get info about user with 'AuthTokenInfoMethod' endpoint.
+--
+-- See also: 'authSigninGetCode'
+authSigninPostCode :: AuthHandler m
+ => Maybe Login -- ^ User login, required
+ -> Maybe SingleUseCode -- ^ Received single usage code, required
+ -> Maybe Seconds
+ -- ^ Time interval after which the token expires, 'Nothing' means
+ -- some default value
+ -> m (OnlyField "token" SimpleToken)
+authSigninPostCode mlogin mcode mexpire = do
+ login <- require "login" mlogin
+ code <- require "code" mcode
+
+ uinfo <- guard404 "user" $ readUserInfoByLogin login
+ let uid = toKey $ respUserId uinfo
+ isValid <- validateSingleUseCode uid code
+ unless isValid $ throw401 "Single usage code doesn't match"
+
+ OnlyField <$> getAuthToken uid mexpire
+
+-- | Calculate expiration timestamp for token
+calcExpire :: AuthHandler m => Maybe Seconds -> m UTCTime
+calcExpire mexpire = do
+ t <- liftIO getCurrentTime
+ AuthConfig{..} <- getConfig
+ let requestedExpire = maybe defaultExpire fromIntegral mexpire
+ let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire
+ return $ boundedExpire `addUTCTime` t
+
+-- prolong token with new timestamp
+touchToken :: AuthHandler m => WithId AuthTokenId AuthToken -> UTCTime -> m SimpleToken
+touchToken (WithField tid tok) expire = do
+ replaceAuthToken tid tok {
+ authTokenExpire = expire
+ }
+ return $ authTokenValue tok
+
+-- | Implementation of "touch" method
+authTouch :: AuthHandler m
+ => Maybe Seconds -- ^ Expire query parameter, how many seconds the token should be valid by now. 'Nothing' means default value defined in server config.
+ -> MToken '[] -- ^ Authorisation header with token
+ -> m Unit
+authTouch mexpire token = do
+ WithField i mt <- guardAuthToken' (fmap unToken token) []
+ expire <- calcExpire mexpire
+ replaceAuthToken i mt { authTokenExpire = expire }
+ return Unit
+
+-- | Implementation of "token" method, return
+-- info about user binded to the token
+authToken :: AuthHandler m
+ => MToken '[] -- ^ Authorisation header with token
+ -> m RespUserInfo
+authToken token = do
+ i <- authUserByToken token
+ guard404 "user" . readUserInfo . fromKey $ i
+
+-- | Getting user id by token
+authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId
+authUserByToken token = do
+ WithField _ mt <- guardAuthToken' (fmap unToken token) []
+ return $ authTokenUser mt
+
+-- | Implementation of "signout" method
+authSignout :: AuthHandler m
+ => Maybe (Token '[]) -- ^ Authorisation header with token
+ -> m Unit
+authSignout token = do
+ WithField i mt <- guardAuthToken' (fmap unToken token) []
+ expire <- liftIO getCurrentTime
+ replaceAuthToken i mt { authTokenExpire = expire }
+ return Unit
+
+-- | Checks given password and if it is invalid in terms of config
+-- password validator, throws 400 error.
+guardPassword :: AuthHandler m => Password -> m ()
+guardPassword p = do
+ AuthConfig{..} <- getConfig
+ whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8
+
+-- | Implementation of "signup" method
+authSignup :: AuthHandler m
+ => ReqRegister -- ^ Registration info
+ -> MToken' '["auth-register"] -- ^ Authorisation header with token
+ -> m (OnlyField "user" UserId)
+authSignup ReqRegister{..} token = do
+ guardAuthToken token
+ guardUserInfo
+ guardPassword reqRegPassword
+ strength <- getsConfig passwordsStrength
+ i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions
+ whenJust reqRegGroups $ setUserGroups i
+ return $ OnlyField . fromKey $ i
+ where
+ guardUserInfo = do
+ mu <- getUserImplByLogin reqRegLogin
+ whenJust mu $ const $ throw400 "User with specified id is already registered"
+
+-- | Implementation of get "users" method
+authUsersInfo :: AuthHandler m
+ => Maybe Page -- ^ Page num parameter
+ -> Maybe PageSize -- ^ Page size parameter
+ -> MToken' '["auth-info"] -- ^ Authorisation header with token
+ -> m RespUsersInfo
+authUsersInfo mp msize token = do
+ guardAuthToken token
+ pagination mp msize $ \page size -> do
+ (users', total) <- listUsersPaged page size
+ perms <- mapM (getUserPermissions . (\(WithField i _) -> i)) users'
+ groups <- mapM (getUserGroups . (\(WithField i _) -> i)) users'
+ let users = zip3 users' perms groups
+ return RespUsersInfo {
+ respUsersItems = (\(user, ps, grs) -> userToUserInfo user ps grs) <$> users
+ , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
+ }
+
+-- | Implementation of get "user" method
+authUserInfo :: AuthHandler m
+ => UserId -- ^ User id
+ -> MToken' '["auth-info"] -- ^ Authorisation header with token
+ -> m RespUserInfo
+authUserInfo uid' token = do
+ guardAuthToken token
+ guard404 "user" $ readUserInfo uid'
+
+-- | Implementation of patch "user" method
+authUserPatch :: AuthHandler m
+ => UserId -- ^ User id
+ -> PatchUser -- ^ JSON with fields for patching
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m Unit
+authUserPatch uid' body token = do
+ guardAuthToken token
+ whenJust (patchUserPassword body) guardPassword
+ let uid = toKey uid'
+ user <- guardUser uid
+ strength <- getsConfig passwordsStrength
+ WithField _ user' <- patchUser strength body $ WithField uid user
+ replaceUserImpl uid user'
+ return Unit
+
+-- | Implementation of put "user" method
+authUserPut :: AuthHandler m
+ => UserId -- ^ User id
+ -> ReqRegister -- ^ New user
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m Unit
+authUserPut uid' ReqRegister{..} token = do
+ guardAuthToken token
+ guardPassword reqRegPassword
+ let uid = toKey uid'
+ let user = UserImpl {
+ userImplLogin = reqRegLogin
+ , userImplPassword = ""
+ , userImplEmail = reqRegEmail
+ }
+ user' <- setUserPassword reqRegPassword user
+ replaceUserImpl uid user'
+ setUserPermissions uid reqRegPermissions
+ whenJust reqRegGroups $ setUserGroups uid
+ return Unit
+
+-- | Implementation of patch "user" method
+authUserDelete :: AuthHandler m
+ => UserId -- ^ User id
+ -> MToken' '["auth-delete"] -- ^ Authorisation header with token
+ -> m Unit
+authUserDelete uid' token = do
+ guardAuthToken token
+ deleteUserImpl $ toKey uid'
+ return Unit
+
+-- Generate new password for user. There is two phases, first, the method
+-- is called without 'code' parameter. The system sends email with a restore code
+-- to email. After that a call of the method with the code is needed to
+-- change password. Need configured SMTP server.
+authRestore :: AuthHandler m
+ => UserId -- ^ User id
+ -> Maybe RestoreCode
+ -> Maybe Password
+ -> m Unit
+authRestore uid' mcode mpass = do
+ let uid = toKey uid'
+ user <- guardUser uid
+ case mcode of
+ Nothing -> do
+ dt <- getsConfig restoreExpire
+ t <- liftIO getCurrentTime
+ AuthConfig{..} <- getConfig
+ rc <- getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t
+ uinfo <- guard404 "user" $ readUserInfo uid'
+ sendRestoreCode uinfo rc
+ Just code -> do
+ pass <- require "password" mpass
+ guardPassword pass
+ guardRestoreCode uid code
+ user' <- setUserPassword pass user
+ replaceUserImpl uid user'
+ return Unit
+
+-- | Implementation of 'AuthGetSingleUseCodes' endpoint.
+authGetSingleUseCodes :: AuthHandler m
+ => UserId -- ^ Id of user
+ -> Maybe Word -- ^ Number of codes. 'Nothing' means that server generates some default count of codes.
+ -- And server can define maximum count of codes that user can have at once.
+ -> MToken' '["auth-single-codes"]
+ -> m (OnlyField "codes" [SingleUseCode])
+authGetSingleUseCodes uid mcount token = do
+ guardAuthToken token
+ let uid' = toKey uid
+ _ <- guard404 "user" $ readUserInfo uid
+ AuthConfig{..} <- getConfig
+ let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount
+ OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n
+
+-- | Getting user by id, throw 404 response if not found
+guardUser :: AuthHandler m => UserImplId -> m UserImpl
+guardUser uid = do
+ muser <- getUserImpl uid
+ case muser of
+ Nothing -> throw404 "User not found"
+ Just user -> return user
+
+-- | If the token is missing or the user of the token
+-- doesn't have needed permissions, throw 401 response
+guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m ()
+guardAuthToken mt = void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms)
+
+class WithAuthToken a where
+
+ -- | Authenticate an entire API rather than each individual
+ -- endpoint.
+ --
+ -- As such, for a given 'HasServer' instance @api@, if you have:
+ --
+ -- @
+ -- f :: 'ServerT' api m
+ -- @
+ --
+ -- then:
+ --
+ -- @
+ -- withAuthToken f :: (AuthHandler m) => ServerT ('TokenHeader' perms :> api) m
+ -- @
+ --
+ -- (Note that the types don't reflect this, as it isn't possible to
+ -- guarantee what all possible @ServerT@ instances might be.)
+ withAuthToken :: (PermsList perms) => a -> MToken perms -> a
+
+instance (AuthHandler m) => WithAuthToken (m a) where
+ withAuthToken m mt = guardAuthToken mt *> m
+
+instance {-# OVERLAPPING #-} (WithAuthToken r) => WithAuthToken (a -> r) where
+ withAuthToken f mt = (`withAuthToken` mt) . f
+
+instance (WithAuthToken a, WithAuthToken b) => WithAuthToken (a :<|> b) where
+ withAuthToken (a :<|> b) mt = withAuthToken a mt :<|> withAuthToken b mt
+
+-- | Same as `guardAuthToken` but returns record about the token
+guardAuthToken' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken)
+guardAuthToken' Nothing _ = throw401 "Token required"
+guardAuthToken' (Just token) perms = do
+ t <- liftIO getCurrentTime
+ mt <- findAuthTokenByValue token
+ case mt of
+ Nothing -> throw401 "Token is not valid"
+ Just et@(WithField _ AuthToken{..}) -> do
+ when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" }
+ mu <- getUserImpl authTokenUser
+ case mu of
+ Nothing -> throw500 "User of the token doesn't exist"
+ Just UserImpl{..} -> do
+ isAdmin <- hasPerm authTokenUser adminPerm
+ hasAllPerms <- hasPerms authTokenUser perms
+ unless (isAdmin || hasAllPerms) $ throw401 $
+ "User doesn't have all required permissions: " <> showb perms
+ return et
+
+-- | Rehash password for user
+setUserPassword :: AuthHandler m => Password -> UserImpl -> m UserImpl
+setUserPassword pass user = do
+ strength <- getsConfig passwordsStrength
+ setUserPassword' strength pass user
+
+-- | Update password hash of user. Can be used to set direct hash for user password
+-- when it is taken from config file.
+setUserPasswordHash :: AuthHandler m => Text -> UserId -> m ()
+setUserPasswordHash hashedPassword i = do
+ let i' = toKey i
+ user <- guard404 "user" $ getUserImpl i'
+ let user' = user { userImplPassword = hashedPassword }
+ replaceUserImpl i' user'
+
+-- | Getting info about user group, requires 'authInfoPerm' for token
+authGroupGet :: AuthHandler m
+ => UserGroupId
+ -> MToken' '["auth-info"] -- ^ Authorisation header with token
+ -> m UserGroup
+authGroupGet i token = do
+ guardAuthToken token
+ guard404 "user group" $ readUserGroup i
+
+-- | Inserting new user group, requires 'authUpdatePerm' for token
+authGroupPost :: AuthHandler m
+ => UserGroup
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m (OnlyId UserGroupId)
+authGroupPost ug token = do
+ guardAuthToken token
+ OnlyField <$> insertUserGroup ug
+
+-- | Replace info about given user group, requires 'authUpdatePerm' for token
+authGroupPut :: AuthHandler m
+ => UserGroupId
+ -> UserGroup
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m Unit
+authGroupPut i ug token = do
+ guardAuthToken token
+ updateUserGroup i ug
+ return Unit
+
+-- | Patch info about given user group, requires 'authUpdatePerm' for token
+authGroupPatch :: AuthHandler m
+ => UserGroupId
+ -> PatchUserGroup
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m Unit
+authGroupPatch i up token = do
+ guardAuthToken token
+ patchUserGroup i up
+ return Unit
+
+-- | Delete all info about given user group, requires 'authDeletePerm' for token
+authGroupDelete :: AuthHandler m
+ => UserGroupId
+ -> MToken' '["auth-delete"] -- ^ Authorisation header with token
+ -> m Unit
+authGroupDelete i token = do
+ guardAuthToken token
+ deleteUserGroup i
+ return Unit
+
+-- | Get list of user groups, requires 'authInfoPerm' for token
+authGroupList :: AuthHandler m
+ => Maybe Page
+ -> Maybe PageSize
+ -> MToken' '["auth-info"] -- ^ Authorisation header with token
+ -> m (PagedList UserGroupId UserGroup)
+authGroupList mp msize token = do
+ guardAuthToken token
+ pagination mp msize $ \page size -> do
+ (groups', total) <- listGroupsPaged page size
+ groups <- forM groups' $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey . (\(WithField i _) -> i)
+ return PagedList {
+ pagedListItems = catMaybes groups
+ , pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
+ }
+
+-- | Check that the token has required permissions and return 'False' if it doesn't.
+authCheckPermissionsMethod :: AuthHandler m
+ => MToken' '["auth-check"] -- ^ Authorisation header with token
+ -> OnlyField "permissions" [Permission] -- ^ Body with permissions to check
+ -> m Bool -- ^ 'True' if all permissions are OK, 'False' if some permissions are not set for token and 401 error if the token doesn't have 'auth-check' permission.
+authCheckPermissionsMethod token (OnlyField perms) = do
+ guardAuthToken token
+ let check = const True <$> guardAuthToken' (unToken <$> token) perms
+ check `catchError` (\e -> if errHTTPCode e == 401 then pure True else throwError e)
+
+-- | Get user ID for the owner of the speified token.
+authGetUserIdMethod :: AuthHandler m
+ => MToken' '["auth-userid"] -- ^ Authorisation header with token
+ -> m (OnlyId UserId)
+authGetUserIdMethod token = do
+ guardAuthToken token
+ OnlyField . respUserId <$> authToken (downgradeToken token)
+
+-- | Implementation of 'AuthFindUserByLogin'. Find user by login, throw 404 error
+-- if cannot find user by such login.
+authFindUserByLogin :: AuthHandler m
+ => Maybe Login -- ^ Login, 'Nothing' will cause 400 error.
+ -> MToken' '["auth-info"]
+ -> m RespUserInfo
+authFindUserByLogin mlogin token = do
+ login <- require "login" mlogin
+ guardAuthToken token
+ userWithId <- guard404 "user" $ getUserImplByLogin login
+ makeUserInfo userWithId
+
+-- | Generate hash from given password and return it as text. May be useful if
+-- you don't like storing unencrypt passwords in config files.
+hashPassword :: AuthHandler m => Password -> m Text
+hashPassword pass = do
+ strength <- getsConfig passwordsStrength
+ hashed <- liftIO $ makePassword (passToByteString pass) strength
+ return $ byteStringToPass hashed
+
+-- | Ensures that DB has at least one admin, if not, creates a new one
+-- with specified info and direct password hash. May be useful if
+-- you don't like storing unencrypt passwords in config files.
+ensureAdminHash :: AuthHandler m => Int -> Login -> Text -> Email -> m ()
+ensureAdminHash strength login passHash email = do
+ madmin <- getFirstUserByPerm adminPerm
+ whenNothing madmin $ do
+ i <- createAdmin strength login "" email
+ setUserPasswordHash passHash $ fromKey i
+
+-- | If you use password hash in configs, you cannot use them in signin
+-- method. This helper allows to get token by password hash and the function
+-- is not available for remote call (no endpoint).
+--
+-- Throws 401 if cannot find user or authorisation is failed.
+--
+-- WARNING: Do not expose the function to end user, never!
+signinByHashUnsafe :: AuthHandler m => Login -- ^ User login
+ -> Text -- ^ Hash of admin password
+ -> Maybe Seconds -- ^ Expire
+ -> m SimpleToken
+signinByHashUnsafe login pass mexpire = do
+ WithField uid UserImpl{..} <- guardLogin login pass
+ getAuthToken uid mexpire
+ where
+ guardLogin login pass = do -- check login and password, return passed user
+ muser <- getUserImplByLogin login
+ let err = throw401 "Cannot find user with given combination of login and pass"
+ case muser of
+ Nothing -> err
+ Just user@(WithField _ UserImpl{..}) -> if pass == userImplPassword
+ then return user
+ else err
diff --git a/src/Servant/Server/Auth/Token/Common.hs b/src/Servant/Server/Auth/Token/Common.hs index 205e2e7..68b3982 100644 --- a/src/Servant/Server/Auth/Token/Common.hs +++ b/src/Servant/Server/Auth/Token/Common.hs @@ -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
diff --git a/src/Servant/Server/Auth/Token/Config.hs b/src/Servant/Server/Auth/Token/Config.hs index ba28068..9237edf 100644 --- a/src/Servant/Server/Auth/Token/Config.hs +++ b/src/Servant/Server/Auth/Token/Config.hs @@ -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
diff --git a/src/Servant/Server/Auth/Token/Error.hs b/src/Servant/Server/Auth/Token/Error.hs index 5cf6afb..5338f27 100644 --- a/src/Servant/Server/Auth/Token/Error.hs +++ b/src/Servant/Server/Auth/Token/Error.hs @@ -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 }
diff --git a/src/Servant/Server/Auth/Token/Model.hs b/src/Servant/Server/Auth/Token/Model.hs index d71a651..36b32b9 100644 --- a/src/Servant/Server/Auth/Token/Model.hs +++ b/src/Servant/Server/Auth/Token/Model.hs @@ -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'
diff --git a/src/Servant/Server/Auth/Token/Monad.hs b/src/Servant/Server/Auth/Token/Monad.hs index d790bfa..2bbe102 100644 --- a/src/Servant/Server/Auth/Token/Monad.hs +++ b/src/Servant/Server/Auth/Token/Monad.hs @@ -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'
diff --git a/src/Servant/Server/Auth/Token/Pagination.hs b/src/Servant/Server/Auth/Token/Pagination.hs index 5f0b361..a6d5908 100644 --- a/src/Servant/Server/Auth/Token/Pagination.hs +++ b/src/Servant/Server/Auth/Token/Pagination.hs @@ -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
diff --git a/src/Servant/Server/Auth/Token/Patch.hs b/src/Servant/Server/Auth/Token/Patch.hs index e5a5bec..9df54f2 100644 --- a/src/Servant/Server/Auth/Token/Patch.hs +++ b/src/Servant/Server/Auth/Token/Patch.hs @@ -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' #-}
\ No newline at end of file diff --git a/src/Servant/Server/Auth/Token/Restore.hs b/src/Servant/Server/Auth/Token/Restore.hs index 9feac5b..bfd68c4 100644 --- a/src/Servant/Server/Auth/Token/Restore.hs +++ b/src/Servant/Server/Auth/Token/Restore.hs @@ -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
diff --git a/src/Servant/Server/Auth/Token/SingleUse.hs b/src/Servant/Server/Auth/Token/SingleUse.hs index 699bdd4..5f7fbf7 100644 --- a/src/Servant/Server/Auth/Token/SingleUse.hs +++ b/src/Servant/Server/Auth/Token/SingleUse.hs @@ -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
@@ -1,90 +1,95 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# http://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-8.8 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- '.' -- 'servant-auth-token-acid' -- 'servant-auth-token-persistent' -- 'servant-auth-token-leveldb' -- 'example/acid' -- 'example/persistent' -- 'example/leveldb' -# - location: -# git: https://github.com/NCrashed/servant-auth-token-api.git -# commit: d011f7bfecd18d07ff67ce9f67f8741e110a2719 -# extra-dep: true -# - '../servant-auth-token-api' - -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: -- aeson-injector-1.0.7.0 -- concurrent-extra-0.7.0.10 -- http-api-data-0.3.5 -- natural-transformation-0.4 -- safecopy-store-0.9.2 -- servant-0.9 -- servant-auth-token-api-0.4.2.0 -- servant-docs-0.9 -- servant-server-0.9 -- store-0.3.1 -- store-core-0.3 -- th-utilities-0.2.0.1 - -# Override default flag values for local packages and extra-deps -flags: {} - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor +# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+# name: custom-snapshot
+# location: "./custom-snapshot.yaml"
+resolver: lts-8.14
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+# git: https://github.com/commercialhaskell/stack.git
+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# extra-dep: true
+# subdirs:
+# - auto-update
+# - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+- 'servant-auth-token-acid'
+- 'servant-auth-token-persistent'
+- 'servant-auth-token-leveldb'
+- 'servant-auth-token-rocksdb'
+- 'example/acid'
+- 'example/persistent'
+- 'example/leveldb'
+# - location:
+# git: https://github.com/NCrashed/servant-auth-token-api.git
+# commit: d011f7bfecd18d07ff67ce9f67f8741e110a2719
+# extra-dep: true
+# - '../servant-auth-token-api'
+- location:
+ git: https://github.com/serokell/rocksdb-haskell.git
+ commit: 325427fc709183c8fdf777ad5ea09f8d92bf8585
+ extra-dep: true
+
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps:
+- aeson-injector-1.0.7.0
+- concurrent-extra-0.7.0.10
+- http-api-data-0.3.5
+- natural-transformation-0.4
+- safecopy-store-0.9.3
+- servant-0.9
+- servant-auth-token-api-0.4.2.0
+- servant-docs-0.9
+- servant-server-0.9
+#- store-0.3.1
+#- store-core-0.3
+- th-utilities-0.2.0.1
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.1"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
|