Skip to content
Browse files

Rip more changes from snaplet-hdbc add more functionality.

  • Loading branch information...
1 parent cf54f6e commit 23c201e05015e95aab4f5bf776be9fd616d75abd External Reality committed Nov 2, 2011
Showing with 69 additions and 7 deletions.
  1. +69 −7 src/Snap/Snaplet/Sedna.hs
View
76 src/Snap/Snaplet/Sedna.hs
@@ -1,18 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+
module Snap.Snaplet.Sedna where
+
+
-------------------------------------------------------------------------------
-import Data.Pool
+import Control.Monad.IO.Control
+import Control.Monad.State
import Database.SednaDB.SednaTypes
import qualified Database.SednaDB.SednaBindings as Sedna
import Snap.Snaplet
+import Snap.Snaplet.Sedna.Types
+
+
+-------------------------------------------------------------------------------
+class (MonadControlIO m, ConnSrc s) => HasSedna m s | m -> s where
+ getConnSrc :: m (s SednaConnection)
+
+
+-------------------------------------------------------------------------------
+data SednaSnaplet s =
+ ConnSrc s => SednaSnaplet { connSrc :: s SednaConnection }
+
+
+-------------------------------------------------------------------------------
+instance MonadControlIO (Handler b v) where
+ liftControlIO f = liftIO (f return)
+
+
+-------------------------------------------------------------------------------
+sednaInit :: ConnSrc s => (s SednaConnection) -> SnapletInit b (SednaSnaplet s)
+sednaInit src = makeSnaplet "sedna" "Sedna Database Connectivity" Nothing $ do
+ return $ SednaSnaplet src
+
+
+-------------------------------------------------------------------------------
+withSedna :: (MonadControlIO m, HasSedna m s) => (SednaConnection -> IO a) -> m a
+withSedna f = do
+ src <- getConnSrc
+ liftIO $ withConn src (liftIO . f)
+
+
+-------------------------------------------------------------------------------
+withSedna' :: HasSedna m s => (SednaConnection -> a) -> m a
+withSedna' f = do
+ src <- getConnSrc
+ liftIO $ withConn src (return . f)
-------------------------------------------------------------------------------
-data SednaSnaplet = SednaSnaplet { sednaConnectionPool :: Pool SednaConnection }
+query :: HasSedna m s => Query -> m QueryResult
+query xQuery = do
+ withSedna (`Sedna.sednaExecute` xQuery)
+ withSedna Sedna.sednaGetResultString
-------------------------------------------------------------------------------
-sednaInit conn = sednaInit' $ createPool conn
- Sedna.sednaCloseConnection
- 1
- 300
- 1
+disconnect :: HasSedna m s => m ()
+disconnect = withSedna Sedna.sednaCloseConnection
+
+
+-------------------------------------------------------------------------------
+commit :: HasSedna m s => m ()
+commit = withSedna Sedna.sednaCommit
+
+
+-------------------------------------------------------------------------------
+rollback :: HasSedna m s => m ()
+rollback = withSedna Sedna.sednaRollBack
+
+
+--------------------------------------------------------------------------------
+--loadXMLFile :: HasSedna m s => Document -> Collection -> m ()
+--loadXMLFile filepath doc coll = withSedna (`Sedna.sednaLoadFile` filepath doc coll)
+
+--------------------------------------------------------------------------------
+

0 comments on commit 23c201e

Please sign in to comment.
Something went wrong with that request. Please try again.