snaplet-hdbc 0.6.2.2 → 0.6.3

raw patch · 4 files changed

+102/−100 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• snaplet-hdbc.cabal +2/−1
• src/Snap/Snaplet/Auth/Backends/Hdbc.hs +36/−54
• src/Snap/Snaplet/Hdbc.hs +43/−45
• src/Snap/Snaplet/Hdbc/Types.hs +21/−0

@@ -1,5 +1,5 @@ name:           snaplet-hdbc-version:        0.6.2.2+version:        0.6.3 synopsis:       HDBC snaplet for Snap Framework description:    This snaplet consists of two parts: an HDBC abstraction snaplet                 and an HDBC authentication backend for Snap's authentication@@ -25,6 +25,7 @@   exposed-modules:     Snap.Snaplet.Auth.Backends.Hdbc     Snap.Snaplet.Hdbc+    Snap.Snaplet.Hdbc.Types    build-depends:     base                      >= 4       && < 5,

@@ -14,11 +14,11 @@ import            Data.Map (Map) import qualified  Data.Map as DM import            Data.Maybe-import            Data.Pool import            Data.Text (Text) import            Database.HDBC import            Snap.Snaplet import            Snap.Snaplet.Auth+import            Snap.Snaplet.Hdbc.Types import            Snap.Snaplet.Session import            Web.ClientSession @@ -26,34 +26,20 @@ -- pool with commonly acceptable default settings. Use `initHdbcAuthManager'` -- to initialise with a custom resource pool. initHdbcAuthManager-  :: IConnection conn+  :: (ConnSrc s, IConnection c)   => AuthSettings  -- ^ Auth settings   -> Lens b (Snaplet SessionManager)  -- ^ Lens to the session manager-  -> IO conn       -- ^ Raw HDBC connection+  -> s c           -- ^ Raw HDBC connection   -> AuthTable     -- ^ Authentication table configuration   -> Queries       -- ^ Queries to be used for authentication   -> SnapletInit b (AuthManager b)-initHdbcAuthManager s l conn tbl qs = initHdbcAuthManager' s l pool tbl qs-  where pool = createPool conn disconnect 1 300 1---- | Initialises this HDBC snaplet with a custom resource pool.-initHdbcAuthManager'-  :: IConnection conn-  => AuthSettings    -- ^ Auth settings-  -> Lens b (Snaplet SessionManager)  -- ^ Lens to the session manager-  -> IO (Pool conn)  -- ^ A pre-configured resource pool which dispenses-                     --   HDBC connections-  -> AuthTable       -- ^ Authentication table configuration-  -> Queries         -- ^ Queries to be used for authentication-  -> SnapletInit b (AuthManager b)-initHdbcAuthManager' s l pool tbl qs =+initHdbcAuthManager s l conn tbl qs =   makeSnaplet  "HdbcAuthManager"                "A snaplet providing user authentication using an HDBC backend"                Nothing $ liftIO $ do-  key  <- getKey (asSiteKey s)-  pl   <- pool+  key <- getKey (asSiteKey s)   return AuthManager-    {  backend = HdbcAuthManager pl tbl qs+    {  backend = HdbcAuthManager conn tbl qs     ,  session = l     ,  activeUser = Nothing     ,  minPasswdLen = asMinPasswdLen s@@ -65,9 +51,9 @@ -- | Authmanager state containing the resource pool and the table/query -- configuration. data HdbcAuthManager-  =   forall conn. IConnection conn+  =   forall c s. (IConnection c, ConnSrc s)   =>  HdbcAuthManager-  {   authDBPool :: Pool conn+  {   authDBPool :: s c   ,   table  :: AuthTable   ,   qries  :: Queries } @@ -210,30 +196,27 @@   safeConvert (UserId uid) = Right $ toSql uid  instance IAuthBackend HdbcAuthManager where-  destroy (HdbcAuthManager pool tbl qs) au = withResource pool $-    \conn -> do-      let (qry, vals) = deleteQuery qs tbl au-      _ <- prepExec conn qry vals-      return ()+  destroy (HdbcAuthManager pool tbl qs) au =+    let  (qry, vals) = deleteQuery qs tbl au+    in   withConn pool $ prepExec qry vals -  save (HdbcAuthManager pool tbl qs) au = withResource pool $-    \conn -> do-      let (qry, idQry, vals) = saveQuery qs tbl au-      _ <- prepExec conn qry vals-      if isJust $ userId au-        then  return au-        else  do-          rw   <- withTransaction conn $ \conn' -> do-            stmt'  <- prepare conn' idQry-            _      <- execute stmt'  [  toSql $ userLogin au-                                     ,  toSql $ userPassword au]-            fetchRow stmt'-          nid  <- case rw of-                    Nothing     -> fail $  "Failed to fetch the newly inserted row. " ++-                                           "It might not have been inserted at all."-                    Just []     -> fail "Something went wrong"-                    Just (x:_)  -> return (fromSql x :: Text)-          return $ au { userId = Just (UserId nid) }+  save (HdbcAuthManager pool tbl qs) au = do+    let (qry, idQry, vals) = saveQuery qs tbl au+    withConn pool $ prepExec qry vals+    if isJust $ userId au+      then  return au+      else  do+        rw <- withConn pool $ \conn -> withTransaction conn $ \conn' -> do+          stmt'  <- prepare conn' idQry+          _      <- execute stmt'  [  toSql $ userLogin au+                                   ,  toSql $ userPassword au]+          fetchRow stmt'+        nid <-  case rw of+                  Nothing     -> fail $  "Failed to fetch the newly inserted row. " +++                                         "It might not have been inserted at all."+                  Just []     -> fail "Something went wrong"+                  Just (x:_)  -> return (fromSql x :: Text)+        return $ au { userId = Just (UserId nid) }    lookupByUserId mgr@(HdbcAuthManager _ tbl qs) uid = authQuery mgr $     selectQuery qs tbl ByUserId [toSql uid]@@ -242,20 +225,19 @@   lookupByRememberToken mgr@(HdbcAuthManager _ tbl qs) rmb = authQuery mgr $     selectQuery qs tbl ByRememberToken [toSql rmb] -prepExec :: IConnection conn => conn -> String -> [SqlValue] -> IO ()-prepExec conn qry vals = withTransaction conn $ \conn' -> do+prepExec :: IConnection conn => String -> [SqlValue] -> conn -> IO ()+prepExec qry vals conn = withTransaction conn $ \conn' -> do   stmt  <- prepare conn' qry   _     <- execute stmt vals   return ()  authQuery :: HdbcAuthManager -> (String, [SqlValue]) -> IO (Maybe AuthUser)-authQuery (HdbcAuthManager pool tbl _) (qry, vals) =-  withResource pool $ \conn -> do-    res <- do-      stmt  <- prepare conn qry-      _     <- execute stmt vals-      fetchRowMap stmt-    return $ (return . mkUser tbl) =<< res+authQuery (HdbcAuthManager pool tbl _) (qry, vals) = do+  res <- withConn pool $ \conn -> do+    stmt  <- prepare conn qry+    _     <- execute stmt vals+    fetchRowMap stmt+  return $ (return . mkUser tbl) =<< res  mkUser :: AuthTable -> Map String SqlValue -> AuthUser mkUser tbl mp =

@@ -77,15 +77,17 @@ import            Control.Monad.IO.Control import            Control.Monad.State import            Data.Map (Map)-import            Data.Pool import qualified  Database.HDBC as HDBC import            Database.HDBC (IConnection(), SqlValue, SqlError, Statement) import            Database.HDBC.ColTypes import            Snap.Snaplet+import            Snap.Snaplet.Hdbc.Types + -- | A map with the column name as key and the value from the database as value type Row = Map String SqlValue + -- | Instantiate this typeclass on 'Handler b YourSnapletState' so this snaplet -- can find the resource pool. Typically you would instantiate it for Snap's -- Handler type and use your snaplet's lens to this snaplet to access this@@ -102,8 +104,9 @@ -- > instance HasHdbc (Handler b App) Connection where -- >   getPool = with dbLens $ gets hdbcPool ---class (IConnection c, MonadControlIO m) => HasHdbc m c | m -> c where-  getPool :: m (Pool c)+class  (IConnection c, ConnSrc s, MonadControlIO m)+  =>   HasHdbc m c s | m -> c s where+  getConnSrc :: m (s c)  -- | This is (hopefully) a temporary instance, which will disppear once the -- entire snap framework is switched to 'MonadControlIO'.@@ -112,10 +115,10 @@  -- | The snaplet state type containing a resource pool, parameterised by a raw -- HDBC connection.-data HdbcSnaplet c-  =   IConnection c+data HdbcSnaplet c s+  =   (IConnection c, ConnSrc s)   =>  HdbcSnaplet-  {   hdbcPool :: Pool c }+  {   connSrc :: s c }  -- | Initialise the snaplet by providing it with a raw HDBC connection. A -- resource pool is created with some default parameters that should be fine@@ -123,37 +126,32 @@ -- desired, use the `hdbcInit'` initialiser instead. When the snaplet is -- unloaded, the 'disconnect' function is called to close any remaining -- connections.-hdbcInit :: IConnection c => IO c -> SnapletInit b (HdbcSnaplet c)-hdbcInit conn = hdbcInit' $ createPool conn HDBC.disconnect 1 300 1+hdbcInit+  ::  (ConnSrc s, IConnection c)+  =>  s c+  ->  SnapletInit b (HdbcSnaplet c s)+hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $+  return $ HdbcSnaplet src --- | Instead of a raw HDBC connection, this initialiser expects a--- pre-configured resource pool that dispenses HDBC connections. When the--- snaplet is unloaded, the 'disconnect' function is called to close any--- remaining connections.-hdbcInit' :: IConnection c => IO (Pool c) -> SnapletInit b (HdbcSnaplet c)-hdbcInit' pl = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do-  pl' <- liftIO pl-  onUnload $ withResource pl' HDBC.disconnect-  return $ HdbcSnaplet pl'  -- | Get a new connection from the resource pool, apply the provided function -- to it and return the result in of the 'IO' compution in monad @m@.-withHdbc :: HasHdbc m c => (c -> IO a) -> m a+withHdbc :: HasHdbc m c s => (c -> IO a) -> m a withHdbc f = do-  pl <- getPool-  withResource pl (liftIO . f)+  pl <- getConnSrc+  withConn pl (liftIO . f)  -- | Get a new connection from the resource pool, apply the provided function -- to it and return the result in of the compution in monad 'm'.-withHdbc' :: HasHdbc m c => (c -> a) -> m a+withHdbc' :: HasHdbc m c s => (c -> a) -> m a withHdbc' f = do-  pl <- getPool-  withResource pl (return . f)+  pl <- getConnSrc+  withConn pl (return . f)  -- | Execute a @SELECT@ query on the database by passing the query as 'String', -- together with a list of values to bind to it. A list of 'Row's is returned. query-  :: HasHdbc m c+  :: HasHdbc m c s   => String      -- ^ The raw SQL to execute. Use @?@ to indicate placeholders.   -> [SqlValue]  -- ^ Values for each placeholder according to its position in                  --   the SQL statement.@@ -167,7 +165,7 @@ -- | Similar to 'query', but instead of returning a list of 'Row's, it returns -- an 'Integer' indicating the numbers of affected rows. This is typically used -- for @INSERT@, @UPDATE@ and @DELETE@ queries.-query' :: HasHdbc m conn => String -> [SqlValue] -> m Integer+query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer query' sql bind = withTransaction' $ do   stmt <- prepare sql   liftIO $ HDBC.execute stmt bind@@ -177,7 +175,7 @@ -- -- > withTransaction' $ \conn -> do ... ---withTransaction :: HasHdbc m c => (c -> IO a) -> m a+withTransaction :: HasHdbc m c s => (c -> IO a) -> m a withTransaction f = withHdbc (`HDBC.withTransaction` f)  -- | Run an action inside a transaction. If the action throws an exception, the@@ -187,7 +185,7 @@ -- >   query "INSERT INTO ..." [] -- >   query "DELETE FROM ..." [] ---withTransaction' :: HasHdbc m c => m a -> m a+withTransaction' :: HasHdbc m c s => m a -> m a withTransaction' action = do   r <- onException action doRollback   commit@@ -200,56 +198,56 @@ -- functions. Please refer to the HDBC documentation to see what they do and -- how they work. -disconnect :: HasHdbc m c => m ()+disconnect :: HasHdbc m c s => m () disconnect = withHdbc HDBC.disconnect -commit :: HasHdbc m c => m ()+commit :: HasHdbc m c s => m () commit = withHdbc HDBC.commit -rollback :: HasHdbc m c => m ()+rollback :: HasHdbc m c s => m () rollback = withHdbc HDBC.rollback -runRaw :: HasHdbc m c => String -> m ()+runRaw :: HasHdbc m c s => String -> m () runRaw str = withHdbc (`HDBC.runRaw` str) -run :: HasHdbc m c => String -> [SqlValue] -> m Integer+run :: HasHdbc m c s => String -> [SqlValue] -> m Integer run str vs = withHdbc (\conn -> HDBC.run conn str vs) -prepare :: HasHdbc m c => String -> m Statement+prepare :: HasHdbc m c s => String -> m Statement prepare str = withHdbc (`HDBC.prepare` str) -clone :: HasHdbc m c => m c+clone :: HasHdbc m c s => m c clone = withHdbc HDBC.clone -hdbcDriverName :: HasHdbc m c => m String+hdbcDriverName :: HasHdbc m c s => m String hdbcDriverName = withHdbc' HDBC.hdbcDriverName -hdbcClientVer :: HasHdbc m c => m String+hdbcClientVer :: HasHdbc m c s => m String hdbcClientVer = withHdbc' HDBC.hdbcClientVer -proxiedClientName :: HasHdbc m c => m String+proxiedClientName :: HasHdbc m c s => m String proxiedClientName = withHdbc' HDBC.proxiedClientName -proxiedClientVer :: HasHdbc m c => m String+proxiedClientVer :: HasHdbc m c s => m String proxiedClientVer = withHdbc' HDBC.proxiedClientVer -dbServerVer :: HasHdbc m c => m String+dbServerVer :: HasHdbc m c s => m String dbServerVer = withHdbc' HDBC.dbServerVer -dbTransactionSupport :: HasHdbc m c => m Bool+dbTransactionSupport :: HasHdbc m c s => m Bool dbTransactionSupport = withHdbc' HDBC.dbTransactionSupport -getTables :: HasHdbc m c => m [String]+getTables :: HasHdbc m c s => m [String] getTables = withHdbc HDBC.getTables -describeTable :: HasHdbc m c => String -> m [(String, SqlColDesc)]+describeTable :: HasHdbc m c s => String -> m [(String, SqlColDesc)] describeTable str = withHdbc (`HDBC.describeTable` str) -quickQuery' :: HasHdbc m c => String -> [SqlValue] -> m [[SqlValue]]+quickQuery' :: HasHdbc m c s => String -> [SqlValue] -> m [[SqlValue]] quickQuery' str vs = withHdbc (\conn -> HDBC.quickQuery' conn str vs) -quickQuery :: HasHdbc m c => String -> [SqlValue] -> m [[SqlValue]]+quickQuery :: HasHdbc m c s => String -> [SqlValue] -> m [[SqlValue]] quickQuery str vs = withHdbc (\conn -> HDBC.quickQuery conn str vs) -sRun :: HasHdbc m c => String -> [Maybe String] -> m Integer+sRun :: HasHdbc m c s => String -> [Maybe String] -> m Integer sRun str mstrs = withHdbc (\conn -> HDBC.sRun conn str mstrs)

@@ -0,0 +1,21 @@+module Snap.Snaplet.Hdbc.Types where++import            Control.Monad.IO.Control+import            Control.Monad.State+import            Database.HDBC (IConnection())+import qualified  Database.HDBC as HDBC+import            Data.Pool++class ConnSrc s where+  withConn   :: (MonadControlIO m, IConnection c) => s c -> (c -> m b) -> m b+  closeConn  :: (MonadControlIO m, IConnection c) => s c -> c -> m ()++instance ConnSrc Pool where+  withConn       = withResource+  closeConn _ _  = return ()++instance ConnSrc IO where+  withConn conn fn = do+    conn' <- liftIO conn+    fn conn'+  closeConn _ = liftIO . HDBC.disconnect