snaplet-postgresql-simple 0.2.1 → 0.3
raw patch · 3 files changed
+36/−21 lines, 3 filesdep +errorsdep ~snap
Dependencies added: errors
Dependency ranges changed: snap
Files
- snaplet-postgresql-simple.cabal +3/−2
- src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs +32/−18
- src/Snap/Snaplet/PostgresqlSimple.hs +1/−1
snaplet-postgresql-simple.cabal view
@@ -1,5 +1,5 @@ name: snaplet-postgresql-simple-version: 0.2.1+version: 0.3 synopsis: postgresql-simple snaplet for the Snap Framework description: This snaplet contains support for using the Postgresql database with a Snap Framework application via the@@ -39,11 +39,12 @@ bytestring >= 0.9.1 && < 0.10, clientsession >= 0.7.2 && < 0.9, configurator >= 0.2 && < 0.3,+ errors >= 1.3 && < 1.4, MonadCatchIO-transformers >= 0.3 && < 0.4, mtl >= 2 && < 3, postgresql-simple >= 0.2 && < 0.3, resource-pool-catchio >= 0.2 && < 0.3,- snap >= 0.9 && < 0.11,+ snap >= 0.10 && < 0.11, text >= 0.11 && < 0.12, transformers >= 0.2 && < 0.4, unordered-containers >= 0.2 && < 0.3
src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs view
@@ -35,12 +35,14 @@ ) where ------------------------------------------------------------------------------+import Prelude hiding (catch)+import Control.Error+import Control.Exception (SomeException, catch) import qualified Data.Configurator as C import qualified Data.HashMap.Lazy as HM import qualified Data.Text as T import Data.Text (Text) import qualified Data.Text.Encoding as T-import Data.Maybe import Data.Pool import qualified Database.PostgreSQL.Simple as P import qualified Database.PostgreSQL.Simple.ToField as P@@ -65,7 +67,7 @@ -- | Initializer for the postgres backend to the auth snaplet. -- initPostgresAuth- :: Lens b (Snaplet SessionManager) -- ^ Lens to the session snaplet+ :: SnapletLens b SessionManager -- ^ Lens to the session snaplet -> Snaplet Postgres -- ^ The postgres snaplet -> SnapletInit b (AuthManager b) initPostgresAuth sess db = makeSnaplet "postgresql-auth" desc datadir $ do@@ -75,7 +77,7 @@ key <- liftIO $ getKey (asSiteKey authSettings) let tableDesc = defAuthTable { tblName = authTable } let manager = PostgresAuthManager tableDesc $- pgPool $ getL snapletValue db+ pgPool $ db ^# snapletValue liftIO $ createTableIfMissing manager rng <- liftIO mkRNG return $ AuthManager@@ -130,6 +132,7 @@ AuthUser <$> _userId <*> _userLogin+ <*> _userEmail <*> _userPassword <*> _userActivatedAt <*> _userSuspendedAt@@ -143,11 +146,14 @@ <*> _userLastLoginIp <*> _userCreatedAt <*> _userUpdatedAt+ <*> _userResetToken+ <*> _userResetRequestedAt <*> _userRoles <*> _userMeta where !_userId = field !_userLogin = field+ !_userEmail = field !_userPassword = field !_userActivatedAt = field !_userSuspendedAt = field@@ -161,6 +167,8 @@ !_userLastLoginIp = field !_userCreatedAt = field !_userUpdatedAt = field+ !_userResetToken = field+ !_userResetRequestedAt = field !_userRoles = pure [] !_userMeta = pure HM.empty @@ -187,6 +195,7 @@ { tblName :: Text , colId :: (Text, Text) , colLogin :: (Text, Text)+ , colEmail :: (Text, Text) , colPassword :: (Text, Text) , colActivatedAt :: (Text, Text) , colSuspendedAt :: (Text, Text)@@ -200,6 +209,8 @@ , colLastLoginIp :: (Text, Text) , colCreatedAt :: (Text, Text) , colUpdatedAt :: (Text, Text)+ , colResetToken :: (Text, Text)+ , colResetRequestedAt :: (Text, Text) , rolesTable :: Text } @@ -210,6 +221,7 @@ { tblName = "snap_auth_user" , colId = ("uid", "SERIAL PRIMARY KEY") , colLogin = ("login", "text UNIQUE NOT NULL")+ , colEmail = ("email", "text NOT NULL") , colPassword = ("password", "text") , colActivatedAt = ("activated_at", "timestamptz") , colSuspendedAt = ("suspended_at", "timestamptz")@@ -223,6 +235,8 @@ , colLastLoginIp = ("last_login_ip", "text") , colCreatedAt = ("created_at", "timestamptz") , colUpdatedAt = ("updated_at", "timestamptz")+ , colResetToken = ("reset_token", "text")+ , colResetRequestedAt = ("reset_requested_at", "timestamptz") , rolesTable = "user_roles" } @@ -235,6 +249,7 @@ colDef = [ (colId , P.toField . fmap unUid . userId) , (colLogin , P.toField . userLogin)+ , (colEmail , P.toField . userEmail) , (colPassword , P.toField . userPassword) , (colActivatedAt , P.toField . userActivatedAt) , (colSuspendedAt , P.toField . userSuspendedAt)@@ -248,6 +263,8 @@ , (colLastLoginIp , P.toField . userLastLoginIp) , (colCreatedAt , P.toField . userCreatedAt) , (colUpdatedAt , P.toField . userUpdatedAt)+ , (colResetToken , P.toField . userResetToken)+ , (colResetRequestedAt, P.toField . userResetRequestedAt) ] saveQuery :: AuthTable -> AuthUser -> (Text, [P.Action])@@ -259,7 +276,8 @@ , T.intercalate "," cols , ") VALUES (" , T.intercalate "," vals- , ")"+ , ") RETURNING "+ , T.intercalate "," (map (fst . ($at) . fst) colDef) ] , params) qval f = fst (f at) `T.append` " = ?"@@ -270,7 +288,8 @@ , T.intercalate "," (map (qval . fst) $ tail colDef) , " WHERE " , fst (colId at)- , " = ?"+ , " = ? RETURNING "+ , T.intercalate "," (map (fst . ($at) . fst) colDef) ] , params ++ [P.toField $ unUid uid]) cols = map (fst . ($at) . fst) $ tail colDef@@ -278,25 +297,20 @@ params = map (($u) . snd) $ tail colDef +onFailure :: Monad m => SomeException -> m (Either AuthFailure a)+onFailure e = return $ Left $ AuthError $ show e+ ------------------------------------------------------------------------------ -- | instance IAuthBackend PostgresAuthManager where save PostgresAuthManager{..} u@AuthUser{..} = do let (qstr, params) = saveQuery pamTable u let q = Query $ T.encodeUtf8 qstr- withResource pamConnPool $ \conn -> do- P.begin conn- P.execute conn q params- let q2 = Query $ T.encodeUtf8 $ T.concat- [ "select * from "- , tblName pamTable- , " where "- , fst (colLogin pamTable)- , " = ?"- ]- res <- P.query conn q2 [userLogin]- P.commit conn- return $ fromMaybe u $ listToMaybe res+ let action = withResource pamConnPool $ \conn -> do+ res <- P.query conn q params+ return $ Right $ fromMaybe u $ listToMaybe res+ catch action onFailure+ lookupByUserId PostgresAuthManager{..} uid = do let q = Query $ T.encodeUtf8 $ T.concat
src/Snap/Snaplet/PostgresqlSimple.hs view
@@ -164,7 +164,7 @@ -- > d <- nestSnaplet "db" db pgsInit -- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d instance (MonadCatchIO m) => HasPostgres (ReaderT (Snaplet Postgres) m) where- getPostgresState = asks (getL snapletValue)+ getPostgresState = asks (^# snapletValue) ------------------------------------------------------------------------------