diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.4.0.0 +======= + +* Abstract over storage: persistent and acid-state backends. + 0.3.2.0 ======= diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,52 +2,26 @@ [![Build Status](https://travis-ci.org/NCrashed/servant-auth-token.svg?branch=master)](https://travis-ci.org/NCrashed/servant-auth-token) -The repo contains server implementation of [servant-auth-toke-api](https://github.com/NCrashed/servant-auth-token-api). +The repo contains server implementation of [servant-auth-token-api](https://github.com/NCrashed/servant-auth-token-api). # How to add to your server -To use the server as constituent part, you need to provide customised 'AuthConfig' for -'authServer' function and implement 'AuthMonad' instance for your handler monad. - -``` haskell -import Servant.Server.Auth.Token as Auth - --- | Example of user side configuration -data Config = Config { - -- | Authorisation specific configuration - authConfig :: AuthConfig - -- other fields - -- ... -} +At the moment you have two options for backend storage: --- | Example of user side handler monad -newtype App a = App { - runApp :: ReaderT Config (ExceptT ServantErr IO) a - } deriving ( Functor, Applicative, Monad, MonadReader Config, - MonadError ServantErr, MonadIO) +- [persistent backend](https://github.com/NCrashed/servant-auth-token/tree/master/servant-auth-token-persistent) - [persistent](https://hackage.haskell.org/package/persistent) backend, simple to integrate with your app. --- | Now you can use authorisation API in your handler -instance AuthMonad App where - getAuthConfig = asks authConfig - liftAuthAction = App . lift +- [acid-state backend](https://github.com/NCrashed/servant-auth-token/tree/master/servant-auth-token-acid) - [acid-state](https://hackage.haskell.org/package/acid-state) backend is light solution for in memory storage, but it is more difficult to integrate it with your app. --- | Include auth 'migrateAll' function into your migration code -doMigrations :: SqlPersistT IO () -doMigrations = runMigrationUnsafe $ do - migrateAll -- other user migrations - Auth.migrateAll -- creation of authorisation entities - -- optional creation of default admin if db is empty - ensureAdmin 17 "admin" "123456" "admin@localhost" -``` +- Possible candidates for other storage backends: VCache, leveldb, JSON files. To see how to implement them, see [HasStorage](https://github.com/NCrashed/servant-auth-token/blob/master/src/Servant/Server/Auth/Token/Model.hs#L220) type class. -Now you can use 'guardAuthToken' to check authorisation headers in endpoints of your server: +Now you can use 'guardAuthToken' to check authorization headers in endpoints of your server: ``` haskell -- | Read a single customer from DB customerGet :: CustomerId -- ^ Customer unique id -> MToken '["customer-read"] -- ^ Required permissions for auth token - -> App Customer -- ^ Customer data + -> ServerM Customer -- ^ Customer data customerGet i token = do - guardAuthToken token - runDB404 "customer" $ getCustomer i + guardAuthToken token + runDB404 "customer" $ getCustomer i ``` diff --git a/example/acid/LICENSE b/example/acid/LICENSE new file mode 100644 --- /dev/null +++ b/example/acid/LICENSE @@ -0,0 +1,30 @@ +Copyright Anton Gushcha (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of NCrashed nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/example/acid/Setup.hs b/example/acid/Setup.hs new file mode 100644 --- /dev/null +++ b/example/acid/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/acid/config.yaml b/example/acid/config.yaml new file mode 100644 --- /dev/null +++ b/example/acid/config.yaml @@ -0,0 +1,3 @@ +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 new file mode 100644 --- /dev/null +++ b/example/acid/servant-auth-token-example-acid.cabal @@ -0,0 +1,70 @@ +name: servant-auth-token-example-acid +version: 0.4.0.0 +synopsis: Example server for token auth for acid-state backend +description: Please see README.md +homepage: https://github.com/ncrashed/servant-auth-token#readme +license: BSD3 +license-file: LICENSE +author: NCrashed +maintainer: ncrashed@gmail.com +copyright: 2017 Anton Gushcha +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable servant-auth-token-example-acid + hs-source-dirs: src + main-is: Main.hs + other-modules: + API + Config + DB + Monad + Server + default-language: Haskell2010 + build-depends: + base >= 4.7 && < 5 + , acid-state >= 0.14 && < 0.15 + , aeson >= 0.11 && < 0.12 + , aeson-injector >= 1.0 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , exceptions >= 0.8 && < 0.9 + , http-types >= 0.9 && < 0.10 + , monad-control >= 1.0 && < 1.1 + , monad-logger >= 0.3 && < 0.4 + , mtl >= 2.2 && < 2.3 + , optparse-applicative >= 0.12 && < 0.13 + , safecopy >= 0.9 && < 0.10 + , servant >= 0.9 && < 0.10 + , servant-auth-token >= 0.4 && < 0.5 + , servant-auth-token-acid >= 0.4 && < 0.5 + , servant-auth-token-api >= 0.4 && < 0.5 + , servant-server >= 0.9 && < 0.10 + , text >= 1.2 && < 1.3 + , time >= 1.6 && < 1.7 + , transformers-base >= 0.4 && < 0.5 + , wai >= 3.2 && < 3.3 + , wai-extra >= 3.0 && < 3.1 + , warp >= 3.2 && < 3.3 + , yaml >= 0.8 && < 0.9 + default-extensions: + BangPatterns + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + MultiParamTypeClasses + OverloadedStrings + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TypeFamilies + TypeOperators + UndecidableInstances + + ghc-options: -threaded diff --git a/example/acid/src/API.hs b/example/acid/src/API.hs new file mode 100644 --- /dev/null +++ b/example/acid/src/API.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/example/acid/src/Config.hs @@ -0,0 +1,30 @@ +module Config( + ServerConfig(..) + , readConfig + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import Data.Text +import Data.Yaml.Config + +-- | Startup configuration of server +data ServerConfig = ServerConfig { + -- | Server host name + serverHost :: !Text + -- | Server port number +, serverPort :: !Int + -- | Server db location +, serverDbPath :: !Text +} + +instance FromJSON ServerConfig where + parseJSON (Object o) = ServerConfig + <$> o .: "host" + <*> o .: "port" + <*> o .: "db" + parseJSON _ = mzero + +readConfig :: MonadIO m => FilePath -> m ServerConfig +readConfig f = liftIO $ loadYamlSettings [f] [] useEnv diff --git a/example/acid/src/DB.hs b/example/acid/src/DB.hs new file mode 100644 --- /dev/null +++ b/example/acid/src/DB.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module DB where + +import Data.SafeCopy + +import Servant.Server.Auth.Token.Acid.Schema as A + +-- | Application global state for acid-state +data DB = DB { + dbAuth :: A.Model -- ^ Storage for Auth state +, dbCustom :: () -- ^ Demo of custom state +} + +-- | Generation of inital state +newDB :: DB +newDB = DB { + dbAuth = A.newModel + , dbCustom = () + } + +instance HasModelRead DB where + askModel = dbAuth + +instance HasModelWrite DB where + putModel db m = db { dbAuth = m } + +deriveSafeCopy 0 'base ''DB + +A.deriveQueries ''DB +A.makeModelAcidic ''DB diff --git a/example/acid/src/Main.hs b/example/acid/src/Main.hs new file mode 100644 --- /dev/null +++ b/example/acid/src/Main.hs @@ -0,0 +1,34 @@ +module Main where + +import Options.Applicative + +import Server + +-- | Argument line options +data Options = Options { + -- | Path to config, if not set, the app will not start + configPath :: FilePath +} + +-- | Command line parser +optionsParser :: Parser Options +optionsParser = Options + <$> strOption ( + long "conf" + <> metavar "CONFIG" + <> help "Path to configuration file" + ) + +-- | Execute server with given options +runServer :: Options -> IO () +runServer Options{..} = do + cfg <- readConfig configPath + runExampleServer cfg + +main :: IO () +main = execParser opts >>= runServer + where + opts = info (helper <*> optionsParser) + ( fullDesc + <> progDesc "Example server for servant-auth-token" + <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" ) diff --git a/example/acid/src/Monad.hs b/example/acid/src/Monad.hs new file mode 100644 --- /dev/null +++ b/example/acid/src/Monad.hs @@ -0,0 +1,98 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Monad( + ServerEnv(..) + , ServerM + , newServerEnv + , runServerM + , runServerMIO + , serverMtoHandler + , AuthM(..) + , runAuth + ) where + +import Control.Monad.Base +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Except +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.Trans.Control +import Data.Acid +import Data.Monoid +import Data.Text (unpack) +import Servant.Server +import Servant.Server.Auth.Token.Acid as A +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Model + +import Config +import DB + +-- | Server private environment +data ServerEnv = ServerEnv { + -- | Configuration used to create the server + envConfig :: !ServerConfig + -- | Configuration of auth server +, envAuthConfig :: !AuthConfig + -- | DB state +, envDB :: !(AcidState DB) +} + +-- | Create new server environment +newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv +newServerEnv cfg = do + let authConfig = defaultAuthConfig + db <- liftIO $ openLocalStateFrom (unpack $ serverDbPath cfg) newDB + -- ensure default admin if missing one + _ <- runAcidBackendT authConfig db $ ensureAdmin 17 "admin" "123456" "admin@localhost" + let env = ServerEnv { + envConfig = cfg + , envAuthConfig = authConfig + , envDB = db + } + return env + +-- | Server monad that holds internal environment +newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv + , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr) + +newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a } + +instance MonadBaseControl IO ServerM where + type StM ServerM a = StMServerM a + liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM) + restoreM = ServerM . restoreM . unStMServerM + +-- | Lift servant monad to server monad +liftHandler :: Handler a -> ServerM a +liftHandler = ServerM . lift . lift + +-- | Execution of 'ServerM' +runServerM :: ServerEnv -> ServerM a -> Handler a +runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM + +-- | Execution of 'ServerM' in IO monad +runServerMIO :: ServerEnv -> ServerM a -> IO a +runServerMIO env m = do + ea <- runExceptT $ runServerM env m + case ea of + Left e -> fail $ "runServerMIO: " <> show e + Right a -> return a + +-- | Transformation to Servant 'Handler' +serverMtoHandler :: ServerEnv -> ServerM :~> Handler +serverMtoHandler e = Nat (runServerM e) + +-- Derive HasStorage for 'AcidBackendT' with your 'DB' +deriveAcidHasStorage ''DB + +-- | Special monad for authorisation actions +newtype AuthM a = AuthM { unAuthM :: AcidBackendT DB IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage) + +-- | Execution of authorisation actions that require 'AuthHandler' context +runAuth :: AuthM a -> ServerM a +runAuth m = do + cfg <- asks envAuthConfig + db <- asks envDB + liftHandler $ ExceptT $ runAcidBackendT cfg db $ unAuthM m diff --git a/example/acid/src/Server.hs b/example/acid/src/Server.hs new file mode 100644 --- /dev/null +++ b/example/acid/src/Server.hs @@ -0,0 +1,49 @@ +module Server( + -- * Server config + ServerConfig(..) + , readConfig + -- * Server environment + , ServerEnv + , newServerEnv + -- * Execution of server + , exampleServerApp + , runExampleServer + ) where + +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Proxy +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.RequestLogger +import Servant.API.Auth.Token +import Servant.Server +import Servant.Server.Auth.Token + +import API +import Config +import Monad + +-- | Enter infinite loop of processing requests for pdf-master-server. +-- +-- Starts new Warp server with initialised threads for serving the master server. +runExampleServer :: MonadIO m => ServerConfig -> m () +runExampleServer config = liftIO $ do + env <- newServerEnv config + liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env + +-- | WAI application of server +exampleServerApp :: ServerEnv -> Application +exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl + where + apiImpl = enter (serverMtoHandler e) exampleServer + +-- | Implementation of main server API +exampleServer :: ServerT ExampleAPI ServerM +exampleServer = testEndpoint + +testEndpoint :: MToken' '["test-permission"] -> ServerM () +testEndpoint token = do + runAuth $ guardAuthToken token + $logInfo "testEndpoint" + return () diff --git a/example/persistent/LICENSE b/example/persistent/LICENSE new file mode 100644 --- /dev/null +++ b/example/persistent/LICENSE @@ -0,0 +1,30 @@ +Copyright Anton Gushcha (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of NCrashed nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/example/persistent/Setup.hs b/example/persistent/Setup.hs new file mode 100644 --- /dev/null +++ b/example/persistent/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/persistent/config.yaml b/example/persistent/config.yaml new file mode 100644 --- /dev/null +++ b/example/persistent/config.yaml @@ -0,0 +1,8 @@ +host: localhost +port: 3000 +db-host: localhost +db-port: 5432 +db-user: postgres +db-pass: "" +db-base: auth-test +db-size: 10 diff --git a/example/persistent/servant-auth-token-example-persistent.cabal b/example/persistent/servant-auth-token-example-persistent.cabal new file mode 100644 --- /dev/null +++ b/example/persistent/servant-auth-token-example-persistent.cabal @@ -0,0 +1,69 @@ +name: servant-auth-token-example-persistent +version: 0.4.0.0 +synopsis: Example server for token auth for persistent backend +description: Please see README.md +homepage: https://github.com/ncrashed/servant-auth-token#readme +license: BSD3 +license-file: LICENSE +author: NCrashed +maintainer: ncrashed@gmail.com +copyright: 2017 Anton Gushcha +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable servant-auth-token-example-persistent + hs-source-dirs: src + main-is: Main.hs + other-modules: + API + Config + Monad + Server + default-language: Haskell2010 + build-depends: + base >= 4.7 && < 5 + , aeson >= 0.11 && < 0.12 + , aeson-injector >= 1.0 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , exceptions >= 0.8 && < 0.9 + , http-types >= 0.9 && < 0.10 + , monad-control >= 1.0 && < 1.1 + , monad-logger >= 0.3 && < 0.4 + , mtl >= 2.2 && < 2.3 + , optparse-applicative >= 0.12 && < 0.13 + , persistent >= 2.6 && < 2.7 + , persistent-postgresql >= 2.6 && < 2.7 + , servant >= 0.9 && < 0.10 + , servant-auth-token >= 0.4 && < 0.5 + , servant-auth-token-api >= 0.4 && < 0.5 + , servant-auth-token-persistent >= 0.4 && < 0.5 + , servant-server >= 0.9 && < 0.10 + , text >= 1.2 && < 1.3 + , time >= 1.6 && < 1.7 + , transformers-base >= 0.4 && < 0.5 + , wai >= 3.2 && < 3.3 + , wai-extra >= 3.0 && < 3.1 + , warp >= 3.2 && < 3.3 + , yaml >= 0.8 && < 0.9 + default-extensions: + BangPatterns + DataKinds + DeriveFunctor + DeriveGeneric + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + MultiParamTypeClasses + OverloadedStrings + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TypeFamilies + TypeOperators + UndecidableInstances + + ghc-options: -threaded diff --git a/example/persistent/src/API.hs b/example/persistent/src/API.hs new file mode 100644 --- /dev/null +++ b/example/persistent/src/API.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/example/persistent/src/Config.hs @@ -0,0 +1,58 @@ +module Config( + ServerConfig(..) + , readConfig + , createPool + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Aeson +import Data.Monoid +import Data.Text +import Data.Text.Encoding +import Data.Yaml.Config + +import Database.Persist.Postgresql + +-- | Startup configuration of server +data ServerConfig = ServerConfig { + -- | Server host name + serverHost :: !Text + -- | Server port number +, serverPort :: !Int + -- | DB host +, serverDBHost :: !Text + -- | DB port +, serverDBPort :: !Int + -- | DB user +, serverDBUser :: !Text + -- | DB user password +, serverDBPass :: !Text + -- | DB database +, serverDBBase :: !Text + -- | DB pool size +, serverDBSize :: !Int +} + +instance FromJSON ServerConfig where + parseJSON (Object o) = ServerConfig + <$> o .: "host" + <*> o .: "port" + <*> o .: "db-host" + <*> o .: "db-port" + <*> o .: "db-user" + <*> o .: "db-pass" + <*> o .: "db-base" + <*> o .: "db-size" + parseJSON _ = mzero + +readConfig :: MonadIO m => FilePath -> m ServerConfig +readConfig f = liftIO $ loadYamlSettings [f] [] useEnv + +-- | Create connection pool to postgres +createPool :: ServerConfig -> IO ConnectionPool +createPool ServerConfig{..} = runStdoutLoggingT $ createPostgresqlPool constr serverDBSize + where + constr = encodeUtf8 $ "host=" <> serverDBHost <> " port=" <> (pack . show $ serverDBPort) + <> " user=" <> serverDBUser <> " password=" <> serverDBPass <> " database=" <> serverDBBase diff --git a/example/persistent/src/Main.hs b/example/persistent/src/Main.hs new file mode 100644 --- /dev/null +++ b/example/persistent/src/Main.hs @@ -0,0 +1,34 @@ +module Main where + +import Options.Applicative + +import Server + +-- | Argument line options +data Options = Options { + -- | Path to config, if not set, the app will not start + configPath :: FilePath +} + +-- | Command line parser +optionsParser :: Parser Options +optionsParser = Options + <$> strOption ( + long "conf" + <> metavar "CONFIG" + <> help "Path to configuration file" + ) + +-- | Execute server with given options +runServer :: Options -> IO () +runServer Options{..} = do + cfg <- readConfig configPath + runExampleServer cfg + +main :: IO () +main = execParser opts >>= runServer + where + opts = info (helper <*> optionsParser) + ( fullDesc + <> progDesc "Example server for servant-auth-token" + <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" ) diff --git a/example/persistent/src/Monad.hs b/example/persistent/src/Monad.hs new file mode 100644 --- /dev/null +++ b/example/persistent/src/Monad.hs @@ -0,0 +1,98 @@ +module Monad( + ServerEnv(..) + , ServerM + , newServerEnv + , runServerM + , runServerMIO + , serverMtoHandler + , AuthM(..) + , runAuth + ) where + +import Control.Monad.Base +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Except +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.Trans.Control +import Data.Monoid +import Database.Persist.Sql +import Servant.Server +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Model +import Servant.Server.Auth.Token.Persistent + +import qualified Servant.Server.Auth.Token.Persistent.Schema as S + +import Config + +-- | Server private environment +data ServerEnv = ServerEnv { + -- | Configuration used to create the server + envConfig :: !ServerConfig + -- | Configuration of auth server +, envAuthConfig :: !AuthConfig + -- | DB pool +, envPool :: !ConnectionPool +} + +-- | Create new server environment +newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv +newServerEnv cfg = do + let authConfig = defaultAuthConfig + pool <- liftIO $ do + pool <- createPool cfg + -- run migrations + flip runSqlPool pool $ runMigration S.migrateAll + -- create default admin if missing one + _ <- runPersistentBackendT authConfig pool $ ensureAdmin 17 "admin" "123456" "admin@localhost" + return pool + let env = ServerEnv { + envConfig = cfg + , envAuthConfig = authConfig + , envPool = pool + } + return env + +-- | Server monad that holds internal environment +newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv + , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr) + +newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a } + +instance MonadBaseControl IO ServerM where + type StM ServerM a = StMServerM a + liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM) + restoreM = ServerM . restoreM . unStMServerM + +-- | Lift servant monad to server monad +liftHandler :: Handler a -> ServerM a +liftHandler = ServerM . lift . lift + +-- | Execution of 'ServerM' +runServerM :: ServerEnv -> ServerM a -> Handler a +runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM + +-- | Execution of 'ServerM' in IO monad +runServerMIO :: ServerEnv -> ServerM a -> IO a +runServerMIO env m = do + ea <- runExceptT $ runServerM env m + case ea of + Left e -> fail $ "runServerMIO: " <> show e + Right a -> return a + +-- | Transformation to Servant 'Handler' +serverMtoHandler :: ServerEnv -> ServerM :~> Handler +serverMtoHandler e = Nat (runServerM e) + +-- | Special monad for authorisation actions +newtype AuthM a = AuthM { unAuthM :: PersistentBackendT IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasStorage, HasAuthConfig) + +-- | Execution of authorisation actions that require 'AuthHandler' context +runAuth :: AuthM a -> ServerM a +runAuth m = do + cfg <- asks envAuthConfig + pool <- asks envPool + liftHandler $ ExceptT $ runPersistentBackendT cfg pool $ unAuthM m diff --git a/example/persistent/src/Server.hs b/example/persistent/src/Server.hs new file mode 100644 --- /dev/null +++ b/example/persistent/src/Server.hs @@ -0,0 +1,49 @@ +module Server( + -- * Server config + ServerConfig(..) + , readConfig + -- * Server environment + , ServerEnv + , newServerEnv + -- * Execution of server + , exampleServerApp + , runExampleServer + ) where + +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Proxy +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.RequestLogger +import Servant.API.Auth.Token +import Servant.Server +import Servant.Server.Auth.Token + +import API +import Config +import Monad + +-- | Enter infinite loop of processing requests for pdf-master-server. +-- +-- Starts new Warp server with initialised threads for serving the master server. +runExampleServer :: MonadIO m => ServerConfig -> m () +runExampleServer config = liftIO $ do + env <- newServerEnv config + liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env + +-- | WAI application of server +exampleServerApp :: ServerEnv -> Application +exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl + where + apiImpl = enter (serverMtoHandler e) exampleServer + +-- | Implementation of main server API +exampleServer :: ServerT ExampleAPI ServerM +exampleServer = testEndpoint + +testEndpoint :: MToken' '["test-permission"] -> ServerM () +testEndpoint token = do + runAuth $ guardAuthToken token + $logInfo "testEndpoint" + return () diff --git a/servant-auth-token.cabal b/servant-auth-token.cabal --- a/servant-auth-token.cabal +++ b/servant-auth-token.cabal @@ -1,5 +1,5 @@ name: servant-auth-token -version: 0.3.2.0 +version: 0.4.0.0 synopsis: Servant based API and server for token based authorisation description: Please see README.md homepage: https://github.com/ncrashed/servant-auth-token#readme @@ -13,6 +13,26 @@ extra-source-files: README.md CHANGELOG.md + stack.yaml + example/acid/src/API.hs + example/acid/src/Config.hs + example/acid/src/DB.hs + example/acid/src/Main.hs + example/acid/src/Monad.hs + example/acid/src/Server.hs + example/acid/LICENSE + example/acid/Setup.hs + example/acid/config.yaml + example/acid/servant-auth-token-example-acid.cabal + example/persistent/src/API.hs + example/persistent/src/Config.hs + example/persistent/src/Main.hs + example/persistent/src/Monad.hs + example/persistent/src/Server.hs + example/persistent/LICENSE + example/persistent/Setup.hs + example/persistent/config.yaml + example/persistent/servant-auth-token-example-persistent.cabal cabal-version: >=1.10 library @@ -38,8 +58,8 @@ , persistent-postgresql >= 2.2 && < 2.7 , persistent-template >= 2.1 && < 2.7 , pwstore-fast >= 2.4 && < 2.5 - , servant-auth-token-api >= 0.3.1 && < 0.4 - , servant-server >= 0.7 && < 0.9 + , servant-auth-token-api >= 0.4 && < 0.5 + , servant-server >= 0.9 && < 0.10 , text >= 1.2 && < 1.3 , time >= 1.5 && < 1.7 , transformers >= 0.4 && < 0.6 @@ -48,10 +68,12 @@ default-language: Haskell2010 default-extensions: BangPatterns + ConstraintKinds DataKinds DeriveGeneric FlexibleContexts FlexibleInstances + FunctionalDependencies GADTs GeneralizedNewtypeDeriving KindSignatures @@ -66,3 +88,4 @@ source-repository head type: git location: https://github.com/ncrashed/servant-auth-token + 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 @@ -11,50 +11,18 @@ The module is server side implementation of "Servant.API.Auth.Token" API and intended to be used as drop in module for user servers or as external micro service. -To use the server as constituent part, you need to provide customised 'AuthConfig' for -'authServer' function and implement 'AuthMonad' instance for your handler monad. -@ -import Servant.Server.Auth.Token as Auth --- | Example of user side configuration -data Config = Config { - -- | Authorisation specific configuration - authConfig :: AuthConfig - -- other fields - -- ... -} - --- | Example of user side handler monad -newtype App a = App { - runApp :: ReaderT Config (ExceptT ServantErr IO) a - } deriving ( Functor, Applicative, Monad, MonadReader Config, - MonadError ServantErr, MonadIO) - --- | Now you can use authorisation API in your handler -instance AuthMonad App where - getAuthConfig = asks authConfig - liftAuthAction = App . lift - --- | Include auth 'migrateAll' function into your migration code -doMigrations :: SqlPersistT IO () -doMigrations = runMigrationUnsafe $ do - migrateAll -- other user migrations - Auth.migrateAll -- creation of authorisation entities - -- optional creation of default admin if db is empty - ensureAdmin 17 "admin" "123456" "admin@localhost" -@ - -Now you can use 'guardAuthToken' to check authorisation headers in endpoints of your server: +Use 'guardAuthToken' to check authorisation headers in endpoints of your server: @ -- | Read a single customer from DB customerGet :: CustomerId -- ^ Customer unique id -> MToken' '["customer-read"] -- ^ Required permissions for auth token - -> App Customer -- ^ Customer data + -> ServerM Customer -- ^ Customer data customerGet i token = do - guardAuthToken token - runDB404 "customer" $ getCustomer i + guardAuthToken token + guard404 "customer" $ getCustomer i @ -} @@ -62,10 +30,10 @@ -- * Implementation authServer -- * Server API - , migrateAll - , AuthMonad(..) + , HasStorage(..) + , AuthHandler -- * Helpers - , guardAuthToken + , guardAuthToken , ensureAdmin , authUserByToken -- * API methods @@ -91,11 +59,10 @@ , authGroupList -- * Low-level API , getAuthToken - ) where + ) where -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader +import Control.Monad +import Control.Monad.Except import Crypto.PasswordStore import Data.Aeson.Unit import Data.Aeson.WithField @@ -105,8 +72,7 @@ import Data.Time.Clock import Data.UUID import Data.UUID.V4 -import Database.Persist.Postgresql -import Servant +import Servant import Servant.API.Auth.Token import Servant.API.Auth.Token.Pagination @@ -118,41 +84,16 @@ import Servant.Server.Auth.Token.Restore import Servant.Server.Auth.Token.SingleUse -import qualified Data.ByteString.Lazy as BS - --- | This function converts our 'AuthHandler' monad into the @ExceptT ServantErr --- IO@ monad that Servant's 'enter' function needs in order to run the --- application. The ':~>' type is a natural transformation, or, in --- non-category theory terms, a function that converts two type --- constructors without looking at the values in the types. -convertAuthHandler :: AuthConfig -> AuthHandler :~> ExceptT ServantErr IO -convertAuthHandler cfg = Nat (flip runReaderT cfg . runAuthHandler) - --- | The interface your application should implement to be able to use --- token authorisation API. -class Monad m => AuthMonad m where - getAuthConfig :: m AuthConfig - liftAuthAction :: ExceptT ServantErr IO a -> m a - -instance AuthMonad AuthHandler where - getAuthConfig = getConfig - liftAuthAction = AuthHandler . lift - --- | Helper to run handler in 'AuthMonad' context -runAuth :: AuthMonad m => AuthHandler a -> m a -runAuth m = do - cfg <- getAuthConfig - let Nat conv = convertAuthHandler cfg - liftAuthAction $ conv m +import qualified Data.ByteString.Lazy as BS -- | Implementation of AuthAPI -authServer :: AuthConfig -> Server AuthAPI -authServer cfg = enter (convertAuthHandler cfg) ( +authServer :: AuthHandler m => ServerT AuthAPI m +authServer = authSignin :<|> authSigninGetCode :<|> authSigninPostCode :<|> authTouch - :<|> authToken + :<|> authToken :<|> authSignout :<|> authSignup :<|> authUsersInfo @@ -162,65 +103,65 @@ :<|> authUserDelete :<|> authRestore :<|> authGetSingleUseCodes - :<|> authGroupGet + :<|> authGroupGet :<|> authGroupPost - :<|> authGroupPut + :<|> authGroupPut :<|> authGroupPatch :<|> authGroupDelete - :<|> authGroupList) + :<|> authGroupList -- | Implementation of "signin" method -authSignin :: AuthMonad m +authSignin :: AuthHandler m => Maybe Login -- ^ Login query parameter -> Maybe Password -- ^ Password query parameter -> Maybe Seconds -- ^ Expire query parameter, how many seconds the token is valid -> m (OnlyField "token" SimpleToken) -- ^ If everything is OK, return token -authSignin mlogin mpass mexpire = runAuth $ do - login <- require "login" mlogin - pass <- require "pass" mpass - Entity uid UserImpl{..} <- guardLogin login pass +authSignin mlogin mpass mexpire = do + login <- require "login" mlogin + pass <- require "pass" mpass + WithField uid UserImpl{..} <- guardLogin login pass OnlyField <$> getAuthToken uid mexpire - where + where guardLogin login pass = do -- check login and password, return passed user - muser <- runDB $ selectFirst [UserImplLogin ==. login] [] + muser <- getUserImplByLogin login let err = throw401 "Cannot find user with given combination of login and pass" - case muser of + case muser of Nothing -> err - Just user@(Entity _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword + Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword then return user else err -- | Helper to get or generate new token for user -getAuthToken :: AuthMonad m +getAuthToken :: AuthHandler m => UserImplId -- ^ User for whom we want token -> Maybe Seconds -- ^ Expiration duration, 'Nothing' means default -> m SimpleToken -- ^ Old token (if it doesn't expire) or new one -getAuthToken uid mexpire = runAuth $ do +getAuthToken uid mexpire = do expire <- calcExpire mexpire mt <- getExistingToken -- check whether there is already existing token - case mt of + case mt of Nothing -> createToken expire -- create new token Just t -> touchToken t expire -- prolong token expiration time where getExistingToken = do -- return active token for specified user id - t <- liftIO getCurrentTime - runDB $ selectFirst [AuthTokenUser ==. uid, AuthTokenExpire >. t] [] + t <- liftIO getCurrentTime + findAuthToken uid t - createToken expire = do -- generate and save fresh token + createToken expire = do -- generate and save fresh token token <- toText <$> liftIO nextRandom - _ <- runDB $ insert AuthToken { - authTokenValue = token - , authTokenUser = uid - , authTokenExpire = expire + _ <- insertAuthToken AuthToken { + authTokenValue = token + , authTokenUser = uid + , authTokenExpire = expire } - return token + return token -- | Authorisation via code of single usage. -- -- Implementation of 'AuthSigninGetCodeMethod' endpoint. -- -- Logic of authorisation via this method is: --- +-- -- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint -- -- * Server generates single use token and sends it via @@ -241,26 +182,26 @@ -- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. -- -- See also: 'authSigninPostCode' -authSigninGetCode :: AuthMonad m +authSigninGetCode :: AuthHandler m => Maybe Login -- ^ User login, required - -> m Unit -authSigninGetCode mlogin = runAuth $ do - login <- require "login" mlogin - uinfo <- runDB404 "user" $ readUserInfoByLogin login - let uid = toKey $ respUserId uinfo + -> m Unit +authSigninGetCode mlogin = do + login <- require "login" mlogin + uinfo <- guard404 "user" $ readUserInfoByLogin login + let uid = toKey $ respUserId uinfo AuthConfig{..} <- getConfig - code <- liftIO singleUseCodeGenerator + code <- liftIO singleUseCodeGenerator expire <- makeSingleUseExpire singleUseCodeExpire - runDB $ registerSingleUseCode uid code (Just expire) - liftIO $ singleUseCodeSender uinfo code + registerSingleUseCode uid code (Just expire) + liftIO $ singleUseCodeSender uinfo code - return Unit + return Unit -- | Authorisation via code of single usage. -- -- Logic of authorisation via this method is: --- +-- -- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint -- -- * Server generates single use token and sends it via @@ -281,328 +222,319 @@ -- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. -- -- See also: 'authSigninGetCode' -authSigninPostCode :: AuthMonad m +authSigninPostCode :: AuthHandler m => Maybe Login -- ^ User login, required -> Maybe SingleUseCode -- ^ Received single usage code, required - -> Maybe Seconds - -- ^ Time interval after which the token expires, 'Nothing' means + -> Maybe Seconds + -- ^ Time interval after which the token expires, 'Nothing' means -- some default value -> m (OnlyField "token" SimpleToken) -authSigninPostCode mlogin mcode mexpire = runAuth $ do - login <- require "login" mlogin +authSigninPostCode mlogin mcode mexpire = do + login <- require "login" mlogin code <- require "code" mcode - uinfo <- runDB404 "user" $ readUserInfoByLogin login - let uid = toKey $ respUserId uinfo - isValid <- runDB $ validateSingleUseCode uid code + uinfo <- guard404 "user" $ readUserInfoByLogin login + let uid = toKey $ respUserId uinfo + isValid <- validateSingleUseCode uid code unless isValid $ throw401 "Single usage code doesn't match" OnlyField <$> getAuthToken uid mexpire -- | Calculate expiration timestamp for token -calcExpire :: Maybe Seconds -> AuthHandler UTCTime -calcExpire mexpire = do +calcExpire :: AuthHandler m => Maybe Seconds -> m UTCTime +calcExpire mexpire = do t <- liftIO getCurrentTime AuthConfig{..} <- getConfig - let requestedExpire = maybe defaultExpire fromIntegral mexpire + let requestedExpire = maybe defaultExpire fromIntegral mexpire let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire return $ boundedExpire `addUTCTime` t -- prolong token with new timestamp -touchToken :: Entity AuthToken -> UTCTime -> AuthHandler SimpleToken -touchToken (Entity tid tok) expire = do - runDB $ replace tid tok { - authTokenExpire = expire +touchToken :: AuthHandler m => WithId AuthTokenId AuthToken -> UTCTime -> m SimpleToken +touchToken (WithField tid tok) expire = do + replaceAuthToken tid tok { + authTokenExpire = expire } return $ authTokenValue tok -- | Implementation of "touch" method -authTouch :: AuthMonad m +authTouch :: AuthHandler m => Maybe Seconds -- ^ Expire query parameter, how many seconds the token should be valid by now. 'Nothing' means default value defined in server config. - -> MToken '[] -- ^ Authorisation header with token + -> MToken '[] -- ^ Authorisation header with token -> m Unit -authTouch mexpire token = runAuth $ do - Entity i mt <- guardAuthToken' (fmap unToken token) [] +authTouch mexpire token = do + WithField i mt <- guardAuthToken' (fmap unToken token) [] expire <- calcExpire mexpire - runDB $ replace i mt { authTokenExpire = expire } - return Unit + replaceAuthToken i mt { authTokenExpire = expire } + return Unit --- | Implementation of "token" method, return +-- | Implementation of "token" method, return -- info about user binded to the token -authToken :: AuthMonad m - => MToken '[] -- ^ Authorisation header with token - -> m RespUserInfo -authToken token = runAuth $ do +authToken :: AuthHandler m + => MToken '[] -- ^ Authorisation header with token + -> m RespUserInfo +authToken token = do i <- authUserByToken token - runDB404 "user" . readUserInfo . fromKey $ i + guard404 "user" . readUserInfo . fromKey $ i -- | Getting user id by token -authUserByToken :: AuthMonad m => MToken '[] -> m UserImplId -authUserByToken token = runAuth $ do - Entity _ mt <- guardAuthToken' (fmap unToken token) [] - return $ authTokenUser mt +authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId +authUserByToken token = do + WithField _ mt <- guardAuthToken' (fmap unToken token) [] + return $ authTokenUser mt -- | Implementation of "signout" method -authSignout :: AuthMonad m - => Maybe (Token '[]) -- ^ Authorisation header with token +authSignout :: AuthHandler m + => Maybe (Token '[]) -- ^ Authorisation header with token -> m Unit -authSignout token = runAuth $ do - Entity i mt <- guardAuthToken' (fmap unToken token) [] +authSignout token = do + WithField i mt <- guardAuthToken' (fmap unToken token) [] expire <- liftIO getCurrentTime - runDB $ replace i mt { authTokenExpire = expire } - return Unit - + replaceAuthToken i mt { authTokenExpire = expire } + return Unit + -- | Checks given password and if it is invalid in terms of config -- password validator, throws 400 error. -guardPassword :: Password -> AuthHandler () -guardPassword p = do +guardPassword :: AuthHandler m => Password -> m () +guardPassword p = do AuthConfig{..} <- getConfig whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8 -- | Implementation of "signup" method -authSignup :: AuthMonad m +authSignup :: AuthHandler m => ReqRegister -- ^ Registration info - -> MToken' '["auth-register"] -- ^ Authorisation header with token + -> MToken' '["auth-register"] -- ^ Authorisation header with token -> m (OnlyField "user" UserId) -authSignup ReqRegister{..} token = runAuth $ do +authSignup ReqRegister{..} token = do guardAuthToken token guardUserInfo guardPassword reqRegPassword strength <- getsConfig passwordsStrength - i <- runDB $ do - i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions - whenJust reqRegGroups $ setUserGroups i - return i - return $ OnlyField . fromKey $ i - where - guardUserInfo = do - c <- runDB $ count [UserImplLogin ==. reqRegLogin] - when (c > 0) $ throw400 "User with specified id is already registered" + i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions + whenJust reqRegGroups $ setUserGroups i + return $ OnlyField . fromKey $ i + where + guardUserInfo = do + mu <- getUserImplByLogin reqRegLogin + whenJust mu $ const $ throw400 "User with specified id is already registered" -- | Implementation of get "users" method -authUsersInfo :: AuthMonad m +authUsersInfo :: AuthHandler m => Maybe Page -- ^ Page num parameter -> Maybe PageSize -- ^ Page size parameter -> MToken' '["auth-info"] -- ^ Authorisation header with token -> m RespUsersInfo -authUsersInfo mp msize token = runAuth $ do +authUsersInfo mp msize token = do guardAuthToken token - pagination mp msize $ \page size -> do - (users, total) <- runDB $ (,) - <$> (do - users <- selectList [] [Asc UserImplId, OffsetBy (fromIntegral $ page * size), LimitTo (fromIntegral size)] - perms <- mapM (getUserPermissions . entityKey) users - groups <- mapM (getUserGroups . entityKey) users - return $ zip3 users perms groups) - <*> count ([] :: [Filter UserImpl]) + pagination mp msize $ \page size -> do + (users', total) <- listUsersPaged page size + perms <- mapM (getUserPermissions . (\(WithField i _) -> i)) users' + groups <- mapM (getUserGroups . (\(WithField i _) -> i)) users' + let users = zip3 users' perms groups return RespUsersInfo { - respUsersItems = (\(user, perms, groups) -> userToUserInfo user perms groups) <$> users + respUsersItems = (\(user, ps, grs) -> userToUserInfo user ps grs) <$> users , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size } -- | Implementation of get "user" method -authUserInfo :: AuthMonad m - => UserId -- ^ User id +authUserInfo :: AuthHandler m + => UserId -- ^ User id -> MToken' '["auth-info"] -- ^ Authorisation header with token -> m RespUserInfo -authUserInfo uid' token = runAuth $ do +authUserInfo uid' token = do guardAuthToken token - runDB404 "user" $ readUserInfo uid' + guard404 "user" $ readUserInfo uid' -- | Implementation of patch "user" method -authUserPatch :: AuthMonad m - => UserId -- ^ User id +authUserPatch :: AuthHandler m + => UserId -- ^ User id -> PatchUser -- ^ JSON with fields for patching -> MToken' '["auth-update"] -- ^ Authorisation header with token -> m Unit -authUserPatch uid' body token = runAuth $ do +authUserPatch uid' body token = do guardAuthToken token - whenJust (patchUserPassword body) guardPassword - let uid = toSqlKey . fromIntegral $ uid' - user <- guardUser uid + whenJust (patchUserPassword body) guardPassword + let uid = toKey uid' + user <- guardUser uid strength <- getsConfig passwordsStrength - Entity _ user' <- runDB $ patchUser strength body $ Entity uid user - runDB $ replace uid user' + WithField _ user' <- patchUser strength body $ WithField uid user + replaceUserImpl uid user' return Unit -- | Implementation of put "user" method -authUserPut :: AuthMonad m - => UserId -- ^ User id +authUserPut :: AuthHandler m + => UserId -- ^ User id -> ReqRegister -- ^ New user -> MToken' '["auth-update"] -- ^ Authorisation header with token -> m Unit -authUserPut uid' ReqRegister{..} token = runAuth $ do +authUserPut uid' ReqRegister{..} token = do guardAuthToken token guardPassword reqRegPassword - let uid = toSqlKey . fromIntegral $ uid' + let uid = toKey uid' let user = UserImpl { userImplLogin = reqRegLogin , userImplPassword = "" , userImplEmail = reqRegEmail } - user' <- setUserPassword reqRegPassword user - runDB $ do - replace uid user' - setUserPermissions uid reqRegPermissions - whenJust reqRegGroups $ setUserGroups uid - return Unit + user' <- setUserPassword reqRegPassword user + replaceUserImpl uid user' + setUserPermissions uid reqRegPermissions + whenJust reqRegGroups $ setUserGroups uid + return Unit -- | Implementation of patch "user" method -authUserDelete :: AuthMonad m - => UserId -- ^ User id +authUserDelete :: AuthHandler m + => UserId -- ^ User id -> MToken' '["auth-delete"] -- ^ Authorisation header with token -> m Unit -authUserDelete uid' token = runAuth $ do +authUserDelete uid' token = do guardAuthToken token - runDB $ deleteCascade (toKey uid' :: UserImplId) - return Unit + deleteUserImpl $ toKey uid' + return Unit -- Generate new password for user. There is two phases, first, the method -- is called without 'code' parameter. The system sends email with a restore code --- to email. After that a call of the method with the code is needed to +-- to email. After that a call of the method with the code is needed to -- change password. Need configured SMTP server. -authRestore :: AuthMonad m - => UserId -- ^ User id +authRestore :: AuthHandler m + => UserId -- ^ User id -> Maybe RestoreCode -> Maybe Password -> m Unit -authRestore uid' mcode mpass = runAuth $ do +authRestore uid' mcode mpass = do let uid = toKey uid' - user <- guardUser uid - case mcode of - Nothing -> do + user <- guardUser uid + case mcode of + Nothing -> do dt <- getsConfig restoreExpire t <- liftIO getCurrentTime AuthConfig{..} <- getConfig - rc <- runDB $ getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t - uinfo <- runDB404 "user" $ readUserInfo uid' - sendRestoreCode uinfo rc - Just code -> do + rc <- getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t + uinfo <- guard404 "user" $ readUserInfo uid' + sendRestoreCode uinfo rc + Just code -> do pass <- require "password" mpass guardPassword pass guardRestoreCode uid code user' <- setUserPassword pass user - runDB $ replace uid user' - return Unit + replaceUserImpl uid user' + return Unit -- | Implementation of 'AuthGetSingleUseCodes' endpoint. -authGetSingleUseCodes :: AuthMonad m +authGetSingleUseCodes :: AuthHandler m => UserId -- ^ Id of user -> Maybe Word -- ^ Number of codes. 'Nothing' means that server generates some default count of codes. -- And server can define maximum count of codes that user can have at once. -> MToken' '["auth-single-codes"] -> m (OnlyField "codes" [SingleUseCode]) -authGetSingleUseCodes uid mcount token = runAuth $ do - guardAuthToken token +authGetSingleUseCodes uid mcount token = do + guardAuthToken token let uid' = toKey uid - _ <- runDB404 "user" $ readUserInfo uid - AuthConfig{..} <- getConfig - let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount - runDB $ OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n + _ <- guard404 "user" $ readUserInfo uid + AuthConfig{..} <- getConfig + let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount + OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n -- | Getting user by id, throw 404 response if not found -guardUser :: UserImplId -> AuthHandler UserImpl -guardUser uid = do - muser <- runDB $ get uid - case muser of +guardUser :: AuthHandler m => UserImplId -> m UserImpl +guardUser uid = do + muser <- getUserImpl uid + case muser of Nothing -> throw404 "User not found" - Just user -> return user + Just user -> return user -- | If the token is missing or the user of the token -- doesn't have needed permissions, throw 401 response -guardAuthToken :: forall perms m . (PermsList perms, AuthMonad m) => MToken perms -> m () -guardAuthToken mt = runAuth $ void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms) +guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m () +guardAuthToken mt = void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms) -- | Same as `guardAuthToken` but returns record about the token -guardAuthToken' :: Maybe SimpleToken -> [Permission] -> AuthHandler (Entity AuthToken) +guardAuthToken' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken) guardAuthToken' Nothing _ = throw401 "Token required" -guardAuthToken' (Just token) perms = do +guardAuthToken' (Just token) perms = do t <- liftIO getCurrentTime - mt <- runDB $ selectFirst [AuthTokenValue ==. token] [] - case mt of + mt <- findAuthTokenByValue token + case mt of Nothing -> throw401 "Token is not valid" - Just et@(Entity _ AuthToken{..}) -> do + Just et@(WithField _ AuthToken{..}) -> do when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" } - mu <- runDB $ get authTokenUser - case mu of + mu <- getUserImpl authTokenUser + case mu of Nothing -> throw500 "User of the token doesn't exist" Just UserImpl{..} -> do - isAdmin <- runDB $ hasPerm authTokenUser adminPerm - hasAllPerms <- runDB $ hasPerms authTokenUser perms + isAdmin <- hasPerm authTokenUser adminPerm + hasAllPerms <- hasPerms authTokenUser perms unless (isAdmin || hasAllPerms) $ throw401 $ "User doesn't have all required permissions: " <> showb perms return et -- | Rehash password for user -setUserPassword :: Password -> UserImpl -> AuthHandler UserImpl -setUserPassword pass user = do - strength <- getsConfig passwordsStrength - setUserPassword' strength pass user +setUserPassword :: AuthHandler m => Password -> UserImpl -> m UserImpl +setUserPassword pass user = do + strength <- getsConfig passwordsStrength + setUserPassword' strength pass user -- | Getting info about user group, requires 'authInfoPerm' for token -authGroupGet :: AuthMonad m +authGroupGet :: AuthHandler m => UserGroupId -> MToken' '["auth-info"] -- ^ Authorisation header with token -> m UserGroup -authGroupGet i token = runAuth $ do +authGroupGet i token = do guardAuthToken token - runDB404 "user group" $ readUserGroup i + guard404 "user group" $ readUserGroup i -- | Inserting new user group, requires 'authUpdatePerm' for token -authGroupPost :: AuthMonad m +authGroupPost :: AuthHandler m => UserGroup -> MToken' '["auth-update"] -- ^ Authorisation header with token -> m (OnlyId UserGroupId) -authGroupPost ug token = runAuth $ do +authGroupPost ug token = do guardAuthToken token - runDB $ OnlyField <$> insertUserGroup ug + OnlyField <$> insertUserGroup ug -- | Replace info about given user group, requires 'authUpdatePerm' for token -authGroupPut :: AuthMonad m +authGroupPut :: AuthHandler m => UserGroupId -> UserGroup -> MToken' '["auth-update"] -- ^ Authorisation header with token -> m Unit -authGroupPut i ug token = runAuth $ do +authGroupPut i ug token = do guardAuthToken token - runDB $ updateUserGroup i ug + updateUserGroup i ug return Unit -- | Patch info about given user group, requires 'authUpdatePerm' for token -authGroupPatch :: AuthMonad m +authGroupPatch :: AuthHandler m => UserGroupId -> PatchUserGroup -> MToken' '["auth-update"] -- ^ Authorisation header with token -> m Unit -authGroupPatch i up token = runAuth $ do +authGroupPatch i up token = do guardAuthToken token - runDB $ patchUserGroup i up - return Unit + patchUserGroup i up + return Unit -- | Delete all info about given user group, requires 'authDeletePerm' for token -authGroupDelete :: AuthMonad m +authGroupDelete :: AuthHandler m => UserGroupId -> MToken' '["auth-delete"] -- ^ Authorisation header with token -> m Unit -authGroupDelete i token = runAuth $ do +authGroupDelete i token = do guardAuthToken token - runDB $ deleteUserGroup i - return Unit + deleteUserGroup i + return Unit --- | Get list of user groups, requires 'authInfoPerm' for token -authGroupList :: AuthMonad m +-- | Get list of user groups, requires 'authInfoPerm' for token +authGroupList :: AuthHandler m => Maybe Page -> Maybe PageSize -> MToken' '["auth-info"] -- ^ Authorisation header with token -> m (PagedList UserGroupId UserGroup) -authGroupList mp msize token = runAuth $ do +authGroupList mp msize token = do guardAuthToken token - pagination mp msize $ \page size -> do - (groups, total) <- runDB $ (,) - <$> (do - is <- selectKeysList [] [Asc AuthUserGroupId, OffsetBy (fromIntegral $ page * size), LimitTo (fromIntegral size)] - forM is $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey) - <*> count ([] :: [Filter AuthUserGroup]) + pagination mp msize $ \page size -> do + (groups', total) <- listGroupsPaged page size + groups <- forM groups' $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey . (\(WithField i _) -> i) return PagedList { pagedListItems = catMaybes groups , pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size 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,43 +1,38 @@ {-| Module : Servant.Server.Auth.Token.Common Description : Internal utilities -Copyright : (c) Anton Gushcha, 2016 +Copyright : (c) Anton Gushcha, 2016-2017 License : MIT Maintainer : ncrashed@gmail.com Stability : experimental Portability : Portable -} -module Servant.Server.Auth.Token.Common where - -import Database.Persist.Sql +module Servant.Server.Auth.Token.Common where -import qualified Data.Text as T -import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Text as T +import qualified Data.ByteString.Lazy.Char8 as BSL -- | Helper to print a value to lazy bytestring showb :: Show a => a -> BSL.ByteString showb = BSL.pack . show -- | Helper to print a value to text -showt :: Show a => a -> T.Text -showt = T.pack . show +showt :: Show a => a -> T.Text +showt = T.pack . show -- | Do something when first value is 'Nothing' whenNothing :: Applicative m => Maybe a -> m () -> m () -whenNothing Nothing m = m +whenNothing Nothing m = m whenNothing (Just _) _ = pure () -- | Do something when first value is 'Just' whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust Nothing _ = pure () -whenJust (Just x) m = m x +whenJust (Just x) m = m x --- | Shortcut to convert sql key -fromKey :: (Integral a, ToBackendKey SqlBackend record) - => Key record -> a -fromKey = fromIntegral . fromSqlKey +class ConvertableKey a where + -- | Shortcut to convert sql key + fromKey :: Integral b => a -> b --- | Shortcut to convert sql key -toKey :: (Integral a, ToBackendKey SqlBackend record) - => a -> Key record -toKey = toSqlKey . fromIntegral + -- | Shortcut to convert sql key + toKey :: Integral b => b -> a 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 @@ -9,26 +9,28 @@ -} module Servant.Server.Auth.Token.Config( AuthConfig(..) + , HasAuthConfig(..) , defaultAuthConfig - ) where + ) where -import Control.Monad.IO.Class +import Control.Monad.IO.Class import Data.Text (Text) -import Data.Time +import Data.Time import Data.UUID import Data.UUID.V4 -import Database.Persist.Sql -import Servant.Server +import Servant.Server -import Servant.API.Auth.Token +import Servant.API.Auth.Token +-- | Monad that can read an auth config +class Monad m => HasAuthConfig m where + getAuthConfig :: m AuthConfig + -- | Configuration specific for authorisation system data AuthConfig = AuthConfig { - -- | Get database connection pool - getPool :: ConnectionPool -- | For authorisation, defines amounts of seconds -- when token becomes invalid. - , defaultExpire :: !NominalDiffTime + defaultExpire :: !NominalDiffTime -- | For password restore, defines amounts of seconds -- when restore code becomes invalid. , restoreExpire :: !NominalDiffTime @@ -44,12 +46,12 @@ , maximumExpire :: !(Maybe NominalDiffTime) -- | For authorisation, defines amount of hashing -- of new user passwords (should be greater or equal 14). - -- The passwords hashed 2^strength times. It is needed to + -- The passwords hashed 2^strength times. It is needed to -- prevent almost all kinds of brute force attacks, rainbow -- tables and dictionary attacks. , passwordsStrength :: !Int -- | Validates user password at registration / password change. - -- + -- -- If the function returns 'Just', then a 400 error is raised with -- specified text. -- @@ -58,9 +60,9 @@ -- | Transformation of errors produced by the auth server , servantErrorFormer :: !(ServantErr -> ServantErr) -- | Default size of page for pagination - , defaultPageSize :: !Word + , defaultPageSize :: !Word -- | User specified method of sending single usage code for authorisation. - -- + -- -- See also: endpoints 'AuthSigninGetCodeMethod' and 'AuthSigninPostCodeMethod'. -- -- By default does nothing. @@ -69,26 +71,25 @@ -- -- By default 1 hour. , singleUseCodeExpire :: !NominalDiffTime - -- | User specified generator for single use codes. + -- | User specified generator for single use codes. -- -- By default the server generates UUID that can be unacceptable for SMS way of sending. , singleUseCodeGenerator :: !(IO SingleUseCode) -- | Number of not expiring single use codes that user can have at once. -- -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 100. - , singleUseCodePermamentMaximum :: !Word - -- | Number of not expiring single use codes that generated by default when client doesn't + , singleUseCodePermamentMaximum :: !Word + -- | Number of not expiring single use codes that generated by default when client doesn't -- specify the value. -- -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 20. - , singleUseCodeDefaultCount :: !Word + , singleUseCodeDefaultCount :: !Word } -- | Default configuration for authorisation server -defaultAuthConfig :: ConnectionPool -> AuthConfig -defaultAuthConfig pool = AuthConfig { - getPool = pool - , defaultExpire = fromIntegral (600 :: Int) +defaultAuthConfig :: AuthConfig +defaultAuthConfig = AuthConfig { + defaultExpire = fromIntegral (600 :: Int) , restoreExpire = fromIntegral (3*24*3600 :: Int) -- 3 days , restoreCodeSender = const $ const $ return () , restoreCodeGenerator = uuidCodeGenerate 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 @@ -14,24 +14,23 @@ , throw404 , throw409 , throw500 - ) where + ) where import Control.Monad.Except -import Control.Monad.Reader.Class import Servant.Server import Servant.Server.Auth.Token.Config -import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy as BS -- | Prepare error response -makeBody :: MonadReader AuthConfig m => ServantErr -> m ServantErr +makeBody :: HasAuthConfig m => ServantErr -> m ServantErr makeBody e = do - f <- asks servantErrorFormer + f <- fmap servantErrorFormer getAuthConfig return $ f e -- | Wrappers to throw corresponding servant errors -throw400, throw401, throw404, throw409, throw500 - :: (MonadError ServantErr m, MonadReader AuthConfig m) +throw400, throw401, throw404, throw409, throw500 + :: (MonadError ServantErr m, HasAuthConfig m) => BS.ByteString -> m a throw400 t = throwError =<< makeBody err400 { errBody = t } throw401 t = throwError =<< makeBody err401 { errBody = t } 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 @@ -18,7 +18,6 @@ , AuthUserGroup(..) , AuthUserGroupUsers(..) , AuthUserGroupPerms(..) - , EntityField(..) , UserSingleUseCode(..) -- * IDs of entities , UserImplId @@ -29,9 +28,9 @@ , AuthUserGroupUsersId , AuthUserGroupPermsId , UserSingleUseCodeId + -- * DB interface + , HasStorage(..) -- * Operations - , runDB - , migrateAll , passToByteString , byteStringToPass -- ** User @@ -41,7 +40,6 @@ , getUserPermissions , setUserPermissions , createUser - , hasPerm , hasPerms , createAdmin , ensureAdmin @@ -60,87 +58,243 @@ , updateUserGroup , deleteUserGroup , patchUserGroup - ) where + ) where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Reader +import Control.Monad +import Control.Monad.IO.Class import Crypto.PasswordStore +import Data.Aeson.WithField +import Data.Int import Data.Maybe import Data.Monoid import Data.Text (Text) import Data.Time -import Database.Persist.Postgresql -import Database.Persist.TH import GHC.Generics -import qualified Data.ByteString as BS -import qualified Data.Foldable as F -import qualified Data.List as L -import qualified Data.Sequence as S -import qualified Data.Text.Encoding as TE +import qualified Data.ByteString as BS +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.Sequence as S +import qualified Data.Text.Encoding as TE import Servant.API.Auth.Token -import Servant.Server.Auth.Token.Common -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Patch +import Servant.API.Auth.Token.Pagination +import Servant.Server.Auth.Token.Common +import Servant.Server.Auth.Token.Patch -share [mkPersist sqlSettings - , mkDeleteCascade sqlSettings - , mkMigrate "migrateAll"] [persistLowerCase| -UserImpl - login Login - password Password -- encrypted with salt - email Email - UniqueLogin login - deriving Generic Show +-- | ID of user +newtype UserImplId = UserImplId { unUserImplId :: Int64 } + deriving (Generic, Show, Eq, Ord) -UserPerm - user UserImplId - permission Permission - deriving Generic Show +instance ConvertableKey UserImplId where + toKey = UserImplId . fromIntegral + fromKey = fromIntegral . unUserImplId + {-# INLINE toKey #-} + {-# INLINE fromKey #-} -AuthToken - value SimpleToken - user UserImplId - expire UTCTime - deriving Generic Show +-- | Internal user implementation +data UserImpl = UserImpl { + userImplLogin :: !Login -- ^ Unique user login +, userImplPassword :: !Password -- ^ Password encrypted with salt +, userImplEmail :: !Email -- ^ User email +} deriving (Generic, Show) -UserRestore - value RestoreCode - user UserImplId - expire UTCTime - deriving Generic Show +-- | ID of user permission +newtype UserPermId = UserPermId { unUserPermId :: Int64 } + deriving (Generic, Show, Eq, Ord) -UserSingleUseCode - value SingleUseCode - user UserImplId - expire UTCTime Maybe -- Nothing is code that never expires - used UTCTime Maybe - deriving Generic Show +instance ConvertableKey UserPermId where + toKey = UserPermId . fromIntegral + fromKey = fromIntegral . unUserPermId + {-# INLINE toKey #-} + {-# INLINE fromKey #-} -AuthUserGroup - name Text - parent AuthUserGroupId Maybe - deriving Generic Show +-- | Internal implementation of permission (1-M) +data UserPerm = UserPerm { + userPermUser :: !UserImplId -- ^ Reference to user +, userPermPermission :: !Permission -- ^ Permission tag +} deriving (Generic, Show) -AuthUserGroupUsers - group AuthUserGroupId - user UserImplId - deriving Generic Show +-- | ID of authorisation token +newtype AuthTokenId = AuthTokenId { unAuthTokenId :: Int64 } + deriving (Generic, Show, Eq, Ord) -AuthUserGroupPerms - group AuthUserGroupId - permission Permission - deriving Generic Show -|] +instance ConvertableKey AuthTokenId where + toKey = AuthTokenId . fromIntegral + fromKey = fromIntegral . unAuthTokenId + {-# INLINE toKey #-} + {-# INLINE fromKey #-} --- | Execute database transaction -runDB :: (MonadReader AuthConfig m, MonadIO m) => SqlPersistT IO b -> m b -runDB query = do - pool <- asks getPool - liftIO $ runSqlPool query pool +-- | Internal implementation of authorisation token +data AuthToken = AuthToken { + authTokenValue :: !SimpleToken -- ^ Value of token +, authTokenUser :: !UserImplId -- ^ Reference to user of the token +, authTokenExpire :: !UTCTime -- ^ When the token expires +} deriving (Generic, Show) +-- | ID of restoration code +newtype UserRestoreId = UserRestoreId { unUserRestoreId :: Int64 } + deriving (Generic, Show, Eq, Ord) + +instance ConvertableKey UserRestoreId where + toKey = UserRestoreId . fromIntegral + fromKey = fromIntegral . unUserRestoreId + {-# INLINE toKey #-} + {-# INLINE fromKey #-} + +-- | Internal implementation of restoration code +data UserRestore = UserRestore { + userRestoreValue :: !RestoreCode -- ^ Code value +, userRestoreUser :: !UserImplId -- ^ Reference to user that the code restores +, userRestoreExpire :: !UTCTime -- ^ When the code expires +} deriving (Generic, Show) + +-- | ID of single use code +newtype UserSingleUseCodeId = UserSingleUseCodeId { unUserSingleUseCodeId :: Int64 } + deriving (Generic, Show, Eq, Ord) + +instance ConvertableKey UserSingleUseCodeId where + toKey = UserSingleUseCodeId . fromIntegral + fromKey = fromIntegral . unUserSingleUseCodeId + {-# INLINE toKey #-} + {-# INLINE fromKey #-} + +-- | Internal implementation of single use code +data UserSingleUseCode = UserSingleUseCode { + userSingleUseCodeValue :: !SingleUseCode -- ^ Value of single use code +, userSingleUseCodeUser :: !UserImplId -- ^ Reference to user the code is owned by +, userSingleUseCodeExpire :: !(Maybe UTCTime) -- ^ When the code expires, 'Nothing' is code that never expires +, userSingleUseCodeUsed :: !(Maybe UTCTime) -- ^ When the code was used +} deriving (Generic, Show) + +-- | ID of user group +newtype AuthUserGroupId = AuthUserGroupId { unAuthUserGroupId :: Int64 } + deriving (Generic, Show, Eq, Ord) + +instance ConvertableKey AuthUserGroupId where + toKey = AuthUserGroupId . fromIntegral + fromKey = fromIntegral . unAuthUserGroupId + {-# INLINE toKey #-} + {-# INLINE fromKey #-} + +-- | Internal implementation of user group +data AuthUserGroup = AuthUserGroup { + authUserGroupName :: !Text -- ^ Name of group +, authUserGroupParent :: !(Maybe AuthUserGroupId) -- ^ Can be a child of another group +} deriving (Generic, Show) + +-- | ID of user-group binding +newtype AuthUserGroupUsersId = AuthUserGroupUsersId { unAuthUserGroupUsersId :: Int64 } + deriving (Generic, Show, Eq, Ord) + +instance ConvertableKey AuthUserGroupUsersId where + toKey = AuthUserGroupUsersId . fromIntegral + fromKey = fromIntegral . unAuthUserGroupUsersId + {-# INLINE toKey #-} + {-# INLINE fromKey #-} + +-- | Implementation of M-M between user and group +data AuthUserGroupUsers = AuthUserGroupUsers { + authUserGroupUsersGroup :: !AuthUserGroupId +, authUserGroupUsersUser :: !UserImplId +} deriving (Generic, Show) + +-- | ID of permission-group binding +newtype AuthUserGroupPermsId = AuthUserGroupPermsId { unAuthUserGroupPermsId :: Int64 } + deriving (Generic, Show, Eq, Ord) + +instance ConvertableKey AuthUserGroupPermsId where + toKey = AuthUserGroupPermsId . fromIntegral + fromKey = fromIntegral . unAuthUserGroupPermsId + {-# INLINE toKey #-} + {-# INLINE fromKey #-} + +-- | Implementation of M-M between permission and group +data AuthUserGroupPerms = AuthUserGroupPerms { + authUserGroupPermsGroup :: AuthUserGroupId +, authUserGroupPermsPermission :: Permission +} deriving (Generic, Show) + +-- | Abstract storage interface. External libraries can implement this in terms +-- of PostgreSQL or acid-state. +class MonadIO m => HasStorage m where + -- | Getting user from storage + getUserImpl :: UserImplId -> m (Maybe UserImpl) + -- | Getting user from storage by login + getUserImplByLogin :: Login -> m (Maybe (WithId UserImplId UserImpl)) + -- | Get paged list of users and total count of users + listUsersPaged :: Page -> PageSize -> m ([WithId UserImplId UserImpl], Word) + -- | Get user permissions, ascending by tag + getUserImplPermissions :: UserImplId -> m [WithId UserPermId UserPerm] + -- | Delete user permissions + deleteUserPermissions :: UserImplId -> m () + -- | Insertion of new user permission + insertUserPerm :: UserPerm -> m UserPermId + -- | Insertion of new user + insertUserImpl :: UserImpl -> m UserImplId + -- | Replace user with new value + replaceUserImpl :: UserImplId -> UserImpl -> m () + -- | Delete user by id + deleteUserImpl :: UserImplId -> m () + -- | Check whether the user has particular permission + hasPerm :: UserImplId -> Permission -> m Bool + -- | Get any user with given permission + getFirstUserByPerm :: Permission -> m (Maybe (WithId UserImplId UserImpl)) + -- | Select user groups and sort them by ascending name + selectUserImplGroups :: UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers] + -- | Remove user from all groups + clearUserImplGroups :: UserImplId -> m () + -- | Add new user group + insertAuthUserGroup :: AuthUserGroup -> m AuthUserGroupId + -- | Add user to given group + insertAuthUserGroupUsers :: AuthUserGroupUsers -> m AuthUserGroupUsersId + -- | Add permission to given group + insertAuthUserGroupPerms :: AuthUserGroupPerms -> m AuthUserGroupPermsId + -- | Find user group by id + getAuthUserGroup :: AuthUserGroupId -> m (Maybe AuthUserGroup) + -- | Get list of permissions of given group + listAuthUserGroupPermissions :: AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms] + -- | Get list of all users of the group + listAuthUserGroupUsers :: AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers] + -- | Replace record of user group + replaceAuthUserGroup :: AuthUserGroupId -> AuthUserGroup -> m () + -- | Remove all users from group + clearAuthUserGroupUsers :: AuthUserGroupId -> m () + -- | Remove all permissions from group + clearAuthUserGroupPerms :: AuthUserGroupId -> m () + -- | Delete user group from storage + deleteAuthUserGroup :: AuthUserGroupId -> m () + -- | Get paged list of user groups with total count + listGroupsPaged :: Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word) + -- | Set group name + setAuthUserGroupName :: AuthUserGroupId -> Text -> m () + -- | Set group parent + setAuthUserGroupParent :: AuthUserGroupId -> Maybe AuthUserGroupId -> m () + -- | Add new single use code + insertSingleUseCode :: UserSingleUseCode -> m UserSingleUseCodeId + -- | Set usage time of the single use code + setSingleUseCodeUsed :: UserSingleUseCodeId -> Maybe UTCTime -> m () + -- | Find unused code for the user and expiration time greater than the given time + getUnusedCode :: SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode)) + -- | Invalidate all permament codes for user and set use time for them + invalidatePermamentCodes :: UserImplId -> UTCTime -> m () + -- | Select last valid restoration code by the given current time + selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore)) + -- | Insert new restore code + insertUserRestore :: UserRestore -> m UserRestoreId + -- | Find unexpired by the time restore code + findRestoreCode :: UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore)) + -- | Replace restore code with new value + replaceRestoreCode :: UserRestoreId -> UserRestore -> m () + -- | Find first non-expired by the time token for user + findAuthToken :: UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken)) + -- | Find token by value + findAuthTokenByValue :: SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken)) + -- | Insert new token + insertAuthToken :: AuthToken -> m AuthTokenId + -- | Replace auth token with new value + replaceAuthToken :: AuthTokenId -> AuthToken -> m () + -- | Convert password to bytestring passToByteString :: Password -> BS.ByteString passToByteString = TE.encodeUtf8 @@ -150,103 +304,96 @@ byteStringToPass = TE.decodeUtf8 -- | Helper to convert user to response -userToUserInfo :: Entity UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo -userToUserInfo (Entity uid UserImpl{..}) perms groups = RespUserInfo { - respUserId = fromIntegral $ fromSqlKey uid +userToUserInfo :: WithId UserImplId UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo +userToUserInfo (WithField uid UserImpl{..}) perms groups = RespUserInfo { + respUserId = fromKey uid , respUserLogin = userImplLogin , respUserEmail = userImplEmail - , respUserPermissions = perms + , respUserPermissions = perms , respUserGroups = groups } -- | Low level operation for collecting info about user -makeUserInfo :: Entity UserImpl -> SqlPersistT IO RespUserInfo -makeUserInfo euser = do - let uid = entityKey euser - perms <- getUserPermissions uid - groups <- getUserGroups uid +makeUserInfo :: HasStorage m => WithId UserImplId UserImpl -> m RespUserInfo +makeUserInfo euser@(WithField uid _) = do + perms <- getUserPermissions uid + groups <- getUserGroups uid return $ userToUserInfo euser perms groups -- | Get user by id -readUserInfo :: UserId -> SqlPersistT IO (Maybe RespUserInfo) -readUserInfo uid' = do +readUserInfo :: HasStorage m => UserId -> m (Maybe RespUserInfo) +readUserInfo uid' = do let uid = toKey uid' - muser <- get uid - maybe (return Nothing) (fmap Just . makeUserInfo . Entity uid) $ muser + muser <- getUserImpl uid + maybe (return Nothing) (fmap Just . makeUserInfo . WithField uid) $ muser -- | Get user by login -readUserInfoByLogin :: Login -> SqlPersistT IO (Maybe RespUserInfo) -readUserInfoByLogin login = do - muser <- getBy $ UniqueLogin login +readUserInfoByLogin :: HasStorage m => Login -> m (Maybe RespUserInfo) +readUserInfoByLogin login = do + muser <- getUserImplByLogin login maybe (return Nothing) (fmap Just . makeUserInfo) muser -- | Return list of permissions for the given user (only permissions that are assigned to him directly) -getUserPermissions :: UserImplId -> SqlPersistT IO [Permission] -getUserPermissions uid = do - perms <- selectList [UserPermUser ==. uid] [Asc UserPermPermission] - return $ userPermPermission . entityVal <$> perms +getUserPermissions :: HasStorage m => UserImplId -> m [Permission] +getUserPermissions uid = do + perms <- getUserImplPermissions uid + return $ userPermPermission . (\(WithField _ v) -> v) <$> perms -- | Return list of permissions for the given user -setUserPermissions :: UserImplId -> [Permission] -> SqlPersistT IO () -setUserPermissions uid perms = do - deleteWhere [UserPermUser ==. uid] - forM_ perms $ void . insert . UserPerm uid +setUserPermissions :: HasStorage m => UserImplId -> [Permission] -> m () +setUserPermissions uid perms = do + deleteUserPermissions uid + forM_ perms $ void . insertUserPerm . UserPerm uid -- | Creation of new user -createUser :: Int -> Login -> Password -> Email -> [Permission] -> SqlPersistT IO UserImplId +createUser :: HasStorage m => Int -> Login -> Password -> Email -> [Permission] -> m UserImplId createUser strength login pass email perms = do pass' <- liftIO $ makePassword (passToByteString pass) strength - i <- insert UserImpl { + i <- insertUserImpl UserImpl { userImplLogin = login , userImplPassword = byteStringToPass pass' - , userImplEmail = email + , userImplEmail = email } - forM_ perms $ void . insert . UserPerm i + forM_ perms $ void . insertUserPerm . UserPerm i return i --- | Check whether the user has particular permission -hasPerm :: UserImplId -> Permission -> SqlPersistT IO Bool -hasPerm i perm = do - c <- count [UserPermUser ==. i, UserPermPermission ==. perm] - return $ c > 0 - -- | Check whether the user has particular permissions -hasPerms :: UserImplId -> [Permission] -> SqlPersistT IO Bool +hasPerms :: HasStorage m => UserImplId -> [Permission] -> m Bool hasPerms _ [] = return True -hasPerms i perms = do - perms' <- getUserAllPermissions i - return $ and $ (`elem` perms') <$> perms +hasPerms i perms = do + perms' <- getUserAllPermissions i + return $ and $ (`elem` perms') <$> perms -- | Creates user with admin privileges -createAdmin :: Int -> Login -> Password -> Email -> SqlPersistT IO UserImplId +createAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m UserImplId createAdmin strength login pass email = createUser strength login pass email [adminPerm] -- | Ensures that DB has at leas one admin, if not, creates a new one -- with specified info. -ensureAdmin :: Int -> Login -> Password -> Email -> SqlPersistT IO () -ensureAdmin strength login pass email = do - madmin <- selectFirst [UserPermPermission ==. adminPerm] [] - whenNothing madmin $ void $ createAdmin strength login pass email +ensureAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m () +ensureAdmin strength login pass email = do + madmin <- getFirstUserByPerm adminPerm + whenNothing madmin $ void $ createAdmin strength login pass email -- | Apply patches for user -patchUser :: Int -- ^ Password strength - -> PatchUser -> Entity UserImpl -> SqlPersistT IO (Entity UserImpl) -patchUser strength PatchUser{..} = - withPatch patchUserLogin (\l (Entity i u) -> pure $ Entity i u { userImplLogin = l }) +patchUser :: HasStorage m => Int -- ^ Password strength + -> PatchUser -> WithId UserImplId UserImpl -> m (WithId UserImplId UserImpl) +patchUser strength PatchUser{..} = + withPatch patchUserLogin (\l (WithField i u) -> pure $ WithField i u { userImplLogin = l }) >=> withPatch patchUserPassword patchPassword - >=> withPatch patchUserEmail (\e (Entity i u) -> pure $ Entity i u { userImplEmail = e }) + >=> withPatch patchUserEmail (\e (WithField i u) -> pure $ WithField i u { userImplEmail = e }) >=> withPatch patchUserPermissions patchPerms >=> withPatch patchUserGroups patchGroups - where - patchPassword ps (Entity i u) = Entity <$> pure i <*> setUserPassword' strength ps u - patchPerms ps (Entity i u) = do + where + patchPassword ps (WithField i u) = WithField <$> pure i <*> setUserPassword' strength ps u + patchPerms ps (WithField i u) = do setUserPermissions i ps - return $ Entity i u - patchGroups gs (Entity i u) = do + return $ WithField i u + patchGroups gs (WithField i u) = do setUserGroups i gs - return $ Entity i u + return $ WithField i u --- | Update password of user +-- | Update password of user setUserPassword' :: MonadIO m => Int -- ^ Password strength -> Password -> UserImpl -> m UserImpl setUserPassword' strength pass user = do @@ -254,126 +401,120 @@ return $ user { userImplPassword = byteStringToPass pass' } -- | Get all groups the user belongs to -getUserGroups :: UserImplId -> SqlPersistT IO [UserGroupId] -getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . entityVal) - <$> selectList [AuthUserGroupUsersUser ==. i] [Asc AuthUserGroupUsersGroup] +getUserGroups :: HasStorage m => UserImplId -> m [UserGroupId] +getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . (\(WithField _ v) -> v)) <$> selectUserImplGroups i -- | Rewrite all user groups -setUserGroups :: UserImplId -> [UserGroupId] -> SqlPersistT IO () -setUserGroups i gs = do - deleteWhere [AuthUserGroupUsersUser ==. i] - gs' <- validateGroups gs - forM_ gs' $ \g -> void $ insert (AuthUserGroupUsers g i) +setUserGroups :: HasStorage m => UserImplId -> [UserGroupId] -> m () +setUserGroups i gs = do + clearUserImplGroups i + gs' <- validateGroups gs + forM_ gs' $ \g -> void $ insertAuthUserGroupUsers $ AuthUserGroupUsers g i -- | Leave only existing groups -validateGroups :: [UserGroupId] -> SqlPersistT IO [AuthUserGroupId] +validateGroups :: HasStorage m => [UserGroupId] -> m [AuthUserGroupId] validateGroups is = do - pairs <- mapM ((\i -> (i,) <$> get i) . toKey) is + pairs <- mapM ((\i -> (i,) <$> getAuthUserGroup i) . toKey) is return $ fmap fst . filter (isJust . snd) $ pairs -- | Getting permission of a group and all it parent groups -getGroupPermissions :: UserGroupId -> SqlPersistT IO [Permission] +getGroupPermissions :: HasStorage m => UserGroupId -> m [Permission] getGroupPermissions = go S.empty S.empty . toKey - where - go !visited !perms !i = do - mg <- get i - case mg of - Nothing -> return $ F.toList perms - Just AuthUserGroup{..} -> do - curPerms <- fmap (authUserGroupPermsPermission . entityVal) <$> - selectList [AuthUserGroupPermsGroup ==. i] [Asc AuthUserGroupPermsPermission] + where + go !visited !perms !i = do + mg <- getAuthUserGroup i + case mg of + Nothing -> return $ F.toList perms + Just AuthUserGroup{..} -> do + curPerms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i let perms' = perms <> S.fromList curPerms - case authUserGroupParent of + case authUserGroupParent of Nothing -> return $ F.toList perms' Just pid -> if isJust $ pid `S.elemIndexL` visited then fail $ "Recursive user group graph: " <> show (visited S.|> pid) - else go (visited S.|> pid) perms' pid + else go (visited S.|> pid) perms' pid -- | Get user permissions that are assigned to him/her via groups only -getUserGroupPermissions :: UserImplId -> SqlPersistT IO [Permission] -getUserGroupPermissions i = do - groups <- getUserGroups i - perms <- mapM getGroupPermissions groups +getUserGroupPermissions :: HasStorage m => UserImplId -> m [Permission] +getUserGroupPermissions i = do + groups <- getUserGroups i + perms <- mapM getGroupPermissions groups return $ L.sort . L.nub . concat $ perms -- | Get user permissions that are assigned to him/her either by direct -- way or by his/her groups. -getUserAllPermissions :: UserImplId -> SqlPersistT IO [Permission] -getUserAllPermissions i = do - permsDr <- getUserPermissions i - permsGr <- getUserGroupPermissions i - return $ L.sort . L.nub $ permsDr <> permsGr +getUserAllPermissions :: HasStorage m => UserImplId -> m [Permission] +getUserAllPermissions i = do + permsDr <- getUserPermissions i + permsGr <- getUserGroupPermissions i + return $ L.sort . L.nub $ permsDr <> permsGr -- | Collect full info about user group from RDBMS -readUserGroup :: UserGroupId -> SqlPersistT IO (Maybe UserGroup) -readUserGroup i = do - let i' = toKey $ i - mu <- get i' - case mu of - Nothing -> return Nothing - Just AuthUserGroup{..} -> do - users <- fmap (authUserGroupUsersUser . entityVal) <$> - selectList [AuthUserGroupUsersGroup ==. i'] [Asc AuthUserGroupUsersUser] - perms <- fmap (authUserGroupPermsPermission . entityVal) <$> - selectList [AuthUserGroupPermsGroup ==. i'] [Asc AuthUserGroupPermsPermission] +readUserGroup :: HasStorage m => UserGroupId -> m (Maybe UserGroup) +readUserGroup i = do + let i' = toKey $ i + mu <- getAuthUserGroup i' + case mu of + Nothing -> return Nothing + Just AuthUserGroup{..} -> do + users <- fmap (authUserGroupUsersUser . (\(WithField _ v) -> v)) <$> listAuthUserGroupUsers i' + perms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i' return $ Just UserGroup { - userGroupName = authUserGroupName - , userGroupUsers = fromKey <$> users - , userGroupPermissions = perms + userGroupName = authUserGroupName + , userGroupUsers = fromKey <$> users + , userGroupPermissions = perms , userGroupParent = fromKey <$> authUserGroupParent } -- | Helper to convert user group into values of several tables toAuthUserGroup :: UserGroup -> (AuthUserGroup, AuthUserGroupId -> [AuthUserGroupUsers], AuthUserGroupId -> [AuthUserGroupPerms]) toAuthUserGroup UserGroup{..} = (ag, users, perms) - where + where ag = AuthUserGroup { - authUserGroupName = userGroupName + authUserGroupName = userGroupName , authUserGroupParent = toKey <$> userGroupParent } - users i = (\ui -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers + users i = (\ui -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers perms i = (\perm -> AuthUserGroupPerms i perm) <$> userGroupPermissions -- | Insert user group into RDBMS -insertUserGroup :: UserGroup -> SqlPersistT IO UserGroupId -insertUserGroup u = do +insertUserGroup :: HasStorage m => UserGroup -> m UserGroupId +insertUserGroup u = do let (ag, users, perms) = toAuthUserGroup u - i <- insert ag - forM_ (users i) $ void . insert - forM_ (perms i) $ void . insert - return $ fromKey $ i + i <- insertAuthUserGroup ag + forM_ (users i) $ void . insertAuthUserGroupUsers + forM_ (perms i) $ void . insertAuthUserGroupPerms + return $ fromKey $ i -- | Replace user group with new value -updateUserGroup :: UserGroupId -> UserGroup -> SqlPersistT IO () -updateUserGroup i u = do - let i' = toKey $ i +updateUserGroup :: HasStorage m => UserGroupId -> UserGroup -> m () +updateUserGroup i u = do + let i' = toKey $ i let (ag, users, perms) = toAuthUserGroup u - replace i' ag - deleteWhere [AuthUserGroupUsersGroup ==. i'] - deleteWhere [AuthUserGroupPermsGroup ==. i'] - forM_ (users i') $ void . insert - forM_ (perms i') $ void . insert + replaceAuthUserGroup i' ag + clearAuthUserGroupUsers i' + clearAuthUserGroupPerms i' + forM_ (users i') $ void . insertAuthUserGroupUsers + forM_ (perms i') $ void . insertAuthUserGroupPerms -- | Erase user group from RDBMS, cascade -deleteUserGroup :: UserGroupId -> SqlPersistT IO () -deleteUserGroup i = do - let i' = toKey $ i - deleteWhere [AuthUserGroupUsersGroup ==. i'] - deleteWhere [AuthUserGroupPermsGroup ==. i'] - deleteCascade i' +deleteUserGroup :: HasStorage m => UserGroupId -> m () +deleteUserGroup i = do + let i' = toKey $ i + clearAuthUserGroupUsers i' + clearAuthUserGroupPerms i' + deleteAuthUserGroup i' -- | Partial update of user group -patchUserGroup :: UserGroupId -> PatchUserGroup -> SqlPersistT IO () -patchUserGroup i PatchUserGroup{..} = do - let i' = toKey $ i - patchName = (\n -> AuthUserGroupName =. n) <$> patchUserGroupName - patchParent = case patchUserGroupNoParent of - Just True -> Just $ AuthUserGroupParent =. Nothing - _ -> (\p -> AuthUserGroupParent =. Just (toSqlKey .fromIntegral $ p)) <$> patchUserGroupParent - update i' $ catMaybes [patchName, patchParent] +patchUserGroup :: HasStorage m => UserGroupId -> PatchUserGroup -> m () +patchUserGroup i PatchUserGroup{..} = do + let i' = toKey i + whenJust patchUserGroupName $ setAuthUserGroupName i' + whenJust patchUserGroupParent $ setAuthUserGroupParent i' . Just . toKey + whenJust patchUserGroupNoParent $ const $ setAuthUserGroupParent i' Nothing whenJust patchUserGroupUsers $ \uids -> do - deleteWhere [AuthUserGroupUsersGroup ==. i'] - forM_ uids $ insert . AuthUserGroupUsers i' . toKey + clearAuthUserGroupUsers i' + forM_ uids $ insertAuthUserGroupUsers . AuthUserGroupUsers i' . toKey whenJust patchUserGroupPermissions $ \perms -> do - deleteWhere [AuthUserGroupUsersGroup ==. i'] - forM_ perms $ insert . AuthUserGroupPerms i' + clearAuthUserGroupPerms i' + forM_ perms $ insertAuthUserGroupPerms . AuthUserGroupPerms i' 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 @@ -8,57 +8,47 @@ Portability : Portable -} module Servant.Server.Auth.Token.Monad( - AuthHandler(..) + AuthHandler + , HasAuthConfig(..) , require , getConfig , getsConfig - , runDB404 + , guard404 , module Reexport - ) where + ) where -import Control.Monad.Except (ExceptT, MonadError) -import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, ask, asks) +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class import Data.Monoid ((<>)) -import Database.Persist.Postgresql -import Servant - -import qualified Data.ByteString.Lazy as BS +import Servant -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Model +import qualified Data.ByteString.Lazy as BS +import Servant.Server.Auth.Token.Config import Servant.Server.Auth.Token.Error as Reexport +import Servant.Server.Auth.Token.Model --- | This type represents the effects we want to have for our application. --- We wrap the standard Servant monad with 'ReaderT Config', which gives us --- access to the application configuration using the 'MonadReader' --- interface's 'ask' function. --- --- By encapsulating the effects in our newtype, we can add layers to the --- monad stack without having to modify code that uses the current layout. -newtype AuthHandler a = AuthHandler { - runAuthHandler :: ReaderT AuthConfig (ExceptT ServantErr IO) a - } deriving ( Functor, Applicative, Monad, MonadReader AuthConfig, - MonadError ServantErr, MonadIO) +-- | Context that is needed to run the auth server +type AuthHandler m = (HasAuthConfig m, MonadError ServantErr m, MonadIO m, HasStorage m) -- | If the value is 'Nothing', throw 400 response -require :: BS.ByteString -> Maybe a -> AuthHandler a +require :: AuthHandler m => BS.ByteString -> Maybe a -> m a require info Nothing = throw400 $ info <> " is required" -require _ (Just a) = return a +require _ (Just a) = return a -- | Getting config from global state -getConfig :: AuthHandler AuthConfig -getConfig = ask +getConfig :: AuthHandler m => m AuthConfig +getConfig = getAuthConfig -- | Getting config part from global state -getsConfig :: (AuthConfig -> a) -> AuthHandler a -getsConfig = asks +getsConfig :: AuthHandler m => (AuthConfig -> a) -> m a +getsConfig f = fmap f getAuthConfig --- | Run RDBMS operation and throw 404 (not found) error if +-- | Run RDBMS operation and throw 404 (not found) error if -- the second arg returns 'Nothing' -runDB404 :: BS.ByteString -> SqlPersistT IO (Maybe a) -> AuthHandler a -runDB404 info ma = do - a <- runDB ma - case a of - Nothing -> throw404 $ "Cannot find " <> info - Just a' -> return a' +guard404 :: AuthHandler m => BS.ByteString -> m (Maybe a) -> m a +guard404 info ma = do + a <- ma + case a of + Nothing -> throw404 $ "Cannot find " <> info + Just a' -> return a' 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 @@ -9,22 +9,23 @@ -} module Servant.Server.Auth.Token.Pagination( pagination - ) where + ) where -import Data.Maybe +import Data.Maybe -import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Monad +import Servant.Server.Auth.Token.Config +import Servant.Server.Auth.Token.Monad import Servant.API.Auth.Token.Pagination -- | Helper that implements pagination logic -pagination :: Maybe Page -- ^ Parameter of page +pagination :: AuthHandler m + => Maybe Page -- ^ Parameter of page -> Maybe PageSize -- ^ Parameter of page size - -> (Page -> PageSize -> AuthHandler a) -- ^ Handler - -> AuthHandler a -pagination pageParam pageSizeParam f = do + -> (Page -> PageSize -> m a) -- ^ Handler + -> m a +pagination pageParam pageSizeParam f = do ps <- getsConfig defaultPageSize - let page = fromMaybe 0 pageParam + let page = fromMaybe 0 pageParam pageSize = fromMaybe ps pageSizeParam - f page pageSize + f page pageSize 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 @@ -11,46 +11,45 @@ getRestoreCode , guardRestoreCode , sendRestoreCode - ) where + ) where -import Control.Monad -import Control.Monad.IO.Class +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson.WithField import Data.Time.Clock -import Database.Persist.Postgresql import Servant.API.Auth.Token import Servant.Server.Auth.Token.Config -import Servant.Server.Auth.Token.Model -import Servant.Server.Auth.Token.Monad +import Servant.Server.Auth.Token.Model +import Servant.Server.Auth.Token.Monad -- | Get current restore code for user or generate new -getRestoreCode :: IO RestoreCode -> UserImplId -> UTCTime -> SqlPersistT IO RestoreCode -getRestoreCode generator uid expire = do +getRestoreCode :: HasStorage m => IO RestoreCode -> UserImplId -> UTCTime -> m RestoreCode +getRestoreCode generator uid expire = do t <- liftIO getCurrentTime - mcode <- selectFirst [UserRestoreUser ==. uid, UserRestoreExpire >. t] [Desc UserRestoreExpire] - case mcode of - Nothing -> do + mcode <- selectLastRestoreCode uid t + case mcode of + Nothing -> do code <- liftIO generator - void $ insert UserRestore { - userRestoreValue = code + void $ insertUserRestore UserRestore { + userRestoreValue = code , userRestoreUser = uid - , userRestoreExpire = expire + , userRestoreExpire = expire } - return code - Just code -> return $ userRestoreValue . entityVal $ code + return code + Just code -> return $ userRestoreValue . (\(WithField _ v) -> v) $ code -- | Throw if the restore code isn't valid for given user, if valid, invalidates the code -guardRestoreCode :: UserImplId -> RestoreCode -> AuthHandler () -guardRestoreCode uid code = do +guardRestoreCode :: AuthHandler m => UserImplId -> RestoreCode -> m () +guardRestoreCode uid code = do t <- liftIO getCurrentTime - mcode <- runDB $ selectFirst [UserRestoreUser ==. uid, UserRestoreValue ==. code - , UserRestoreExpire >. t] [Desc UserRestoreExpire] - case mcode of + mcode <- findRestoreCode uid code t + case mcode of Nothing -> throw400 "Invalid restore code" - Just (Entity i rc) -> runDB $ replace i rc { userRestoreExpire = t } + Just (WithField i rc) -> replaceRestoreCode i rc { userRestoreExpire = t } -- | Send restore code to the user' email -sendRestoreCode :: RespUserInfo -> RestoreCode -> AuthHandler () -sendRestoreCode user code = do +sendRestoreCode :: AuthHandler m => RespUserInfo -> RestoreCode -> m () +sendRestoreCode user code = do AuthConfig{..} <- getConfig - liftIO $ restoreCodeSender user code + liftIO $ restoreCodeSender user code 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 @@ -10,76 +10,64 @@ module Servant.Server.Auth.Token.SingleUse( makeSingleUseExpire , registerSingleUseCode - , invalideSingleUseCode + , invalidateSingleUseCode , validateSingleUseCode , generateSingleUsedCodes - ) where + ) where import Control.Monad -import Control.Monad.IO.Class -import Data.Time -import Database.Persist.Sql +import Control.Monad.IO.Class +import Data.Aeson.WithField +import Data.Time import Servant.API.Auth.Token import Servant.Server.Auth.Token.Common -import Servant.Server.Auth.Token.Model +import Servant.Server.Auth.Token.Model -- | Calculate expire date for single usage code makeSingleUseExpire :: MonadIO m => NominalDiffTime -- ^ Duration of code -> m UTCTime -- ^ Time when the code expires -makeSingleUseExpire dt = do +makeSingleUseExpire dt = do t <- liftIO getCurrentTime return $ dt `addUTCTime` t -- | Register single use code in DB -registerSingleUseCode :: MonadIO m => UserImplId -- ^ Id of user +registerSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user -> SingleUseCode -- ^ Single usage code -> Maybe UTCTime -- ^ Time when the code expires, 'Nothing' is never expiring code - -> SqlPersistT m () -registerSingleUseCode uid code expire = void $ insert + -> m () +registerSingleUseCode uid code expire = void $ insertSingleUseCode $ UserSingleUseCode code uid expire Nothing -- | Marks single use code that it cannot be used again -invalideSingleUseCode :: MonadIO m => UserSingleUseCodeId -- ^ Id of code - -> SqlPersistT m () -invalideSingleUseCode i = do +invalidateSingleUseCode :: HasStorage m => UserSingleUseCodeId -- ^ Id of code + -> m () +invalidateSingleUseCode i = do t <- liftIO getCurrentTime - update i [UserSingleUseCodeUsed =. Just t] + setSingleUseCodeUsed i $ Just t -- | Check single use code and return 'True' on success. -- -- On success invalidates single use code. -validateSingleUseCode :: MonadIO m => UserImplId -- ^ Id of user - -> SingleUseCode -- ^ Single usage code - -> SqlPersistT m Bool -validateSingleUseCode uid code = do +validateSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user + -> SingleUseCode -- ^ Single usage code + -> m Bool +validateSingleUseCode uid code = do t <- liftIO getCurrentTime - mcode <- selectFirst ([ - UserSingleUseCodeValue ==. code - , UserSingleUseCodeUser ==. uid - , UserSingleUseCodeUsed ==. Nothing - ] ++ ( - [UserSingleUseCodeExpire ==. Nothing] - ||. [UserSingleUseCodeExpire >=. Just t] - )) [Desc UserSingleUseCodeExpire] - whenJust mcode $ invalideSingleUseCode . entityKey + mcode <- getUnusedCode code uid t + whenJust mcode $ invalidateSingleUseCode . (\(WithField i _) -> i) return $ maybe False (const True) mcode -- | Generates a set single use codes that doesn't expire. -- -- Note: previous codes without expiration are invalidated. -generateSingleUsedCodes :: MonadIO m => UserImplId -- ^ Id of user +generateSingleUsedCodes :: HasStorage m => UserImplId -- ^ Id of user -> IO SingleUseCode -- ^ Generator of codes -> Word -- Count of codes - -> SqlPersistT m [SingleUseCode] -generateSingleUsedCodes uid gen n = do + -> m [SingleUseCode] +generateSingleUsedCodes uid gen n = do t <- liftIO getCurrentTime - updateWhere [ - UserSingleUseCodeUser ==. uid - , UserSingleUseCodeUsed ==. Nothing - , UserSingleUseCodeExpire ==. Nothing - ] - [UserSingleUseCodeUsed =. Just t] - replicateM (fromIntegral n) $ do - code <- liftIO gen - _ <- insert $ UserSingleUseCode code uid Nothing Nothing + invalidatePermamentCodes uid t + replicateM (fromIntegral n) $ do + code <- liftIO gen + _ <- insertSingleUseCode $ UserSingleUseCode code uid Nothing Nothing return code diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,83 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-7.16 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +- 'servant-auth-token-acid' +- 'servant-auth-token-persistent' +- 'example/acid' +- 'example/persistent' +# - location: +# git: https://github.com/NCrashed/servant-auth-token-api.git +# commit: d011f7bfecd18d07ff67ce9f67f8741e110a2719 +# extra-dep: true +- '../servant-auth-token-api' + +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: +- aeson-injector-1.0.7.0 +- http-api-data-0.3.5 +- natural-transformation-0.4 +- servant-0.9 +- servant-docs-0.9 +- servant-auth-token-api-0.3.1.0 +- servant-server-0.9 + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor