summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNCrashed <>2017-05-19 10:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-05-19 10:21:00 (GMT)
commit1ba5ad2c9bd2fb4ea5dad709f301a4a4367c20dd (patch)
treeb59d9211782e1dba6fde08145449622736c6f7c2
parente1a92cd5149f4d520f9de33e7667302bb56b0867 (diff)
version 0.4.7.00.4.7.0
-rw-r--r--CHANGELOG.md169
-rw-r--r--LICENSE60
-rw-r--r--README.md54
-rw-r--r--Setup.hs4
-rw-r--r--example/acid/LICENSE60
-rw-r--r--example/acid/Setup.hs4
-rw-r--r--example/acid/config.yaml6
-rw-r--r--example/acid/servant-auth-token-example-acid.cabal140
-rw-r--r--example/acid/src/API.hs20
-rw-r--r--example/acid/src/Config.hs60
-rw-r--r--example/acid/src/DB.hs60
-rw-r--r--example/acid/src/Main.hs70
-rw-r--r--example/acid/src/Monad.hs196
-rw-r--r--example/acid/src/Server.hs98
-rw-r--r--example/leveldb/LICENSE60
-rw-r--r--example/leveldb/Setup.hs4
-rw-r--r--example/leveldb/config.yaml6
-rw-r--r--example/leveldb/servant-auth-token-example-leveldb.cabal140
-rw-r--r--example/leveldb/src/API.hs20
-rw-r--r--example/leveldb/src/Config.hs60
-rw-r--r--example/leveldb/src/Main.hs70
-rw-r--r--example/leveldb/src/Monad.hs196
-rw-r--r--example/leveldb/src/Server.hs98
-rw-r--r--example/persistent/LICENSE60
-rw-r--r--example/persistent/Setup.hs4
-rw-r--r--example/persistent/config.yaml16
-rw-r--r--example/persistent/servant-auth-token-example-persistent.cabal138
-rw-r--r--example/persistent/src/API.hs20
-rw-r--r--example/persistent/src/Config.hs116
-rw-r--r--example/persistent/src/Main.hs70
-rw-r--r--example/persistent/src/Monad.hs196
-rw-r--r--example/persistent/src/Server.hs98
-rw-r--r--servant-auth-token.cabal194
-rw-r--r--src/Servant/Server/Auth/Token.hs1328
-rw-r--r--src/Servant/Server/Auth/Token/Common.hs76
-rw-r--r--src/Servant/Server/Auth/Token/Config.hs276
-rw-r--r--src/Servant/Server/Auth/Token/Error.hs78
-rw-r--r--src/Servant/Server/Auth/Token/Model.hs1308
-rw-r--r--src/Servant/Server/Auth/Token/Monad.hs108
-rw-r--r--src/Servant/Server/Auth/Token/Pagination.hs62
-rw-r--r--src/Servant/Server/Auth/Token/Patch.hs102
-rw-r--r--src/Servant/Server/Auth/Token/Restore.hs110
-rw-r--r--src/Servant/Server/Auth/Token/SingleUse.hs146
-rw-r--r--stack.yaml185
44 files changed, 3178 insertions, 3168 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 6f5ff39..b5bc303 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,82 +1,87 @@
-0.4.6.0
-=======
-
-* Add `withAuthToken` to guard groups of endpoints.
-
-0.4.5.0
-=======
-
-* Auto deriving `HasAuthConfig` and `HasStorage` for transformers.
-
-0.4.4.1
-=======
-
-* `persistent-postgresql` is not actually used
-
-0.4.4.0
-=======
-
-* Add `signinByHashUnsafe` for internal usage.
-
-0.4.3.0
-=======
-
-* Implementation for `AuthFindUserByLogin` endpoint.
-* Feature to manipulate with hashes of passwords. For instance, now you can store
-hashed admin password in config.
-
-0.4.2.0
-=======
-
-* Add implementation for `AuthCheckPermissionsMethod` and `AuthGetUserIdMethod` endpoints.
-
-0.4.1.1
-=======
-
-* Relax `aeson` and `opt-parse-applicative` bounds.
-* Add `monad-control` instances.
-
-0.4.1.0
-=======
-
-* Remove persistent dependencies from abstract package.
-
-0.4.0.0
-=======
-
-* Abstract over storage: persistent and acid-state backends.
-
-0.3.2.0
-=======
-
-* Support lts-7.1 (ghc 8 and persistent-0.6)
-
-0.3.0.0
-=======
-
-* Add authorisation by single usage codes.
-
-0.2.0.1
-=======
-
-* Relax boundaries for ghc 8.0.1.
-
-0.2.0.0
-=======
-
-* Implement `servant-auth-token-0.2.0.0` API.
-
-0.1.2.0
-=======
-
-* Expose implementation of API for embedding in complex servers.
-
-0.1.1.0
-=======
-
-* Added `restoreCodeGenerator` to configuration
-
-0.1.0.0
-=======
-
-* Initial publication
+0.4.7.0
+=======
+
+* Make `withAuthToken` work properly.
+
+0.4.6.0
+=======
+
+* Add `withAuthToken` to guard groups of endpoints.
+
+0.4.5.0
+=======
+
+* Auto deriving `HasAuthConfig` and `HasStorage` for transformers.
+
+0.4.4.1
+=======
+
+* `persistent-postgresql` is not actually used
+
+0.4.4.0
+=======
+
+* Add `signinByHashUnsafe` for internal usage.
+
+0.4.3.0
+=======
+
+* Implementation for `AuthFindUserByLogin` endpoint.
+* Feature to manipulate with hashes of passwords. For instance, now you can store
+hashed admin password in config.
+
+0.4.2.0
+=======
+
+* Add implementation for `AuthCheckPermissionsMethod` and `AuthGetUserIdMethod` endpoints.
+
+0.4.1.1
+=======
+
+* Relax `aeson` and `opt-parse-applicative` bounds.
+* Add `monad-control` instances.
+
+0.4.1.0
+=======
+
+* Remove persistent dependencies from abstract package.
+
+0.4.0.0
+=======
+
+* Abstract over storage: persistent and acid-state backends.
+
+0.3.2.0
+=======
+
+* Support lts-7.1 (ghc 8 and persistent-0.6)
+
+0.3.0.0
+=======
+
+* Add authorisation by single usage codes.
+
+0.2.0.1
+=======
+
+* Relax boundaries for ghc 8.0.1.
+
+0.2.0.0
+=======
+
+* Implement `servant-auth-token-0.2.0.0` API.
+
+0.1.2.0
+=======
+
+* Expose implementation of API for embedding in complex servers.
+
+0.1.1.0
+=======
+
+* Added `restoreCodeGenerator` to configuration
+
+0.1.0.0
+=======
+
+* Initial publication
diff --git a/LICENSE b/LICENSE
index 4544b60..1e9663d 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,30 +1,30 @@
-Copyright Anton Gushcha (c) 2016-2017
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of NCrashed nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright Anton Gushcha (c) 2016-2017
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of NCrashed nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
index f433d45..0e21950 100644
--- a/README.md
+++ b/README.md
@@ -1,27 +1,27 @@
-# servant-auth-token
-
-[![Build Status](https://travis-ci.org/NCrashed/servant-auth-token.svg?branch=master)](https://travis-ci.org/NCrashed/servant-auth-token)
-
-The repo contains server implementation of [servant-auth-token-api](https://github.com/NCrashed/servant-auth-token-api).
-
-# How to add to your server
-
-At the moment you have two options for backend storage:
-
-- [persistent backend](https://github.com/NCrashed/servant-auth-token/tree/master/servant-auth-token-persistent) - [persistent](https://hackage.haskell.org/package/persistent) backend, simple to integrate with your app.
-
-- [acid-state backend](https://github.com/NCrashed/servant-auth-token/tree/master/servant-auth-token-acid) - [acid-state](https://hackage.haskell.org/package/acid-state) backend is light solution for in memory storage, but it is more difficult to integrate it with your app.
-
-- Possible candidates for other storage backends: VCache, leveldb, JSON files. To see how to implement them, see [HasStorage](https://github.com/NCrashed/servant-auth-token/blob/master/src/Servant/Server/Auth/Token/Model.hs#L220) type class.
-
-Now you can use 'guardAuthToken' to check authorization headers in endpoints of your server:
-
-``` haskell
--- | Read a single customer from DB
-customerGet :: CustomerId -- ^ Customer unique id
- -> MToken '["customer-read"] -- ^ Required permissions for auth token
- -> ServerM Customer -- ^ Customer data
-customerGet i token = do
- guardAuthToken token
- runDB404 "customer" $ getCustomer i
-```
+# servant-auth-token
+
+[![Build Status](https://travis-ci.org/NCrashed/servant-auth-token.svg?branch=master)](https://travis-ci.org/NCrashed/servant-auth-token)
+
+The repo contains server implementation of [servant-auth-token-api](https://github.com/NCrashed/servant-auth-token-api).
+
+# How to add to your server
+
+At the moment you have two options for backend storage:
+
+- [persistent backend](https://github.com/NCrashed/servant-auth-token/tree/master/servant-auth-token-persistent) - [persistent](https://hackage.haskell.org/package/persistent) backend, simple to integrate with your app.
+
+- [acid-state backend](https://github.com/NCrashed/servant-auth-token/tree/master/servant-auth-token-acid) - [acid-state](https://hackage.haskell.org/package/acid-state) backend is light solution for in memory storage, but it is more difficult to integrate it with your app.
+
+- Possible candidates for other storage backends: VCache, leveldb, JSON files. To see how to implement them, see [HasStorage](https://github.com/NCrashed/servant-auth-token/blob/master/src/Servant/Server/Auth/Token/Model.hs#L220) type class.
+
+Now you can use 'guardAuthToken' to check authorization headers in endpoints of your server:
+
+``` haskell
+-- | Read a single customer from DB
+customerGet :: CustomerId -- ^ Customer unique id
+ -> MToken '["customer-read"] -- ^ Required permissions for auth token
+ -> ServerM Customer -- ^ Customer data
+customerGet i token = do
+ guardAuthToken token
+ runDB404 "customer" $ getCustomer i
+```
diff --git a/Setup.hs b/Setup.hs
index 9a994af..833b4c6 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple
+main = defaultMain
diff --git a/example/acid/LICENSE b/example/acid/LICENSE
index e1a0e52..18d524c 100644
--- a/example/acid/LICENSE
+++ b/example/acid/LICENSE
@@ -1,30 +1,30 @@
-Copyright Anton Gushcha (c) 2016
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of NCrashed nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright Anton Gushcha (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of NCrashed nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/example/acid/Setup.hs b/example/acid/Setup.hs
index 9a994af..833b4c6 100644
--- a/example/acid/Setup.hs
+++ b/example/acid/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple
+main = defaultMain
diff --git a/example/acid/config.yaml b/example/acid/config.yaml
index ec3852f..2423477 100644
--- a/example/acid/config.yaml
+++ b/example/acid/config.yaml
@@ -1,3 +1,3 @@
-host: localhost
-port: 3000
-db: "state"
+host: localhost
+port: 3000
+db: "state"
diff --git a/example/acid/servant-auth-token-example-acid.cabal b/example/acid/servant-auth-token-example-acid.cabal
index cca67bb..865ab9b 100644
--- a/example/acid/servant-auth-token-example-acid.cabal
+++ b/example/acid/servant-auth-token-example-acid.cabal
@@ -1,70 +1,70 @@
-name: servant-auth-token-example-acid
-version: 0.4.0.1
-synopsis: Example server for token auth for acid-state backend
-description: Please see README.md
-homepage: https://github.com/ncrashed/servant-auth-token#readme
-license: BSD3
-license-file: LICENSE
-author: NCrashed
-maintainer: ncrashed@gmail.com
-copyright: 2017 Anton Gushcha
-category: Web
-build-type: Simple
-cabal-version: >=1.10
-
-executable servant-auth-token-example-acid
- hs-source-dirs: src
- main-is: Main.hs
- other-modules:
- API
- Config
- DB
- Monad
- Server
- default-language: Haskell2010
- build-depends:
- base >= 4.7 && < 5
- , acid-state >= 0.14 && < 0.15
- , aeson >= 0.11 && < 1.1
- , aeson-injector >= 1.0 && < 1.1
- , bytestring >= 0.10 && < 0.11
- , exceptions >= 0.8 && < 0.9
- , http-types >= 0.9 && < 0.10
- , monad-control >= 1.0 && < 1.1
- , monad-logger >= 0.3 && < 0.4
- , mtl >= 2.2 && < 2.3
- , optparse-applicative >= 0.12 && < 0.14
- , safecopy >= 0.9 && < 0.10
- , servant >= 0.9 && < 0.10
- , servant-auth-token >= 0.4 && < 0.5
- , servant-auth-token-acid >= 0.4 && < 0.5
- , servant-auth-token-api >= 0.4 && < 0.5
- , servant-server >= 0.9 && < 0.10
- , text >= 1.2 && < 1.3
- , time >= 1.6 && < 1.7
- , transformers-base >= 0.4 && < 0.5
- , wai >= 3.2 && < 3.3
- , wai-extra >= 3.0 && < 3.1
- , warp >= 3.2 && < 3.3
- , yaml >= 0.8 && < 0.9
- default-extensions:
- BangPatterns
- DataKinds
- DeriveFunctor
- DeriveGeneric
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GeneralizedNewtypeDeriving
- MultiParamTypeClasses
- OverloadedStrings
- RecordWildCards
- RecursiveDo
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TypeFamilies
- TypeOperators
- UndecidableInstances
-
- ghc-options: -threaded
+name: servant-auth-token-example-acid
+version: 0.4.0.1
+synopsis: Example server for token auth for acid-state backend
+description: Please see README.md
+homepage: https://github.com/ncrashed/servant-auth-token#readme
+license: BSD3
+license-file: LICENSE
+author: NCrashed
+maintainer: ncrashed@gmail.com
+copyright: 2017 Anton Gushcha
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+
+executable servant-auth-token-example-acid
+ hs-source-dirs: src
+ main-is: Main.hs
+ other-modules:
+ API
+ Config
+ DB
+ Monad
+ Server
+ default-language: Haskell2010
+ build-depends:
+ base >= 4.7 && < 5
+ , acid-state >= 0.14 && < 0.15
+ , aeson >= 0.11 && < 1.1
+ , aeson-injector >= 1.0 && < 1.1
+ , bytestring >= 0.10 && < 0.11
+ , exceptions >= 0.8 && < 0.9
+ , http-types >= 0.9 && < 0.10
+ , monad-control >= 1.0 && < 1.1
+ , monad-logger >= 0.3 && < 0.4
+ , mtl >= 2.2 && < 2.3
+ , optparse-applicative >= 0.12 && < 0.14
+ , safecopy >= 0.9 && < 0.10
+ , servant >= 0.9 && < 0.10
+ , servant-auth-token >= 0.4 && < 0.5
+ , servant-auth-token-acid >= 0.4 && < 0.5
+ , servant-auth-token-api >= 0.4 && < 0.5
+ , servant-server >= 0.9 && < 0.10
+ , text >= 1.2 && < 1.3
+ , time >= 1.6 && < 1.7
+ , transformers-base >= 0.4 && < 0.5
+ , wai >= 3.2 && < 3.3
+ , wai-extra >= 3.0 && < 3.1
+ , warp >= 3.2 && < 3.3
+ , yaml >= 0.8 && < 0.9
+ default-extensions:
+ BangPatterns
+ DataKinds
+ DeriveFunctor
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ RecursiveDo
+ ScopedTypeVariables
+ StandaloneDeriving
+ TemplateHaskell
+ TypeFamilies
+ TypeOperators
+ UndecidableInstances
+
+ ghc-options: -threaded
diff --git a/example/acid/src/API.hs b/example/acid/src/API.hs
index 33faeb0..a962619 100644
--- a/example/acid/src/API.hs
+++ b/example/acid/src/API.hs
@@ -1,10 +1,10 @@
-module API(
- ExampleAPI
- ) where
-
-import Servant.API
-import Servant.API.Auth.Token
-
-type ExampleAPI = "test"
- :> TokenHeader' '["test-permission"]
- :> Get '[JSON] ()
+module API(
+ ExampleAPI
+ ) where
+
+import Servant.API
+import Servant.API.Auth.Token
+
+type ExampleAPI = "test"
+ :> TokenHeader' '["test-permission"]
+ :> Get '[JSON] ()
diff --git a/example/acid/src/Config.hs b/example/acid/src/Config.hs
index 732538f..d1b46e8 100644
--- a/example/acid/src/Config.hs
+++ b/example/acid/src/Config.hs
@@ -1,30 +1,30 @@
-module Config(
- ServerConfig(..)
- , readConfig
- ) where
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Aeson
-import Data.Text
-import Data.Yaml.Config
-
--- | Startup configuration of server
-data ServerConfig = ServerConfig {
- -- | Server host name
- serverHost :: !Text
- -- | Server port number
-, serverPort :: !Int
- -- | Server db location
-, serverDbPath :: !Text
-}
-
-instance FromJSON ServerConfig where
- parseJSON (Object o) = ServerConfig
- <$> o .: "host"
- <*> o .: "port"
- <*> o .: "db"
- parseJSON _ = mzero
-
-readConfig :: MonadIO m => FilePath -> m ServerConfig
-readConfig f = liftIO $ loadYamlSettings [f] [] useEnv
+module Config(
+ ServerConfig(..)
+ , readConfig
+ ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson
+import Data.Text
+import Data.Yaml.Config
+
+-- | Startup configuration of server
+data ServerConfig = ServerConfig {
+ -- | Server host name
+ serverHost :: !Text
+ -- | Server port number
+, serverPort :: !Int
+ -- | Server db location
+, serverDbPath :: !Text
+}
+
+instance FromJSON ServerConfig where
+ parseJSON (Object o) = ServerConfig
+ <$> o .: "host"
+ <*> o .: "port"
+ <*> o .: "db"
+ parseJSON _ = mzero
+
+readConfig :: MonadIO m => FilePath -> m ServerConfig
+readConfig f = liftIO $ loadYamlSettings [f] [] useEnv
diff --git a/example/acid/src/DB.hs b/example/acid/src/DB.hs
index 315842b..e2cbda1 100644
--- a/example/acid/src/DB.hs
+++ b/example/acid/src/DB.hs
@@ -1,30 +1,30 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-module DB where
-
-import Data.SafeCopy
-
-import Servant.Server.Auth.Token.Acid.Schema as A
-
--- | Application global state for acid-state
-data DB = DB {
- dbAuth :: A.Model -- ^ Storage for Auth state
-, dbCustom :: () -- ^ Demo of custom state
-}
-
--- | Generation of inital state
-newDB :: DB
-newDB = DB {
- dbAuth = A.newModel
- , dbCustom = ()
- }
-
-instance HasModelRead DB where
- askModel = dbAuth
-
-instance HasModelWrite DB where
- putModel db m = db { dbAuth = m }
-
-deriveSafeCopy 0 'base ''DB
-
-A.deriveQueries ''DB
-A.makeModelAcidic ''DB
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+module DB where
+
+import Data.SafeCopy
+
+import Servant.Server.Auth.Token.Acid.Schema as A
+
+-- | Application global state for acid-state
+data DB = DB {
+ dbAuth :: A.Model -- ^ Storage for Auth state
+, dbCustom :: () -- ^ Demo of custom state
+}
+
+-- | Generation of inital state
+newDB :: DB
+newDB = DB {
+ dbAuth = A.newModel
+ , dbCustom = ()
+ }
+
+instance HasModelRead DB where
+ askModel = dbAuth
+
+instance HasModelWrite DB where
+ putModel db m = db { dbAuth = m }
+
+deriveSafeCopy 0 'base ''DB
+
+A.deriveQueries ''DB
+A.makeModelAcidic ''DB
diff --git a/example/acid/src/Main.hs b/example/acid/src/Main.hs
index ffab7ed..c36307c 100644
--- a/example/acid/src/Main.hs
+++ b/example/acid/src/Main.hs
@@ -1,35 +1,35 @@
-module Main where
-
-import Data.Monoid
-import Options.Applicative
-
-import Server
-
--- | Argument line options
-data Options = Options {
- -- | Path to config, if not set, the app will not start
- configPath :: FilePath
-}
-
--- | Command line parser
-optionsParser :: Parser Options
-optionsParser = Options
- <$> strOption (
- long "conf"
- <> metavar "CONFIG"
- <> help "Path to configuration file"
- )
-
--- | Execute server with given options
-runServer :: Options -> IO ()
-runServer Options{..} = do
- cfg <- readConfig configPath
- runExampleServer cfg
-
-main :: IO ()
-main = execParser opts >>= runServer
- where
- opts = info (helper <*> optionsParser)
- ( fullDesc
- <> progDesc "Example server for servant-auth-token"
- <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" )
+module Main where
+
+import Data.Monoid
+import Options.Applicative
+
+import Server
+
+-- | Argument line options
+data Options = Options {
+ -- | Path to config, if not set, the app will not start
+ configPath :: FilePath
+}
+
+-- | Command line parser
+optionsParser :: Parser Options
+optionsParser = Options
+ <$> strOption (
+ long "conf"
+ <> metavar "CONFIG"
+ <> help "Path to configuration file"
+ )
+
+-- | Execute server with given options
+runServer :: Options -> IO ()
+runServer Options{..} = do
+ cfg <- readConfig configPath
+ runExampleServer cfg
+
+main :: IO ()
+main = execParser opts >>= runServer
+ where
+ opts = info (helper <*> optionsParser)
+ ( fullDesc
+ <> progDesc "Example server for servant-auth-token"
+ <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" )
diff --git a/example/acid/src/Monad.hs b/example/acid/src/Monad.hs
index b1b57ba..4142449 100644
--- a/example/acid/src/Monad.hs
+++ b/example/acid/src/Monad.hs
@@ -1,98 +1,98 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Monad(
- ServerEnv(..)
- , ServerM
- , newServerEnv
- , runServerM
- , runServerMIO
- , serverMtoHandler
- , AuthM(..)
- , runAuth
- ) where
-
-import Control.Monad.Base
-import Control.Monad.Catch (MonadCatch, MonadThrow)
-import Control.Monad.Except
-import Control.Monad.Logger
-import Control.Monad.Reader
-import Control.Monad.Trans.Control
-import Data.Acid
-import Data.Monoid
-import Data.Text (unpack)
-import Servant.Server
-import Servant.Server.Auth.Token.Acid as A
-import Servant.Server.Auth.Token.Config
-import Servant.Server.Auth.Token.Model
-
-import Config
-import DB
-
--- | Server private environment
-data ServerEnv = ServerEnv {
- -- | Configuration used to create the server
- envConfig :: !ServerConfig
- -- | Configuration of auth server
-, envAuthConfig :: !AuthConfig
- -- | DB state
-, envDB :: !(AcidState DB)
-}
-
--- | Create new server environment
-newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
-newServerEnv cfg = do
- let authConfig = defaultAuthConfig
- db <- liftIO $ openLocalStateFrom (unpack $ serverDbPath cfg) newDB
- -- ensure default admin if missing one
- _ <- runAcidBackendT authConfig db $ ensureAdmin 17 "admin" "123456" "admin@localhost"
- let env = ServerEnv {
- envConfig = cfg
- , envAuthConfig = authConfig
- , envDB = db
- }
- return env
-
--- | Server monad that holds internal environment
-newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
- , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
-
-newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
-
-instance MonadBaseControl IO ServerM where
- type StM ServerM a = StMServerM a
- liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
- restoreM = ServerM . restoreM . unStMServerM
-
--- | Lift servant monad to server monad
-liftHandler :: Handler a -> ServerM a
-liftHandler = ServerM . lift . lift
-
--- | Execution of 'ServerM'
-runServerM :: ServerEnv -> ServerM a -> Handler a
-runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
-
--- | Execution of 'ServerM' in IO monad
-runServerMIO :: ServerEnv -> ServerM a -> IO a
-runServerMIO env m = do
- ea <- runExceptT $ runServerM env m
- case ea of
- Left e -> fail $ "runServerMIO: " <> show e
- Right a -> return a
-
--- | Transformation to Servant 'Handler'
-serverMtoHandler :: ServerEnv -> ServerM :~> Handler
-serverMtoHandler e = Nat (runServerM e)
-
--- Derive HasStorage for 'AcidBackendT' with your 'DB'
-deriveAcidHasStorage ''DB
-
--- | Special monad for authorisation actions
-newtype AuthM a = AuthM { unAuthM :: AcidBackendT DB IO a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage)
-
--- | Execution of authorisation actions that require 'AuthHandler' context
-runAuth :: AuthM a -> ServerM a
-runAuth m = do
- cfg <- asks envAuthConfig
- db <- asks envDB
- liftHandler $ ExceptT $ runAcidBackendT cfg db $ unAuthM m
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Monad(
+ ServerEnv(..)
+ , ServerM
+ , newServerEnv
+ , runServerM
+ , runServerMIO
+ , serverMtoHandler
+ , AuthM(..)
+ , runAuth
+ ) where
+
+import Control.Monad.Base
+import Control.Monad.Catch (MonadCatch, MonadThrow)
+import Control.Monad.Except
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Acid
+import Data.Monoid
+import Data.Text (unpack)
+import Servant.Server
+import Servant.Server.Auth.Token.Acid as A
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+
+import Config
+import DB
+
+-- | Server private environment
+data ServerEnv = ServerEnv {
+ -- | Configuration used to create the server
+ envConfig :: !ServerConfig
+ -- | Configuration of auth server
+, envAuthConfig :: !AuthConfig
+ -- | DB state
+, envDB :: !(AcidState DB)
+}
+
+-- | Create new server environment
+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
+newServerEnv cfg = do
+ let authConfig = defaultAuthConfig
+ db <- liftIO $ openLocalStateFrom (unpack $ serverDbPath cfg) newDB
+ -- ensure default admin if missing one
+ _ <- runAcidBackendT authConfig db $ ensureAdmin 17 "admin" "123456" "admin@localhost"
+ let env = ServerEnv {
+ envConfig = cfg
+ , envAuthConfig = authConfig
+ , envDB = db
+ }
+ return env
+
+-- | Server monad that holds internal environment
+newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
+ , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
+
+newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
+
+instance MonadBaseControl IO ServerM where
+ type StM ServerM a = StMServerM a
+ liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
+ restoreM = ServerM . restoreM . unStMServerM
+
+-- | Lift servant monad to server monad
+liftHandler :: Handler a -> ServerM a
+liftHandler = ServerM . lift . lift
+
+-- | Execution of 'ServerM'
+runServerM :: ServerEnv -> ServerM a -> Handler a
+runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
+
+-- | Execution of 'ServerM' in IO monad
+runServerMIO :: ServerEnv -> ServerM a -> IO a
+runServerMIO env m = do
+ ea <- runExceptT $ runServerM env m
+ case ea of
+ Left e -> fail $ "runServerMIO: " <> show e
+ Right a -> return a
+
+-- | Transformation to Servant 'Handler'
+serverMtoHandler :: ServerEnv -> ServerM :~> Handler
+serverMtoHandler e = Nat (runServerM e)
+
+-- Derive HasStorage for 'AcidBackendT' with your 'DB'
+deriveAcidHasStorage ''DB
+
+-- | Special monad for authorisation actions
+newtype AuthM a = AuthM { unAuthM :: AcidBackendT DB IO a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage)
+
+-- | Execution of authorisation actions that require 'AuthHandler' context
+runAuth :: AuthM a -> ServerM a
+runAuth m = do
+ cfg <- asks envAuthConfig
+ db <- asks envDB
+ liftHandler $ ExceptT $ runAcidBackendT cfg db $ unAuthM m
diff --git a/example/acid/src/Server.hs b/example/acid/src/Server.hs
index 41a9e85..9fc3be0 100644
--- a/example/acid/src/Server.hs
+++ b/example/acid/src/Server.hs
@@ -1,49 +1,49 @@
-module Server(
- -- * Server config
- ServerConfig(..)
- , readConfig
- -- * Server environment
- , ServerEnv
- , newServerEnv
- -- * Execution of server
- , exampleServerApp
- , runExampleServer
- ) where
-
-import Control.Monad.IO.Class
-import Control.Monad.Logger
-import Data.Proxy
-import Network.Wai
-import Network.Wai.Handler.Warp
-import Network.Wai.Middleware.RequestLogger
-import Servant.API.Auth.Token
-import Servant.Server
-import Servant.Server.Auth.Token
-
-import API
-import Config
-import Monad
-
--- | Enter infinite loop of processing requests for pdf-master-server.
---
--- Starts new Warp server with initialised threads for serving the master server.
-runExampleServer :: MonadIO m => ServerConfig -> m ()
-runExampleServer config = liftIO $ do
- env <- newServerEnv config
- liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env
-
--- | WAI application of server
-exampleServerApp :: ServerEnv -> Application
-exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl
- where
- apiImpl = enter (serverMtoHandler e) exampleServer
-
--- | Implementation of main server API
-exampleServer :: ServerT ExampleAPI ServerM
-exampleServer = testEndpoint
-
-testEndpoint :: MToken' '["test-permission"] -> ServerM ()
-testEndpoint token = do
- runAuth $ guardAuthToken token
- $logInfo "testEndpoint"
- return ()
+module Server(
+ -- * Server config
+ ServerConfig(..)
+ , readConfig
+ -- * Server environment
+ , ServerEnv
+ , newServerEnv
+ -- * Execution of server
+ , exampleServerApp
+ , runExampleServer
+ ) where
+
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Data.Proxy
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.RequestLogger
+import Servant.API.Auth.Token
+import Servant.Server
+import Servant.Server.Auth.Token
+
+import API
+import Config
+import Monad
+
+-- | Enter infinite loop of processing requests for pdf-master-server.
+--
+-- Starts new Warp server with initialised threads for serving the master server.
+runExampleServer :: MonadIO m => ServerConfig -> m ()
+runExampleServer config = liftIO $ do
+ env <- newServerEnv config
+ liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env
+
+-- | WAI application of server
+exampleServerApp :: ServerEnv -> Application
+exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl
+ where
+ apiImpl = enter (serverMtoHandler e) exampleServer
+
+-- | Implementation of main server API
+exampleServer :: ServerT ExampleAPI ServerM
+exampleServer = testEndpoint
+
+testEndpoint :: MToken' '["test-permission"] -> ServerM ()
+testEndpoint token = do
+ runAuth $ guardAuthToken token
+ $logInfo "testEndpoint"
+ return ()
diff --git a/example/leveldb/LICENSE b/example/leveldb/LICENSE
index e1a0e52..18d524c 100644
--- a/example/leveldb/LICENSE
+++ b/example/leveldb/LICENSE
@@ -1,30 +1,30 @@
-Copyright Anton Gushcha (c) 2016
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of NCrashed nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright Anton Gushcha (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of NCrashed nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/example/leveldb/Setup.hs b/example/leveldb/Setup.hs
index 9a994af..833b4c6 100644
--- a/example/leveldb/Setup.hs
+++ b/example/leveldb/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple
+main = defaultMain
diff --git a/example/leveldb/config.yaml b/example/leveldb/config.yaml
index ec3852f..2423477 100644
--- a/example/leveldb/config.yaml
+++ b/example/leveldb/config.yaml
@@ -1,3 +1,3 @@
-host: localhost
-port: 3000
-db: "state"
+host: localhost
+port: 3000
+db: "state"
diff --git a/example/leveldb/servant-auth-token-example-leveldb.cabal b/example/leveldb/servant-auth-token-example-leveldb.cabal
index 4ead172..dc4e57f 100644
--- a/example/leveldb/servant-auth-token-example-leveldb.cabal
+++ b/example/leveldb/servant-auth-token-example-leveldb.cabal
@@ -1,70 +1,70 @@
-name: servant-auth-token-example-leveldb
-version: 0.4.0.1
-synopsis: Example server for token auth for leveldb backend
-description: Please see README.md
-homepage: https://github.com/ncrashed/servant-auth-token#readme
-license: BSD3
-license-file: LICENSE
-author: NCrashed
-maintainer: ncrashed@gmail.com
-copyright: 2017 Anton Gushcha
-category: Web
-build-type: Simple
-cabal-version: >=1.10
-
-executable servant-auth-token-example-leveldb
- hs-source-dirs: src
- main-is: Main.hs
- other-modules:
- API
- Config
- Monad
- Server
- default-language: Haskell2010
- build-depends:
- base >= 4.7 && < 5
- , acid-state >= 0.14 && < 0.15
- , aeson >= 0.11 && < 1.1
- , aeson-injector >= 1.0 && < 1.1
- , bytestring >= 0.10 && < 0.11
- , exceptions >= 0.8 && < 0.9
- , http-types >= 0.9 && < 0.10
- , leveldb-haskell >= 0.6 && < 0.7
- , monad-control >= 1.0 && < 1.1
- , monad-logger >= 0.3 && < 0.4
- , mtl >= 2.2 && < 2.3
- , optparse-applicative >= 0.12 && < 0.14
- , safecopy-store >= 0.9 && < 0.10
- , servant >= 0.9 && < 0.10
- , servant-auth-token >= 0.4 && < 0.5
- , servant-auth-token-api >= 0.4 && < 0.5
- , servant-auth-token-leveldb >= 0.4 && < 0.5
- , servant-server >= 0.9 && < 0.10
- , text >= 1.2 && < 1.3
- , time >= 1.6 && < 1.7
- , transformers-base >= 0.4 && < 0.5
- , wai >= 3.2 && < 3.3
- , wai-extra >= 3.0 && < 3.1
- , warp >= 3.2 && < 3.3
- , yaml >= 0.8 && < 0.9
- default-extensions:
- BangPatterns
- DataKinds
- DeriveFunctor
- DeriveGeneric
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GeneralizedNewtypeDeriving
- MultiParamTypeClasses
- OverloadedStrings
- RecordWildCards
- RecursiveDo
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TypeFamilies
- TypeOperators
- UndecidableInstances
-
- ghc-options: -threaded
+name: servant-auth-token-example-leveldb
+version: 0.4.0.1
+synopsis: Example server for token auth for leveldb backend
+description: Please see README.md
+homepage: https://github.com/ncrashed/servant-auth-token#readme
+license: BSD3
+license-file: LICENSE
+author: NCrashed
+maintainer: ncrashed@gmail.com
+copyright: 2017 Anton Gushcha
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+
+executable servant-auth-token-example-leveldb
+ hs-source-dirs: src
+ main-is: Main.hs
+ other-modules:
+ API
+ Config
+ Monad
+ Server
+ default-language: Haskell2010
+ build-depends:
+ base >= 4.7 && < 5
+ , acid-state >= 0.14 && < 0.15
+ , aeson >= 0.11 && < 1.1
+ , aeson-injector >= 1.0 && < 1.1
+ , bytestring >= 0.10 && < 0.11
+ , exceptions >= 0.8 && < 0.9
+ , http-types >= 0.9 && < 0.10
+ , leveldb-haskell >= 0.6 && < 0.7
+ , monad-control >= 1.0 && < 1.1
+ , monad-logger >= 0.3 && < 0.4
+ , mtl >= 2.2 && < 2.3
+ , optparse-applicative >= 0.12 && < 0.14
+ , safecopy-store >= 0.9 && < 0.10
+ , servant >= 0.9 && < 0.10
+ , servant-auth-token >= 0.4 && < 0.5
+ , servant-auth-token-api >= 0.4 && < 0.5
+ , servant-auth-token-leveldb >= 0.4 && < 0.5
+ , servant-server >= 0.9 && < 0.10
+ , text >= 1.2 && < 1.3
+ , time >= 1.6 && < 1.7
+ , transformers-base >= 0.4 && < 0.5
+ , wai >= 3.2 && < 3.3
+ , wai-extra >= 3.0 && < 3.1
+ , warp >= 3.2 && < 3.3
+ , yaml >= 0.8 && < 0.9
+ default-extensions:
+ BangPatterns
+ DataKinds
+ DeriveFunctor
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ RecursiveDo
+ ScopedTypeVariables
+ StandaloneDeriving
+ TemplateHaskell
+ TypeFamilies
+ TypeOperators
+ UndecidableInstances
+
+ ghc-options: -threaded
diff --git a/example/leveldb/src/API.hs b/example/leveldb/src/API.hs
index 33faeb0..a962619 100644
--- a/example/leveldb/src/API.hs
+++ b/example/leveldb/src/API.hs
@@ -1,10 +1,10 @@
-module API(
- ExampleAPI
- ) where
-
-import Servant.API
-import Servant.API.Auth.Token
-
-type ExampleAPI = "test"
- :> TokenHeader' '["test-permission"]
- :> Get '[JSON] ()
+module API(
+ ExampleAPI
+ ) where
+
+import Servant.API
+import Servant.API.Auth.Token
+
+type ExampleAPI = "test"
+ :> TokenHeader' '["test-permission"]
+ :> Get '[JSON] ()
diff --git a/example/leveldb/src/Config.hs b/example/leveldb/src/Config.hs
index 732538f..d1b46e8 100644
--- a/example/leveldb/src/Config.hs
+++ b/example/leveldb/src/Config.hs
@@ -1,30 +1,30 @@
-module Config(
- ServerConfig(..)
- , readConfig
- ) where
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Aeson
-import Data.Text
-import Data.Yaml.Config
-
--- | Startup configuration of server
-data ServerConfig = ServerConfig {
- -- | Server host name
- serverHost :: !Text
- -- | Server port number
-, serverPort :: !Int
- -- | Server db location
-, serverDbPath :: !Text
-}
-
-instance FromJSON ServerConfig where
- parseJSON (Object o) = ServerConfig
- <$> o .: "host"
- <*> o .: "port"
- <*> o .: "db"
- parseJSON _ = mzero
-
-readConfig :: MonadIO m => FilePath -> m ServerConfig
-readConfig f = liftIO $ loadYamlSettings [f] [] useEnv
+module Config(
+ ServerConfig(..)
+ , readConfig
+ ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson
+import Data.Text
+import Data.Yaml.Config
+
+-- | Startup configuration of server
+data ServerConfig = ServerConfig {
+ -- | Server host name
+ serverHost :: !Text
+ -- | Server port number
+, serverPort :: !Int
+ -- | Server db location
+, serverDbPath :: !Text
+}
+
+instance FromJSON ServerConfig where
+ parseJSON (Object o) = ServerConfig
+ <$> o .: "host"
+ <*> o .: "port"
+ <*> o .: "db"
+ parseJSON _ = mzero
+
+readConfig :: MonadIO m => FilePath -> m ServerConfig
+readConfig f = liftIO $ loadYamlSettings [f] [] useEnv
diff --git a/example/leveldb/src/Main.hs b/example/leveldb/src/Main.hs
index ffab7ed..c36307c 100644
--- a/example/leveldb/src/Main.hs
+++ b/example/leveldb/src/Main.hs
@@ -1,35 +1,35 @@
-module Main where
-
-import Data.Monoid
-import Options.Applicative
-
-import Server
-
--- | Argument line options
-data Options = Options {
- -- | Path to config, if not set, the app will not start
- configPath :: FilePath
-}
-
--- | Command line parser
-optionsParser :: Parser Options
-optionsParser = Options
- <$> strOption (
- long "conf"
- <> metavar "CONFIG"
- <> help "Path to configuration file"
- )
-
--- | Execute server with given options
-runServer :: Options -> IO ()
-runServer Options{..} = do
- cfg <- readConfig configPath
- runExampleServer cfg
-
-main :: IO ()
-main = execParser opts >>= runServer
- where
- opts = info (helper <*> optionsParser)
- ( fullDesc
- <> progDesc "Example server for servant-auth-token"
- <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" )
+module Main where
+
+import Data.Monoid
+import Options.Applicative
+
+import Server
+
+-- | Argument line options
+data Options = Options {
+ -- | Path to config, if not set, the app will not start
+ configPath :: FilePath
+}
+
+-- | Command line parser
+optionsParser :: Parser Options
+optionsParser = Options
+ <$> strOption (
+ long "conf"
+ <> metavar "CONFIG"
+ <> help "Path to configuration file"
+ )
+
+-- | Execute server with given options
+runServer :: Options -> IO ()
+runServer Options{..} = do
+ cfg <- readConfig configPath
+ runExampleServer cfg
+
+main :: IO ()
+main = execParser opts >>= runServer
+ where
+ opts = info (helper <*> optionsParser)
+ ( fullDesc
+ <> progDesc "Example server for servant-auth-token"
+ <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" )
diff --git a/example/leveldb/src/Monad.hs b/example/leveldb/src/Monad.hs
index b1f867d..bc9422b 100644
--- a/example/leveldb/src/Monad.hs
+++ b/example/leveldb/src/Monad.hs
@@ -1,98 +1,98 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Monad(
- ServerEnv(..)
- , ServerM
- , newServerEnv
- , runServerM
- , runServerMIO
- , serverMtoHandler
- , AuthM(..)
- , runAuth
- ) where
-
-import Control.Monad.Base
-import Control.Monad.Catch (MonadCatch, MonadThrow)
-import Control.Monad.Except
-import Control.Monad.Logger
-import Control.Monad.Reader
-import Control.Monad.Trans.Control
-import Data.Acid
-import Data.Monoid
-import Data.Text (unpack)
-import Database.LevelDB.MonadResource
-import Servant.Server
-import Servant.Server.Auth.Token.Config
-import Servant.Server.Auth.Token.LevelDB
-import Servant.Server.Auth.Token.Model
-
-import Config
-
--- | Server private environment
-data ServerEnv = ServerEnv {
- -- | Configuration used to create the server
- envConfig :: !ServerConfig
- -- | Configuration of auth server
-, envAuthConfig :: !AuthConfig
- -- | DB state
-, envDB :: !LevelDBEnv
-}
-
--- | Create new server environment
-newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
-newServerEnv cfg = do
- let authConfig = defaultAuthConfig
- dbEnv <- liftIO . runResourceT $ do
- db <- open (unpack $ serverDbPath cfg) defaultOptions { createIfMissing = True }
- dbEnv <- newLevelDBEnv db defaultReadOptions defaultWriteOptions
- -- ensure default admin if missing one
- _ <- runLevelDBBackendT authConfig dbEnv $ ensureAdmin 17 "admin" "123456" "admin@localhost"
- return dbEnv
- let env = ServerEnv {
- envConfig = cfg
- , envAuthConfig = authConfig
- , envDB = dbEnv
- }
- return env
-
--- | Server monad that holds internal environment
-newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
- , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
-
-newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
-
-instance MonadBaseControl IO ServerM where
- type StM ServerM a = StMServerM a
- liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
- restoreM = ServerM . restoreM . unStMServerM
-
--- | Lift servant monad to server monad
-liftHandler :: Handler a -> ServerM a
-liftHandler = ServerM . lift . lift
-
--- | Execution of 'ServerM'
-runServerM :: ServerEnv -> ServerM a -> Handler a
-runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
-
--- | Execution of 'ServerM' in IO monad
-runServerMIO :: ServerEnv -> ServerM a -> IO a
-runServerMIO env m = do
- ea <- runExceptT $ runServerM env m
- case ea of
- Left e -> fail $ "runServerMIO: " <> show e
- Right a -> return a
-
--- | Transformation to Servant 'Handler'
-serverMtoHandler :: ServerEnv -> ServerM :~> Handler
-serverMtoHandler e = Nat (runServerM e)
-
--- | Special monad for authorisation actions
-newtype AuthM a = AuthM { unAuthM :: LevelDBBackendT IO a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage)
-
--- | Execution of authorisation actions that require 'AuthHandler' context
-runAuth :: AuthM a -> ServerM a
-runAuth m = do
- cfg <- asks envAuthConfig
- db <- asks envDB
- liftHandler $ ExceptT $ runLevelDBBackendT cfg db $ unAuthM m
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Monad(
+ ServerEnv(..)
+ , ServerM
+ , newServerEnv
+ , runServerM
+ , runServerMIO
+ , serverMtoHandler
+ , AuthM(..)
+ , runAuth
+ ) where
+
+import Control.Monad.Base
+import Control.Monad.Catch (MonadCatch, MonadThrow)
+import Control.Monad.Except
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Acid
+import Data.Monoid
+import Data.Text (unpack)
+import Database.LevelDB.MonadResource
+import Servant.Server
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.LevelDB
+import Servant.Server.Auth.Token.Model
+
+import Config
+
+-- | Server private environment
+data ServerEnv = ServerEnv {
+ -- | Configuration used to create the server
+ envConfig :: !ServerConfig
+ -- | Configuration of auth server
+, envAuthConfig :: !AuthConfig
+ -- | DB state
+, envDB :: !LevelDBEnv
+}
+
+-- | Create new server environment
+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
+newServerEnv cfg = do
+ let authConfig = defaultAuthConfig
+ dbEnv <- liftIO . runResourceT $ do
+ db <- open (unpack $ serverDbPath cfg) defaultOptions { createIfMissing = True }
+ dbEnv <- newLevelDBEnv db defaultReadOptions defaultWriteOptions
+ -- ensure default admin if missing one
+ _ <- runLevelDBBackendT authConfig dbEnv $ ensureAdmin 17 "admin" "123456" "admin@localhost"
+ return dbEnv
+ let env = ServerEnv {
+ envConfig = cfg
+ , envAuthConfig = authConfig
+ , envDB = dbEnv
+ }
+ return env
+
+-- | Server monad that holds internal environment
+newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
+ , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
+
+newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
+
+instance MonadBaseControl IO ServerM where
+ type StM ServerM a = StMServerM a
+ liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
+ restoreM = ServerM . restoreM . unStMServerM
+
+-- | Lift servant monad to server monad
+liftHandler :: Handler a -> ServerM a
+liftHandler = ServerM . lift . lift
+
+-- | Execution of 'ServerM'
+runServerM :: ServerEnv -> ServerM a -> Handler a
+runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
+
+-- | Execution of 'ServerM' in IO monad
+runServerMIO :: ServerEnv -> ServerM a -> IO a
+runServerMIO env m = do
+ ea <- runExceptT $ runServerM env m
+ case ea of
+ Left e -> fail $ "runServerMIO: " <> show e
+ Right a -> return a
+
+-- | Transformation to Servant 'Handler'
+serverMtoHandler :: ServerEnv -> ServerM :~> Handler
+serverMtoHandler e = Nat (runServerM e)
+
+-- | Special monad for authorisation actions
+newtype AuthM a = AuthM { unAuthM :: LevelDBBackendT IO a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasAuthConfig, HasStorage)
+
+-- | Execution of authorisation actions that require 'AuthHandler' context
+runAuth :: AuthM a -> ServerM a
+runAuth m = do
+ cfg <- asks envAuthConfig
+ db <- asks envDB
+ liftHandler $ ExceptT $ runLevelDBBackendT cfg db $ unAuthM m
diff --git a/example/leveldb/src/Server.hs b/example/leveldb/src/Server.hs
index 41a9e85..9fc3be0 100644
--- a/example/leveldb/src/Server.hs
+++ b/example/leveldb/src/Server.hs
@@ -1,49 +1,49 @@
-module Server(
- -- * Server config
- ServerConfig(..)
- , readConfig
- -- * Server environment
- , ServerEnv
- , newServerEnv
- -- * Execution of server
- , exampleServerApp
- , runExampleServer
- ) where
-
-import Control.Monad.IO.Class
-import Control.Monad.Logger
-import Data.Proxy
-import Network.Wai
-import Network.Wai.Handler.Warp
-import Network.Wai.Middleware.RequestLogger
-import Servant.API.Auth.Token
-import Servant.Server
-import Servant.Server.Auth.Token
-
-import API
-import Config
-import Monad
-
--- | Enter infinite loop of processing requests for pdf-master-server.
---
--- Starts new Warp server with initialised threads for serving the master server.
-runExampleServer :: MonadIO m => ServerConfig -> m ()
-runExampleServer config = liftIO $ do
- env <- newServerEnv config
- liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env
-
--- | WAI application of server
-exampleServerApp :: ServerEnv -> Application
-exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl
- where
- apiImpl = enter (serverMtoHandler e) exampleServer
-
--- | Implementation of main server API
-exampleServer :: ServerT ExampleAPI ServerM
-exampleServer = testEndpoint
-
-testEndpoint :: MToken' '["test-permission"] -> ServerM ()
-testEndpoint token = do
- runAuth $ guardAuthToken token
- $logInfo "testEndpoint"
- return ()
+module Server(
+ -- * Server config
+ ServerConfig(..)
+ , readConfig
+ -- * Server environment
+ , ServerEnv
+ , newServerEnv
+ -- * Execution of server
+ , exampleServerApp
+ , runExampleServer
+ ) where
+
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Data.Proxy
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.RequestLogger
+import Servant.API.Auth.Token
+import Servant.Server
+import Servant.Server.Auth.Token
+
+import API
+import Config
+import Monad
+
+-- | Enter infinite loop of processing requests for pdf-master-server.
+--
+-- Starts new Warp server with initialised threads for serving the master server.
+runExampleServer :: MonadIO m => ServerConfig -> m ()
+runExampleServer config = liftIO $ do
+ env <- newServerEnv config
+ liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env
+
+-- | WAI application of server
+exampleServerApp :: ServerEnv -> Application
+exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl
+ where
+ apiImpl = enter (serverMtoHandler e) exampleServer
+
+-- | Implementation of main server API
+exampleServer :: ServerT ExampleAPI ServerM
+exampleServer = testEndpoint
+
+testEndpoint :: MToken' '["test-permission"] -> ServerM ()
+testEndpoint token = do
+ runAuth $ guardAuthToken token
+ $logInfo "testEndpoint"
+ return ()
diff --git a/example/persistent/LICENSE b/example/persistent/LICENSE
index e1a0e52..18d524c 100644
--- a/example/persistent/LICENSE
+++ b/example/persistent/LICENSE
@@ -1,30 +1,30 @@
-Copyright Anton Gushcha (c) 2016
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of NCrashed nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright Anton Gushcha (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of NCrashed nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/example/persistent/Setup.hs b/example/persistent/Setup.hs
index 9a994af..833b4c6 100644
--- a/example/persistent/Setup.hs
+++ b/example/persistent/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple
+main = defaultMain
diff --git a/example/persistent/config.yaml b/example/persistent/config.yaml
index 83392be..71262b7 100644
--- a/example/persistent/config.yaml
+++ b/example/persistent/config.yaml
@@ -1,8 +1,8 @@
-host: localhost
-port: 3000
-db-host: localhost
-db-port: 5432
-db-user: postgres
-db-pass: ""
-db-base: auth-test
-db-size: 10
+host: localhost
+port: 3000
+db-host: localhost
+db-port: 5432
+db-user: postgres
+db-pass: ""
+db-base: auth-test
+db-size: 10
diff --git a/example/persistent/servant-auth-token-example-persistent.cabal b/example/persistent/servant-auth-token-example-persistent.cabal
index eb1d969..eda2cd6 100644
--- a/example/persistent/servant-auth-token-example-persistent.cabal
+++ b/example/persistent/servant-auth-token-example-persistent.cabal
@@ -1,69 +1,69 @@
-name: servant-auth-token-example-persistent
-version: 0.4.0.1
-synopsis: Example server for token auth for persistent backend
-description: Please see README.md
-homepage: https://github.com/ncrashed/servant-auth-token#readme
-license: BSD3
-license-file: LICENSE
-author: NCrashed
-maintainer: ncrashed@gmail.com
-copyright: 2017 Anton Gushcha
-category: Web
-build-type: Simple
-cabal-version: >=1.10
-
-executable servant-auth-token-example-persistent
- hs-source-dirs: src
- main-is: Main.hs
- other-modules:
- API
- Config
- Monad
- Server
- default-language: Haskell2010
- build-depends:
- base >= 4.7 && < 5
- , aeson >= 0.11 && < 1.1
- , aeson-injector >= 1.0 && < 1.1
- , bytestring >= 0.10 && < 0.11
- , exceptions >= 0.8 && < 0.9
- , http-types >= 0.9 && < 0.10
- , monad-control >= 1.0 && < 1.1
- , monad-logger >= 0.3 && < 0.4
- , mtl >= 2.2 && < 2.3
- , optparse-applicative >= 0.12 && < 0.14
- , persistent >= 2.6 && < 2.7
- , persistent-postgresql >= 2.6 && < 2.7
- , servant >= 0.9 && < 0.10
- , servant-auth-token >= 0.4 && < 0.5
- , servant-auth-token-api >= 0.4 && < 0.5
- , servant-auth-token-persistent >= 0.4 && < 0.6
- , servant-server >= 0.9 && < 0.10
- , text >= 1.2 && < 1.3
- , time >= 1.6 && < 1.7
- , transformers-base >= 0.4 && < 0.5
- , wai >= 3.2 && < 3.3
- , wai-extra >= 3.0 && < 3.1
- , warp >= 3.2 && < 3.3
- , yaml >= 0.8 && < 0.9
- default-extensions:
- BangPatterns
- DataKinds
- DeriveFunctor
- DeriveGeneric
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GeneralizedNewtypeDeriving
- MultiParamTypeClasses
- OverloadedStrings
- RecordWildCards
- RecursiveDo
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TypeFamilies
- TypeOperators
- UndecidableInstances
-
- ghc-options: -threaded
+name: servant-auth-token-example-persistent
+version: 0.4.0.1
+synopsis: Example server for token auth for persistent backend
+description: Please see README.md
+homepage: https://github.com/ncrashed/servant-auth-token#readme
+license: BSD3
+license-file: LICENSE
+author: NCrashed
+maintainer: ncrashed@gmail.com
+copyright: 2017 Anton Gushcha
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+
+executable servant-auth-token-example-persistent
+ hs-source-dirs: src
+ main-is: Main.hs
+ other-modules:
+ API
+ Config
+ Monad
+ Server
+ default-language: Haskell2010
+ build-depends:
+ base >= 4.7 && < 5
+ , aeson >= 0.11 && < 1.1
+ , aeson-injector >= 1.0 && < 1.1
+ , bytestring >= 0.10 && < 0.11
+ , exceptions >= 0.8 && < 0.9
+ , http-types >= 0.9 && < 0.10
+ , monad-control >= 1.0 && < 1.1
+ , monad-logger >= 0.3 && < 0.4
+ , mtl >= 2.2 && < 2.3
+ , optparse-applicative >= 0.12 && < 0.14
+ , persistent >= 2.6 && < 2.7
+ , persistent-postgresql >= 2.6 && < 2.7
+ , servant >= 0.9 && < 0.10
+ , servant-auth-token >= 0.4 && < 0.5
+ , servant-auth-token-api >= 0.4 && < 0.5
+ , servant-auth-token-persistent >= 0.4 && < 0.6
+ , servant-server >= 0.9 && < 0.10
+ , text >= 1.2 && < 1.3
+ , time >= 1.6 && < 1.7
+ , transformers-base >= 0.4 && < 0.5
+ , wai >= 3.2 && < 3.3
+ , wai-extra >= 3.0 && < 3.1
+ , warp >= 3.2 && < 3.3
+ , yaml >= 0.8 && < 0.9
+ default-extensions:
+ BangPatterns
+ DataKinds
+ DeriveFunctor
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ RecursiveDo
+ ScopedTypeVariables
+ StandaloneDeriving
+ TemplateHaskell
+ TypeFamilies
+ TypeOperators
+ UndecidableInstances
+
+ ghc-options: -threaded
diff --git a/example/persistent/src/API.hs b/example/persistent/src/API.hs
index 33faeb0..a962619 100644
--- a/example/persistent/src/API.hs
+++ b/example/persistent/src/API.hs
@@ -1,10 +1,10 @@
-module API(
- ExampleAPI
- ) where
-
-import Servant.API
-import Servant.API.Auth.Token
-
-type ExampleAPI = "test"
- :> TokenHeader' '["test-permission"]
- :> Get '[JSON] ()
+module API(
+ ExampleAPI
+ ) where
+
+import Servant.API
+import Servant.API.Auth.Token
+
+type ExampleAPI = "test"
+ :> TokenHeader' '["test-permission"]
+ :> Get '[JSON] ()
diff --git a/example/persistent/src/Config.hs b/example/persistent/src/Config.hs
index 972508d..28cac60 100644
--- a/example/persistent/src/Config.hs
+++ b/example/persistent/src/Config.hs
@@ -1,58 +1,58 @@
-module Config(
- ServerConfig(..)
- , readConfig
- , createPool
- ) where
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Logger
-import Data.Aeson
-import Data.Monoid
-import Data.Text
-import Data.Text.Encoding
-import Data.Yaml.Config
-
-import Database.Persist.Postgresql
-
--- | Startup configuration of server
-data ServerConfig = ServerConfig {
- -- | Server host name
- serverHost :: !Text
- -- | Server port number
-, serverPort :: !Int
- -- | DB host
-, serverDBHost :: !Text
- -- | DB port
-, serverDBPort :: !Int
- -- | DB user
-, serverDBUser :: !Text
- -- | DB user password
-, serverDBPass :: !Text
- -- | DB database
-, serverDBBase :: !Text
- -- | DB pool size
-, serverDBSize :: !Int
-}
-
-instance FromJSON ServerConfig where
- parseJSON (Object o) = ServerConfig
- <$> o .: "host"
- <*> o .: "port"
- <*> o .: "db-host"
- <*> o .: "db-port"
- <*> o .: "db-user"
- <*> o .: "db-pass"
- <*> o .: "db-base"
- <*> o .: "db-size"
- parseJSON _ = mzero
-
-readConfig :: MonadIO m => FilePath -> m ServerConfig
-readConfig f = liftIO $ loadYamlSettings [f] [] useEnv
-
--- | Create connection pool to postgres
-createPool :: ServerConfig -> IO ConnectionPool
-createPool ServerConfig{..} = runStdoutLoggingT $ createPostgresqlPool constr serverDBSize
- where
- constr = encodeUtf8 $ "host=" <> serverDBHost <> " port=" <> (pack . show $ serverDBPort)
- <> " user=" <> serverDBUser <> " password=" <> serverDBPass <> " database=" <> serverDBBase
+module Config(
+ ServerConfig(..)
+ , readConfig
+ , createPool
+ ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Data.Aeson
+import Data.Monoid
+import Data.Text
+import Data.Text.Encoding
+import Data.Yaml.Config
+
+import Database.Persist.Postgresql
+
+-- | Startup configuration of server
+data ServerConfig = ServerConfig {
+ -- | Server host name
+ serverHost :: !Text
+ -- | Server port number
+, serverPort :: !Int
+ -- | DB host
+, serverDBHost :: !Text
+ -- | DB port
+, serverDBPort :: !Int
+ -- | DB user
+, serverDBUser :: !Text
+ -- | DB user password
+, serverDBPass :: !Text
+ -- | DB database
+, serverDBBase :: !Text
+ -- | DB pool size
+, serverDBSize :: !Int
+}
+
+instance FromJSON ServerConfig where
+ parseJSON (Object o) = ServerConfig
+ <$> o .: "host"
+ <*> o .: "port"
+ <*> o .: "db-host"
+ <*> o .: "db-port"
+ <*> o .: "db-user"
+ <*> o .: "db-pass"
+ <*> o .: "db-base"
+ <*> o .: "db-size"
+ parseJSON _ = mzero
+
+readConfig :: MonadIO m => FilePath -> m ServerConfig
+readConfig f = liftIO $ loadYamlSettings [f] [] useEnv
+
+-- | Create connection pool to postgres
+createPool :: ServerConfig -> IO ConnectionPool
+createPool ServerConfig{..} = runStdoutLoggingT $ createPostgresqlPool constr serverDBSize
+ where
+ constr = encodeUtf8 $ "host=" <> serverDBHost <> " port=" <> (pack . show $ serverDBPort)
+ <> " user=" <> serverDBUser <> " password=" <> serverDBPass <> " database=" <> serverDBBase
diff --git a/example/persistent/src/Main.hs b/example/persistent/src/Main.hs
index 98354a5..bb2a30e 100644
--- a/example/persistent/src/Main.hs
+++ b/example/persistent/src/Main.hs
@@ -1,35 +1,35 @@
-module Main where
-
-import Data.Monoid
-import Options.Applicative
-
-import Server
-
--- | Argument line options
-data Options = Options {
- -- | Path to config, if not set, the app will not start
- configPath :: FilePath
-}
-
--- | Command line parser
-optionsParser :: Parser Options
-optionsParser = Options
- <$> strOption (
- long "conf"
- <> metavar "CONFIG"
- <> help "Path to configuration file"
- )
-
--- | Execute server with given options
-runServer :: Options -> IO ()
-runServer Options{..} = do
- cfg <- readConfig configPath
- runExampleServer cfg
-
-main :: IO ()
-main = execParser opts >>= runServer
- where
- opts = info (helper <*> optionsParser)
- ( fullDesc
- <> progDesc "Example server for servant-auth-token"
- <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" )
+module Main where
+
+import Data.Monoid
+import Options.Applicative
+
+import Server
+
+-- | Argument line options
+data Options = Options {
+ -- | Path to config, if not set, the app will not start
+ configPath :: FilePath
+}
+
+-- | Command line parser
+optionsParser :: Parser Options
+optionsParser = Options
+ <$> strOption (
+ long "conf"
+ <> metavar "CONFIG"
+ <> help "Path to configuration file"
+ )
+
+-- | Execute server with given options
+runServer :: Options -> IO ()
+runServer Options{..} = do
+ cfg <- readConfig configPath
+ runExampleServer cfg
+
+main :: IO ()
+main = execParser opts >>= runServer
+ where
+ opts = info (helper <*> optionsParser)
+ ( fullDesc
+ <> progDesc "Example server for servant-auth-token"
+ <> header "servant-auth-token-example-persistent - example of integration of servant token auth library" )
diff --git a/example/persistent/src/Monad.hs b/example/persistent/src/Monad.hs
index 46ea401..4cef7d7 100644
--- a/example/persistent/src/Monad.hs
+++ b/example/persistent/src/Monad.hs
@@ -1,98 +1,98 @@
-module Monad(
- ServerEnv(..)
- , ServerM
- , newServerEnv
- , runServerM
- , runServerMIO
- , serverMtoHandler
- , AuthM(..)
- , runAuth
- ) where
-
-import Control.Monad.Base
-import Control.Monad.Catch (MonadCatch, MonadThrow)
-import Control.Monad.Except
-import Control.Monad.Logger
-import Control.Monad.Reader
-import Control.Monad.Trans.Control
-import Data.Monoid
-import Database.Persist.Sql
-import Servant.Server
-import Servant.Server.Auth.Token.Config
-import Servant.Server.Auth.Token.Model
-import Servant.Server.Auth.Token.Persistent
-
-import qualified Servant.Server.Auth.Token.Persistent.Schema as S
-
-import Config
-
--- | Server private environment
-data ServerEnv = ServerEnv {
- -- | Configuration used to create the server
- envConfig :: !ServerConfig
- -- | Configuration of auth server
-, envAuthConfig :: !AuthConfig
- -- | DB pool
-, envPool :: !ConnectionPool
-}
-
--- | Create new server environment
-newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
-newServerEnv cfg = do
- let authConfig = defaultAuthConfig
- pool <- liftIO $ do
- pool <- createPool cfg
- -- run migrations
- flip runSqlPool pool $ runMigration S.migrateAll
- -- create default admin if missing one
- _ <- runPersistentBackendT authConfig pool $ ensureAdmin 17 "admin" "123456" "admin@localhost"
- return pool
- let env = ServerEnv {
- envConfig = cfg
- , envAuthConfig = authConfig
- , envPool = pool
- }
- return env
-
--- | Server monad that holds internal environment
-newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
- , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
-
-newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
-
-instance MonadBaseControl IO ServerM where
- type StM ServerM a = StMServerM a
- liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
- restoreM = ServerM . restoreM . unStMServerM
-
--- | Lift servant monad to server monad
-liftHandler :: Handler a -> ServerM a
-liftHandler = ServerM . lift . lift
-
--- | Execution of 'ServerM'
-runServerM :: ServerEnv -> ServerM a -> Handler a
-runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
-
--- | Execution of 'ServerM' in IO monad
-runServerMIO :: ServerEnv -> ServerM a -> IO a
-runServerMIO env m = do
- ea <- runExceptT $ runServerM env m
- case ea of
- Left e -> fail $ "runServerMIO: " <> show e
- Right a -> return a
-
--- | Transformation to Servant 'Handler'
-serverMtoHandler :: ServerEnv -> ServerM :~> Handler
-serverMtoHandler e = Nat (runServerM e)
-
--- | Special monad for authorisation actions
-newtype AuthM a = AuthM { unAuthM :: PersistentBackendT IO a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasStorage, HasAuthConfig)
-
--- | Execution of authorisation actions that require 'AuthHandler' context
-runAuth :: AuthM a -> ServerM a
-runAuth m = do
- cfg <- asks envAuthConfig
- pool <- asks envPool
- liftHandler $ ExceptT $ runPersistentBackendT cfg pool $ unAuthM m
+module Monad(
+ ServerEnv(..)
+ , ServerM
+ , newServerEnv
+ , runServerM
+ , runServerMIO
+ , serverMtoHandler
+ , AuthM(..)
+ , runAuth
+ ) where
+
+import Control.Monad.Base
+import Control.Monad.Catch (MonadCatch, MonadThrow)
+import Control.Monad.Except
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Monoid
+import Database.Persist.Sql
+import Servant.Server
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+import Servant.Server.Auth.Token.Persistent
+
+import qualified Servant.Server.Auth.Token.Persistent.Schema as S
+
+import Config
+
+-- | Server private environment
+data ServerEnv = ServerEnv {
+ -- | Configuration used to create the server
+ envConfig :: !ServerConfig
+ -- | Configuration of auth server
+, envAuthConfig :: !AuthConfig
+ -- | DB pool
+, envPool :: !ConnectionPool
+}
+
+-- | Create new server environment
+newServerEnv :: MonadIO m => ServerConfig -> m ServerEnv
+newServerEnv cfg = do
+ let authConfig = defaultAuthConfig
+ pool <- liftIO $ do
+ pool <- createPool cfg
+ -- run migrations
+ flip runSqlPool pool $ runMigration S.migrateAll
+ -- create default admin if missing one
+ _ <- runPersistentBackendT authConfig pool $ ensureAdmin 17 "admin" "123456" "admin@localhost"
+ return pool
+ let env = ServerEnv {
+ envConfig = cfg
+ , envAuthConfig = authConfig
+ , envPool = pool
+ }
+ return env
+
+-- | Server monad that holds internal environment
+newtype ServerM a = ServerM { unServerM :: ReaderT ServerEnv (LoggingT Handler) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadReader ServerEnv
+ , MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadError ServantErr)
+
+newtype StMServerM a = StMServerM { unStMServerM :: StM (ReaderT ServerEnv (LoggingT Handler)) a }
+
+instance MonadBaseControl IO ServerM where
+ type StM ServerM a = StMServerM a
+ liftBaseWith f = ServerM $ liftBaseWith $ \q -> f (fmap StMServerM . q . unServerM)
+ restoreM = ServerM . restoreM . unStMServerM
+
+-- | Lift servant monad to server monad
+liftHandler :: Handler a -> ServerM a
+liftHandler = ServerM . lift . lift
+
+-- | Execution of 'ServerM'
+runServerM :: ServerEnv -> ServerM a -> Handler a
+runServerM e = runStdoutLoggingT . flip runReaderT e . unServerM
+
+-- | Execution of 'ServerM' in IO monad
+runServerMIO :: ServerEnv -> ServerM a -> IO a
+runServerMIO env m = do
+ ea <- runExceptT $ runServerM env m
+ case ea of
+ Left e -> fail $ "runServerMIO: " <> show e
+ Right a -> return a
+
+-- | Transformation to Servant 'Handler'
+serverMtoHandler :: ServerEnv -> ServerM :~> Handler
+serverMtoHandler e = Nat (runServerM e)
+
+-- | Special monad for authorisation actions
+newtype AuthM a = AuthM { unAuthM :: PersistentBackendT IO a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr, HasStorage, HasAuthConfig)
+
+-- | Execution of authorisation actions that require 'AuthHandler' context
+runAuth :: AuthM a -> ServerM a
+runAuth m = do
+ cfg <- asks envAuthConfig
+ pool <- asks envPool
+ liftHandler $ ExceptT $ runPersistentBackendT cfg pool $ unAuthM m
diff --git a/example/persistent/src/Server.hs b/example/persistent/src/Server.hs
index 41a9e85..9fc3be0 100644
--- a/example/persistent/src/Server.hs
+++ b/example/persistent/src/Server.hs
@@ -1,49 +1,49 @@
-module Server(
- -- * Server config
- ServerConfig(..)
- , readConfig
- -- * Server environment
- , ServerEnv
- , newServerEnv
- -- * Execution of server
- , exampleServerApp
- , runExampleServer
- ) where
-
-import Control.Monad.IO.Class
-import Control.Monad.Logger
-import Data.Proxy
-import Network.Wai
-import Network.Wai.Handler.Warp
-import Network.Wai.Middleware.RequestLogger
-import Servant.API.Auth.Token
-import Servant.Server
-import Servant.Server.Auth.Token
-
-import API
-import Config
-import Monad
-
--- | Enter infinite loop of processing requests for pdf-master-server.
---
--- Starts new Warp server with initialised threads for serving the master server.
-runExampleServer :: MonadIO m => ServerConfig -> m ()
-runExampleServer config = liftIO $ do
- env <- newServerEnv config
- liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env
-
--- | WAI application of server
-exampleServerApp :: ServerEnv -> Application
-exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl
- where
- apiImpl = enter (serverMtoHandler e) exampleServer
-
--- | Implementation of main server API
-exampleServer :: ServerT ExampleAPI ServerM
-exampleServer = testEndpoint
-
-testEndpoint :: MToken' '["test-permission"] -> ServerM ()
-testEndpoint token = do
- runAuth $ guardAuthToken token
- $logInfo "testEndpoint"
- return ()
+module Server(
+ -- * Server config
+ ServerConfig(..)
+ , readConfig
+ -- * Server environment
+ , ServerEnv
+ , newServerEnv
+ -- * Execution of server
+ , exampleServerApp
+ , runExampleServer
+ ) where
+
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Data.Proxy
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.RequestLogger
+import Servant.API.Auth.Token
+import Servant.Server
+import Servant.Server.Auth.Token
+
+import API
+import Config
+import Monad
+
+-- | Enter infinite loop of processing requests for pdf-master-server.
+--
+-- Starts new Warp server with initialised threads for serving the master server.
+runExampleServer :: MonadIO m => ServerConfig -> m ()
+runExampleServer config = liftIO $ do
+ env <- newServerEnv config
+ liftIO $ run (serverPort config) $ logStdoutDev $ exampleServerApp env
+
+-- | WAI application of server
+exampleServerApp :: ServerEnv -> Application
+exampleServerApp e = serve (Proxy :: Proxy ExampleAPI) apiImpl
+ where
+ apiImpl = enter (serverMtoHandler e) exampleServer
+
+-- | Implementation of main server API
+exampleServer :: ServerT ExampleAPI ServerM
+exampleServer = testEndpoint
+
+testEndpoint :: MToken' '["test-permission"] -> ServerM ()
+testEndpoint token = do
+ runAuth $ guardAuthToken token
+ $logInfo "testEndpoint"
+ return ()
diff --git a/servant-auth-token.cabal b/servant-auth-token.cabal
index bb68f66..bd55c1a 100644
--- a/servant-auth-token.cabal
+++ b/servant-auth-token.cabal
@@ -1,97 +1,97 @@
-name: servant-auth-token
-version: 0.4.6.0
-synopsis: Servant based API and server for token based authorisation
-description: Please see README.md
-homepage: https://github.com/ncrashed/servant-auth-token#readme
-license: BSD3
-license-file: LICENSE
-author: Anton Gushcha <ncrashed@gmail.com>
- , Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>
-maintainer: ncrashed@gmail.com
-copyright: 2016-2017 Anton Gushcha
-category: Web
-build-type: Simple
-extra-source-files:
- README.md
- CHANGELOG.md
- stack.yaml
- example/acid/src/API.hs
- example/acid/src/Config.hs
- example/acid/src/DB.hs
- example/acid/src/Main.hs
- example/acid/src/Monad.hs
- example/acid/src/Server.hs
- example/acid/LICENSE
- example/acid/Setup.hs
- example/acid/config.yaml
- example/acid/servant-auth-token-example-acid.cabal
- example/persistent/src/API.hs
- example/persistent/src/Config.hs
- example/persistent/src/Main.hs
- example/persistent/src/Monad.hs
- example/persistent/src/Server.hs
- example/persistent/LICENSE
- example/persistent/Setup.hs
- example/persistent/config.yaml
- example/persistent/servant-auth-token-example-persistent.cabal
- example/leveldb/src/API.hs
- example/leveldb/src/Config.hs
- example/leveldb/src/Main.hs
- example/leveldb/src/Monad.hs
- example/leveldb/src/Server.hs
- example/leveldb/LICENSE
- example/leveldb/Setup.hs
- example/leveldb/config.yaml
- example/leveldb/servant-auth-token-example-leveldb.cabal
-cabal-version: >=1.10
-
-library
- hs-source-dirs: src
- exposed-modules:
- Servant.Server.Auth.Token
- Servant.Server.Auth.Token.Common
- Servant.Server.Auth.Token.Config
- Servant.Server.Auth.Token.Error
- Servant.Server.Auth.Token.Model
- Servant.Server.Auth.Token.Monad
- Servant.Server.Auth.Token.Pagination
- Servant.Server.Auth.Token.Patch
- Servant.Server.Auth.Token.Restore
- Servant.Server.Auth.Token.SingleUse
- build-depends:
- base >= 4.7 && < 5
- , aeson-injector >= 1.0.4 && < 1.1
- , bytestring >= 0.10 && < 0.11
- , containers >= 0.5 && < 0.6
- , mtl >= 2.2 && < 2.3
- , pwstore-fast >= 2.4 && < 2.5
- , servant-auth-token-api >= 0.4.2 && < 0.5
- , servant-server >= 0.9 && < 0.10
- , text >= 1.2 && < 1.3
- , time >= 1.5 && < 1.7
- , transformers >= 0.4 && < 0.6
- , uuid >= 1.3 && < 1.4
-
- default-language: Haskell2010
- default-extensions:
- BangPatterns
- ConstraintKinds
- DataKinds
- DeriveGeneric
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- KindSignatures
- MultiParamTypeClasses
- OverloadedStrings
- RecordWildCards
- ScopedTypeVariables
- TupleSections
- TypeFamilies
- TypeOperators
-
-source-repository head
- type: git
- location: https://github.com/ncrashed/servant-auth-token
+name: servant-auth-token
+version: 0.4.7.0
+synopsis: Servant based API and server for token based authorisation
+description: Please see README.md
+homepage: https://github.com/ncrashed/servant-auth-token#readme
+license: BSD3
+license-file: LICENSE
+author: Anton Gushcha <ncrashed@gmail.com>
+ , Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>
+maintainer: ncrashed@gmail.com
+copyright: 2016-2017 Anton Gushcha
+category: Web
+build-type: Simple
+extra-source-files:
+ README.md
+ CHANGELOG.md
+ stack.yaml
+ example/acid/src/API.hs
+ example/acid/src/Config.hs
+ example/acid/src/DB.hs
+ example/acid/src/Main.hs
+ example/acid/src/Monad.hs
+ example/acid/src/Server.hs
+ example/acid/LICENSE
+ example/acid/Setup.hs
+ example/acid/config.yaml
+ example/acid/servant-auth-token-example-acid.cabal
+ example/persistent/src/API.hs
+ example/persistent/src/Config.hs
+ example/persistent/src/Main.hs
+ example/persistent/src/Monad.hs
+ example/persistent/src/Server.hs
+ example/persistent/LICENSE
+ example/persistent/Setup.hs
+ example/persistent/config.yaml
+ example/persistent/servant-auth-token-example-persistent.cabal
+ example/leveldb/src/API.hs
+ example/leveldb/src/Config.hs
+ example/leveldb/src/Main.hs
+ example/leveldb/src/Monad.hs
+ example/leveldb/src/Server.hs
+ example/leveldb/LICENSE
+ example/leveldb/Setup.hs
+ example/leveldb/config.yaml
+ example/leveldb/servant-auth-token-example-leveldb.cabal
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ exposed-modules:
+ Servant.Server.Auth.Token
+ Servant.Server.Auth.Token.Common
+ Servant.Server.Auth.Token.Config
+ Servant.Server.Auth.Token.Error
+ Servant.Server.Auth.Token.Model
+ Servant.Server.Auth.Token.Monad
+ Servant.Server.Auth.Token.Pagination
+ Servant.Server.Auth.Token.Patch
+ Servant.Server.Auth.Token.Restore
+ Servant.Server.Auth.Token.SingleUse
+ build-depends:
+ base >= 4.8 && < 5
+ , aeson-injector >= 1.0.4 && < 1.1
+ , bytestring >= 0.10 && < 0.11
+ , containers >= 0.5 && < 0.6
+ , mtl >= 2.2 && < 2.3
+ , pwstore-fast >= 2.4 && < 2.5
+ , servant-auth-token-api >= 0.4.2 && < 0.5
+ , servant-server >= 0.9 && < 0.10
+ , text >= 1.2 && < 1.3
+ , time >= 1.5 && < 1.7
+ , transformers >= 0.4 && < 0.6
+ , uuid >= 1.3 && < 1.4
+
+ default-language: Haskell2010
+ default-extensions:
+ BangPatterns
+ ConstraintKinds
+ DataKinds
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GADTs
+ GeneralizedNewtypeDeriving
+ KindSignatures
+ MultiParamTypeClasses
+ OverloadedStrings
+ RecordWildCards
+ ScopedTypeVariables
+ TupleSections
+ TypeFamilies
+ TypeOperators
+
+source-repository head
+ type: git
+ location: https://github.com/ncrashed/servant-auth-token
diff --git a/src/Servant/Server/Auth/Token.hs b/src/Servant/Server/Auth/Token.hs
index 233f1e8..81f7b31 100644
--- a/src/Servant/Server/Auth/Token.hs
+++ b/src/Servant/Server/Auth/Token.hs
@@ -1,664 +1,664 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-|
-Module : Servant.Server.Auth.Token
-Description : Implementation of token authorisation API
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
-
-The module is server side implementation of "Servant.API.Auth.Token" API and intended to be
-used as drop in module for user servers or as external micro service.
-
-
-
-Use 'guardAuthToken' to check authorisation headers in endpoints of your server:
-
-@
--- | Read a single customer from DB
-customerGet :: CustomerId -- ^ Customer unique id
- -> MToken' '["customer-read"] -- ^ Required permissions for auth token
- -> ServerM Customer -- ^ Customer data
-customerGet i token = do
- guardAuthToken token
- guard404 "customer" $ getCustomer i
-@
-
--}
-module Servant.Server.Auth.Token(
- -- * Implementation
- authServer
- -- * Server API
- , HasStorage(..)
- , AuthHandler
- -- * Helpers
- , guardAuthToken
- , WithAuthToken(..)
- , ensureAdmin
- , authUserByToken
- -- * API methods
- , authSignin
- , authSigninGetCode
- , authSigninPostCode
- , authTouch
- , authToken
- , authSignout
- , authSignup
- , authUsersInfo
- , authUserInfo
- , authUserPatch
- , authUserPut
- , authUserDelete
- , authRestore
- , authGetSingleUseCodes
- , authGroupGet
- , authGroupPost
- , authGroupPut
- , authGroupPatch
- , authGroupDelete
- , authGroupList
- , authCheckPermissionsMethod
- , authGetUserIdMethod
- , authFindUserByLogin
- -- * Low-level API
- , getAuthToken
- , hashPassword
- , setUserPasswordHash
- , ensureAdminHash
- , signinByHashUnsafe
- ) where
-
-import Control.Monad
-import Control.Monad.Except
-import Crypto.PasswordStore
-import Data.Aeson.Unit
-import Data.Aeson.WithField
-import Data.Maybe
-import Data.Monoid
-import Data.Text (Text)
-import Data.Text.Encoding
-import Data.Time.Clock
-import Data.UUID
-import Data.UUID.V4
-import Servant
-
-import Servant.API.Auth.Token
-import Servant.API.Auth.Token.Pagination
-import Servant.Server.Auth.Token.Common
-import Servant.Server.Auth.Token.Config
-import Servant.Server.Auth.Token.Model
-import Servant.Server.Auth.Token.Monad
-import Servant.Server.Auth.Token.Pagination
-import Servant.Server.Auth.Token.Restore
-import Servant.Server.Auth.Token.SingleUse
-
-import qualified Data.ByteString.Lazy as BS
-
--- | Implementation of AuthAPI
-authServer :: AuthHandler m => ServerT AuthAPI m
-authServer =
- authSignin
- :<|> authSigninGetCode
- :<|> authSigninPostCode
- :<|> authTouch
- :<|> authToken
- :<|> authSignout
- :<|> authSignup
- :<|> authUsersInfo
- :<|> authUserInfo
- :<|> authUserPatch
- :<|> authUserPut
- :<|> authUserDelete
- :<|> authRestore
- :<|> authGetSingleUseCodes
- :<|> authGroupGet
- :<|> authGroupPost
- :<|> authGroupPut
- :<|> authGroupPatch
- :<|> authGroupDelete
- :<|> authGroupList
- :<|> authCheckPermissionsMethod
- :<|> authGetUserIdMethod
- :<|> authFindUserByLogin
-
--- | Implementation of "signin" method
-authSignin :: AuthHandler m
- => Maybe Login -- ^ Login query parameter
- -> Maybe Password -- ^ Password query parameter
- -> Maybe Seconds -- ^ Expire query parameter, how many seconds the token is valid
- -> m (OnlyField "token" SimpleToken) -- ^ If everything is OK, return token
-authSignin mlogin mpass mexpire = do
- login <- require "login" mlogin
- pass <- require "pass" mpass
- WithField uid UserImpl{..} <- guardLogin login pass
- OnlyField <$> getAuthToken uid mexpire
- where
- guardLogin login pass = do -- check login and password, return passed user
- muser <- getUserImplByLogin login
- let err = throw401 "Cannot find user with given combination of login and pass"
- case muser of
- Nothing -> err
- Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword
- then return user
- else err
-
--- | Helper to get or generate new token for user
-getAuthToken :: AuthHandler m
- => UserImplId -- ^ User for whom we want token
- -> Maybe Seconds -- ^ Expiration duration, 'Nothing' means default
- -> m SimpleToken -- ^ Old token (if it doesn't expire) or new one
-getAuthToken uid mexpire = do
- expire <- calcExpire mexpire
- mt <- getExistingToken -- check whether there is already existing token
- case mt of
- Nothing -> createToken expire -- create new token
- Just t -> touchToken t expire -- prolong token expiration time
- where
- getExistingToken = do -- return active token for specified user id
- t <- liftIO getCurrentTime
- findAuthToken uid t
-
- createToken expire = do -- generate and save fresh token
- token <- toText <$> liftIO nextRandom
- _ <- insertAuthToken AuthToken {
- authTokenValue = token
- , authTokenUser = uid
- , authTokenExpire = expire
- }
- return token
-
--- | Authorisation via code of single usage.
---
--- Implementation of 'AuthSigninGetCodeMethod' endpoint.
---
--- Logic of authorisation via this method is:
---
--- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint
---
--- * Server generates single use token and sends it via
--- SMS or email, defined in configuration by 'singleUseCodeSender' field.
---
--- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint
---
--- * Server responds with auth token.
---
--- * Client uses the token with other requests as authorisation
--- header
---
--- * Client can extend lifetime of token by periodically pinging
--- of 'AuthTouchMethod' endpoint
---
--- * Client can invalidate token instantly by 'AuthSignoutMethod'
---
--- * Client can get info about user with 'AuthTokenInfoMethod' endpoint.
---
--- See also: 'authSigninPostCode'
-authSigninGetCode :: AuthHandler m
- => Maybe Login -- ^ User login, required
- -> m Unit
-authSigninGetCode mlogin = do
- login <- require "login" mlogin
- uinfo <- guard404 "user" $ readUserInfoByLogin login
- let uid = toKey $ respUserId uinfo
-
- AuthConfig{..} <- getConfig
- code <- liftIO singleUseCodeGenerator
- expire <- makeSingleUseExpire singleUseCodeExpire
- registerSingleUseCode uid code (Just expire)
- liftIO $ singleUseCodeSender uinfo code
-
- return Unit
-
--- | Authorisation via code of single usage.
---
--- Logic of authorisation via this method is:
---
--- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint
---
--- * Server generates single use token and sends it via
--- SMS or email, defined in configuration by 'singleUseCodeSender' field.
---
--- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint
---
--- * Server responds with auth token.
---
--- * Client uses the token with other requests as authorisation
--- header
---
--- * Client can extend lifetime of token by periodically pinging
--- of 'AuthTouchMethod' endpoint
---
--- * Client can invalidate token instantly by 'AuthSignoutMethod'
---
--- * Client can get info about user with 'AuthTokenInfoMethod' endpoint.
---
--- See also: 'authSigninGetCode'
-authSigninPostCode :: AuthHandler m
- => Maybe Login -- ^ User login, required
- -> Maybe SingleUseCode -- ^ Received single usage code, required
- -> Maybe Seconds
- -- ^ Time interval after which the token expires, 'Nothing' means
- -- some default value
- -> m (OnlyField "token" SimpleToken)
-authSigninPostCode mlogin mcode mexpire = do
- login <- require "login" mlogin
- code <- require "code" mcode
-
- uinfo <- guard404 "user" $ readUserInfoByLogin login
- let uid = toKey $ respUserId uinfo
- isValid <- validateSingleUseCode uid code
- unless isValid $ throw401 "Single usage code doesn't match"
-
- OnlyField <$> getAuthToken uid mexpire
-
--- | Calculate expiration timestamp for token
-calcExpire :: AuthHandler m => Maybe Seconds -> m UTCTime
-calcExpire mexpire = do
- t <- liftIO getCurrentTime
- AuthConfig{..} <- getConfig
- let requestedExpire = maybe defaultExpire fromIntegral mexpire
- let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire
- return $ boundedExpire `addUTCTime` t
-
--- prolong token with new timestamp
-touchToken :: AuthHandler m => WithId AuthTokenId AuthToken -> UTCTime -> m SimpleToken
-touchToken (WithField tid tok) expire = do
- replaceAuthToken tid tok {
- authTokenExpire = expire
- }
- return $ authTokenValue tok
-
--- | Implementation of "touch" method
-authTouch :: AuthHandler m
- => Maybe Seconds -- ^ Expire query parameter, how many seconds the token should be valid by now. 'Nothing' means default value defined in server config.
- -> MToken '[] -- ^ Authorisation header with token
- -> m Unit
-authTouch mexpire token = do
- WithField i mt <- guardAuthToken' (fmap unToken token) []
- expire <- calcExpire mexpire
- replaceAuthToken i mt { authTokenExpire = expire }
- return Unit
-
--- | Implementation of "token" method, return
--- info about user binded to the token
-authToken :: AuthHandler m
- => MToken '[] -- ^ Authorisation header with token
- -> m RespUserInfo
-authToken token = do
- i <- authUserByToken token
- guard404 "user" . readUserInfo . fromKey $ i
-
--- | Getting user id by token
-authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId
-authUserByToken token = do
- WithField _ mt <- guardAuthToken' (fmap unToken token) []
- return $ authTokenUser mt
-
--- | Implementation of "signout" method
-authSignout :: AuthHandler m
- => Maybe (Token '[]) -- ^ Authorisation header with token
- -> m Unit
-authSignout token = do
- WithField i mt <- guardAuthToken' (fmap unToken token) []
- expire <- liftIO getCurrentTime
- replaceAuthToken i mt { authTokenExpire = expire }
- return Unit
-
--- | Checks given password and if it is invalid in terms of config
--- password validator, throws 400 error.
-guardPassword :: AuthHandler m => Password -> m ()
-guardPassword p = do
- AuthConfig{..} <- getConfig
- whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8
-
--- | Implementation of "signup" method
-authSignup :: AuthHandler m
- => ReqRegister -- ^ Registration info
- -> MToken' '["auth-register"] -- ^ Authorisation header with token
- -> m (OnlyField "user" UserId)
-authSignup ReqRegister{..} token = do
- guardAuthToken token
- guardUserInfo
- guardPassword reqRegPassword
- strength <- getsConfig passwordsStrength
- i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions
- whenJust reqRegGroups $ setUserGroups i
- return $ OnlyField . fromKey $ i
- where
- guardUserInfo = do
- mu <- getUserImplByLogin reqRegLogin
- whenJust mu $ const $ throw400 "User with specified id is already registered"
-
--- | Implementation of get "users" method
-authUsersInfo :: AuthHandler m
- => Maybe Page -- ^ Page num parameter
- -> Maybe PageSize -- ^ Page size parameter
- -> MToken' '["auth-info"] -- ^ Authorisation header with token
- -> m RespUsersInfo
-authUsersInfo mp msize token = do
- guardAuthToken token
- pagination mp msize $ \page size -> do
- (users', total) <- listUsersPaged page size
- perms <- mapM (getUserPermissions . (\(WithField i _) -> i)) users'
- groups <- mapM (getUserGroups . (\(WithField i _) -> i)) users'
- let users = zip3 users' perms groups
- return RespUsersInfo {
- respUsersItems = (\(user, ps, grs) -> userToUserInfo user ps grs) <$> users
- , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
- }
-
--- | Implementation of get "user" method
-authUserInfo :: AuthHandler m
- => UserId -- ^ User id
- -> MToken' '["auth-info"] -- ^ Authorisation header with token
- -> m RespUserInfo
-authUserInfo uid' token = do
- guardAuthToken token
- guard404 "user" $ readUserInfo uid'
-
--- | Implementation of patch "user" method
-authUserPatch :: AuthHandler m
- => UserId -- ^ User id
- -> PatchUser -- ^ JSON with fields for patching
- -> MToken' '["auth-update"] -- ^ Authorisation header with token
- -> m Unit
-authUserPatch uid' body token = do
- guardAuthToken token
- whenJust (patchUserPassword body) guardPassword
- let uid = toKey uid'
- user <- guardUser uid
- strength <- getsConfig passwordsStrength
- WithField _ user' <- patchUser strength body $ WithField uid user
- replaceUserImpl uid user'
- return Unit
-
--- | Implementation of put "user" method
-authUserPut :: AuthHandler m
- => UserId -- ^ User id
- -> ReqRegister -- ^ New user
- -> MToken' '["auth-update"] -- ^ Authorisation header with token
- -> m Unit
-authUserPut uid' ReqRegister{..} token = do
- guardAuthToken token
- guardPassword reqRegPassword
- let uid = toKey uid'
- let user = UserImpl {
- userImplLogin = reqRegLogin
- , userImplPassword = ""
- , userImplEmail = reqRegEmail
- }
- user' <- setUserPassword reqRegPassword user
- replaceUserImpl uid user'
- setUserPermissions uid reqRegPermissions
- whenJust reqRegGroups $ setUserGroups uid
- return Unit
-
--- | Implementation of patch "user" method
-authUserDelete :: AuthHandler m
- => UserId -- ^ User id
- -> MToken' '["auth-delete"] -- ^ Authorisation header with token
- -> m Unit
-authUserDelete uid' token = do
- guardAuthToken token
- deleteUserImpl $ toKey uid'
- return Unit
-
--- Generate new password for user. There is two phases, first, the method
--- is called without 'code' parameter. The system sends email with a restore code
--- to email. After that a call of the method with the code is needed to
--- change password. Need configured SMTP server.
-authRestore :: AuthHandler m
- => UserId -- ^ User id
- -> Maybe RestoreCode
- -> Maybe Password
- -> m Unit
-authRestore uid' mcode mpass = do
- let uid = toKey uid'
- user <- guardUser uid
- case mcode of
- Nothing -> do
- dt <- getsConfig restoreExpire
- t <- liftIO getCurrentTime
- AuthConfig{..} <- getConfig
- rc <- getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t
- uinfo <- guard404 "user" $ readUserInfo uid'
- sendRestoreCode uinfo rc
- Just code -> do
- pass <- require "password" mpass
- guardPassword pass
- guardRestoreCode uid code
- user' <- setUserPassword pass user
- replaceUserImpl uid user'
- return Unit
-
--- | Implementation of 'AuthGetSingleUseCodes' endpoint.
-authGetSingleUseCodes :: AuthHandler m
- => UserId -- ^ Id of user
- -> Maybe Word -- ^ Number of codes. 'Nothing' means that server generates some default count of codes.
- -- And server can define maximum count of codes that user can have at once.
- -> MToken' '["auth-single-codes"]
- -> m (OnlyField "codes" [SingleUseCode])
-authGetSingleUseCodes uid mcount token = do
- guardAuthToken token
- let uid' = toKey uid
- _ <- guard404 "user" $ readUserInfo uid
- AuthConfig{..} <- getConfig
- let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount
- OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n
-
--- | Getting user by id, throw 404 response if not found
-guardUser :: AuthHandler m => UserImplId -> m UserImpl
-guardUser uid = do
- muser <- getUserImpl uid
- case muser of
- Nothing -> throw404 "User not found"
- Just user -> return user
-
--- | If the token is missing or the user of the token
--- doesn't have needed permissions, throw 401 response
-guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m ()
-guardAuthToken mt = void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms)
-
-class WithAuthToken a where
-
- -- | Authenticate an entire API rather than each individual
- -- endpoint.
- --
- -- As such, for a given 'HasServer' instance @api@, if you have:
- --
- -- @
- -- f :: 'ServerT' api m
- -- @
- --
- -- then:
- --
- -- @
- -- withAuthToken f :: (AuthHandler m) => ServerT ('TokenHeader' perms :> api) m
- -- @
- --
- -- (Note that the types don't reflect this, as it isn't possible to
- -- guarantee what all possible @ServerT@ instances might be.)
- withAuthToken :: (PermsList perms) => a -> MToken perms -> a
-
-instance (AuthHandler m) => WithAuthToken (m a) where
- withAuthToken m mt = guardAuthToken mt *> m
-
-instance (WithAuthToken r) => WithAuthToken (a -> r) where
- withAuthToken f mt = (`withAuthToken` mt) . f
-
-instance (WithAuthToken a, WithAuthToken b) => WithAuthToken (a :<|> b) where
- withAuthToken (a :<|> b) mt = withAuthToken a mt :<|> withAuthToken b mt
-
--- | Same as `guardAuthToken` but returns record about the token
-guardAuthToken' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken)
-guardAuthToken' Nothing _ = throw401 "Token required"
-guardAuthToken' (Just token) perms = do
- t <- liftIO getCurrentTime
- mt <- findAuthTokenByValue token
- case mt of
- Nothing -> throw401 "Token is not valid"
- Just et@(WithField _ AuthToken{..}) -> do
- when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" }
- mu <- getUserImpl authTokenUser
- case mu of
- Nothing -> throw500 "User of the token doesn't exist"
- Just UserImpl{..} -> do
- isAdmin <- hasPerm authTokenUser adminPerm
- hasAllPerms <- hasPerms authTokenUser perms
- unless (isAdmin || hasAllPerms) $ throw401 $
- "User doesn't have all required permissions: " <> showb perms
- return et
-
--- | Rehash password for user
-setUserPassword :: AuthHandler m => Password -> UserImpl -> m UserImpl
-setUserPassword pass user = do
- strength <- getsConfig passwordsStrength
- setUserPassword' strength pass user
-
--- | Update password hash of user. Can be used to set direct hash for user password
--- when it is taken from config file.
-setUserPasswordHash :: AuthHandler m => Text -> UserId -> m ()
-setUserPasswordHash hashedPassword i = do
- let i' = toKey i
- user <- guard404 "user" $ getUserImpl i'
- let user' = user { userImplPassword = hashedPassword }
- replaceUserImpl i' user'
-
--- | Getting info about user group, requires 'authInfoPerm' for token
-authGroupGet :: AuthHandler m
- => UserGroupId
- -> MToken' '["auth-info"] -- ^ Authorisation header with token
- -> m UserGroup
-authGroupGet i token = do
- guardAuthToken token
- guard404 "user group" $ readUserGroup i
-
--- | Inserting new user group, requires 'authUpdatePerm' for token
-authGroupPost :: AuthHandler m
- => UserGroup
- -> MToken' '["auth-update"] -- ^ Authorisation header with token
- -> m (OnlyId UserGroupId)
-authGroupPost ug token = do
- guardAuthToken token
- OnlyField <$> insertUserGroup ug
-
--- | Replace info about given user group, requires 'authUpdatePerm' for token
-authGroupPut :: AuthHandler m
- => UserGroupId
- -> UserGroup
- -> MToken' '["auth-update"] -- ^ Authorisation header with token
- -> m Unit
-authGroupPut i ug token = do
- guardAuthToken token
- updateUserGroup i ug
- return Unit
-
--- | Patch info about given user group, requires 'authUpdatePerm' for token
-authGroupPatch :: AuthHandler m
- => UserGroupId
- -> PatchUserGroup
- -> MToken' '["auth-update"] -- ^ Authorisation header with token
- -> m Unit
-authGroupPatch i up token = do
- guardAuthToken token
- patchUserGroup i up
- return Unit
-
--- | Delete all info about given user group, requires 'authDeletePerm' for token
-authGroupDelete :: AuthHandler m
- => UserGroupId
- -> MToken' '["auth-delete"] -- ^ Authorisation header with token
- -> m Unit
-authGroupDelete i token = do
- guardAuthToken token
- deleteUserGroup i
- return Unit
-
--- | Get list of user groups, requires 'authInfoPerm' for token
-authGroupList :: AuthHandler m
- => Maybe Page
- -> Maybe PageSize
- -> MToken' '["auth-info"] -- ^ Authorisation header with token
- -> m (PagedList UserGroupId UserGroup)
-authGroupList mp msize token = do
- guardAuthToken token
- pagination mp msize $ \page size -> do
- (groups', total) <- listGroupsPaged page size
- groups <- forM groups' $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey . (\(WithField i _) -> i)
- return PagedList {
- pagedListItems = catMaybes groups
- , pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
- }
-
--- | Check that the token has required permissions and return 'False' if it doesn't.
-authCheckPermissionsMethod :: AuthHandler m
- => MToken' '["auth-check"] -- ^ Authorisation header with token
- -> OnlyField "permissions" [Permission] -- ^ Body with permissions to check
- -> m Bool -- ^ 'True' if all permissions are OK, 'False' if some permissions are not set for token and 401 error if the token doesn't have 'auth-check' permission.
-authCheckPermissionsMethod token (OnlyField perms) = do
- guardAuthToken token
- let check = const True <$> guardAuthToken' (unToken <$> token) perms
- check `catchError` (\e -> if errHTTPCode e == 401 then pure True else throwError e)
-
--- | Get user ID for the owner of the speified token.
-authGetUserIdMethod :: AuthHandler m
- => MToken' '["auth-userid"] -- ^ Authorisation header with token
- -> m (OnlyId UserId)
-authGetUserIdMethod token = do
- guardAuthToken token
- OnlyField . respUserId <$> authToken (downgradeToken token)
-
--- | Implementation of 'AuthFindUserByLogin'. Find user by login, throw 404 error
--- if cannot find user by such login.
-authFindUserByLogin :: AuthHandler m
- => Maybe Login -- ^ Login, 'Nothing' will cause 400 error.
- -> MToken' '["auth-info"]
- -> m RespUserInfo
-authFindUserByLogin mlogin token = do
- login <- require "login" mlogin
- guardAuthToken token
- userWithId <- guard404 "user" $ getUserImplByLogin login
- makeUserInfo userWithId
-
--- | Generate hash from given password and return it as text. May be useful if
--- you don't like storing unencrypt passwords in config files.
-hashPassword :: AuthHandler m => Password -> m Text
-hashPassword pass = do
- strength <- getsConfig passwordsStrength
- hashed <- liftIO $ makePassword (passToByteString pass) strength
- return $ byteStringToPass hashed
-
--- | Ensures that DB has at least one admin, if not, creates a new one
--- with specified info and direct password hash. May be useful if
--- you don't like storing unencrypt passwords in config files.
-ensureAdminHash :: AuthHandler m => Int -> Login -> Text -> Email -> m ()
-ensureAdminHash strength login passHash email = do
- madmin <- getFirstUserByPerm adminPerm
- whenNothing madmin $ do
- i <- createAdmin strength login "" email
- setUserPasswordHash passHash $ fromKey i
-
--- | If you use password hash in configs, you cannot use them in signin
--- method. This helper allows to get token by password hash and the function
--- is not available for remote call (no endpoint).
---
--- Throws 401 if cannot find user or authorisation is failed.
---
--- WARNING: Do not expose the function to end user, never!
-signinByHashUnsafe :: AuthHandler m => Login -- ^ User login
- -> Text -- ^ Hash of admin password
- -> Maybe Seconds -- ^ Expire
- -> m SimpleToken
-signinByHashUnsafe login pass mexpire = do
- WithField uid UserImpl{..} <- guardLogin login pass
- getAuthToken uid mexpire
- where
- guardLogin login pass = do -- check login and password, return passed user
- muser <- getUserImplByLogin login
- let err = throw401 "Cannot find user with given combination of login and pass"
- case muser of
- Nothing -> err
- Just user@(WithField _ UserImpl{..}) -> if pass == userImplPassword
- then return user
- else err
+{-# LANGUAGE UndecidableInstances #-}
+{-|
+Module : Servant.Server.Auth.Token
+Description : Implementation of token authorisation API
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+
+The module is server side implementation of "Servant.API.Auth.Token" API and intended to be
+used as drop in module for user servers or as external micro service.
+
+
+
+Use 'guardAuthToken' to check authorisation headers in endpoints of your server:
+
+@
+-- | Read a single customer from DB
+customerGet :: CustomerId -- ^ Customer unique id
+ -> MToken' '["customer-read"] -- ^ Required permissions for auth token
+ -> ServerM Customer -- ^ Customer data
+customerGet i token = do
+ guardAuthToken token
+ guard404 "customer" $ getCustomer i
+@
+
+-}
+module Servant.Server.Auth.Token(
+ -- * Implementation
+ authServer
+ -- * Server API
+ , HasStorage(..)
+ , AuthHandler
+ -- * Helpers
+ , guardAuthToken
+ , WithAuthToken(..)
+ , ensureAdmin
+ , authUserByToken
+ -- * API methods
+ , authSignin
+ , authSigninGetCode
+ , authSigninPostCode
+ , authTouch
+ , authToken
+ , authSignout
+ , authSignup
+ , authUsersInfo
+ , authUserInfo
+ , authUserPatch
+ , authUserPut
+ , authUserDelete
+ , authRestore
+ , authGetSingleUseCodes
+ , authGroupGet
+ , authGroupPost
+ , authGroupPut
+ , authGroupPatch
+ , authGroupDelete
+ , authGroupList
+ , authCheckPermissionsMethod
+ , authGetUserIdMethod
+ , authFindUserByLogin
+ -- * Low-level API
+ , getAuthToken
+ , hashPassword
+ , setUserPasswordHash
+ , ensureAdminHash
+ , signinByHashUnsafe
+ ) where
+
+import Control.Monad
+import Control.Monad.Except
+import Crypto.PasswordStore
+import Data.Aeson.Unit
+import Data.Aeson.WithField
+import Data.Maybe
+import Data.Monoid
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Time.Clock
+import Data.UUID
+import Data.UUID.V4
+import Servant
+
+import Servant.API.Auth.Token
+import Servant.API.Auth.Token.Pagination
+import Servant.Server.Auth.Token.Common
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+import Servant.Server.Auth.Token.Monad
+import Servant.Server.Auth.Token.Pagination
+import Servant.Server.Auth.Token.Restore
+import Servant.Server.Auth.Token.SingleUse
+
+import qualified Data.ByteString.Lazy as BS
+
+-- | Implementation of AuthAPI
+authServer :: AuthHandler m => ServerT AuthAPI m
+authServer =
+ authSignin
+ :<|> authSigninGetCode
+ :<|> authSigninPostCode
+ :<|> authTouch
+ :<|> authToken
+ :<|> authSignout
+ :<|> authSignup
+ :<|> authUsersInfo
+ :<|> authUserInfo
+ :<|> authUserPatch
+ :<|> authUserPut
+ :<|> authUserDelete
+ :<|> authRestore
+ :<|> authGetSingleUseCodes
+ :<|> authGroupGet
+ :<|> authGroupPost
+ :<|> authGroupPut
+ :<|> authGroupPatch
+ :<|> authGroupDelete
+ :<|> authGroupList
+ :<|> authCheckPermissionsMethod
+ :<|> authGetUserIdMethod
+ :<|> authFindUserByLogin
+
+-- | Implementation of "signin" method
+authSignin :: AuthHandler m
+ => Maybe Login -- ^ Login query parameter
+ -> Maybe Password -- ^ Password query parameter
+ -> Maybe Seconds -- ^ Expire query parameter, how many seconds the token is valid
+ -> m (OnlyField "token" SimpleToken) -- ^ If everything is OK, return token
+authSignin mlogin mpass mexpire = do
+ login <- require "login" mlogin
+ pass <- require "pass" mpass
+ WithField uid UserImpl{..} <- guardLogin login pass
+ OnlyField <$> getAuthToken uid mexpire
+ where
+ guardLogin login pass = do -- check login and password, return passed user
+ muser <- getUserImplByLogin login
+ let err = throw401 "Cannot find user with given combination of login and pass"
+ case muser of
+ Nothing -> err
+ Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword
+ then return user
+ else err
+
+-- | Helper to get or generate new token for user
+getAuthToken :: AuthHandler m
+ => UserImplId -- ^ User for whom we want token
+ -> Maybe Seconds -- ^ Expiration duration, 'Nothing' means default
+ -> m SimpleToken -- ^ Old token (if it doesn't expire) or new one
+getAuthToken uid mexpire = do
+ expire <- calcExpire mexpire
+ mt <- getExistingToken -- check whether there is already existing token
+ case mt of
+ Nothing -> createToken expire -- create new token
+ Just t -> touchToken t expire -- prolong token expiration time
+ where
+ getExistingToken = do -- return active token for specified user id
+ t <- liftIO getCurrentTime
+ findAuthToken uid t
+
+ createToken expire = do -- generate and save fresh token
+ token <- toText <$> liftIO nextRandom
+ _ <- insertAuthToken AuthToken {
+ authTokenValue = token
+ , authTokenUser = uid
+ , authTokenExpire = expire
+ }
+ return token
+
+-- | Authorisation via code of single usage.
+--
+-- Implementation of 'AuthSigninGetCodeMethod' endpoint.
+--
+-- Logic of authorisation via this method is:
+--
+-- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint
+--
+-- * Server generates single use token and sends it via
+-- SMS or email, defined in configuration by 'singleUseCodeSender' field.
+--
+-- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint
+--
+-- * Server responds with auth token.
+--
+-- * Client uses the token with other requests as authorisation
+-- header
+--
+-- * Client can extend lifetime of token by periodically pinging
+-- of 'AuthTouchMethod' endpoint
+--
+-- * Client can invalidate token instantly by 'AuthSignoutMethod'
+--
+-- * Client can get info about user with 'AuthTokenInfoMethod' endpoint.
+--
+-- See also: 'authSigninPostCode'
+authSigninGetCode :: AuthHandler m
+ => Maybe Login -- ^ User login, required
+ -> m Unit
+authSigninGetCode mlogin = do
+ login <- require "login" mlogin
+ uinfo <- guard404 "user" $ readUserInfoByLogin login
+ let uid = toKey $ respUserId uinfo
+
+ AuthConfig{..} <- getConfig
+ code <- liftIO singleUseCodeGenerator
+ expire <- makeSingleUseExpire singleUseCodeExpire
+ registerSingleUseCode uid code (Just expire)
+ liftIO $ singleUseCodeSender uinfo code
+
+ return Unit
+
+-- | Authorisation via code of single usage.
+--
+-- Logic of authorisation via this method is:
+--
+-- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint
+--
+-- * Server generates single use token and sends it via
+-- SMS or email, defined in configuration by 'singleUseCodeSender' field.
+--
+-- * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint
+--
+-- * Server responds with auth token.
+--
+-- * Client uses the token with other requests as authorisation
+-- header
+--
+-- * Client can extend lifetime of token by periodically pinging
+-- of 'AuthTouchMethod' endpoint
+--
+-- * Client can invalidate token instantly by 'AuthSignoutMethod'
+--
+-- * Client can get info about user with 'AuthTokenInfoMethod' endpoint.
+--
+-- See also: 'authSigninGetCode'
+authSigninPostCode :: AuthHandler m
+ => Maybe Login -- ^ User login, required
+ -> Maybe SingleUseCode -- ^ Received single usage code, required
+ -> Maybe Seconds
+ -- ^ Time interval after which the token expires, 'Nothing' means
+ -- some default value
+ -> m (OnlyField "token" SimpleToken)
+authSigninPostCode mlogin mcode mexpire = do
+ login <- require "login" mlogin
+ code <- require "code" mcode
+
+ uinfo <- guard404 "user" $ readUserInfoByLogin login
+ let uid = toKey $ respUserId uinfo
+ isValid <- validateSingleUseCode uid code
+ unless isValid $ throw401 "Single usage code doesn't match"
+
+ OnlyField <$> getAuthToken uid mexpire
+
+-- | Calculate expiration timestamp for token
+calcExpire :: AuthHandler m => Maybe Seconds -> m UTCTime
+calcExpire mexpire = do
+ t <- liftIO getCurrentTime
+ AuthConfig{..} <- getConfig
+ let requestedExpire = maybe defaultExpire fromIntegral mexpire
+ let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire
+ return $ boundedExpire `addUTCTime` t
+
+-- prolong token with new timestamp
+touchToken :: AuthHandler m => WithId AuthTokenId AuthToken -> UTCTime -> m SimpleToken
+touchToken (WithField tid tok) expire = do
+ replaceAuthToken tid tok {
+ authTokenExpire = expire
+ }
+ return $ authTokenValue tok
+
+-- | Implementation of "touch" method
+authTouch :: AuthHandler m
+ => Maybe Seconds -- ^ Expire query parameter, how many seconds the token should be valid by now. 'Nothing' means default value defined in server config.
+ -> MToken '[] -- ^ Authorisation header with token
+ -> m Unit
+authTouch mexpire token = do
+ WithField i mt <- guardAuthToken' (fmap unToken token) []
+ expire <- calcExpire mexpire
+ replaceAuthToken i mt { authTokenExpire = expire }
+ return Unit
+
+-- | Implementation of "token" method, return
+-- info about user binded to the token
+authToken :: AuthHandler m
+ => MToken '[] -- ^ Authorisation header with token
+ -> m RespUserInfo
+authToken token = do
+ i <- authUserByToken token
+ guard404 "user" . readUserInfo . fromKey $ i
+
+-- | Getting user id by token
+authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId
+authUserByToken token = do
+ WithField _ mt <- guardAuthToken' (fmap unToken token) []
+ return $ authTokenUser mt
+
+-- | Implementation of "signout" method
+authSignout :: AuthHandler m
+ => Maybe (Token '[]) -- ^ Authorisation header with token
+ -> m Unit
+authSignout token = do
+ WithField i mt <- guardAuthToken' (fmap unToken token) []
+ expire <- liftIO getCurrentTime
+ replaceAuthToken i mt { authTokenExpire = expire }
+ return Unit
+
+-- | Checks given password and if it is invalid in terms of config
+-- password validator, throws 400 error.
+guardPassword :: AuthHandler m => Password -> m ()
+guardPassword p = do
+ AuthConfig{..} <- getConfig
+ whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8
+
+-- | Implementation of "signup" method
+authSignup :: AuthHandler m
+ => ReqRegister -- ^ Registration info
+ -> MToken' '["auth-register"] -- ^ Authorisation header with token
+ -> m (OnlyField "user" UserId)
+authSignup ReqRegister{..} token = do
+ guardAuthToken token
+ guardUserInfo
+ guardPassword reqRegPassword
+ strength <- getsConfig passwordsStrength
+ i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions
+ whenJust reqRegGroups $ setUserGroups i
+ return $ OnlyField . fromKey $ i
+ where
+ guardUserInfo = do
+ mu <- getUserImplByLogin reqRegLogin
+ whenJust mu $ const $ throw400 "User with specified id is already registered"
+
+-- | Implementation of get "users" method
+authUsersInfo :: AuthHandler m
+ => Maybe Page -- ^ Page num parameter
+ -> Maybe PageSize -- ^ Page size parameter
+ -> MToken' '["auth-info"] -- ^ Authorisation header with token
+ -> m RespUsersInfo
+authUsersInfo mp msize token = do
+ guardAuthToken token
+ pagination mp msize $ \page size -> do
+ (users', total) <- listUsersPaged page size
+ perms <- mapM (getUserPermissions . (\(WithField i _) -> i)) users'
+ groups <- mapM (getUserGroups . (\(WithField i _) -> i)) users'
+ let users = zip3 users' perms groups
+ return RespUsersInfo {
+ respUsersItems = (\(user, ps, grs) -> userToUserInfo user ps grs) <$> users
+ , respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
+ }
+
+-- | Implementation of get "user" method
+authUserInfo :: AuthHandler m
+ => UserId -- ^ User id
+ -> MToken' '["auth-info"] -- ^ Authorisation header with token
+ -> m RespUserInfo
+authUserInfo uid' token = do
+ guardAuthToken token
+ guard404 "user" $ readUserInfo uid'
+
+-- | Implementation of patch "user" method
+authUserPatch :: AuthHandler m
+ => UserId -- ^ User id
+ -> PatchUser -- ^ JSON with fields for patching
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m Unit
+authUserPatch uid' body token = do
+ guardAuthToken token
+ whenJust (patchUserPassword body) guardPassword
+ let uid = toKey uid'
+ user <- guardUser uid
+ strength <- getsConfig passwordsStrength
+ WithField _ user' <- patchUser strength body $ WithField uid user
+ replaceUserImpl uid user'
+ return Unit
+
+-- | Implementation of put "user" method
+authUserPut :: AuthHandler m
+ => UserId -- ^ User id
+ -> ReqRegister -- ^ New user
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m Unit
+authUserPut uid' ReqRegister{..} token = do
+ guardAuthToken token
+ guardPassword reqRegPassword
+ let uid = toKey uid'
+ let user = UserImpl {
+ userImplLogin = reqRegLogin
+ , userImplPassword = ""
+ , userImplEmail = reqRegEmail
+ }
+ user' <- setUserPassword reqRegPassword user
+ replaceUserImpl uid user'
+ setUserPermissions uid reqRegPermissions
+ whenJust reqRegGroups $ setUserGroups uid
+ return Unit
+
+-- | Implementation of patch "user" method
+authUserDelete :: AuthHandler m
+ => UserId -- ^ User id
+ -> MToken' '["auth-delete"] -- ^ Authorisation header with token
+ -> m Unit
+authUserDelete uid' token = do
+ guardAuthToken token
+ deleteUserImpl $ toKey uid'
+ return Unit
+
+-- Generate new password for user. There is two phases, first, the method
+-- is called without 'code' parameter. The system sends email with a restore code
+-- to email. After that a call of the method with the code is needed to
+-- change password. Need configured SMTP server.
+authRestore :: AuthHandler m
+ => UserId -- ^ User id
+ -> Maybe RestoreCode
+ -> Maybe Password
+ -> m Unit
+authRestore uid' mcode mpass = do
+ let uid = toKey uid'
+ user <- guardUser uid
+ case mcode of
+ Nothing -> do
+ dt <- getsConfig restoreExpire
+ t <- liftIO getCurrentTime
+ AuthConfig{..} <- getConfig
+ rc <- getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t
+ uinfo <- guard404 "user" $ readUserInfo uid'
+ sendRestoreCode uinfo rc
+ Just code -> do
+ pass <- require "password" mpass
+ guardPassword pass
+ guardRestoreCode uid code
+ user' <- setUserPassword pass user
+ replaceUserImpl uid user'
+ return Unit
+
+-- | Implementation of 'AuthGetSingleUseCodes' endpoint.
+authGetSingleUseCodes :: AuthHandler m
+ => UserId -- ^ Id of user
+ -> Maybe Word -- ^ Number of codes. 'Nothing' means that server generates some default count of codes.
+ -- And server can define maximum count of codes that user can have at once.
+ -> MToken' '["auth-single-codes"]
+ -> m (OnlyField "codes" [SingleUseCode])
+authGetSingleUseCodes uid mcount token = do
+ guardAuthToken token
+ let uid' = toKey uid
+ _ <- guard404 "user" $ readUserInfo uid
+ AuthConfig{..} <- getConfig
+ let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount
+ OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n
+
+-- | Getting user by id, throw 404 response if not found
+guardUser :: AuthHandler m => UserImplId -> m UserImpl
+guardUser uid = do
+ muser <- getUserImpl uid
+ case muser of
+ Nothing -> throw404 "User not found"
+ Just user -> return user
+
+-- | If the token is missing or the user of the token
+-- doesn't have needed permissions, throw 401 response
+guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m ()
+guardAuthToken mt = void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms)
+
+class WithAuthToken a where
+
+ -- | Authenticate an entire API rather than each individual
+ -- endpoint.
+ --
+ -- As such, for a given 'HasServer' instance @api@, if you have:
+ --
+ -- @
+ -- f :: 'ServerT' api m
+ -- @
+ --
+ -- then:
+ --
+ -- @
+ -- withAuthToken f :: (AuthHandler m) => ServerT ('TokenHeader' perms :> api) m
+ -- @
+ --
+ -- (Note that the types don't reflect this, as it isn't possible to
+ -- guarantee what all possible @ServerT@ instances might be.)
+ withAuthToken :: (PermsList perms) => a -> MToken perms -> a
+
+instance (AuthHandler m) => WithAuthToken (m a) where
+ withAuthToken m mt = guardAuthToken mt *> m
+
+instance {-# OVERLAPPING #-} (WithAuthToken r) => WithAuthToken (a -> r) where
+ withAuthToken f mt = (`withAuthToken` mt) . f
+
+instance (WithAuthToken a, WithAuthToken b) => WithAuthToken (a :<|> b) where
+ withAuthToken (a :<|> b) mt = withAuthToken a mt :<|> withAuthToken b mt
+
+-- | Same as `guardAuthToken` but returns record about the token
+guardAuthToken' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken)
+guardAuthToken' Nothing _ = throw401 "Token required"
+guardAuthToken' (Just token) perms = do
+ t <- liftIO getCurrentTime
+ mt <- findAuthTokenByValue token
+ case mt of
+ Nothing -> throw401 "Token is not valid"
+ Just et@(WithField _ AuthToken{..}) -> do
+ when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" }
+ mu <- getUserImpl authTokenUser
+ case mu of
+ Nothing -> throw500 "User of the token doesn't exist"
+ Just UserImpl{..} -> do
+ isAdmin <- hasPerm authTokenUser adminPerm
+ hasAllPerms <- hasPerms authTokenUser perms
+ unless (isAdmin || hasAllPerms) $ throw401 $
+ "User doesn't have all required permissions: " <> showb perms
+ return et
+
+-- | Rehash password for user
+setUserPassword :: AuthHandler m => Password -> UserImpl -> m UserImpl
+setUserPassword pass user = do
+ strength <- getsConfig passwordsStrength
+ setUserPassword' strength pass user
+
+-- | Update password hash of user. Can be used to set direct hash for user password
+-- when it is taken from config file.
+setUserPasswordHash :: AuthHandler m => Text -> UserId -> m ()
+setUserPasswordHash hashedPassword i = do
+ let i' = toKey i
+ user <- guard404 "user" $ getUserImpl i'
+ let user' = user { userImplPassword = hashedPassword }
+ replaceUserImpl i' user'
+
+-- | Getting info about user group, requires 'authInfoPerm' for token
+authGroupGet :: AuthHandler m
+ => UserGroupId
+ -> MToken' '["auth-info"] -- ^ Authorisation header with token
+ -> m UserGroup
+authGroupGet i token = do
+ guardAuthToken token
+ guard404 "user group" $ readUserGroup i
+
+-- | Inserting new user group, requires 'authUpdatePerm' for token
+authGroupPost :: AuthHandler m
+ => UserGroup
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m (OnlyId UserGroupId)
+authGroupPost ug token = do
+ guardAuthToken token
+ OnlyField <$> insertUserGroup ug
+
+-- | Replace info about given user group, requires 'authUpdatePerm' for token
+authGroupPut :: AuthHandler m
+ => UserGroupId
+ -> UserGroup
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m Unit
+authGroupPut i ug token = do
+ guardAuthToken token
+ updateUserGroup i ug
+ return Unit
+
+-- | Patch info about given user group, requires 'authUpdatePerm' for token
+authGroupPatch :: AuthHandler m
+ => UserGroupId
+ -> PatchUserGroup
+ -> MToken' '["auth-update"] -- ^ Authorisation header with token
+ -> m Unit
+authGroupPatch i up token = do
+ guardAuthToken token
+ patchUserGroup i up
+ return Unit
+
+-- | Delete all info about given user group, requires 'authDeletePerm' for token
+authGroupDelete :: AuthHandler m
+ => UserGroupId
+ -> MToken' '["auth-delete"] -- ^ Authorisation header with token
+ -> m Unit
+authGroupDelete i token = do
+ guardAuthToken token
+ deleteUserGroup i
+ return Unit
+
+-- | Get list of user groups, requires 'authInfoPerm' for token
+authGroupList :: AuthHandler m
+ => Maybe Page
+ -> Maybe PageSize
+ -> MToken' '["auth-info"] -- ^ Authorisation header with token
+ -> m (PagedList UserGroupId UserGroup)
+authGroupList mp msize token = do
+ guardAuthToken token
+ pagination mp msize $ \page size -> do
+ (groups', total) <- listGroupsPaged page size
+ groups <- forM groups' $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey . (\(WithField i _) -> i)
+ return PagedList {
+ pagedListItems = catMaybes groups
+ , pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
+ }
+
+-- | Check that the token has required permissions and return 'False' if it doesn't.
+authCheckPermissionsMethod :: AuthHandler m
+ => MToken' '["auth-check"] -- ^ Authorisation header with token
+ -> OnlyField "permissions" [Permission] -- ^ Body with permissions to check
+ -> m Bool -- ^ 'True' if all permissions are OK, 'False' if some permissions are not set for token and 401 error if the token doesn't have 'auth-check' permission.
+authCheckPermissionsMethod token (OnlyField perms) = do
+ guardAuthToken token
+ let check = const True <$> guardAuthToken' (unToken <$> token) perms
+ check `catchError` (\e -> if errHTTPCode e == 401 then pure True else throwError e)
+
+-- | Get user ID for the owner of the speified token.
+authGetUserIdMethod :: AuthHandler m
+ => MToken' '["auth-userid"] -- ^ Authorisation header with token
+ -> m (OnlyId UserId)
+authGetUserIdMethod token = do
+ guardAuthToken token
+ OnlyField . respUserId <$> authToken (downgradeToken token)
+
+-- | Implementation of 'AuthFindUserByLogin'. Find user by login, throw 404 error
+-- if cannot find user by such login.
+authFindUserByLogin :: AuthHandler m
+ => Maybe Login -- ^ Login, 'Nothing' will cause 400 error.
+ -> MToken' '["auth-info"]
+ -> m RespUserInfo
+authFindUserByLogin mlogin token = do
+ login <- require "login" mlogin
+ guardAuthToken token
+ userWithId <- guard404 "user" $ getUserImplByLogin login
+ makeUserInfo userWithId
+
+-- | Generate hash from given password and return it as text. May be useful if
+-- you don't like storing unencrypt passwords in config files.
+hashPassword :: AuthHandler m => Password -> m Text
+hashPassword pass = do
+ strength <- getsConfig passwordsStrength
+ hashed <- liftIO $ makePassword (passToByteString pass) strength
+ return $ byteStringToPass hashed
+
+-- | Ensures that DB has at least one admin, if not, creates a new one
+-- with specified info and direct password hash. May be useful if
+-- you don't like storing unencrypt passwords in config files.
+ensureAdminHash :: AuthHandler m => Int -> Login -> Text -> Email -> m ()
+ensureAdminHash strength login passHash email = do
+ madmin <- getFirstUserByPerm adminPerm
+ whenNothing madmin $ do
+ i <- createAdmin strength login "" email
+ setUserPasswordHash passHash $ fromKey i
+
+-- | If you use password hash in configs, you cannot use them in signin
+-- method. This helper allows to get token by password hash and the function
+-- is not available for remote call (no endpoint).
+--
+-- Throws 401 if cannot find user or authorisation is failed.
+--
+-- WARNING: Do not expose the function to end user, never!
+signinByHashUnsafe :: AuthHandler m => Login -- ^ User login
+ -> Text -- ^ Hash of admin password
+ -> Maybe Seconds -- ^ Expire
+ -> m SimpleToken
+signinByHashUnsafe login pass mexpire = do
+ WithField uid UserImpl{..} <- guardLogin login pass
+ getAuthToken uid mexpire
+ where
+ guardLogin login pass = do -- check login and password, return passed user
+ muser <- getUserImplByLogin login
+ let err = throw401 "Cannot find user with given combination of login and pass"
+ case muser of
+ Nothing -> err
+ Just user@(WithField _ UserImpl{..}) -> if pass == userImplPassword
+ then return user
+ else err
diff --git a/src/Servant/Server/Auth/Token/Common.hs b/src/Servant/Server/Auth/Token/Common.hs
index 205e2e7..68b3982 100644
--- a/src/Servant/Server/Auth/Token/Common.hs
+++ b/src/Servant/Server/Auth/Token/Common.hs
@@ -1,38 +1,38 @@
-{-|
-Module : Servant.Server.Auth.Token.Common
-Description : Internal utilities
-Copyright : (c) Anton Gushcha, 2016-2017
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.Common where
-
-import qualified Data.Text as T
-import qualified Data.ByteString.Lazy.Char8 as BSL
-
--- | Helper to print a value to lazy bytestring
-showb :: Show a => a -> BSL.ByteString
-showb = BSL.pack . show
-
--- | Helper to print a value to text
-showt :: Show a => a -> T.Text
-showt = T.pack . show
-
--- | Do something when first value is 'Nothing'
-whenNothing :: Applicative m => Maybe a -> m () -> m ()
-whenNothing Nothing m = m
-whenNothing (Just _) _ = pure ()
-
--- | Do something when first value is 'Just'
-whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
-whenJust Nothing _ = pure ()
-whenJust (Just x) m = m x
-
-class ConvertableKey a where
- -- | Shortcut to convert sql key
- fromKey :: Integral b => a -> b
-
- -- | Shortcut to convert sql key
- toKey :: Integral b => b -> a
+{-|
+Module : Servant.Server.Auth.Token.Common
+Description : Internal utilities
+Copyright : (c) Anton Gushcha, 2016-2017
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Common where
+
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy.Char8 as BSL
+
+-- | Helper to print a value to lazy bytestring
+showb :: Show a => a -> BSL.ByteString
+showb = BSL.pack . show
+
+-- | Helper to print a value to text
+showt :: Show a => a -> T.Text
+showt = T.pack . show
+
+-- | Do something when first value is 'Nothing'
+whenNothing :: Applicative m => Maybe a -> m () -> m ()
+whenNothing Nothing m = m
+whenNothing (Just _) _ = pure ()
+
+-- | Do something when first value is 'Just'
+whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
+whenJust Nothing _ = pure ()
+whenJust (Just x) m = m x
+
+class ConvertableKey a where
+ -- | Shortcut to convert sql key
+ fromKey :: Integral b => a -> b
+
+ -- | Shortcut to convert sql key
+ toKey :: Integral b => b -> a
diff --git a/src/Servant/Server/Auth/Token/Config.hs b/src/Servant/Server/Auth/Token/Config.hs
index ba28068..9237edf 100644
--- a/src/Servant/Server/Auth/Token/Config.hs
+++ b/src/Servant/Server/Auth/Token/Config.hs
@@ -1,138 +1,138 @@
-{-# LANGUAGE DefaultSignatures #-}
-
-{-|
-Module : Servant.Server.Auth.Token.Config
-Description : Configuration of auth server
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.Config(
- AuthConfig(..)
- , HasAuthConfig(..)
- , defaultAuthConfig
- ) where
-
-import Control.Monad.Cont (ContT)
-import Control.Monad.Except (ExceptT)
-import Control.Monad.IO.Class
-import Control.Monad.Reader (ReaderT)
-import qualified Control.Monad.RWS.Lazy as LRWS
-import qualified Control.Monad.RWS.Strict as SRWS
-import qualified Control.Monad.State.Lazy as LS
-import qualified Control.Monad.State.Strict as SS
-import qualified Control.Monad.Writer.Lazy as LW
-import qualified Control.Monad.Writer.Strict as SW
-import Control.Monad.Trans.Class (MonadTrans(lift))
-import Data.Text (Text)
-import Data.Time
-import Data.UUID
-import Data.UUID.V4
-import Servant.Server
-
-import Servant.API.Auth.Token
-
--- | Monad that can read an auth config
-class Monad m => HasAuthConfig m where
- getAuthConfig :: m AuthConfig
- default getAuthConfig :: (m ~ t n, MonadTrans t, HasAuthConfig n) => m AuthConfig
- getAuthConfig = lift getAuthConfig
-
-instance HasAuthConfig m => HasAuthConfig (ContT r m)
-instance HasAuthConfig m => HasAuthConfig (ExceptT e m)
-instance HasAuthConfig m => HasAuthConfig (ReaderT r m)
-instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LRWS.RWST r w s m)
-instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SRWS.RWST r w s m)
-instance HasAuthConfig m => HasAuthConfig (LS.StateT s m)
-instance HasAuthConfig m => HasAuthConfig (SS.StateT s m)
-instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LW.WriterT w m)
-instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SW.WriterT w m)
-
--- | Configuration specific for authorisation system
-data AuthConfig = AuthConfig {
- -- | For authorisation, defines amounts of seconds
- -- when token becomes invalid.
- defaultExpire :: !NominalDiffTime
- -- | For password restore, defines amounts of seconds
- -- when restore code becomes invalid.
- , restoreExpire :: !NominalDiffTime
- -- | User specified implementation of restore code sending. It could
- -- be a email sender or SMS message or mobile application method, whatever
- -- the implementation needs.
- , restoreCodeSender :: !(RespUserInfo -> RestoreCode -> IO ())
- -- | User specified generator for restore codes. By default the server
- -- generates UUID that can be unacceptable for SMS restoration routine.
- , restoreCodeGenerator :: !(IO RestoreCode)
- -- | Upper bound of expiration time that user can request
- -- for a token.
- , maximumExpire :: !(Maybe NominalDiffTime)
- -- | For authorisation, defines amount of hashing
- -- of new user passwords (should be greater or equal 14).
- -- The passwords hashed 2^strength times. It is needed to
- -- prevent almost all kinds of brute force attacks, rainbow
- -- tables and dictionary attacks.
- , passwordsStrength :: !Int
- -- | Validates user password at registration / password change.
- --
- -- If the function returns 'Just', then a 400 error is raised with
- -- specified text.
- --
- -- Default value doesn't validate passwords at all.
- , passwordValidator :: !(Text -> Maybe Text)
- -- | Transformation of errors produced by the auth server
- , servantErrorFormer :: !(ServantErr -> ServantErr)
- -- | Default size of page for pagination
- , defaultPageSize :: !Word
- -- | User specified method of sending single usage code for authorisation.
- --
- -- See also: endpoints 'AuthSigninGetCodeMethod' and 'AuthSigninPostCodeMethod'.
- --
- -- By default does nothing.
- , singleUseCodeSender :: !(RespUserInfo -> SingleUseCode -> IO ())
- -- | Time the generated single usage code expires after.
- --
- -- By default 1 hour.
- , singleUseCodeExpire :: !NominalDiffTime
- -- | User specified generator for single use codes.
- --
- -- By default the server generates UUID that can be unacceptable for SMS way of sending.
- , singleUseCodeGenerator :: !(IO SingleUseCode)
- -- | Number of not expiring single use codes that user can have at once.
- --
- -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 100.
- , singleUseCodePermamentMaximum :: !Word
- -- | Number of not expiring single use codes that generated by default when client doesn't
- -- specify the value.
- --
- -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 20.
- , singleUseCodeDefaultCount :: !Word
- }
-
--- | Default configuration for authorisation server
-defaultAuthConfig :: AuthConfig
-defaultAuthConfig = AuthConfig {
- defaultExpire = fromIntegral (600 :: Int)
- , restoreExpire = fromIntegral (3*24*3600 :: Int) -- 3 days
- , restoreCodeSender = const $ const $ return ()
- , restoreCodeGenerator = uuidCodeGenerate
- , maximumExpire = Nothing
- , passwordsStrength = 17
- , passwordValidator = const Nothing
- , servantErrorFormer = id
- , defaultPageSize = 50
- , singleUseCodeSender = const $ const $ return ()
- , singleUseCodeExpire = fromIntegral (60 * 60 :: Int) -- 1 hour
- , singleUseCodeGenerator = uuidSingleUseCodeGenerate
- , singleUseCodePermamentMaximum = 100
- , singleUseCodeDefaultCount = 20
- }
-
--- | Default generator of restore codes
-uuidCodeGenerate :: IO RestoreCode
-uuidCodeGenerate = toText <$> liftIO nextRandom
-
--- | Default generator of restore codes
-uuidSingleUseCodeGenerate :: IO RestoreCode
-uuidSingleUseCodeGenerate = toText <$> liftIO nextRandom
+{-# LANGUAGE DefaultSignatures #-}
+
+{-|
+Module : Servant.Server.Auth.Token.Config
+Description : Configuration of auth server
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Config(
+ AuthConfig(..)
+ , HasAuthConfig(..)
+ , defaultAuthConfig
+ ) where
+
+import Control.Monad.Cont (ContT)
+import Control.Monad.Except (ExceptT)
+import Control.Monad.IO.Class
+import Control.Monad.Reader (ReaderT)
+import qualified Control.Monad.RWS.Lazy as LRWS
+import qualified Control.Monad.RWS.Strict as SRWS
+import qualified Control.Monad.State.Lazy as LS
+import qualified Control.Monad.State.Strict as SS
+import qualified Control.Monad.Writer.Lazy as LW
+import qualified Control.Monad.Writer.Strict as SW
+import Control.Monad.Trans.Class (MonadTrans(lift))
+import Data.Text (Text)
+import Data.Time
+import Data.UUID
+import Data.UUID.V4
+import Servant.Server
+
+import Servant.API.Auth.Token
+
+-- | Monad that can read an auth config
+class Monad m => HasAuthConfig m where
+ getAuthConfig :: m AuthConfig
+ default getAuthConfig :: (m ~ t n, MonadTrans t, HasAuthConfig n) => m AuthConfig
+ getAuthConfig = lift getAuthConfig
+
+instance HasAuthConfig m => HasAuthConfig (ContT r m)
+instance HasAuthConfig m => HasAuthConfig (ExceptT e m)
+instance HasAuthConfig m => HasAuthConfig (ReaderT r m)
+instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LRWS.RWST r w s m)
+instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SRWS.RWST r w s m)
+instance HasAuthConfig m => HasAuthConfig (LS.StateT s m)
+instance HasAuthConfig m => HasAuthConfig (SS.StateT s m)
+instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LW.WriterT w m)
+instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SW.WriterT w m)
+
+-- | Configuration specific for authorisation system
+data AuthConfig = AuthConfig {
+ -- | For authorisation, defines amounts of seconds
+ -- when token becomes invalid.
+ defaultExpire :: !NominalDiffTime
+ -- | For password restore, defines amounts of seconds
+ -- when restore code becomes invalid.
+ , restoreExpire :: !NominalDiffTime
+ -- | User specified implementation of restore code sending. It could
+ -- be a email sender or SMS message or mobile application method, whatever
+ -- the implementation needs.
+ , restoreCodeSender :: !(RespUserInfo -> RestoreCode -> IO ())
+ -- | User specified generator for restore codes. By default the server
+ -- generates UUID that can be unacceptable for SMS restoration routine.
+ , restoreCodeGenerator :: !(IO RestoreCode)
+ -- | Upper bound of expiration time that user can request
+ -- for a token.
+ , maximumExpire :: !(Maybe NominalDiffTime)
+ -- | For authorisation, defines amount of hashing
+ -- of new user passwords (should be greater or equal 14).
+ -- The passwords hashed 2^strength times. It is needed to
+ -- prevent almost all kinds of brute force attacks, rainbow
+ -- tables and dictionary attacks.
+ , passwordsStrength :: !Int
+ -- | Validates user password at registration / password change.
+ --
+ -- If the function returns 'Just', then a 400 error is raised with
+ -- specified text.
+ --
+ -- Default value doesn't validate passwords at all.
+ , passwordValidator :: !(Text -> Maybe Text)
+ -- | Transformation of errors produced by the auth server
+ , servantErrorFormer :: !(ServantErr -> ServantErr)
+ -- | Default size of page for pagination
+ , defaultPageSize :: !Word
+ -- | User specified method of sending single usage code for authorisation.
+ --
+ -- See also: endpoints 'AuthSigninGetCodeMethod' and 'AuthSigninPostCodeMethod'.
+ --
+ -- By default does nothing.
+ , singleUseCodeSender :: !(RespUserInfo -> SingleUseCode -> IO ())
+ -- | Time the generated single usage code expires after.
+ --
+ -- By default 1 hour.
+ , singleUseCodeExpire :: !NominalDiffTime
+ -- | User specified generator for single use codes.
+ --
+ -- By default the server generates UUID that can be unacceptable for SMS way of sending.
+ , singleUseCodeGenerator :: !(IO SingleUseCode)
+ -- | Number of not expiring single use codes that user can have at once.
+ --
+ -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 100.
+ , singleUseCodePermamentMaximum :: !Word
+ -- | Number of not expiring single use codes that generated by default when client doesn't
+ -- specify the value.
+ --
+ -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 20.
+ , singleUseCodeDefaultCount :: !Word
+ }
+
+-- | Default configuration for authorisation server
+defaultAuthConfig :: AuthConfig
+defaultAuthConfig = AuthConfig {
+ defaultExpire = fromIntegral (600 :: Int)
+ , restoreExpire = fromIntegral (3*24*3600 :: Int) -- 3 days
+ , restoreCodeSender = const $ const $ return ()
+ , restoreCodeGenerator = uuidCodeGenerate
+ , maximumExpire = Nothing
+ , passwordsStrength = 17
+ , passwordValidator = const Nothing
+ , servantErrorFormer = id
+ , defaultPageSize = 50
+ , singleUseCodeSender = const $ const $ return ()
+ , singleUseCodeExpire = fromIntegral (60 * 60 :: Int) -- 1 hour
+ , singleUseCodeGenerator = uuidSingleUseCodeGenerate
+ , singleUseCodePermamentMaximum = 100
+ , singleUseCodeDefaultCount = 20
+ }
+
+-- | Default generator of restore codes
+uuidCodeGenerate :: IO RestoreCode
+uuidCodeGenerate = toText <$> liftIO nextRandom
+
+-- | Default generator of restore codes
+uuidSingleUseCodeGenerate :: IO RestoreCode
+uuidSingleUseCodeGenerate = toText <$> liftIO nextRandom
diff --git a/src/Servant/Server/Auth/Token/Error.hs b/src/Servant/Server/Auth/Token/Error.hs
index 5cf6afb..5338f27 100644
--- a/src/Servant/Server/Auth/Token/Error.hs
+++ b/src/Servant/Server/Auth/Token/Error.hs
@@ -1,39 +1,39 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-|
-Module : Servant.Server.Auth.Token.Error
-Description : Utilities to wrap errors
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.Error(
- throw400
- , throw401
- , throw404
- , throw409
- , throw500
- ) where
-
-import Control.Monad.Except
-import Servant.Server
-import Servant.Server.Auth.Token.Config
-
-import qualified Data.ByteString.Lazy as BS
-
--- | Prepare error response
-makeBody :: HasAuthConfig m => ServantErr -> m ServantErr
-makeBody e = do
- f <- fmap servantErrorFormer getAuthConfig
- return $ f e
-
--- | Wrappers to throw corresponding servant errors
-throw400, throw401, throw404, throw409, throw500
- :: (MonadError ServantErr m, HasAuthConfig m)
- => BS.ByteString -> m a
-throw400 t = throwError =<< makeBody err400 { errBody = t }
-throw401 t = throwError =<< makeBody err401 { errBody = t }
-throw404 t = throwError =<< makeBody err404 { errBody = t }
-throw409 t = throwError =<< makeBody err409 { errBody = t }
-throw500 t = throwError =<< makeBody err500 { errBody = t }
+{-# LANGUAGE TemplateHaskell #-}
+{-|
+Module : Servant.Server.Auth.Token.Error
+Description : Utilities to wrap errors
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Error(
+ throw400
+ , throw401
+ , throw404
+ , throw409
+ , throw500
+ ) where
+
+import Control.Monad.Except
+import Servant.Server
+import Servant.Server.Auth.Token.Config
+
+import qualified Data.ByteString.Lazy as BS
+
+-- | Prepare error response
+makeBody :: HasAuthConfig m => ServantErr -> m ServantErr
+makeBody e = do
+ f <- fmap servantErrorFormer getAuthConfig
+ return $ f e
+
+-- | Wrappers to throw corresponding servant errors
+throw400, throw401, throw404, throw409, throw500
+ :: (MonadError ServantErr m, HasAuthConfig m)
+ => BS.ByteString -> m a
+throw400 t = throwError =<< makeBody err400 { errBody = t }
+throw401 t = throwError =<< makeBody err401 { errBody = t }
+throw404 t = throwError =<< makeBody err404 { errBody = t }
+throw409 t = throwError =<< makeBody err409 { errBody = t }
+throw500 t = throwError =<< makeBody err500 { errBody = t }
diff --git a/src/Servant/Server/Auth/Token/Model.hs b/src/Servant/Server/Auth/Token/Model.hs
index d71a651..36b32b9 100644
--- a/src/Servant/Server/Auth/Token/Model.hs
+++ b/src/Servant/Server/Auth/Token/Model.hs
@@ -1,654 +1,654 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-|
-Module : Servant.Server.Auth.Token.Model
-Description : Internal operations with RDBMS
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.Model(
- -- * DB entities
- UserImpl(..)
- , UserPerm(..)
- , AuthToken(..)
- , UserRestore(..)
- , AuthUserGroup(..)
- , AuthUserGroupUsers(..)
- , AuthUserGroupPerms(..)
- , UserSingleUseCode(..)
- -- * IDs of entities
- , UserImplId
- , UserPermId
- , AuthTokenId
- , UserRestoreId
- , AuthUserGroupId
- , AuthUserGroupUsersId
- , AuthUserGroupPermsId
- , UserSingleUseCodeId
- -- * DB interface
- , HasStorage(..)
- -- * Operations
- , passToByteString
- , byteStringToPass
- -- ** User
- , userToUserInfo
- , readUserInfo
- , readUserInfoByLogin
- , getUserPermissions
- , setUserPermissions
- , createUser
- , hasPerms
- , createAdmin
- , ensureAdmin
- , patchUser
- , setUserPassword'
- -- ** User groups
- , getUserGroups
- , setUserGroups
- , validateGroups
- , getGroupPermissions
- , getUserGroupPermissions
- , getUserAllPermissions
- , readUserGroup
- , toAuthUserGroup
- , insertUserGroup
- , updateUserGroup
- , deleteUserGroup
- , patchUserGroup
- -- * Low-level
- , makeUserInfo
- ) where
-
-import Control.Monad
-import Control.Monad.Cont (ContT)
-import Control.Monad.Except (ExceptT)
-import Control.Monad.IO.Class
-import Control.Monad.Reader (ReaderT)
-import qualified Control.Monad.RWS.Lazy as LRWS
-import qualified Control.Monad.RWS.Strict as SRWS
-import qualified Control.Monad.State.Lazy as LS
-import qualified Control.Monad.State.Strict as SS
-import qualified Control.Monad.Writer.Lazy as LW
-import qualified Control.Monad.Writer.Strict as SW
-import Control.Monad.Trans.Class (MonadTrans(lift))
-import Crypto.PasswordStore
-import Data.Aeson.WithField
-import Data.Int
-import Data.Maybe
-import Data.Monoid
-import Data.Text (Text)
-import Data.Time
-import GHC.Generics
-
-import qualified Data.ByteString as BS
-import qualified Data.Foldable as F
-import qualified Data.List as L
-import qualified Data.Sequence as S
-import qualified Data.Text.Encoding as TE
-
-import Servant.API.Auth.Token
-import Servant.API.Auth.Token.Pagination
-import Servant.Server.Auth.Token.Common
-import Servant.Server.Auth.Token.Patch
-
--- | ID of user
-newtype UserImplId = UserImplId { unUserImplId :: Int64 }
- deriving (Generic, Show, Eq, Ord)
-
-instance ConvertableKey UserImplId where
- toKey = UserImplId . fromIntegral
- fromKey = fromIntegral . unUserImplId
- {-# INLINE toKey #-}
- {-# INLINE fromKey #-}
-
--- | Internal user implementation
-data UserImpl = UserImpl {
- userImplLogin :: !Login -- ^ Unique user login
-, userImplPassword :: !Password -- ^ Password encrypted with salt
-, userImplEmail :: !Email -- ^ User email
-} deriving (Generic, Show)
-
--- | ID of user permission
-newtype UserPermId = UserPermId { unUserPermId :: Int64 }
- deriving (Generic, Show, Eq, Ord)
-
-instance ConvertableKey UserPermId where
- toKey = UserPermId . fromIntegral
- fromKey = fromIntegral . unUserPermId
- {-# INLINE toKey #-}
- {-# INLINE fromKey #-}
-
--- | Internal implementation of permission (1-M)
-data UserPerm = UserPerm {
- userPermUser :: !UserImplId -- ^ Reference to user
-, userPermPermission :: !Permission -- ^ Permission tag
-} deriving (Generic, Show)
-
--- | ID of authorisation token
-newtype AuthTokenId = AuthTokenId { unAuthTokenId :: Int64 }
- deriving (Generic, Show, Eq, Ord)
-
-instance ConvertableKey AuthTokenId where
- toKey = AuthTokenId . fromIntegral
- fromKey = fromIntegral . unAuthTokenId
- {-# INLINE toKey #-}
- {-# INLINE fromKey #-}
-
--- | Internal implementation of authorisation token
-data AuthToken = AuthToken {
- authTokenValue :: !SimpleToken -- ^ Value of token
-, authTokenUser :: !UserImplId -- ^ Reference to user of the token
-, authTokenExpire :: !UTCTime -- ^ When the token expires
-} deriving (Generic, Show)
-
--- | ID of restoration code
-newtype UserRestoreId = UserRestoreId { unUserRestoreId :: Int64 }
- deriving (Generic, Show, Eq, Ord)
-
-instance ConvertableKey UserRestoreId where
- toKey = UserRestoreId . fromIntegral
- fromKey = fromIntegral . unUserRestoreId
- {-# INLINE toKey #-}
- {-# INLINE fromKey #-}
-
--- | Internal implementation of restoration code
-data UserRestore = UserRestore {
- userRestoreValue :: !RestoreCode -- ^ Code value
-, userRestoreUser :: !UserImplId -- ^ Reference to user that the code restores
-, userRestoreExpire :: !UTCTime -- ^ When the code expires
-} deriving (Generic, Show)
-
--- | ID of single use code
-newtype UserSingleUseCodeId = UserSingleUseCodeId { unUserSingleUseCodeId :: Int64 }
- deriving (Generic, Show, Eq, Ord)
-
-instance ConvertableKey UserSingleUseCodeId where
- toKey = UserSingleUseCodeId . fromIntegral
- fromKey = fromIntegral . unUserSingleUseCodeId
- {-# INLINE toKey #-}
- {-# INLINE fromKey #-}
-
--- | Internal implementation of single use code
-data UserSingleUseCode = UserSingleUseCode {
- userSingleUseCodeValue :: !SingleUseCode -- ^ Value of single use code
-, userSingleUseCodeUser :: !UserImplId -- ^ Reference to user the code is owned by
-, userSingleUseCodeExpire :: !(Maybe UTCTime) -- ^ When the code expires, 'Nothing' is code that never expires
-, userSingleUseCodeUsed :: !(Maybe UTCTime) -- ^ When the code was used
-} deriving (Generic, Show)
-
--- | ID of user group
-newtype AuthUserGroupId = AuthUserGroupId { unAuthUserGroupId :: Int64 }
- deriving (Generic, Show, Eq, Ord)
-
-instance ConvertableKey AuthUserGroupId where
- toKey = AuthUserGroupId . fromIntegral
- fromKey = fromIntegral . unAuthUserGroupId
- {-# INLINE toKey #-}
- {-# INLINE fromKey #-}
-
--- | Internal implementation of user group
-data AuthUserGroup = AuthUserGroup {
- authUserGroupName :: !Text -- ^ Name of group
-, authUserGroupParent :: !(Maybe AuthUserGroupId) -- ^ Can be a child of another group
-} deriving (Generic, Show)
-
--- | ID of user-group binding
-newtype AuthUserGroupUsersId = AuthUserGroupUsersId { unAuthUserGroupUsersId :: Int64 }
- deriving (Generic, Show, Eq, Ord)
-
-instance ConvertableKey AuthUserGroupUsersId where
- toKey = AuthUserGroupUsersId . fromIntegral
- fromKey = fromIntegral . unAuthUserGroupUsersId
- {-# INLINE toKey #-}
- {-# INLINE fromKey #-}
-
--- | Implementation of M-M between user and group
-data AuthUserGroupUsers = AuthUserGroupUsers {
- authUserGroupUsersGroup :: !AuthUserGroupId
-, authUserGroupUsersUser :: !UserImplId
-} deriving (Generic, Show)
-
--- | ID of permission-group binding
-newtype AuthUserGroupPermsId = AuthUserGroupPermsId { unAuthUserGroupPermsId :: Int64 }
- deriving (Generic, Show, Eq, Ord)
-
-instance ConvertableKey AuthUserGroupPermsId where
- toKey = AuthUserGroupPermsId . fromIntegral
- fromKey = fromIntegral . unAuthUserGroupPermsId
- {-# INLINE toKey #-}
- {-# INLINE fromKey #-}
-
--- | Implementation of M-M between permission and group
-data AuthUserGroupPerms = AuthUserGroupPerms {
- authUserGroupPermsGroup :: AuthUserGroupId
-, authUserGroupPermsPermission :: Permission
-} deriving (Generic, Show)
-
--- | Abstract storage interface. External libraries can implement this in terms
--- of PostgreSQL or acid-state.
-class MonadIO m => HasStorage m where
- -- | Getting user from storage
- getUserImpl :: UserImplId -> m (Maybe UserImpl)
- default getUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m (Maybe UserImpl)
- getUserImpl = lift . getUserImpl
-
- -- | Getting user from storage by login
- getUserImplByLogin :: Login -> m (Maybe (WithId UserImplId UserImpl))
- default getUserImplByLogin :: (m ~ t n, MonadTrans t, HasStorage n) => Login -> m (Maybe (WithId UserImplId UserImpl))
- getUserImplByLogin = lift . getUserImplByLogin
-
- -- | Get paged list of users and total count of users
- listUsersPaged :: Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
- default listUsersPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
- listUsersPaged = (lift .) . listUsersPaged
-
- -- | Get user permissions, ascending by tag
- getUserImplPermissions :: UserImplId -> m [WithId UserPermId UserPerm]
- default getUserImplPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId UserPermId UserPerm]
- getUserImplPermissions = lift . getUserImplPermissions
-
- -- | Delete user permissions
- deleteUserPermissions :: UserImplId -> m ()
- default deleteUserPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
- deleteUserPermissions = lift . deleteUserPermissions
-
- -- | Insertion of new user permission
- insertUserPerm :: UserPerm -> m UserPermId
- default insertUserPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserPerm -> m UserPermId
- insertUserPerm = lift . insertUserPerm
-
- -- | Insertion of new user
- insertUserImpl :: UserImpl -> m UserImplId
- default insertUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImpl -> m UserImplId
- insertUserImpl = lift . insertUserImpl
-
- -- | Replace user with new value
- replaceUserImpl :: UserImplId -> UserImpl -> m ()
- default replaceUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UserImpl -> m ()
- replaceUserImpl = (lift .) . replaceUserImpl
-
- -- | Delete user by id
- deleteUserImpl :: UserImplId -> m ()
- default deleteUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
- deleteUserImpl = lift . deleteUserImpl
-
- -- | Check whether the user has particular permission
- hasPerm :: UserImplId -> Permission -> m Bool
- default hasPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> Permission -> m Bool
- hasPerm = (lift .) . hasPerm
-
- -- | Get any user with given permission
- getFirstUserByPerm :: Permission -> m (Maybe (WithId UserImplId UserImpl))
- default getFirstUserByPerm :: (m ~ t n, MonadTrans t, HasStorage n) => Permission -> m (Maybe (WithId UserImplId UserImpl))
- getFirstUserByPerm = lift . getFirstUserByPerm
-
- -- | Select user groups and sort them by ascending name
- selectUserImplGroups :: UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
- default selectUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
- selectUserImplGroups = lift . selectUserImplGroups
-
- -- | Remove user from all groups
- clearUserImplGroups :: UserImplId -> m ()
- default clearUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
- clearUserImplGroups = lift . clearUserImplGroups
-
- -- | Add new user group
- insertAuthUserGroup :: AuthUserGroup -> m AuthUserGroupId
- default insertAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroup -> m AuthUserGroupId
- insertAuthUserGroup = lift . insertAuthUserGroup
-
- -- | Add user to given group
- insertAuthUserGroupUsers :: AuthUserGroupUsers -> m AuthUserGroupUsersId
- default insertAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupUsers -> m AuthUserGroupUsersId
- insertAuthUserGroupUsers = lift . insertAuthUserGroupUsers
-
- -- | Add permission to given group
- insertAuthUserGroupPerms :: AuthUserGroupPerms -> m AuthUserGroupPermsId
- default insertAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupPerms -> m AuthUserGroupPermsId
- insertAuthUserGroupPerms = lift . insertAuthUserGroupPerms
-
- -- | Find user group by id
- getAuthUserGroup :: AuthUserGroupId -> m (Maybe AuthUserGroup)
- default getAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m (Maybe AuthUserGroup)
- getAuthUserGroup = lift . getAuthUserGroup
-
- -- | Get list of permissions of given group
- listAuthUserGroupPermissions :: AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
- default listAuthUserGroupPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
- listAuthUserGroupPermissions = lift . listAuthUserGroupPermissions
-
- -- | Get list of all users of the group
- listAuthUserGroupUsers :: AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
- default listAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
- listAuthUserGroupUsers = lift . listAuthUserGroupUsers
-
- -- | Replace record of user group
- replaceAuthUserGroup :: AuthUserGroupId -> AuthUserGroup -> m ()
- default replaceAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> AuthUserGroup -> m ()
- replaceAuthUserGroup = (lift .) . replaceAuthUserGroup
-
- -- | Remove all users from group
- clearAuthUserGroupUsers :: AuthUserGroupId -> m ()
- default clearAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
- clearAuthUserGroupUsers = lift . clearAuthUserGroupUsers
-
- -- | Remove all permissions from group
- clearAuthUserGroupPerms :: AuthUserGroupId -> m ()
- default clearAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
- clearAuthUserGroupPerms = lift . clearAuthUserGroupPerms
-
- -- | Delete user group from storage
- deleteAuthUserGroup :: AuthUserGroupId -> m ()
- default deleteAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
- deleteAuthUserGroup = lift . deleteAuthUserGroup
-
- -- | Get paged list of user groups with total count
- listGroupsPaged :: Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
- default listGroupsPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
- listGroupsPaged = (lift .) . listGroupsPaged
-
- -- | Set group name
- setAuthUserGroupName :: AuthUserGroupId -> Text -> m ()
- default setAuthUserGroupName :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Text -> m ()
- setAuthUserGroupName = (lift .) . setAuthUserGroupName
-
- -- | Set group parent
- setAuthUserGroupParent :: AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
- default setAuthUserGroupParent :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
- setAuthUserGroupParent = (lift .) . setAuthUserGroupParent
-
- -- | Add new single use code
- insertSingleUseCode :: UserSingleUseCode -> m UserSingleUseCodeId
- default insertSingleUseCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCode -> m UserSingleUseCodeId
- insertSingleUseCode = lift . insertSingleUseCode
-
- -- | Set usage time of the single use code
- setSingleUseCodeUsed :: UserSingleUseCodeId -> Maybe UTCTime -> m ()
- default setSingleUseCodeUsed :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCodeId -> Maybe UTCTime -> m ()
- setSingleUseCodeUsed = (lift .) . setSingleUseCodeUsed
-
- -- | Find unused code for the user and expiration time greater than the given time
- getUnusedCode :: SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
- default getUnusedCode :: (m ~ t n, MonadTrans t, HasStorage n) => SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
- getUnusedCode suc = (lift .) . getUnusedCode suc
-
- -- | Invalidate all permament codes for user and set use time for them
- invalidatePermamentCodes :: UserImplId -> UTCTime -> m ()
- default invalidatePermamentCodes :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m ()
- invalidatePermamentCodes = (lift .) . invalidatePermamentCodes
-
- -- | Select last valid restoration code by the given current time
- selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
- default selectLastRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
- selectLastRestoreCode = (lift .) . selectLastRestoreCode
-
- -- | Insert new restore code
- insertUserRestore :: UserRestore -> m UserRestoreId
- default insertUserRestore :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestore -> m UserRestoreId
- insertUserRestore = lift . insertUserRestore
-
- -- | Find unexpired by the time restore code
- findRestoreCode :: UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
- default findRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
- findRestoreCode uid = (lift .) . findRestoreCode uid
-
- -- | Replace restore code with new value
- replaceRestoreCode :: UserRestoreId -> UserRestore -> m ()
- default replaceRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestoreId -> UserRestore -> m ()
- replaceRestoreCode = (lift .) . replaceRestoreCode
-
- -- | Find first non-expired by the time token for user
- findAuthToken :: UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
- default findAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
- findAuthToken = (lift .) . findAuthToken
-
- -- | Find token by value
- findAuthTokenByValue :: SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
- default findAuthTokenByValue :: (m ~ t n, MonadTrans t, HasStorage n) => SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
- findAuthTokenByValue = lift . findAuthTokenByValue
-
- -- | Insert new token
- insertAuthToken :: AuthToken -> m AuthTokenId
- default insertAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthToken -> m AuthTokenId
- insertAuthToken = lift . insertAuthToken
-
- -- | Replace auth token with new value
- replaceAuthToken :: AuthTokenId -> AuthToken -> m ()
- default replaceAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthTokenId -> AuthToken -> m ()
- replaceAuthToken = (lift .) . replaceAuthToken
-
-instance HasStorage m => HasStorage (ContT r m)
-instance HasStorage m => HasStorage (ExceptT e m)
-instance HasStorage m => HasStorage (ReaderT r m)
-instance (HasStorage m, Monoid w) => HasStorage (LRWS.RWST r w s m)
-instance (HasStorage m, Monoid w) => HasStorage (SRWS.RWST r w s m)
-instance HasStorage m => HasStorage (LS.StateT s m)
-instance HasStorage m => HasStorage (SS.StateT s m)
-instance (HasStorage m, Monoid w) => HasStorage (LW.WriterT w m)
-instance (HasStorage m, Monoid w) => HasStorage (SW.WriterT w m)
-
--- | Convert password to bytestring
-passToByteString :: Password -> BS.ByteString
-passToByteString = TE.encodeUtf8
-
--- | Convert bytestring into password
-byteStringToPass :: BS.ByteString -> Password
-byteStringToPass = TE.decodeUtf8
-
--- | Helper to convert user to response
-userToUserInfo :: WithId UserImplId UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo
-userToUserInfo (WithField uid UserImpl{..}) perms groups = RespUserInfo {
- respUserId = fromKey uid
- , respUserLogin = userImplLogin
- , respUserEmail = userImplEmail
- , respUserPermissions = perms
- , respUserGroups = groups
- }
-
--- | Low level operation for collecting info about user
-makeUserInfo :: HasStorage m => WithId UserImplId UserImpl -> m RespUserInfo
-makeUserInfo euser@(WithField uid _) = do
- perms <- getUserPermissions uid
- groups <- getUserGroups uid
- return $ userToUserInfo euser perms groups
-
--- | Get user by id
-readUserInfo :: HasStorage m => UserId -> m (Maybe RespUserInfo)
-readUserInfo uid' = do
- let uid = toKey uid'
- muser <- getUserImpl uid
- maybe (return Nothing) (fmap Just . makeUserInfo . WithField uid) $ muser
-
--- | Get user by login
-readUserInfoByLogin :: HasStorage m => Login -> m (Maybe RespUserInfo)
-readUserInfoByLogin login = do
- muser <- getUserImplByLogin login
- maybe (return Nothing) (fmap Just . makeUserInfo) muser
-
--- | Return list of permissions for the given user (only permissions that are assigned to him directly)
-getUserPermissions :: HasStorage m => UserImplId -> m [Permission]
-getUserPermissions uid = do
- perms <- getUserImplPermissions uid
- return $ userPermPermission . (\(WithField _ v) -> v) <$> perms
-
--- | Return list of permissions for the given user
-setUserPermissions :: HasStorage m => UserImplId -> [Permission] -> m ()
-setUserPermissions uid perms = do
- deleteUserPermissions uid
- forM_ perms $ void . insertUserPerm . UserPerm uid
-
--- | Creation of new user
-createUser :: HasStorage m => Int -> Login -> Password -> Email -> [Permission] -> m UserImplId
-createUser strength login pass email perms = do
- pass' <- liftIO $ makePassword (passToByteString pass) strength
- i <- insertUserImpl UserImpl {
- userImplLogin = login
- , userImplPassword = byteStringToPass pass'
- , userImplEmail = email
- }
- forM_ perms $ void . insertUserPerm . UserPerm i
- return i
-
--- | Check whether the user has particular permissions
-hasPerms :: HasStorage m => UserImplId -> [Permission] -> m Bool
-hasPerms _ [] = return True
-hasPerms i perms = do
- perms' <- getUserAllPermissions i
- return $ and $ (`elem` perms') <$> perms
-
--- | Creates user with admin privileges
-createAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m UserImplId
-createAdmin strength login pass email = createUser strength login pass email [adminPerm]
-
--- | Ensures that DB has at leas one admin, if not, creates a new one
--- with specified info.
-ensureAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m ()
-ensureAdmin strength login pass email = do
- madmin <- getFirstUserByPerm adminPerm
- whenNothing madmin $ void $ createAdmin strength login pass email
-
--- | Apply patches for user
-patchUser :: HasStorage m => Int -- ^ Password strength
- -> PatchUser -> WithId UserImplId UserImpl -> m (WithId UserImplId UserImpl)
-patchUser strength PatchUser{..} =
- withPatch patchUserLogin (\l (WithField i u) -> pure $ WithField i u { userImplLogin = l })
- >=> withPatch patchUserPassword patchPassword
- >=> withPatch patchUserEmail (\e (WithField i u) -> pure $ WithField i u { userImplEmail = e })
- >=> withPatch patchUserPermissions patchPerms
- >=> withPatch patchUserGroups patchGroups
- where
- patchPassword ps (WithField i u) = WithField <$> pure i <*> setUserPassword' strength ps u
- patchPerms ps (WithField i u) = do
- setUserPermissions i ps
- return $ WithField i u
- patchGroups gs (WithField i u) = do
- setUserGroups i gs
- return $ WithField i u
-
--- | Update password of user
-setUserPassword' :: MonadIO m => Int -- ^ Password strength
- -> Password -> UserImpl -> m UserImpl
-setUserPassword' strength pass user = do
- pass' <- liftIO $ makePassword (passToByteString pass) strength
- return $ user { userImplPassword = byteStringToPass pass' }
-
--- | Get all groups the user belongs to
-getUserGroups :: HasStorage m => UserImplId -> m [UserGroupId]
-getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . (\(WithField _ v) -> v)) <$> selectUserImplGroups i
-
--- | Rewrite all user groups
-setUserGroups :: HasStorage m => UserImplId -> [UserGroupId] -> m ()
-setUserGroups i gs = do
- clearUserImplGroups i
- gs' <- validateGroups gs
- forM_ gs' $ \g -> void $ insertAuthUserGroupUsers $ AuthUserGroupUsers g i
-
--- | Leave only existing groups
-validateGroups :: HasStorage m => [UserGroupId] -> m [AuthUserGroupId]
-validateGroups is = do
- pairs <- mapM ((\i -> (i,) <$> getAuthUserGroup i) . toKey) is
- return $ fmap fst . filter (isJust . snd) $ pairs
-
--- | Getting permission of a group and all it parent groups
-getGroupPermissions :: HasStorage m => UserGroupId -> m [Permission]
-getGroupPermissions = go S.empty S.empty . toKey
- where
- go !visited !perms !i = do
- mg <- getAuthUserGroup i
- case mg of
- Nothing -> return $ F.toList perms
- Just AuthUserGroup{..} -> do
- curPerms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i
- let perms' = perms <> S.fromList curPerms
- case authUserGroupParent of
- Nothing -> return $ F.toList perms'
- Just pid -> if isJust $ pid `S.elemIndexL` visited
- then fail $ "Recursive user group graph: " <> show (visited S.|> pid)
- else go (visited S.|> pid) perms' pid
-
--- | Get user permissions that are assigned to him/her via groups only
-getUserGroupPermissions :: HasStorage m => UserImplId -> m [Permission]
-getUserGroupPermissions i = do
- groups <- getUserGroups i
- perms <- mapM getGroupPermissions groups
- return $ L.sort . L.nub . concat $ perms
-
--- | Get user permissions that are assigned to him/her either by direct
--- way or by his/her groups.
-getUserAllPermissions :: HasStorage m => UserImplId -> m [Permission]
-getUserAllPermissions i = do
- permsDr <- getUserPermissions i
- permsGr <- getUserGroupPermissions i
- return $ L.sort . L.nub $ permsDr <> permsGr
-
--- | Collect full info about user group from RDBMS
-readUserGroup :: HasStorage m => UserGroupId -> m (Maybe UserGroup)
-readUserGroup i = do
- let i' = toKey $ i
- mu <- getAuthUserGroup i'
- case mu of
- Nothing -> return Nothing
- Just AuthUserGroup{..} -> do
- users <- fmap (authUserGroupUsersUser . (\(WithField _ v) -> v)) <$> listAuthUserGroupUsers i'
- perms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i'
- return $ Just UserGroup {
- userGroupName = authUserGroupName
- , userGroupUsers = fromKey <$> users
- , userGroupPermissions = perms
- , userGroupParent = fromKey <$> authUserGroupParent
- }
-
--- | Helper to convert user group into values of several tables
-toAuthUserGroup :: UserGroup -> (AuthUserGroup, AuthUserGroupId -> [AuthUserGroupUsers], AuthUserGroupId -> [AuthUserGroupPerms])
-toAuthUserGroup UserGroup{..} = (ag, users, perms)
- where
- ag = AuthUserGroup {
- authUserGroupName = userGroupName
- , authUserGroupParent = toKey <$> userGroupParent
- }
- users i = (\ui -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers
- perms i = (\perm -> AuthUserGroupPerms i perm) <$> userGroupPermissions
-
--- | Insert user group into RDBMS
-insertUserGroup :: HasStorage m => UserGroup -> m UserGroupId
-insertUserGroup u = do
- let (ag, users, perms) = toAuthUserGroup u
- i <- insertAuthUserGroup ag
- forM_ (users i) $ void . insertAuthUserGroupUsers
- forM_ (perms i) $ void . insertAuthUserGroupPerms
- return $ fromKey $ i
-
--- | Replace user group with new value
-updateUserGroup :: HasStorage m => UserGroupId -> UserGroup -> m ()
-updateUserGroup i u = do
- let i' = toKey $ i
- let (ag, users, perms) = toAuthUserGroup u
- replaceAuthUserGroup i' ag
- clearAuthUserGroupUsers i'
- clearAuthUserGroupPerms i'
- forM_ (users i') $ void . insertAuthUserGroupUsers
- forM_ (perms i') $ void . insertAuthUserGroupPerms
-
--- | Erase user group from RDBMS, cascade
-deleteUserGroup :: HasStorage m => UserGroupId -> m ()
-deleteUserGroup i = do
- let i' = toKey $ i
- clearAuthUserGroupUsers i'
- clearAuthUserGroupPerms i'
- deleteAuthUserGroup i'
-
--- | Partial update of user group
-patchUserGroup :: HasStorage m => UserGroupId -> PatchUserGroup -> m ()
-patchUserGroup i PatchUserGroup{..} = do
- let i' = toKey i
- whenJust patchUserGroupName $ setAuthUserGroupName i'
- whenJust patchUserGroupParent $ setAuthUserGroupParent i' . Just . toKey
- whenJust patchUserGroupNoParent $ const $ setAuthUserGroupParent i' Nothing
- whenJust patchUserGroupUsers $ \uids -> do
- clearAuthUserGroupUsers i'
- forM_ uids $ insertAuthUserGroupUsers . AuthUserGroupUsers i' . toKey
- whenJust patchUserGroupPermissions $ \perms -> do
- clearAuthUserGroupPerms i'
- forM_ perms $ insertAuthUserGroupPerms . AuthUserGroupPerms i'
+{-# LANGUAGE DefaultSignatures #-}
+{-|
+Module : Servant.Server.Auth.Token.Model
+Description : Internal operations with RDBMS
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Model(
+ -- * DB entities
+ UserImpl(..)
+ , UserPerm(..)
+ , AuthToken(..)
+ , UserRestore(..)
+ , AuthUserGroup(..)
+ , AuthUserGroupUsers(..)
+ , AuthUserGroupPerms(..)
+ , UserSingleUseCode(..)
+ -- * IDs of entities
+ , UserImplId
+ , UserPermId
+ , AuthTokenId
+ , UserRestoreId
+ , AuthUserGroupId
+ , AuthUserGroupUsersId
+ , AuthUserGroupPermsId
+ , UserSingleUseCodeId
+ -- * DB interface
+ , HasStorage(..)
+ -- * Operations
+ , passToByteString
+ , byteStringToPass
+ -- ** User
+ , userToUserInfo
+ , readUserInfo
+ , readUserInfoByLogin
+ , getUserPermissions
+ , setUserPermissions
+ , createUser
+ , hasPerms
+ , createAdmin
+ , ensureAdmin
+ , patchUser
+ , setUserPassword'
+ -- ** User groups
+ , getUserGroups
+ , setUserGroups
+ , validateGroups
+ , getGroupPermissions
+ , getUserGroupPermissions
+ , getUserAllPermissions
+ , readUserGroup
+ , toAuthUserGroup
+ , insertUserGroup
+ , updateUserGroup
+ , deleteUserGroup
+ , patchUserGroup
+ -- * Low-level
+ , makeUserInfo
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont (ContT)
+import Control.Monad.Except (ExceptT)
+import Control.Monad.IO.Class
+import Control.Monad.Reader (ReaderT)
+import qualified Control.Monad.RWS.Lazy as LRWS
+import qualified Control.Monad.RWS.Strict as SRWS
+import qualified Control.Monad.State.Lazy as LS
+import qualified Control.Monad.State.Strict as SS
+import qualified Control.Monad.Writer.Lazy as LW
+import qualified Control.Monad.Writer.Strict as SW
+import Control.Monad.Trans.Class (MonadTrans(lift))
+import Crypto.PasswordStore
+import Data.Aeson.WithField
+import Data.Int
+import Data.Maybe
+import Data.Monoid
+import Data.Text (Text)
+import Data.Time
+import GHC.Generics
+
+import qualified Data.ByteString as BS
+import qualified Data.Foldable as F
+import qualified Data.List as L
+import qualified Data.Sequence as S
+import qualified Data.Text.Encoding as TE
+
+import Servant.API.Auth.Token
+import Servant.API.Auth.Token.Pagination
+import Servant.Server.Auth.Token.Common
+import Servant.Server.Auth.Token.Patch
+
+-- | ID of user
+newtype UserImplId = UserImplId { unUserImplId :: Int64 }
+ deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey UserImplId where
+ toKey = UserImplId . fromIntegral
+ fromKey = fromIntegral . unUserImplId
+ {-# INLINE toKey #-}
+ {-# INLINE fromKey #-}
+
+-- | Internal user implementation
+data UserImpl = UserImpl {
+ userImplLogin :: !Login -- ^ Unique user login
+, userImplPassword :: !Password -- ^ Password encrypted with salt
+, userImplEmail :: !Email -- ^ User email
+} deriving (Generic, Show)
+
+-- | ID of user permission
+newtype UserPermId = UserPermId { unUserPermId :: Int64 }
+ deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey UserPermId where
+ toKey = UserPermId . fromIntegral
+ fromKey = fromIntegral . unUserPermId
+ {-# INLINE toKey #-}
+ {-# INLINE fromKey #-}
+
+-- | Internal implementation of permission (1-M)
+data UserPerm = UserPerm {
+ userPermUser :: !UserImplId -- ^ Reference to user
+, userPermPermission :: !Permission -- ^ Permission tag
+} deriving (Generic, Show)
+
+-- | ID of authorisation token
+newtype AuthTokenId = AuthTokenId { unAuthTokenId :: Int64 }
+ deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey AuthTokenId where
+ toKey = AuthTokenId . fromIntegral
+ fromKey = fromIntegral . unAuthTokenId
+ {-# INLINE toKey #-}
+ {-# INLINE fromKey #-}
+
+-- | Internal implementation of authorisation token
+data AuthToken = AuthToken {
+ authTokenValue :: !SimpleToken -- ^ Value of token
+, authTokenUser :: !UserImplId -- ^ Reference to user of the token
+, authTokenExpire :: !UTCTime -- ^ When the token expires
+} deriving (Generic, Show)
+
+-- | ID of restoration code
+newtype UserRestoreId = UserRestoreId { unUserRestoreId :: Int64 }
+ deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey UserRestoreId where
+ toKey = UserRestoreId . fromIntegral
+ fromKey = fromIntegral . unUserRestoreId
+ {-# INLINE toKey #-}
+ {-# INLINE fromKey #-}
+
+-- | Internal implementation of restoration code
+data UserRestore = UserRestore {
+ userRestoreValue :: !RestoreCode -- ^ Code value
+, userRestoreUser :: !UserImplId -- ^ Reference to user that the code restores
+, userRestoreExpire :: !UTCTime -- ^ When the code expires
+} deriving (Generic, Show)
+
+-- | ID of single use code
+newtype UserSingleUseCodeId = UserSingleUseCodeId { unUserSingleUseCodeId :: Int64 }
+ deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey UserSingleUseCodeId where
+ toKey = UserSingleUseCodeId . fromIntegral
+ fromKey = fromIntegral . unUserSingleUseCodeId
+ {-# INLINE toKey #-}
+ {-# INLINE fromKey #-}
+
+-- | Internal implementation of single use code
+data UserSingleUseCode = UserSingleUseCode {
+ userSingleUseCodeValue :: !SingleUseCode -- ^ Value of single use code
+, userSingleUseCodeUser :: !UserImplId -- ^ Reference to user the code is owned by
+, userSingleUseCodeExpire :: !(Maybe UTCTime) -- ^ When the code expires, 'Nothing' is code that never expires
+, userSingleUseCodeUsed :: !(Maybe UTCTime) -- ^ When the code was used
+} deriving (Generic, Show)
+
+-- | ID of user group
+newtype AuthUserGroupId = AuthUserGroupId { unAuthUserGroupId :: Int64 }
+ deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey AuthUserGroupId where
+ toKey = AuthUserGroupId . fromIntegral
+ fromKey = fromIntegral . unAuthUserGroupId
+ {-# INLINE toKey #-}
+ {-# INLINE fromKey #-}
+
+-- | Internal implementation of user group
+data AuthUserGroup = AuthUserGroup {
+ authUserGroupName :: !Text -- ^ Name of group
+, authUserGroupParent :: !(Maybe AuthUserGroupId) -- ^ Can be a child of another group
+} deriving (Generic, Show)
+
+-- | ID of user-group binding
+newtype AuthUserGroupUsersId = AuthUserGroupUsersId { unAuthUserGroupUsersId :: Int64 }
+ deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey AuthUserGroupUsersId where
+ toKey = AuthUserGroupUsersId . fromIntegral
+ fromKey = fromIntegral . unAuthUserGroupUsersId
+ {-# INLINE toKey #-}
+ {-# INLINE fromKey #-}
+
+-- | Implementation of M-M between user and group
+data AuthUserGroupUsers = AuthUserGroupUsers {
+ authUserGroupUsersGroup :: !AuthUserGroupId
+, authUserGroupUsersUser :: !UserImplId
+} deriving (Generic, Show)
+
+-- | ID of permission-group binding
+newtype AuthUserGroupPermsId = AuthUserGroupPermsId { unAuthUserGroupPermsId :: Int64 }
+ deriving (Generic, Show, Eq, Ord)
+
+instance ConvertableKey AuthUserGroupPermsId where
+ toKey = AuthUserGroupPermsId . fromIntegral
+ fromKey = fromIntegral . unAuthUserGroupPermsId
+ {-# INLINE toKey #-}
+ {-# INLINE fromKey #-}
+
+-- | Implementation of M-M between permission and group
+data AuthUserGroupPerms = AuthUserGroupPerms {
+ authUserGroupPermsGroup :: AuthUserGroupId
+, authUserGroupPermsPermission :: Permission
+} deriving (Generic, Show)
+
+-- | Abstract storage interface. External libraries can implement this in terms
+-- of PostgreSQL or acid-state.
+class MonadIO m => HasStorage m where
+ -- | Getting user from storage
+ getUserImpl :: UserImplId -> m (Maybe UserImpl)
+ default getUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m (Maybe UserImpl)
+ getUserImpl = lift . getUserImpl
+
+ -- | Getting user from storage by login
+ getUserImplByLogin :: Login -> m (Maybe (WithId UserImplId UserImpl))
+ default getUserImplByLogin :: (m ~ t n, MonadTrans t, HasStorage n) => Login -> m (Maybe (WithId UserImplId UserImpl))
+ getUserImplByLogin = lift . getUserImplByLogin
+
+ -- | Get paged list of users and total count of users
+ listUsersPaged :: Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
+ default listUsersPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId UserImplId UserImpl], Word)
+ listUsersPaged = (lift .) . listUsersPaged
+
+ -- | Get user permissions, ascending by tag
+ getUserImplPermissions :: UserImplId -> m [WithId UserPermId UserPerm]
+ default getUserImplPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId UserPermId UserPerm]
+ getUserImplPermissions = lift . getUserImplPermissions
+
+ -- | Delete user permissions
+ deleteUserPermissions :: UserImplId -> m ()
+ default deleteUserPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
+ deleteUserPermissions = lift . deleteUserPermissions
+
+ -- | Insertion of new user permission
+ insertUserPerm :: UserPerm -> m UserPermId
+ default insertUserPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserPerm -> m UserPermId
+ insertUserPerm = lift . insertUserPerm
+
+ -- | Insertion of new user
+ insertUserImpl :: UserImpl -> m UserImplId
+ default insertUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImpl -> m UserImplId
+ insertUserImpl = lift . insertUserImpl
+
+ -- | Replace user with new value
+ replaceUserImpl :: UserImplId -> UserImpl -> m ()
+ default replaceUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UserImpl -> m ()
+ replaceUserImpl = (lift .) . replaceUserImpl
+
+ -- | Delete user by id
+ deleteUserImpl :: UserImplId -> m ()
+ default deleteUserImpl :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
+ deleteUserImpl = lift . deleteUserImpl
+
+ -- | Check whether the user has particular permission
+ hasPerm :: UserImplId -> Permission -> m Bool
+ default hasPerm :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> Permission -> m Bool
+ hasPerm = (lift .) . hasPerm
+
+ -- | Get any user with given permission
+ getFirstUserByPerm :: Permission -> m (Maybe (WithId UserImplId UserImpl))
+ default getFirstUserByPerm :: (m ~ t n, MonadTrans t, HasStorage n) => Permission -> m (Maybe (WithId UserImplId UserImpl))
+ getFirstUserByPerm = lift . getFirstUserByPerm
+
+ -- | Select user groups and sort them by ascending name
+ selectUserImplGroups :: UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
+ default selectUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
+ selectUserImplGroups = lift . selectUserImplGroups
+
+ -- | Remove user from all groups
+ clearUserImplGroups :: UserImplId -> m ()
+ default clearUserImplGroups :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> m ()
+ clearUserImplGroups = lift . clearUserImplGroups
+
+ -- | Add new user group
+ insertAuthUserGroup :: AuthUserGroup -> m AuthUserGroupId
+ default insertAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroup -> m AuthUserGroupId
+ insertAuthUserGroup = lift . insertAuthUserGroup
+
+ -- | Add user to given group
+ insertAuthUserGroupUsers :: AuthUserGroupUsers -> m AuthUserGroupUsersId
+ default insertAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupUsers -> m AuthUserGroupUsersId
+ insertAuthUserGroupUsers = lift . insertAuthUserGroupUsers
+
+ -- | Add permission to given group
+ insertAuthUserGroupPerms :: AuthUserGroupPerms -> m AuthUserGroupPermsId
+ default insertAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupPerms -> m AuthUserGroupPermsId
+ insertAuthUserGroupPerms = lift . insertAuthUserGroupPerms
+
+ -- | Find user group by id
+ getAuthUserGroup :: AuthUserGroupId -> m (Maybe AuthUserGroup)
+ default getAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m (Maybe AuthUserGroup)
+ getAuthUserGroup = lift . getAuthUserGroup
+
+ -- | Get list of permissions of given group
+ listAuthUserGroupPermissions :: AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
+ default listAuthUserGroupPermissions :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupPermsId AuthUserGroupPerms]
+ listAuthUserGroupPermissions = lift . listAuthUserGroupPermissions
+
+ -- | Get list of all users of the group
+ listAuthUserGroupUsers :: AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
+ default listAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m [WithId AuthUserGroupUsersId AuthUserGroupUsers]
+ listAuthUserGroupUsers = lift . listAuthUserGroupUsers
+
+ -- | Replace record of user group
+ replaceAuthUserGroup :: AuthUserGroupId -> AuthUserGroup -> m ()
+ default replaceAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> AuthUserGroup -> m ()
+ replaceAuthUserGroup = (lift .) . replaceAuthUserGroup
+
+ -- | Remove all users from group
+ clearAuthUserGroupUsers :: AuthUserGroupId -> m ()
+ default clearAuthUserGroupUsers :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
+ clearAuthUserGroupUsers = lift . clearAuthUserGroupUsers
+
+ -- | Remove all permissions from group
+ clearAuthUserGroupPerms :: AuthUserGroupId -> m ()
+ default clearAuthUserGroupPerms :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
+ clearAuthUserGroupPerms = lift . clearAuthUserGroupPerms
+
+ -- | Delete user group from storage
+ deleteAuthUserGroup :: AuthUserGroupId -> m ()
+ default deleteAuthUserGroup :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> m ()
+ deleteAuthUserGroup = lift . deleteAuthUserGroup
+
+ -- | Get paged list of user groups with total count
+ listGroupsPaged :: Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
+ default listGroupsPaged :: (m ~ t n, MonadTrans t, HasStorage n) => Page -> PageSize -> m ([WithId AuthUserGroupId AuthUserGroup], Word)
+ listGroupsPaged = (lift .) . listGroupsPaged
+
+ -- | Set group name
+ setAuthUserGroupName :: AuthUserGroupId -> Text -> m ()
+ default setAuthUserGroupName :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Text -> m ()
+ setAuthUserGroupName = (lift .) . setAuthUserGroupName
+
+ -- | Set group parent
+ setAuthUserGroupParent :: AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
+ default setAuthUserGroupParent :: (m ~ t n, MonadTrans t, HasStorage n) => AuthUserGroupId -> Maybe AuthUserGroupId -> m ()
+ setAuthUserGroupParent = (lift .) . setAuthUserGroupParent
+
+ -- | Add new single use code
+ insertSingleUseCode :: UserSingleUseCode -> m UserSingleUseCodeId
+ default insertSingleUseCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCode -> m UserSingleUseCodeId
+ insertSingleUseCode = lift . insertSingleUseCode
+
+ -- | Set usage time of the single use code
+ setSingleUseCodeUsed :: UserSingleUseCodeId -> Maybe UTCTime -> m ()
+ default setSingleUseCodeUsed :: (m ~ t n, MonadTrans t, HasStorage n) => UserSingleUseCodeId -> Maybe UTCTime -> m ()
+ setSingleUseCodeUsed = (lift .) . setSingleUseCodeUsed
+
+ -- | Find unused code for the user and expiration time greater than the given time
+ getUnusedCode :: SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
+ default getUnusedCode :: (m ~ t n, MonadTrans t, HasStorage n) => SingleUseCode -> UserImplId -> UTCTime -> m (Maybe (WithId UserSingleUseCodeId UserSingleUseCode))
+ getUnusedCode suc = (lift .) . getUnusedCode suc
+
+ -- | Invalidate all permament codes for user and set use time for them
+ invalidatePermamentCodes :: UserImplId -> UTCTime -> m ()
+ default invalidatePermamentCodes :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m ()
+ invalidatePermamentCodes = (lift .) . invalidatePermamentCodes
+
+ -- | Select last valid restoration code by the given current time
+ selectLastRestoreCode :: UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
+ default selectLastRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
+ selectLastRestoreCode = (lift .) . selectLastRestoreCode
+
+ -- | Insert new restore code
+ insertUserRestore :: UserRestore -> m UserRestoreId
+ default insertUserRestore :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestore -> m UserRestoreId
+ insertUserRestore = lift . insertUserRestore
+
+ -- | Find unexpired by the time restore code
+ findRestoreCode :: UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
+ default findRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> RestoreCode -> UTCTime -> m (Maybe (WithId UserRestoreId UserRestore))
+ findRestoreCode uid = (lift .) . findRestoreCode uid
+
+ -- | Replace restore code with new value
+ replaceRestoreCode :: UserRestoreId -> UserRestore -> m ()
+ default replaceRestoreCode :: (m ~ t n, MonadTrans t, HasStorage n) => UserRestoreId -> UserRestore -> m ()
+ replaceRestoreCode = (lift .) . replaceRestoreCode
+
+ -- | Find first non-expired by the time token for user
+ findAuthToken :: UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
+ default findAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => UserImplId -> UTCTime -> m (Maybe (WithId AuthTokenId AuthToken))
+ findAuthToken = (lift .) . findAuthToken
+
+ -- | Find token by value
+ findAuthTokenByValue :: SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
+ default findAuthTokenByValue :: (m ~ t n, MonadTrans t, HasStorage n) => SimpleToken -> m (Maybe (WithId AuthTokenId AuthToken))
+ findAuthTokenByValue = lift . findAuthTokenByValue
+
+ -- | Insert new token
+ insertAuthToken :: AuthToken -> m AuthTokenId
+ default insertAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthToken -> m AuthTokenId
+ insertAuthToken = lift . insertAuthToken
+
+ -- | Replace auth token with new value
+ replaceAuthToken :: AuthTokenId -> AuthToken -> m ()
+ default replaceAuthToken :: (m ~ t n, MonadTrans t, HasStorage n) => AuthTokenId -> AuthToken -> m ()
+ replaceAuthToken = (lift .) . replaceAuthToken
+
+instance HasStorage m => HasStorage (ContT r m)
+instance HasStorage m => HasStorage (ExceptT e m)
+instance HasStorage m => HasStorage (ReaderT r m)
+instance (HasStorage m, Monoid w) => HasStorage (LRWS.RWST r w s m)
+instance (HasStorage m, Monoid w) => HasStorage (SRWS.RWST r w s m)
+instance HasStorage m => HasStorage (LS.StateT s m)
+instance HasStorage m => HasStorage (SS.StateT s m)
+instance (HasStorage m, Monoid w) => HasStorage (LW.WriterT w m)
+instance (HasStorage m, Monoid w) => HasStorage (SW.WriterT w m)
+
+-- | Convert password to bytestring
+passToByteString :: Password -> BS.ByteString
+passToByteString = TE.encodeUtf8
+
+-- | Convert bytestring into password
+byteStringToPass :: BS.ByteString -> Password
+byteStringToPass = TE.decodeUtf8
+
+-- | Helper to convert user to response
+userToUserInfo :: WithId UserImplId UserImpl -> [Permission] -> [UserGroupId] -> RespUserInfo
+userToUserInfo (WithField uid UserImpl{..}) perms groups = RespUserInfo {
+ respUserId = fromKey uid
+ , respUserLogin = userImplLogin
+ , respUserEmail = userImplEmail
+ , respUserPermissions = perms
+ , respUserGroups = groups
+ }
+
+-- | Low level operation for collecting info about user
+makeUserInfo :: HasStorage m => WithId UserImplId UserImpl -> m RespUserInfo
+makeUserInfo euser@(WithField uid _) = do
+ perms <- getUserPermissions uid
+ groups <- getUserGroups uid
+ return $ userToUserInfo euser perms groups
+
+-- | Get user by id
+readUserInfo :: HasStorage m => UserId -> m (Maybe RespUserInfo)
+readUserInfo uid' = do
+ let uid = toKey uid'
+ muser <- getUserImpl uid
+ maybe (return Nothing) (fmap Just . makeUserInfo . WithField uid) $ muser
+
+-- | Get user by login
+readUserInfoByLogin :: HasStorage m => Login -> m (Maybe RespUserInfo)
+readUserInfoByLogin login = do
+ muser <- getUserImplByLogin login
+ maybe (return Nothing) (fmap Just . makeUserInfo) muser
+
+-- | Return list of permissions for the given user (only permissions that are assigned to him directly)
+getUserPermissions :: HasStorage m => UserImplId -> m [Permission]
+getUserPermissions uid = do
+ perms <- getUserImplPermissions uid
+ return $ userPermPermission . (\(WithField _ v) -> v) <$> perms
+
+-- | Return list of permissions for the given user
+setUserPermissions :: HasStorage m => UserImplId -> [Permission] -> m ()
+setUserPermissions uid perms = do
+ deleteUserPermissions uid
+ forM_ perms $ void . insertUserPerm . UserPerm uid
+
+-- | Creation of new user
+createUser :: HasStorage m => Int -> Login -> Password -> Email -> [Permission] -> m UserImplId
+createUser strength login pass email perms = do
+ pass' <- liftIO $ makePassword (passToByteString pass) strength
+ i <- insertUserImpl UserImpl {
+ userImplLogin = login
+ , userImplPassword = byteStringToPass pass'
+ , userImplEmail = email
+ }
+ forM_ perms $ void . insertUserPerm . UserPerm i
+ return i
+
+-- | Check whether the user has particular permissions
+hasPerms :: HasStorage m => UserImplId -> [Permission] -> m Bool
+hasPerms _ [] = return True
+hasPerms i perms = do
+ perms' <- getUserAllPermissions i
+ return $ and $ (`elem` perms') <$> perms
+
+-- | Creates user with admin privileges
+createAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m UserImplId
+createAdmin strength login pass email = createUser strength login pass email [adminPerm]
+
+-- | Ensures that DB has at leas one admin, if not, creates a new one
+-- with specified info.
+ensureAdmin :: HasStorage m => Int -> Login -> Password -> Email -> m ()
+ensureAdmin strength login pass email = do
+ madmin <- getFirstUserByPerm adminPerm
+ whenNothing madmin $ void $ createAdmin strength login pass email
+
+-- | Apply patches for user
+patchUser :: HasStorage m => Int -- ^ Password strength
+ -> PatchUser -> WithId UserImplId UserImpl -> m (WithId UserImplId UserImpl)
+patchUser strength PatchUser{..} =
+ withPatch patchUserLogin (\l (WithField i u) -> pure $ WithField i u { userImplLogin = l })
+ >=> withPatch patchUserPassword patchPassword
+ >=> withPatch patchUserEmail (\e (WithField i u) -> pure $ WithField i u { userImplEmail = e })
+ >=> withPatch patchUserPermissions patchPerms
+ >=> withPatch patchUserGroups patchGroups
+ where
+ patchPassword ps (WithField i u) = WithField <$> pure i <*> setUserPassword' strength ps u
+ patchPerms ps (WithField i u) = do
+ setUserPermissions i ps
+ return $ WithField i u
+ patchGroups gs (WithField i u) = do
+ setUserGroups i gs
+ return $ WithField i u
+
+-- | Update password of user
+setUserPassword' :: MonadIO m => Int -- ^ Password strength
+ -> Password -> UserImpl -> m UserImpl
+setUserPassword' strength pass user = do
+ pass' <- liftIO $ makePassword (passToByteString pass) strength
+ return $ user { userImplPassword = byteStringToPass pass' }
+
+-- | Get all groups the user belongs to
+getUserGroups :: HasStorage m => UserImplId -> m [UserGroupId]
+getUserGroups i = fmap (fromKey . authUserGroupUsersGroup . (\(WithField _ v) -> v)) <$> selectUserImplGroups i
+
+-- | Rewrite all user groups
+setUserGroups :: HasStorage m => UserImplId -> [UserGroupId] -> m ()
+setUserGroups i gs = do
+ clearUserImplGroups i
+ gs' <- validateGroups gs
+ forM_ gs' $ \g -> void $ insertAuthUserGroupUsers $ AuthUserGroupUsers g i
+
+-- | Leave only existing groups
+validateGroups :: HasStorage m => [UserGroupId] -> m [AuthUserGroupId]
+validateGroups is = do
+ pairs <- mapM ((\i -> (i,) <$> getAuthUserGroup i) . toKey) is
+ return $ fmap fst . filter (isJust . snd) $ pairs
+
+-- | Getting permission of a group and all it parent groups
+getGroupPermissions :: HasStorage m => UserGroupId -> m [Permission]
+getGroupPermissions = go S.empty S.empty . toKey
+ where
+ go !visited !perms !i = do
+ mg <- getAuthUserGroup i
+ case mg of
+ Nothing -> return $ F.toList perms
+ Just AuthUserGroup{..} -> do
+ curPerms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i
+ let perms' = perms <> S.fromList curPerms
+ case authUserGroupParent of
+ Nothing -> return $ F.toList perms'
+ Just pid -> if isJust $ pid `S.elemIndexL` visited
+ then fail $ "Recursive user group graph: " <> show (visited S.|> pid)
+ else go (visited S.|> pid) perms' pid
+
+-- | Get user permissions that are assigned to him/her via groups only
+getUserGroupPermissions :: HasStorage m => UserImplId -> m [Permission]
+getUserGroupPermissions i = do
+ groups <- getUserGroups i
+ perms <- mapM getGroupPermissions groups
+ return $ L.sort . L.nub . concat $ perms
+
+-- | Get user permissions that are assigned to him/her either by direct
+-- way or by his/her groups.
+getUserAllPermissions :: HasStorage m => UserImplId -> m [Permission]
+getUserAllPermissions i = do
+ permsDr <- getUserPermissions i
+ permsGr <- getUserGroupPermissions i
+ return $ L.sort . L.nub $ permsDr <> permsGr
+
+-- | Collect full info about user group from RDBMS
+readUserGroup :: HasStorage m => UserGroupId -> m (Maybe UserGroup)
+readUserGroup i = do
+ let i' = toKey $ i
+ mu <- getAuthUserGroup i'
+ case mu of
+ Nothing -> return Nothing
+ Just AuthUserGroup{..} -> do
+ users <- fmap (authUserGroupUsersUser . (\(WithField _ v) -> v)) <$> listAuthUserGroupUsers i'
+ perms <- fmap (authUserGroupPermsPermission . (\(WithField _ v) -> v)) <$> listAuthUserGroupPermissions i'
+ return $ Just UserGroup {
+ userGroupName = authUserGroupName
+ , userGroupUsers = fromKey <$> users
+ , userGroupPermissions = perms
+ , userGroupParent = fromKey <$> authUserGroupParent
+ }
+
+-- | Helper to convert user group into values of several tables
+toAuthUserGroup :: UserGroup -> (AuthUserGroup, AuthUserGroupId -> [AuthUserGroupUsers], AuthUserGroupId -> [AuthUserGroupPerms])
+toAuthUserGroup UserGroup{..} = (ag, users, perms)
+ where
+ ag = AuthUserGroup {
+ authUserGroupName = userGroupName
+ , authUserGroupParent = toKey <$> userGroupParent
+ }
+ users i = (\ui -> AuthUserGroupUsers i (toKey $ ui)) <$> userGroupUsers
+ perms i = (\perm -> AuthUserGroupPerms i perm) <$> userGroupPermissions
+
+-- | Insert user group into RDBMS
+insertUserGroup :: HasStorage m => UserGroup -> m UserGroupId
+insertUserGroup u = do
+ let (ag, users, perms) = toAuthUserGroup u
+ i <- insertAuthUserGroup ag
+ forM_ (users i) $ void . insertAuthUserGroupUsers
+ forM_ (perms i) $ void . insertAuthUserGroupPerms
+ return $ fromKey $ i
+
+-- | Replace user group with new value
+updateUserGroup :: HasStorage m => UserGroupId -> UserGroup -> m ()
+updateUserGroup i u = do
+ let i' = toKey $ i
+ let (ag, users, perms) = toAuthUserGroup u
+ replaceAuthUserGroup i' ag
+ clearAuthUserGroupUsers i'
+ clearAuthUserGroupPerms i'
+ forM_ (users i') $ void . insertAuthUserGroupUsers
+ forM_ (perms i') $ void . insertAuthUserGroupPerms
+
+-- | Erase user group from RDBMS, cascade
+deleteUserGroup :: HasStorage m => UserGroupId -> m ()
+deleteUserGroup i = do
+ let i' = toKey $ i
+ clearAuthUserGroupUsers i'
+ clearAuthUserGroupPerms i'
+ deleteAuthUserGroup i'
+
+-- | Partial update of user group
+patchUserGroup :: HasStorage m => UserGroupId -> PatchUserGroup -> m ()
+patchUserGroup i PatchUserGroup{..} = do
+ let i' = toKey i
+ whenJust patchUserGroupName $ setAuthUserGroupName i'
+ whenJust patchUserGroupParent $ setAuthUserGroupParent i' . Just . toKey
+ whenJust patchUserGroupNoParent $ const $ setAuthUserGroupParent i' Nothing
+ whenJust patchUserGroupUsers $ \uids -> do
+ clearAuthUserGroupUsers i'
+ forM_ uids $ insertAuthUserGroupUsers . AuthUserGroupUsers i' . toKey
+ whenJust patchUserGroupPermissions $ \perms -> do
+ clearAuthUserGroupPerms i'
+ forM_ perms $ insertAuthUserGroupPerms . AuthUserGroupPerms i'
diff --git a/src/Servant/Server/Auth/Token/Monad.hs b/src/Servant/Server/Auth/Token/Monad.hs
index d790bfa..2bbe102 100644
--- a/src/Servant/Server/Auth/Token/Monad.hs
+++ b/src/Servant/Server/Auth/Token/Monad.hs
@@ -1,54 +1,54 @@
-{-|
-Module : Servant.Server.Auth.Token.Monad
-Description : Monad for auth server handler
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.Monad(
- AuthHandler
- , HasAuthConfig(..)
- , require
- , getConfig
- , getsConfig
- , guard404
- , module Reexport
- ) where
-
-import Control.Monad.Except (MonadError)
-import Control.Monad.IO.Class
-import Data.Monoid ((<>))
-import Servant
-
-import qualified Data.ByteString.Lazy as BS
-
-import Servant.Server.Auth.Token.Config
-import Servant.Server.Auth.Token.Error as Reexport
-import Servant.Server.Auth.Token.Model
-
--- | Context that is needed to run the auth server
-type AuthHandler m = (HasAuthConfig m, MonadError ServantErr m, MonadIO m, HasStorage m)
-
--- | If the value is 'Nothing', throw 400 response
-require :: AuthHandler m => BS.ByteString -> Maybe a -> m a
-require info Nothing = throw400 $ info <> " is required"
-require _ (Just a) = return a
-
--- | Getting config from global state
-getConfig :: AuthHandler m => m AuthConfig
-getConfig = getAuthConfig
-
--- | Getting config part from global state
-getsConfig :: AuthHandler m => (AuthConfig -> a) -> m a
-getsConfig f = fmap f getAuthConfig
-
--- | Run RDBMS operation and throw 404 (not found) error if
--- the second arg returns 'Nothing'
-guard404 :: AuthHandler m => BS.ByteString -> m (Maybe a) -> m a
-guard404 info ma = do
- a <- ma
- case a of
- Nothing -> throw404 $ "Cannot find " <> info
- Just a' -> return a'
+{-|
+Module : Servant.Server.Auth.Token.Monad
+Description : Monad for auth server handler
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Monad(
+ AuthHandler
+ , HasAuthConfig(..)
+ , require
+ , getConfig
+ , getsConfig
+ , guard404
+ , module Reexport
+ ) where
+
+import Control.Monad.Except (MonadError)
+import Control.Monad.IO.Class
+import Data.Monoid ((<>))
+import Servant
+
+import qualified Data.ByteString.Lazy as BS
+
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Error as Reexport
+import Servant.Server.Auth.Token.Model
+
+-- | Context that is needed to run the auth server
+type AuthHandler m = (HasAuthConfig m, MonadError ServantErr m, MonadIO m, HasStorage m)
+
+-- | If the value is 'Nothing', throw 400 response
+require :: AuthHandler m => BS.ByteString -> Maybe a -> m a
+require info Nothing = throw400 $ info <> " is required"
+require _ (Just a) = return a
+
+-- | Getting config from global state
+getConfig :: AuthHandler m => m AuthConfig
+getConfig = getAuthConfig
+
+-- | Getting config part from global state
+getsConfig :: AuthHandler m => (AuthConfig -> a) -> m a
+getsConfig f = fmap f getAuthConfig
+
+-- | Run RDBMS operation and throw 404 (not found) error if
+-- the second arg returns 'Nothing'
+guard404 :: AuthHandler m => BS.ByteString -> m (Maybe a) -> m a
+guard404 info ma = do
+ a <- ma
+ case a of
+ Nothing -> throw404 $ "Cannot find " <> info
+ Just a' -> return a'
diff --git a/src/Servant/Server/Auth/Token/Pagination.hs b/src/Servant/Server/Auth/Token/Pagination.hs
index 5f0b361..a6d5908 100644
--- a/src/Servant/Server/Auth/Token/Pagination.hs
+++ b/src/Servant/Server/Auth/Token/Pagination.hs
@@ -1,31 +1,31 @@
-{-|
-Module : Servant.Server.Auth.Token.Monad
-Description : Helpers for pagination implementation
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.Pagination(
- pagination
- ) where
-
-import Data.Maybe
-
-import Servant.Server.Auth.Token.Config
-import Servant.Server.Auth.Token.Monad
-
-import Servant.API.Auth.Token.Pagination
-
--- | Helper that implements pagination logic
-pagination :: AuthHandler m
- => Maybe Page -- ^ Parameter of page
- -> Maybe PageSize -- ^ Parameter of page size
- -> (Page -> PageSize -> m a) -- ^ Handler
- -> m a
-pagination pageParam pageSizeParam f = do
- ps <- getsConfig defaultPageSize
- let page = fromMaybe 0 pageParam
- pageSize = fromMaybe ps pageSizeParam
- f page pageSize
+{-|
+Module : Servant.Server.Auth.Token.Monad
+Description : Helpers for pagination implementation
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Pagination(
+ pagination
+ ) where
+
+import Data.Maybe
+
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Monad
+
+import Servant.API.Auth.Token.Pagination
+
+-- | Helper that implements pagination logic
+pagination :: AuthHandler m
+ => Maybe Page -- ^ Parameter of page
+ -> Maybe PageSize -- ^ Parameter of page size
+ -> (Page -> PageSize -> m a) -- ^ Handler
+ -> m a
+pagination pageParam pageSizeParam f = do
+ ps <- getsConfig defaultPageSize
+ let page = fromMaybe 0 pageParam
+ pageSize = fromMaybe ps pageSizeParam
+ f page pageSize
diff --git a/src/Servant/Server/Auth/Token/Patch.hs b/src/Servant/Server/Auth/Token/Patch.hs
index e5a5bec..9df54f2 100644
--- a/src/Servant/Server/Auth/Token/Patch.hs
+++ b/src/Servant/Server/Auth/Token/Patch.hs
@@ -1,52 +1,52 @@
-{-|
-Module : Servant.Server.Auth.Token.Patch
-Description : Helpers for patching entities
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.Patch(
- withPatch
- , withPatch'
- , withNullPatch
- , withNullPatch'
- ) where
-
--- | Helper for implementation of 'HasPatch'
-withPatch :: Monad m => Maybe a -> (a -> b -> m b) -> b -> m b
-withPatch v f b = case v of
- Nothing -> return b
- Just a -> f a b
-{-# INLINE withPatch #-}
-
--- | Helper for implementation of 'HasPatch'
-withPatch' :: Maybe a -> (a -> b -> b) -> b -> b
-withPatch' v f b = case v of
- Nothing -> b
- Just a -> f a b
-{-# INLINE withPatch' #-}
-
--- | Helper to implement patch with nullable flag
-withNullPatch :: Monad m
- => Maybe Bool -- ^ If this is 'Just true' then execute following updater
- -> (b -> m b) -- ^ Updater when previous value is 'Just true'
- -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater
- -> (a -> b -> m b) -- ^ Main updater
- -> b -> m b
-withNullPatch mnull nullify ma updater b = case mnull of
- Just True -> nullify b
- _ -> withPatch ma updater b
-{-# INLINE withNullPatch #-}
-
--- | Helper to implement patch with nullable flag
-withNullPatch' :: Maybe Bool -- ^ If this is 'Just true' then execute following updater
- -> (b -> b) -- ^ Updater when previous value is 'Just true'
- -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater
- -> (a -> b -> b) -- ^ Main updater
- -> b -> b
-withNullPatch' mnull nullify ma updater b = case mnull of
- Just True -> nullify b
- _ -> withPatch' ma updater b
+{-|
+Module : Servant.Server.Auth.Token.Patch
+Description : Helpers for patching entities
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Patch(
+ withPatch
+ , withPatch'
+ , withNullPatch
+ , withNullPatch'
+ ) where
+
+-- | Helper for implementation of 'HasPatch'
+withPatch :: Monad m => Maybe a -> (a -> b -> m b) -> b -> m b
+withPatch v f b = case v of
+ Nothing -> return b
+ Just a -> f a b
+{-# INLINE withPatch #-}
+
+-- | Helper for implementation of 'HasPatch'
+withPatch' :: Maybe a -> (a -> b -> b) -> b -> b
+withPatch' v f b = case v of
+ Nothing -> b
+ Just a -> f a b
+{-# INLINE withPatch' #-}
+
+-- | Helper to implement patch with nullable flag
+withNullPatch :: Monad m
+ => Maybe Bool -- ^ If this is 'Just true' then execute following updater
+ -> (b -> m b) -- ^ Updater when previous value is 'Just true'
+ -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater
+ -> (a -> b -> m b) -- ^ Main updater
+ -> b -> m b
+withNullPatch mnull nullify ma updater b = case mnull of
+ Just True -> nullify b
+ _ -> withPatch ma updater b
+{-# INLINE withNullPatch #-}
+
+-- | Helper to implement patch with nullable flag
+withNullPatch' :: Maybe Bool -- ^ If this is 'Just true' then execute following updater
+ -> (b -> b) -- ^ Updater when previous value is 'Just true'
+ -> Maybe a -- ^ If the value is 'Just' and the first parameter is 'Nothing' then execute following updater
+ -> (a -> b -> b) -- ^ Main updater
+ -> b -> b
+withNullPatch' mnull nullify ma updater b = case mnull of
+ Just True -> nullify b
+ _ -> withPatch' ma updater b
{-# INLINE withNullPatch' #-} \ No newline at end of file
diff --git a/src/Servant/Server/Auth/Token/Restore.hs b/src/Servant/Server/Auth/Token/Restore.hs
index 9feac5b..bfd68c4 100644
--- a/src/Servant/Server/Auth/Token/Restore.hs
+++ b/src/Servant/Server/Auth/Token/Restore.hs
@@ -1,55 +1,55 @@
-{-|
-Module : Servant.Server.Auth.Token.Restore
-Description : Operations with restore codes
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.Restore(
- getRestoreCode
- , guardRestoreCode
- , sendRestoreCode
- ) where
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Aeson.WithField
-import Data.Time.Clock
-
-import Servant.API.Auth.Token
-import Servant.Server.Auth.Token.Config
-import Servant.Server.Auth.Token.Model
-import Servant.Server.Auth.Token.Monad
-
--- | Get current restore code for user or generate new
-getRestoreCode :: HasStorage m => IO RestoreCode -> UserImplId -> UTCTime -> m RestoreCode
-getRestoreCode generator uid expire = do
- t <- liftIO getCurrentTime
- mcode <- selectLastRestoreCode uid t
- case mcode of
- Nothing -> do
- code <- liftIO generator
- void $ insertUserRestore UserRestore {
- userRestoreValue = code
- , userRestoreUser = uid
- , userRestoreExpire = expire
- }
- return code
- Just code -> return $ userRestoreValue . (\(WithField _ v) -> v) $ code
-
--- | Throw if the restore code isn't valid for given user, if valid, invalidates the code
-guardRestoreCode :: AuthHandler m => UserImplId -> RestoreCode -> m ()
-guardRestoreCode uid code = do
- t <- liftIO getCurrentTime
- mcode <- findRestoreCode uid code t
- case mcode of
- Nothing -> throw400 "Invalid restore code"
- Just (WithField i rc) -> replaceRestoreCode i rc { userRestoreExpire = t }
-
--- | Send restore code to the user' email
-sendRestoreCode :: AuthHandler m => RespUserInfo -> RestoreCode -> m ()
-sendRestoreCode user code = do
- AuthConfig{..} <- getConfig
- liftIO $ restoreCodeSender user code
+{-|
+Module : Servant.Server.Auth.Token.Restore
+Description : Operations with restore codes
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.Restore(
+ getRestoreCode
+ , guardRestoreCode
+ , sendRestoreCode
+ ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson.WithField
+import Data.Time.Clock
+
+import Servant.API.Auth.Token
+import Servant.Server.Auth.Token.Config
+import Servant.Server.Auth.Token.Model
+import Servant.Server.Auth.Token.Monad
+
+-- | Get current restore code for user or generate new
+getRestoreCode :: HasStorage m => IO RestoreCode -> UserImplId -> UTCTime -> m RestoreCode
+getRestoreCode generator uid expire = do
+ t <- liftIO getCurrentTime
+ mcode <- selectLastRestoreCode uid t
+ case mcode of
+ Nothing -> do
+ code <- liftIO generator
+ void $ insertUserRestore UserRestore {
+ userRestoreValue = code
+ , userRestoreUser = uid
+ , userRestoreExpire = expire
+ }
+ return code
+ Just code -> return $ userRestoreValue . (\(WithField _ v) -> v) $ code
+
+-- | Throw if the restore code isn't valid for given user, if valid, invalidates the code
+guardRestoreCode :: AuthHandler m => UserImplId -> RestoreCode -> m ()
+guardRestoreCode uid code = do
+ t <- liftIO getCurrentTime
+ mcode <- findRestoreCode uid code t
+ case mcode of
+ Nothing -> throw400 "Invalid restore code"
+ Just (WithField i rc) -> replaceRestoreCode i rc { userRestoreExpire = t }
+
+-- | Send restore code to the user' email
+sendRestoreCode :: AuthHandler m => RespUserInfo -> RestoreCode -> m ()
+sendRestoreCode user code = do
+ AuthConfig{..} <- getConfig
+ liftIO $ restoreCodeSender user code
diff --git a/src/Servant/Server/Auth/Token/SingleUse.hs b/src/Servant/Server/Auth/Token/SingleUse.hs
index 699bdd4..5f7fbf7 100644
--- a/src/Servant/Server/Auth/Token/SingleUse.hs
+++ b/src/Servant/Server/Auth/Token/SingleUse.hs
@@ -1,73 +1,73 @@
-{-|
-Module : Servant.Server.Auth.Token.SingleUse
-Description : Specific functions to work with single usage codes.
-Copyright : (c) Anton Gushcha, 2016
-License : MIT
-Maintainer : ncrashed@gmail.com
-Stability : experimental
-Portability : Portable
--}
-module Servant.Server.Auth.Token.SingleUse(
- makeSingleUseExpire
- , registerSingleUseCode
- , invalidateSingleUseCode
- , validateSingleUseCode
- , generateSingleUsedCodes
- ) where
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Aeson.WithField
-import Data.Time
-import Servant.API.Auth.Token
-import Servant.Server.Auth.Token.Common
-import Servant.Server.Auth.Token.Model
-
--- | Calculate expire date for single usage code
-makeSingleUseExpire :: MonadIO m => NominalDiffTime -- ^ Duration of code
- -> m UTCTime -- ^ Time when the code expires
-makeSingleUseExpire dt = do
- t <- liftIO getCurrentTime
- return $ dt `addUTCTime` t
-
--- | Register single use code in DB
-registerSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user
- -> SingleUseCode -- ^ Single usage code
- -> Maybe UTCTime -- ^ Time when the code expires, 'Nothing' is never expiring code
- -> m ()
-registerSingleUseCode uid code expire = void $ insertSingleUseCode
- $ UserSingleUseCode code uid expire Nothing
-
--- | Marks single use code that it cannot be used again
-invalidateSingleUseCode :: HasStorage m => UserSingleUseCodeId -- ^ Id of code
- -> m ()
-invalidateSingleUseCode i = do
- t <- liftIO getCurrentTime
- setSingleUseCodeUsed i $ Just t
-
--- | Check single use code and return 'True' on success.
---
--- On success invalidates single use code.
-validateSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user
- -> SingleUseCode -- ^ Single usage code
- -> m Bool
-validateSingleUseCode uid code = do
- t <- liftIO getCurrentTime
- mcode <- getUnusedCode code uid t
- whenJust mcode $ invalidateSingleUseCode . (\(WithField i _) -> i)
- return $ maybe False (const True) mcode
-
--- | Generates a set single use codes that doesn't expire.
---
--- Note: previous codes without expiration are invalidated.
-generateSingleUsedCodes :: HasStorage m => UserImplId -- ^ Id of user
- -> IO SingleUseCode -- ^ Generator of codes
- -> Word -- Count of codes
- -> m [SingleUseCode]
-generateSingleUsedCodes uid gen n = do
- t <- liftIO getCurrentTime
- invalidatePermamentCodes uid t
- replicateM (fromIntegral n) $ do
- code <- liftIO gen
- _ <- insertSingleUseCode $ UserSingleUseCode code uid Nothing Nothing
- return code
+{-|
+Module : Servant.Server.Auth.Token.SingleUse
+Description : Specific functions to work with single usage codes.
+Copyright : (c) Anton Gushcha, 2016
+License : MIT
+Maintainer : ncrashed@gmail.com
+Stability : experimental
+Portability : Portable
+-}
+module Servant.Server.Auth.Token.SingleUse(
+ makeSingleUseExpire
+ , registerSingleUseCode
+ , invalidateSingleUseCode
+ , validateSingleUseCode
+ , generateSingleUsedCodes
+ ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson.WithField
+import Data.Time
+import Servant.API.Auth.Token
+import Servant.Server.Auth.Token.Common
+import Servant.Server.Auth.Token.Model
+
+-- | Calculate expire date for single usage code
+makeSingleUseExpire :: MonadIO m => NominalDiffTime -- ^ Duration of code
+ -> m UTCTime -- ^ Time when the code expires
+makeSingleUseExpire dt = do
+ t <- liftIO getCurrentTime
+ return $ dt `addUTCTime` t
+
+-- | Register single use code in DB
+registerSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user
+ -> SingleUseCode -- ^ Single usage code
+ -> Maybe UTCTime -- ^ Time when the code expires, 'Nothing' is never expiring code
+ -> m ()
+registerSingleUseCode uid code expire = void $ insertSingleUseCode
+ $ UserSingleUseCode code uid expire Nothing
+
+-- | Marks single use code that it cannot be used again
+invalidateSingleUseCode :: HasStorage m => UserSingleUseCodeId -- ^ Id of code
+ -> m ()
+invalidateSingleUseCode i = do
+ t <- liftIO getCurrentTime
+ setSingleUseCodeUsed i $ Just t
+
+-- | Check single use code and return 'True' on success.
+--
+-- On success invalidates single use code.
+validateSingleUseCode :: HasStorage m => UserImplId -- ^ Id of user
+ -> SingleUseCode -- ^ Single usage code
+ -> m Bool
+validateSingleUseCode uid code = do
+ t <- liftIO getCurrentTime
+ mcode <- getUnusedCode code uid t
+ whenJust mcode $ invalidateSingleUseCode . (\(WithField i _) -> i)
+ return $ maybe False (const True) mcode
+
+-- | Generates a set single use codes that doesn't expire.
+--
+-- Note: previous codes without expiration are invalidated.
+generateSingleUsedCodes :: HasStorage m => UserImplId -- ^ Id of user
+ -> IO SingleUseCode -- ^ Generator of codes
+ -> Word -- Count of codes
+ -> m [SingleUseCode]
+generateSingleUsedCodes uid gen n = do
+ t <- liftIO getCurrentTime
+ invalidatePermamentCodes uid t
+ replicateM (fromIntegral n) $ do
+ code <- liftIO gen
+ _ <- insertSingleUseCode $ UserSingleUseCode code uid Nothing Nothing
+ return code
diff --git a/stack.yaml b/stack.yaml
index 58c2c5f..45a7a13 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,90 +1,95 @@
-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# http://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-# resolver: ghcjs-0.1.0_ghc-7.10.2
-# resolver:
-# name: custom-snapshot
-# location: "./custom-snapshot.yaml"
-resolver: lts-8.8
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-# - location:
-# git: https://github.com/commercialhaskell/stack.git
-# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# extra-dep: true
-# subdirs:
-# - auto-update
-# - wai
-#
-# A package marked 'extra-dep: true' will only be built if demanded by a
-# non-dependency (i.e. a user package), and its test suites and benchmarks
-# will not be run. This is useful for tweaking upstream packages.
-packages:
-- '.'
-- 'servant-auth-token-acid'
-- 'servant-auth-token-persistent'
-- 'servant-auth-token-leveldb'
-- 'example/acid'
-- 'example/persistent'
-- 'example/leveldb'
-# - location:
-# git: https://github.com/NCrashed/servant-auth-token-api.git
-# commit: d011f7bfecd18d07ff67ce9f67f8741e110a2719
-# extra-dep: true
-# - '../servant-auth-token-api'
-
-# Dependency packages to be pulled from upstream that are not in the resolver
-# (e.g., acme-missiles-0.3)
-extra-deps:
-- aeson-injector-1.0.7.0
-- concurrent-extra-0.7.0.10
-- http-api-data-0.3.5
-- natural-transformation-0.4
-- safecopy-store-0.9.2
-- servant-0.9
-- servant-auth-token-api-0.4.2.0
-- servant-docs-0.9
-- servant-server-0.9
-- store-0.3.1
-- store-core-0.3
-- th-utilities-0.2.0.1
-
-# Override default flag values for local packages and extra-deps
-flags: {}
-
-# Extra package databases containing global packages
-extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=1.1"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+# name: custom-snapshot
+# location: "./custom-snapshot.yaml"
+resolver: lts-8.14
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+# git: https://github.com/commercialhaskell/stack.git
+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# extra-dep: true
+# subdirs:
+# - auto-update
+# - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+- 'servant-auth-token-acid'
+- 'servant-auth-token-persistent'
+- 'servant-auth-token-leveldb'
+- 'servant-auth-token-rocksdb'
+- 'example/acid'
+- 'example/persistent'
+- 'example/leveldb'
+# - location:
+# git: https://github.com/NCrashed/servant-auth-token-api.git
+# commit: d011f7bfecd18d07ff67ce9f67f8741e110a2719
+# extra-dep: true
+# - '../servant-auth-token-api'
+- location:
+ git: https://github.com/serokell/rocksdb-haskell.git
+ commit: 325427fc709183c8fdf777ad5ea09f8d92bf8585
+ extra-dep: true
+
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps:
+- aeson-injector-1.0.7.0
+- concurrent-extra-0.7.0.10
+- http-api-data-0.3.5
+- natural-transformation-0.4
+- safecopy-store-0.9.3
+- servant-0.9
+- servant-auth-token-api-0.4.2.0
+- servant-docs-0.9
+- servant-server-0.9
+#- store-0.3.1
+#- store-core-0.3
+- th-utilities-0.2.0.1
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.1"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor