servant-auth-token-persistent (empty) → 0.4.0.0

raw patch · 7 files changed

+335/−0 lines, 7 filesdep +aeson-injectordep +basedep +bytestringsetup-changed

Dependencies added: aeson-injector, base, bytestring, containers, ghc-prim, monad-control, mtl, persistent, persistent-postgresql, persistent-template, servant-auth-token, servant-auth-token-api, servant-server, text, time, transformers, transformers-base, uuid

Files

CHANGELOG.md +4/−0
LICENSE +30/−0
README.md +40/−0
Setup.hs +2/−0
servant-auth-token-persistent.cabal +65/−0
src/Servant/Server/Auth/Token/Persistent.hs +109/−0
src/Servant/Server/Auth/Token/Persistent/Schema.hs +85/−0

+ CHANGELOG.md view

@@ -0,0 +1,4 @@+0.3.2.0+=======++* Initial factor out from parent package.

+ LICENSE view

@@ -0,0 +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.

+ README.md view

@@ -0,0 +1,40 @@+# servant-auth-token-persistent++Storage backend on persistent for [servant-auth-token](https://github.com/NCrashed/servant-auth-token) server.++An itegration of the backend is simple:+``` haskell+-- | 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+```++Don't forget to add migration to your server startup (if you actually want automatic migrations):+``` haskell+-- | 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+```++See a full example in [servant-auth-token-example-persistent](https://github.com/NCrashed/servant-auth-token/tree/master/example/persistent).

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ servant-auth-token-persistent.cabal view

@@ -0,0 +1,65 @@+name:                servant-auth-token-persistent+version:             0.4.0.0+synopsis:            Persistent backend for servant-auth-token server+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:           2016 Anton Gushcha+category:            Web+build-type:          Simple+extra-source-files:+  README.md+  CHANGELOG.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:+    Servant.Server.Auth.Token.Persistent+    Servant.Server.Auth.Token.Persistent.Schema+  build-depends:+      base                    >= 4.7    && < 5+    , aeson-injector          >= 1.0    && < 1.1+    , bytestring              >= 0.10   && < 0.11+    , containers              >= 0.5    && < 0.6+    , ghc-prim                >= 0.5    && < 0.6+    , monad-control           >= 1.0    && < 1.1+    , mtl                     >= 2.2    && < 2.3+    , persistent              >= 2.2    && < 2.7+    , persistent-postgresql   >= 2.2    && < 2.7+    , persistent-template     >= 2.1    && < 2.7+    , servant-server          >= 0.9    && < 0.10+    , servant-auth-token      >= 0.4    && < 0.5+    , servant-auth-token-api  >= 0.4    && < 0.5+    , text                    >= 1.2    && < 1.3+    , time                    >= 1.5    && < 1.7+    , transformers            >= 0.4    && < 0.6+    , transformers-base       >= 0.4    && < 0.5+    , uuid                    >= 1.3    && < 1.4+  default-language:    Haskell2010+  default-extensions:+    BangPatterns+    DataKinds+    DeriveGeneric+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    KindSignatures+    MultiParamTypeClasses+    OverloadedStrings+    QuasiQuotes+    RecordWildCards+    ScopedTypeVariables+    TemplateHaskell+    TupleSections+    TypeFamilies+    TypeOperators++source-repository head+  type:     git+  location: https://github.com/ncrashed/servant-auth-token

+ src/Servant/Server/Auth/Token/Persistent.hs view

