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