@@ -0,0 +1,109 @@+module Servant.Server.Auth.Token.Persistent(+    PersistentBackendT+  , runPersistentBackendT+  ) where++import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Except+import Data.Aeson.WithField+import Database.Persist+import Database.Persist.Sql+import Servant.Server+import Servant.Server.Auth.Token.Monad+import Servant.Server.Auth.Token.Model+import Servant.Server.Auth.Token.Config++import qualified Servant.Server.Auth.Token.Persistent.Schema as S++-- | Monad transformer that implements storage backend+newtype PersistentBackendT m a = PersistentBackendT { unPersistentBackendT :: ReaderT (AuthConfig, ConnectionPool) (ExceptT ServantErr (SqlPersistT m)) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadError ServantErr)++instance Monad m => MonadReader SqlBackend (PersistentBackendT m) where+  ask = PersistentBackendT $ lift . lift $ ask+  local f m = do+    (cfg, pool) <- PersistentBackendT ask+    em <- PersistentBackendT . lift . lift $ local f $ runExceptT $ runReaderT (unPersistentBackendT m) (cfg, pool)+    case em of+      Left er -> PersistentBackendT . lift $ throwError er+      Right m' -> return m'++instance Monad m => HasAuthConfig (PersistentBackendT m) where+  getAuthConfig = fmap fst $ PersistentBackendT ask++-- | Execute backend action with given connection pool.+runPersistentBackendT :: MonadBaseControl IO m => AuthConfig -> ConnectionPool -> PersistentBackendT m a -> m (Either ServantErr a)+runPersistentBackendT cfg pool ma = runSqlPool (runExceptT $ runReaderT (unPersistentBackendT ma) (cfg, pool)) pool++-- | Convert entity struct to 'WithId' version+toWithId :: (S.ConvertStorage a' a, S.ConvertStorage (Key a') i) => Entity a' -> WithId i a+toWithId (Entity k v) = WithField (S.convertFrom k) (S.convertFrom v)++-- | Helper to execute DB actions in backend monad+liftDB :: Monad m => SqlPersistT m a -> PersistentBackendT m a+liftDB = PersistentBackendT . lift . lift++instance (MonadIO m) => HasStorage (PersistentBackendT m) where+  getUserImpl = liftDB . fmap (fmap S.convertFrom) . get . S.convertTo+  getUserImplByLogin = liftDB . fmap (fmap toWithId) . getBy . S.UniqueLogin+  listUsersPaged page size = liftDB $ do+    users <- selectList [] [Asc S.UserImplId, OffsetBy (fromIntegral $ page * size), LimitTo (fromIntegral size)]+    total <- count ([] :: [Filter S.UserImpl])+    return (fmap toWithId users, fromIntegral total)+  getUserImplPermissions uid = liftDB . fmap (fmap toWithId) $ selectList [S.UserPermUser ==. S.convertTo uid] [Asc S.UserPermPermission]+  deleteUserPermissions uid = liftDB $ deleteWhere [S.UserPermUser ==. S.convertTo uid]+  insertUserPerm = liftDB . fmap S.convertFrom . insert . S.convertTo+  insertUserImpl = liftDB . fmap S.convertFrom . insert . S.convertTo+  replaceUserImpl i v = liftDB $ replace (S.convertTo i) (S.convertTo v)+  deleteUserImpl = liftDB . delete . S.convertTo+  hasPerm i p = liftDB $ do+    c <- count [S.UserPermUser ==. S.convertTo i, S.UserPermPermission ==. p]+    return $ c > 0+  getFirstUserByPerm p = liftDB . fmap (fmap toWithId) $ do+    mp <- selectFirst [S.UserPermPermission ==. p] []+    case mp of+      Nothing -> return Nothing+      Just (Entity _ S.UserPerm{..}) -> fmap (Entity userPermUser) <$> get userPermUser+  selectUserImplGroups i = liftDB . fmap (fmap toWithId) $ selectList [S.AuthUserGroupUsersUser ==. S.convertTo i] [Asc S.AuthUserGroupUsersGroup]+  clearUserImplGroups i = liftDB $ deleteWhere [S.AuthUserGroupUsersUser ==. S.convertTo i]+  insertAuthUserGroup = liftDB . fmap S.convertFrom . insert . S.convertTo+  insertAuthUserGroupUsers = liftDB . fmap S.convertFrom . insert . S.convertTo+  insertAuthUserGroupPerms = liftDB . fmap S.convertFrom . insert . S.convertTo+  getAuthUserGroup = liftDB . fmap (fmap S.convertFrom) . get . S.convertTo+  listAuthUserGroupPermissions i = liftDB . fmap (fmap toWithId) $ selectList [S.AuthUserGroupPermsGroup ==. S.convertTo i] [Asc S.AuthUserGroupPermsPermission]+  listAuthUserGroupUsers i = liftDB . fmap (fmap toWithId) $ selectList [S.AuthUserGroupUsersGroup ==. S.convertTo i] [Asc S.AuthUserGroupUsersUser]+  replaceAuthUserGroup i v = liftDB $ replace (S.convertTo i) (S.convertTo v)+  clearAuthUserGroupUsers i = liftDB $ deleteWhere [S.AuthUserGroupUsersGroup ==. S.convertTo i]+  clearAuthUserGroupPerms i = liftDB $ deleteWhere [S.AuthUserGroupPermsGroup ==. S.convertTo i]+  deleteAuthUserGroup = liftDB . delete . S.convertTo+  listGroupsPaged page size = liftDB $ do+    groups <- selectList [] [Asc S.AuthUserGroupId, OffsetBy (fromIntegral $ page * size), LimitTo (fromIntegral size)]+    total <- count ([] :: [Filter S.AuthUserGroup])+    return (fmap toWithId groups, fromIntegral total)+  setAuthUserGroupName i n = liftDB $ update (S.convertTo i) [S.AuthUserGroupName =. n]+  setAuthUserGroupParent i mp = liftDB $ update (S.convertTo i) [S.AuthUserGroupParent =. fmap S.convertTo mp]+  insertSingleUseCode = liftDB . fmap S.convertFrom . insert . S.convertTo+  setSingleUseCodeUsed i mt = liftDB $ update (S.convertTo i) [S.UserSingleUseCodeUsed =. mt]+  getUnusedCode c i t = liftDB . fmap (fmap toWithId) $ selectFirst ([+          S.UserSingleUseCodeValue ==. c+        , S.UserSingleUseCodeUser ==. S.convertTo i+        , S.UserSingleUseCodeUsed ==. Nothing+        ] ++ (+            [S.UserSingleUseCodeExpire ==. Nothing]+        ||. [S.UserSingleUseCodeExpire >=. Just t]+    )) [Desc S.UserSingleUseCodeExpire]+  invalidatePermamentCodes i t = liftDB $ updateWhere [+      S.UserSingleUseCodeUser ==. S.convertTo i+    , S.UserSingleUseCodeUsed ==. Nothing+    , S.UserSingleUseCodeExpire ==. Nothing+    ]+    [S.UserSingleUseCodeUsed =. Just t]+  selectLastRestoreCode i t = liftDB . fmap (fmap toWithId) $ selectFirst [S.UserRestoreUser ==. S.convertTo i, S.UserRestoreExpire >. t] [Desc S.UserRestoreExpire]+  insertUserRestore = liftDB . fmap S.convertFrom . insert . S.convertTo+  findRestoreCode i rc t = liftDB . fmap (fmap toWithId) $ selectFirst [S.UserRestoreUser ==. S.convertTo i, S.UserRestoreValue ==. rc, S.UserRestoreExpire >. t] [Desc S.UserRestoreExpire]+  replaceRestoreCode i v = liftDB $ replace (S.convertTo i) (S.convertTo v)+  findAuthToken i t = liftDB . fmap (fmap toWithId) $ selectFirst [S.AuthTokenUser ==. S.convertTo i, S.AuthTokenExpire >. t] []+  findAuthTokenByValue t = liftDB . fmap (fmap toWithId) $ selectFirst [S.AuthTokenValue ==. t] []+  insertAuthToken = liftDB . fmap S.convertFrom . insert . S.convertTo+  replaceAuthToken i v = liftDB $ replace (S.convertTo i) (S.convertTo v)

+ src/Servant/Server/Auth/Token/Persistent/Schema.hs view

@@ -0,0 +1,85 @@+{-# LANGUAGE MagicHash #-}+module Servant.Server.Auth.Token.Persistent.Schema where++import Data.Text+import Data.Time+import Database.Persist.TH+import GHC.Generics+import GHC.Prim++import Servant.API.Auth.Token++import qualified Servant.Server.Auth.Token.Model as M++share [mkPersist sqlSettings+     , mkDeleteCascade sqlSettings+     , mkMigrate "migrateAll"] [persistLowerCase|+UserImpl+  login       Login+  password    Password     -- encrypted with salt+  email       Email+  UniqueLogin login+  deriving Generic Show+UserPerm+  user        UserImplId+  permission  Permission+  deriving Generic Show+AuthToken+  value       SimpleToken+  user        UserImplId+  expire      UTCTime+  deriving Generic Show+UserRestore+  value       RestoreCode+  user        UserImplId+  expire      UTCTime+  deriving Generic Show+UserSingleUseCode+  value     SingleUseCode+  user      UserImplId+  expire    UTCTime Maybe -- Nothing is code that never expires+  used      UTCTime Maybe+  deriving Generic Show+AuthUserGroup+  name        Text+  parent      AuthUserGroupId Maybe+  deriving Generic Show+AuthUserGroupUsers+  group       AuthUserGroupId+  user        UserImplId+  deriving Generic Show+AuthUserGroupPerms+  group       AuthUserGroupId+  permission  Permission+  deriving Generic Show+|]++-- | Defines way to convert from persistent struct to model struct and vice versa.+--+-- Warning: default implementation is done via 'unsafeCoerce#', so make sure that+-- structure of 'a' and 'b' is completely identical.+class ConvertStorage a b | a -> b, b -> a where+  -- | Convert to internal representation+  convertTo   :: b -> a+  convertTo = unsafeCoerce#+  -- | Convert from internal representation+  convertFrom :: a -> b+  convertFrom = unsafeCoerce#++instance ConvertStorage UserImpl M.UserImpl+instance ConvertStorage UserPerm M.UserPerm+instance ConvertStorage AuthToken M.AuthToken+instance ConvertStorage UserRestore M.UserRestore+instance ConvertStorage UserSingleUseCode M.UserSingleUseCode+instance ConvertStorage AuthUserGroup M.AuthUserGroup+instance ConvertStorage AuthUserGroupUsers M.AuthUserGroupUsers+instance ConvertStorage AuthUserGroupPerms M.AuthUserGroupPerms++instance ConvertStorage UserImplId M.UserImplId+instance ConvertStorage UserPermId M.UserPermId+instance ConvertStorage AuthTokenId M.AuthTokenId+instance ConvertStorage UserRestoreId M.UserRestoreId+instance ConvertStorage UserSingleUseCodeId M.UserSingleUseCodeId+instance ConvertStorage AuthUserGroupId M.AuthUserGroupId+instance ConvertStorage AuthUserGroupUsersId M.AuthUserGroupUsersId+instance ConvertStorage AuthUserGroupPermsId M.AuthUserGroupPermsId