Takusen 0.8.5 → 0.8.6

raw patch · 11 files changed

+609/−253 lines, 11 filesdep +randomdep ~QuickChecknew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: random

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• Database/ODBC/Enumerator.lhs +61/−24
• Database/ODBC/OdbcFunctions.hsc +189/−129
• Database/ODBC/Test/Enumerator.lhs +24/−14
• Database/ODBC/Test/OdbcFunctions.lhs +105/−64
• Database/PostgreSQL/Enumerator.lhs +17/−1
• Database/PostgreSQL/PGFunctions.lhs +98/−3
• Database/PostgreSQL/Test/Enumerator.lhs +25/−1
• Database/PostgreSQL/Test/PGFunctions.lhs +76/−4
• Database/Test/Enumerator.lhs +9/−7
• Database/Util.lhs +1/−2
• Takusen.cabal +4/−4

@@ -44,6 +44,7 @@ >   , prepareQuery, prepareLargeQuery, prepareCommand
 >   , sql, sqlbind, prefetch, cmdbind
 >   , Out(..), InfoDbmsName(..)
+>   , CharEncoding(..), setStringEnc
 >   , module Database.Enumerator
 >   )
 > where
@@ -57,7 +58,7 @@ > import Control.Monad
 > import Control.Exception.Extensible (bracket)
 > import Database.ODBC.OdbcFunctions
->   (EnvHandle, ConnHandle, StmtHandle, OdbcException(..), catchOdbc, throwOdbc)
+>   (EnvHandle, ConnHandle, StmtHandle, CharEncoding(..), OdbcException(..), catchOdbc, throwOdbc)
 > import qualified Database.ODBC.OdbcFunctions as DBAPI
 > import Control.Monad.Trans
 > import Control.Monad.Reader
@@ -159,10 +160,22 @@ >   return (Session env conn)
 
 
-Note: the PostgreSQL ODBC driver only supports ReadCommitted
-and Serializable. It throws an error on other values.
-It'd be nicer if it just silently upgraded, but c'est la vie...
+We need a way to set the char encoding for String marshaling.
+EnvInquiry.inquire gives us a way to run arbitrary actions
+in the DBM monad, so make an instance for it.
 
+> instance EnvInquiry CharEncoding Session () where
+>   inquire charenc sess = DBAPI.setConnEncoding (connHandle sess) charenc
+
+Also make a synonym for inquire, because "inquire EncUTF8" will look odd,
+and non-obvious.
+
+> setStringEnc enc = Database.Enumerator.inquire enc
+
+Note: the PostgreSQL and Oracle ODBC drivers only support ReadCommitted
+and Serializable. You get an error on other values.
+It'd be nicer if they just silently upgraded, but c'est la vie...
+
 Apparently MS SQL Server upgrades RepeatableRead to Serializable.
 Presumably the other modes are still supported.
 
@@ -177,7 +190,9 @@ >     disconnectDb (connHandle sess)
 >     freeConn (connHandle sess)
 >     freeEnv (envHandle sess)
->   -- With ODBC, transactions are implicitly started.
+>   -- With ODBC, transactions are implicitly started,
+>   -- so all we do is commit the previous transaction
+>   -- (probably done already) and set isolation level.
 >   beginTransaction sess isolation = do
 >     commitTrans (connHandle sess)
 >     setTransLevel (connHandle sess) (isolationLevel isolation)
@@ -213,6 +228,7 @@ >       (action sess)
 >       (freeStmt . stmtHandle)
 >       (\pstmt -> do
+>         freeBindBuffers pstmt
 >         sequence_ (zipWith (\i (BindA ba) -> ba sess pstmt i) [1..] bas)
 >         stmtExecute (stmtHandle pstmt)
 >         rowCount (stmtHandle pstmt)
@@ -227,7 +243,8 @@ 
 > instance EnvInquiry InfoDbmsName Session String where
 >   inquire InfoDbmsName sess =
->     liftM (map toLower) (DBAPI.getInfoDbmsName (connHandle sess))
+>     --liftM (map toLower) (DBAPI.getInfoDbmsName (connHandle sess))
+>     return (DBAPI.connDbms (connHandle sess))
 
 
 About stmtFreeWithQuery:
@@ -252,11 +269,11 @@ > data PreparedStmtObj = PreparedStmtObj
 >   { stmtHandle :: StmtHandle
 >   , stmtLifetime :: StmtLifetime
->   -- stmtBuffers are actually output bind buffers.
->   -- we package them to look like ColumnBuffers
+>   , stmtBuffers :: IORef [ColumnBuffer]
+>   -- We package output bind buffers to look like ColumnBuffers
 >   -- (as created by allocBuffer) so that we can use them
 >   -- like ColumnBuffers.
->   , stmtBuffers :: IORef [ColumnBuffer]
+>   , stmtOutputBuffers :: IORef [ColumnBuffer]
 >   , stmtFetched :: IORef Bool
 >   }
 
@@ -280,15 +297,20 @@ 
 > newPreparedStmt stmt lifetime = do
 >   b <- newIORef []
+>   ob <- newIORef []
 >   f <- newIORef False
->   return (PreparedStmtObj stmt lifetime b f)
+>   return (PreparedStmtObj stmt lifetime b ob f)
 
+> freeBindBuffers stmt = do
+>   writeIORef (stmtBuffers stmt) []
+>   writeIORef (stmtOutputBuffers stmt) []
+
 --------------------------------------------------------------------
 -- ** Binding
 --------------------------------------------------------------------
 
 > newtype BoundStmt = BoundStmt { boundStmt :: PreparedStmtObj }
-> type BindObj = Int -> IO ()
+> type BindObj = Int -> IO DBAPI.BindBuffer
 > newtype Out a = Out a
 
 > instance IPrepared PreparedStmtObj Session BoundStmt BindObj where
@@ -296,14 +318,13 @@ >     fetched <- readIORef (stmtFetched pstmt)
 >     when (fetched)
 >       (closeCursor (stmtHandle pstmt) >> writeIORef (stmtFetched pstmt) False)
+>     freeBindBuffers pstmt
 >     sequence_ (zipWith (\i (BindA ba) -> ba sess pstmt i) [1..] bas)
 >     stmtExecute (stmtHandle pstmt)
 >     action (BoundStmt pstmt)
 >   destroyStmt sess pstmt = do
 >     -- Could free output bind buffers here, but for now we don't bother.
 >     -- They are ForeignPtrs, so we expect them to be GC'd.
->     --buffers <- readIORef (stmtBuffers pstmt)
->     --sequence_ (map (freeBindBuffer . colBuffer) buffers)
 >     freeStmt (stmtHandle pstmt)
 
 
@@ -311,7 +332,8 @@ >   bindP val = makeBindAction val DBAPI.bindParamBuffer 0
 
 > instance DBBind (Out (Maybe String)) Session PreparedStmtObj BindObj where
->   bindP (Out val) = makeOutputBindAction (DBAPI.InOutParam val) DBAPI.bindParamBuffer 16000
+>   -- SQL Server will raise an error if buffer size > 7999
+>   bindP (Out val) = makeOutputBindAction (DBAPI.InOutParam val) DBAPI.bindParamBuffer 7999
 
 
 > instance DBBind (Maybe Int) Session PreparedStmtObj BindObj where
@@ -354,18 +376,32 @@ >   bindP (Out (Just x)) = bindP (Out (Just (show x)))
 >   bindP (Out Nothing) = bindP (Out (Nothing `asTypeOf` Just ""))
 
-> makeBindAction val binder size = BindA (\ses st pos -> do
->   convertEx (binder (stmtHandle st) pos val size >> return ()))
+> makeBindAction val binder size = BindA (\sess stmt pos -> do
+>   convertEx (do
+>     buf <- binder (stmtHandle stmt) pos val size
+>     appendBindBuffer stmt buf
+>     ))
 
-> makeOutputBindAction val binder size = BindA (\ses st pos -> do
->   convertEx (binder (stmtHandle st) pos val size >>= appendOutputBindBuffer st))
+> makeOutputBindAction val binder size = BindA (\sess stmt pos -> do
+>   convertEx (do
+>     buf <- binder (stmtHandle stmt) pos val size
+>     appendBindBuffer stmt buf
+>     appendOutputBindBuffer stmt buf
+>     ))
 
-> appendOutputBindBuffer stmt buffer = do
+> appendBindBuffer stmt buffer = do
 >   buffers <- readIORef (stmtBuffers stmt)
 >   let colbuf = ColumnBuffer (1 + length buffers) buffer
 >   modifyIORef (stmtBuffers stmt) (++ [colbuf])
+>   return buffer
 
+> appendOutputBindBuffer stmt buffer = do
+>   buffers <- readIORef (stmtOutputBuffers stmt)
+>   let colbuf = ColumnBuffer (1 + length buffers) buffer
+>   modifyIORef (stmtOutputBuffers stmt) (++ [colbuf])
+>   return buffer
 
+
 --------------------------------------------------------------------
 -- ** Queries
 --------------------------------------------------------------------
@@ -403,6 +439,7 @@ >   makeQuery sess (StmtBind sqltext bas) = do
 >     let (PreparationA action) = prepareStmt' sqltext FreeWithQuery
 >     pstmt <- action sess
+>     freeBindBuffers pstmt
 >     sequence_ (zipWith (\i (BindA ba) -> ba sess pstmt i) [1..] bas)
 >     stmtExecute (stmtHandle pstmt)
 >     n <- newIORef 0
@@ -418,11 +455,11 @@ >   makeQuery sess (NextResultSet (PreparedStmt pstmt)) = do
 >     -- If stmt buffers are present, then the first doQuery
 >     -- will have processed its results from there.
->     -- So for tne next query, we want to clear the buffer list
+>     -- So for the next query, we want to clear the buffer list
 >     -- and start fetching from the stmt handle.
 >     -- This allows us to call stored procedures that return
 >     -- both output parameters and (multiple) result-sets.
->     buffers <- readIORef (stmtBuffers pstmt)
+>     buffers <- readIORef (stmtOutputBuffers pstmt)
 >     if null buffers
 >       then do
 >         more <- DBAPI.moreResults (stmtHandle pstmt)
@@ -439,7 +476,7 @@ >   destroyQuery query = do
 >     let pstmt = queryStmt query
 >     when (stmtLifetime pstmt == FreeWithQuery)
->       (freeStmt (stmtHandle pstmt))
+>       (freeBindBuffers pstmt >> freeStmt (stmtHandle pstmt))
 >   fetchOneRow query = do
 >     let pstmt = queryStmt query
 >     -- Only call fetchRow if there are no bind output buffers
@@ -447,7 +484,7 @@ >     -- procedure call.
 >     -- In this case you will always get the same row over and over,
 >     -- so you'd better be careful with your iteratees
->     buffers <- readIORef (stmtBuffers pstmt)
+>     buffers <- readIORef (stmtOutputBuffers pstmt)
 >     if not (null buffers) then return True
 >       else do
 >         moreRows <- fetchRow (stmtHandle pstmt)
@@ -469,7 +506,7 @@ 
 > allocBuffer q pos size val = do
 >   let stmt = queryStmt q
->   buffers <- readIORef (stmtBuffers stmt)
+>   buffers <- readIORef (stmtOutputBuffers stmt)
 >   if null buffers
 >     then do
 >       bindbuffer <- convertEx (DBAPI.bindColBuffer (stmtHandle stmt) pos size val)

@@ -38,6 +38,7 @@ import Control.Exception.Extensible import Control.Monad import Data.Dynamic+import Data.IORef import Data.Time import Database.Util import Foreign@@ -57,28 +58,53 @@ -- parameters for MS SQL Server. data ConnObj = ConnObj type ConnHdl = Ptr ConnObj-data ConnHandle = ConnHandle { connHdl :: ConnHdl, connDbms :: String }+data ConnHandle = ConnHandle { connHdl :: ConnHdl, connDbms :: String, connCharEnc :: IORef CharEncoding } data StmtObj = StmtObj type StmtHdl = Ptr StmtObj-data StmtHandle = StmtHandle { stmtHdl :: StmtHdl, stmtDbms :: String }+data StmtHandle = StmtHandle { stmtHdl :: StmtHdl, stmtDbms :: String, stmtCharEnc :: IORef CharEncoding } type WindowHandle = Ptr () data Buffer = Buffer type BufferFPtr = ForeignPtr Buffer type SizeFPtr = ForeignPtr SqlLen -type MyCString = CString-type MyCStringLen = CStringLen-myPeekCStringLen p = peekUTF8StringLen p-myWithCString s = withUTF8String s-myWithCStringLen s = withUTF8StringLen s---myPeekCStringLen p = peekCStringLen p---myWithCString s = withCString s---myWithCStringLen s = withCStringLen s +-- We need a way for user code to specify what charset is expected.+-- A bit limited, but it works for most DBMSs...+data CharEncoding = EncLatin1 | EncUTF8 | EncUTF16++-- Helper functions for String marshalling++withEncStringLen :: CharEncoding -> String -> (CStringLen -> IO a) -> IO a+withEncStringLen charenc str action = do+  case charenc of+    EncLatin1 -> withCAStringLen str action+    EncUTF8   -> withUTF8StringLen str action+    EncUTF16  -> withCWStringLen str (\(cwstr, clen) -> action (castPtr cwstr, clen))++peekEncString :: CharEncoding -> CString -> IO String+peekEncString charenc cstr = do+  case charenc of+    EncLatin1 -> peekCAString cstr+    EncUTF8   -> peekUTF8String cstr+    EncUTF16  -> peekCWString (castPtr cstr)++peekEncStringLen :: CharEncoding -> CStringLen -> IO String+peekEncStringLen charenc cstrlen = do+  case charenc of+    EncLatin1 -> peekCAStringLen cstrlen+    EncUTF8   -> peekUTF8StringLen cstrlen+    EncUTF16  -> peekCWStringLen (cstr2cwstr cstrlen)+  where+    cstr2cwstr :: CStringLen -> CWStringLen+    cstr2cwstr (cstr, clen) = (castPtr cstr, clen)+++ data BindBuffer = BindBuffer   { bindBufPtr :: BufferFPtr   , bindBufSzPtr :: SizeFPtr   , bindBufSize :: SqlLen+  , bindBufCharEnc :: CharEncoding   }  type SqlInteger = #{type SQLINTEGER}@@ -203,7 +229,8 @@  -- ODBC SQL data types (-  sqlDTypeString :+  sqlDTypeChar :+  sqlDTypeVarchar :   sqlDTypeInt :   sqlDTypeBinary :   sqlDTypeDouble :@@ -213,7 +240,8 @@   sqlDTypeCursor :   []) =   (-  #{const SQL_CHAR} :  -- 1+  #{const SQL_CHAR} :  -- CHAR = 1, VARCHAR = 12, LONGVARCHAR = -1+  #{const SQL_VARCHAR} :  -- CHAR = 1, VARCHAR = 12, LONGVARCHAR = -1   #{const SQL_INTEGER} :  -- 4   #{const SQL_BINARY} :  -- -2   #{const SQL_DOUBLE} :  -- 8@@ -350,10 +378,10 @@     case () of       _ | rc == sqlRcSuccess -> do           errnum <- peek errorNumPtr-          state <- myPeekCStringLen (cstrState, 5)+          state <- peekCStringLen (cstrState, 5)           msglen <- peek msgLenPtr           --debugStmt ("getDiagRec: msglen=" ++ show msglen)-          msg <- myPeekCStringLen (cstrMsg, fromIntegral msglen)+          msg <- peekCStringLen (cstrMsg, fromIntegral msglen)           --debugStmt ("getDiagRec: msg=" ++ msg)           more <- getDiagRec retcode htype handle (row+1)           return ((OdbcException (fromIntegral errnum) state msg []) : more)@@ -386,13 +414,23 @@ allocConn :: EnvHandle -> IO ConnHandle allocConn env = do   c <- allocHdl (castPtr env) sqlHTypeConn-  return (ConnHandle c "")+  -- default char encoding is UTF8; change with setCharEncoding+  ior <- newIORef EncUTF8+  return (ConnHandle c "" ior) +setConnEncoding :: ConnHandle -> CharEncoding -> IO ()+setConnEncoding conn enc = writeIORef (connCharEnc conn) enc++setStmtEncoding :: StmtHandle -> CharEncoding -> IO ()+setStmtEncoding stmt enc = writeIORef (stmtCharEnc stmt) enc+ allocStmt :: ConnHandle -> IO StmtHandle allocStmt conn = do   s <- allocHdl (castPtr (connHdl conn)) sqlHTypeStmt-  -- copy dbms name from connection object-  return (StmtHandle s (connDbms conn))+  -- copy dbms name and char encoding from connection object+  enc <- readIORef (connCharEnc conn)+  ior <- newIORef enc+  return (StmtHandle s (connDbms conn) ior)  freeHandle :: SqlHandleType -> Handle -> IO () freeHandle htype h = do@@ -418,14 +456,14 @@  connect :: ConnHandle -> String -> IO String connect conn connstr = do-  myWithCStringLen connstr $ \(cstr, clen) -> do+  withCStringLen connstr $ \(cstr, clen) -> do   allocaBytes 1000 $ \outConnStr -> do   alloca $ \ptrOutLen -> do   rc <- sqlDriverConnect (connHdl conn) nullPtr cstr (fromIntegral clen)     outConnStr 1000 ptrOutLen sqlDriverNoPrompt   checkError rc sqlHTypeConn (castPtr (connHdl conn))   outLen <- peek ptrOutLen-  myPeekCStringLen (outConnStr, fromIntegral outLen)+  peekCStringLen (outConnStr, fromIntegral outLen)  disconnect :: ConnHandle -> IO () disconnect conn = do@@ -435,9 +473,11 @@  prepareStmt :: StmtHandle -> String -> IO () prepareStmt stmt sqltext = do-  myWithCString sqltext $ \cstr -> do-  rc <- sqlPrepare (stmtHdl stmt) cstr sqlNullTermedString-  checkError rc sqlHTypeStmt (castPtr (stmtHdl stmt))+  charenc <- readIORef (stmtCharEnc stmt)+  withEncStringLen charenc sqltext (\(cstr, clen) -> do+      rc <- sqlPrepare (stmtHdl stmt) cstr (fromIntegral clen)+      checkError rc sqlHTypeStmt (castPtr (stmtHdl stmt))+    )  executeStmt :: StmtHandle -> IO () executeStmt stmt = do@@ -497,8 +537,19 @@  setTxnIsolation :: ConnHandle -> SqlInteger -> IO () setTxnIsolation conn level = do-  rc <- sqlSetConnectAttr (connHdl conn) sqlAttrTxnIsolation (int2Ptr level) 0-  checkError rc sqlHTypeConn (castPtr (connHdl conn))+  -- MS Access has transactions, but not isolation levels.+  -- Oracle & PostgreSQL don't do sqlTxnReadUncommitted or sqlTxnRepeatableRead;+  -- we get: "206 HY009 Illegal parameter value for SQL_TXN_ISOLATION"+  --     or: "  0 HYC00 [Oracle][ODBC]Optional feature not implemented."+  let doNothing = ("access" == connDbms conn)+        || (("postgresql" == connDbms conn)+          && (level == sqlTxnReadUncommitted || level == sqlTxnRepeatableRead) )+	|| (("oracle" == connDbms conn)+          && (level == sqlTxnReadUncommitted || level == sqlTxnRepeatableRead) )+  unless doNothing ( do+      rc <- sqlSetConnectAttr (connHdl conn) sqlAttrTxnIsolation (int2Ptr level) 0+      checkError rc sqlHTypeConn (castPtr (connHdl conn))+    )  getInfoString :: ConnHandle -> SqlInfoType -> IO String getInfoString conn infotype = do@@ -508,7 +559,7 @@   rc <- sqlGetInfo (connHdl conn) infotype buffer (fromIntegral bufsize) outsizeptr   checkError rc sqlHTypeConn (castPtr (connHdl conn))   outsize <- peek outsizeptr-  myPeekCStringLen (castPtr buffer, fromIntegral outsize)+  peekCStringLen (castPtr buffer, fromIntegral outsize)  getInfoDbmsName :: ConnHandle -> IO String getInfoDbmsName conn = getInfoString conn sqlInfoDbmsName@@ -525,16 +576,24 @@ getInfoDriverVer :: ConnHandle -> IO String getInfoDriverVer conn = getInfoString conn sqlInfoDriverVer +-- The ODBC spec allows you to use escape sequences+-- for product-specific functions i.e. stuff not in the SQL specs.+-- That is, it provides an abstraction over various SQL extensions.+-- getNativeSql shows you how these get translated into product-specific SQL.+-- Note that the MS Access, MS SQL Server, and PostgreSQL drivers seem to+-- return the original SQL text unchanged i.e. the ODBC escape sequences+-- are not translated, and are passed to the DBMS unchanged. getNativeSql :: ConnHandle -> String -> IO String getNativeSql conn sqltext = do   let bufsize = 100000   alloca $ \outsizeptr -> do   allocaBytes bufsize $ \buffer -> do-  myWithCStringLen sqltext $ \(cstr,clen) -> do+  charenc <- readIORef (connCharEnc conn)+  withEncStringLen charenc sqltext $ \(cstr,clen) -> do   rc <- sqlNativeSql (connHdl conn) cstr (fromIntegral clen) buffer (fromIntegral bufsize) outsizeptr   checkError rc sqlHTypeConn (castPtr (connHdl conn))   outsize <- peek outsizeptr-  myPeekCStringLen (castPtr buffer, fromIntegral outsize)+  peekEncStringLen charenc (castPtr buffer, fromIntegral outsize)     @@ -576,32 +635,29 @@   alloca $ \szptr -> do   allocaBytes 16 $ \dummyptr -> do   -- Call GetData with 0-sized buffer to get size information.-  rc <- sqlGetData (stmtHdl stmt) (fromIntegral pos) sqlDTypeString (castPtr dummyptr) 0 szptr+  -- We have to use sqlDTypeChar; sqlDTypeVarchar causes error "Program type out of range".+  rc <- sqlGetData (stmtHdl stmt) (fromIntegral pos) sqlDTypeChar (castPtr dummyptr) 0 szptr   when (rc /= sqlRcSuccessWithInfo)     (checkError rc sqlHTypeStmt (castPtr (stmtHdl stmt)))   bufSize <- peek szptr   let bufSize' = 1 + if bufSize < 0 then 0 else bufSize   -- Use size information to allocate perfectly-sized buffer.+  -- We have to use sqlDTypeChar; sqlDTypeVarchar causes error "Program type out of range".   allocaBytes (fromIntegral bufSize') $ \bptr -> do-  rc <- sqlGetData (stmtHdl stmt) (fromIntegral pos) sqlDTypeString (castPtr bptr) bufSize' szptr+  rc <- sqlGetData (stmtHdl stmt) (fromIntegral pos) sqlDTypeChar (castPtr bptr) bufSize' szptr   checkError rc sqlHTypeStmt (castPtr (stmtHdl stmt))   len <- peek szptr   if len < 0 then return Nothing     else return (Just (castPtr bptr, fromIntegral len)) -getDataUTF8String :: StmtHandle -> Int -> IO (Maybe String)-getDataUTF8String stmt pos = do-  mbcstrlen <- getDataCStringLen stmt pos-  case mbcstrlen of-    Nothing -> return Nothing-    Just cstrlen -> peekUTF8StringLen cstrlen >>= return . Just--getDataCString :: StmtHandle -> Int -> IO (Maybe String)-getDataCString stmt pos = do+getDataString :: StmtHandle -> Int -> IO (Maybe String)+getDataString stmt pos = do   mbcstrlen <- getDataCStringLen stmt pos   case mbcstrlen of     Nothing -> return Nothing-    Just cstrlen -> peekCStringLen cstrlen >>= return . Just+    Just cstrlen -> do+      charenc <- readIORef (stmtCharEnc stmt)+      peekEncStringLen charenc cstrlen >>= return . Just  {- from sqltypes.h. Struct size depends on size of SmallInt etc, but is 16 bytes on a 32-bit platform. 32 bytes on 64-bit?@@ -642,13 +698,13 @@ --------------------------------------------------------------------- -- Return-set column binding. -- Apparently this is faster than SQLGetData for larger result-sets,--- because the output buffers do not need to be rebound with--- every call.+-- because the output buffers do not need to be rebound with every call. -- Dunno how much difference this'll make in practice. Suck 'n' see.  bindColumnBuffer :: StmtHandle -> Int -> SqlDataType -> SqlLen -> IO BindBuffer bindColumnBuffer stmt pos dtype size = do   alloca $ \colPtr -> do+  charenc <- readIORef (stmtCharEnc stmt)   rc <- sqlNumResultCols (stmtHdl stmt) colPtr   checkError rc sqlHTypeStmt (castPtr (stmtHdl stmt))   nc <- peek colPtr@@ -656,18 +712,18 @@     then throwOdbc (OdbcException (-1) "01000"       ("Attempted fetch from invalid column number " ++ show pos) [])     else do-      buffer <- createEmptyBuffer (fromIntegral size)+      buffer <- createEmptyBuffer (fromIntegral size) charenc       withForeignPtr (bindBufPtr buffer) $ \bptr -> do       withForeignPtr (bindBufSzPtr buffer) $ \szptr -> do       rc <- sqlBindCol (stmtHdl stmt) (fromIntegral pos) dtype bptr size szptr       checkError rc sqlHTypeStmt (castPtr (stmtHdl stmt))       return buffer -createEmptyBuffer :: SqlLen -> IO BindBuffer-createEmptyBuffer size = do+createEmptyBuffer :: SqlLen -> CharEncoding -> IO BindBuffer+createEmptyBuffer size charenc = do   szfptr <- mallocForeignPtr   bfptr <- mallocForeignPtrBytes (fromIntegral size)-  return (BindBuffer bfptr szfptr size)+  return (BindBuffer bfptr szfptr size charenc)   testForNull :: BindBuffer -> (Ptr Buffer -> SqlLen -> IO a) -> IO (Maybe a)@@ -684,54 +740,52 @@ getStorableFromBuffer buffer =   testForNull buffer (\bptr _ -> peek (castPtr bptr)) -getCAStringFromBuffer :: BindBuffer -> IO (Maybe String)-getCAStringFromBuffer buffer =-  -- FIXME also assume null-termed string?-  testForNull buffer (\ptr len -> peekCAStringLen (castPtr ptr, fromIntegral len))--getCWStringFromBuffer :: BindBuffer -> IO (Maybe String)-getCWStringFromBuffer buffer =-  testForNull buffer (\ptr len -> peekCWStringLen (castPtr ptr, fromIntegral len))--getUTF8StringFromBuffer :: BindBuffer -> IO (Maybe String)-getUTF8StringFromBuffer buffer =-  testForNull buffer (\ptr len ->-    debugStmt ("getUTF8StringFromBuffer: size " ++ show len) >>-    --peekUTF8StringLen (castPtr ptr, fromIntegral len))-    -- assume null-termed string-    peekUTF8String (castPtr ptr))+getStringFromBuffer :: BindBuffer -> IO (Maybe String)+getStringFromBuffer buffer =+  testForNull buffer (\ptr len -> peekEncStringLen (bindBufCharEnc buffer) (castPtr ptr, fromIntegral len))  getUtcTimeFromBuffer :: BindBuffer -> IO (Maybe UTCTime)-getUtcTimeFromBuffer bindbuffer = do-  testForNull bindbuffer $ \buffer _ -> do-  readUtcTimeFromMemory (castPtr buffer)+getUtcTimeFromBuffer bindbuffer =+  testForNull bindbuffer (\b _ -> readUtcTimeFromMemory (castPtr b))   --------------------------------------------------------------------- -- Parameter binding -createBufferForStorable :: Storable a => Maybe a -> IO BindBuffer-createBufferForStorable Nothing =-  let zero :: Int; zero = 0; in createBufferHelper zero (fromIntegral (sizeOf zero)) (sizeOf zero)-createBufferForStorable (Just val) = createBufferHelper val (fromIntegral (sizeOf val)) (sizeOf val)+-----------------------------------+-- First some helper functions...+----------------------------------- -createBufferHelper :: Storable a => a -> SqlLen -> Int -> IO BindBuffer-createBufferHelper val valsize bufsize = do-  -- alloc space for size parameter-  szfptr <- mallocForeignPtr-  withForeignPtr szfptr (\szptr -> poke szptr valsize)-  -- alloc buffer for storable value-  bfptr <- mallocForeignPtr-  withForeignPtr bfptr (\bptr -> poke bptr val)-  return (BindBuffer (castForeignPtr bfptr) szfptr (fromIntegral bufsize))+-- Create a Bind Buffer for a value in the Storable class+-- e.g. Int, Double, Char+mkBindBufferForStorable :: Storable a => Maybe a -> IO BindBuffer+mkBindBufferForStorable mbv =+  case mbv of+    Nothing -> let zero :: Int; zero = 0; in mkBindBufferHelper zero sqlNullData (sizeOf zero)+    Just val -> mkBindBufferHelper val (fromIntegral (sizeOf val)) (sizeOf val)+  where +    mkBindBufferHelper :: Storable a => a -> SqlLen -> Int -> IO BindBuffer+    mkBindBufferHelper val valsize bufsize = do+      bptr <- malloc+      poke bptr val+      mkBindBuffer bptr valsize bufsize EncUTF8 -wrapSizedBuffer :: Ptr a -> SqlLen -> Int -> IO BindBuffer-wrapSizedBuffer valptr valsize bufsize = do+-- Create a Bind Buffer for a chunk of memory (so, anything at all).+-- Given:+--   * a Ptr to a buffer (already allocated and filled)+--   * the size (SqlLen) of the data in the buffer (not necessarily the same as the buffer size)+--   * the size of the buffer+--   * a character encoding for Strings+-- create a BindBuffer object.+-- The buffer is wrapped with a ForeignPtr so it will be freed when the buffer+-- is no longer required.+mkBindBuffer :: Ptr a -> SqlLen -> Int -> CharEncoding -> IO BindBuffer+mkBindBuffer valptr valsize bufsize charenc = do   szfptr <- mallocForeignPtr   withForeignPtr szfptr (\szptr -> poke szptr valsize)   bfptr <- newForeignPtr finalizerFree valptr   let size2 = if valsize > (fromIntegral bufsize) then valsize else (fromIntegral bufsize)-  return (BindBuffer (castForeignPtr bfptr) szfptr size2)+  return (BindBuffer (castForeignPtr bfptr) szfptr size2 charenc)  bindParam ::   StmtHandle@@ -750,49 +804,52 @@   rc <- sqlBindParameter (stmtHdl stmt) (fromIntegral pos) direction ctype sqltype precision scale bptr bufsize valszptr   checkError rc sqlHTypeStmt (castPtr (stmtHdl stmt)) ++------------------------------------------------------+-- Now type-specific functions to bind values.+-- Each of these creates and returns a BindBuffer.+------------------------------------------------------+ bindNull :: StmtHandle -> Int -> SqlParamDirection -> SqlCDataType -> SqlDataType -> IO BindBuffer bindNull stmt pos direction ctype dtype = do   let val :: Maybe Int; val = Nothing-  buffer <- createBufferForStorable val+  buffer <- mkBindBufferForStorable val   bindParam stmt pos direction ctype dtype 0 0 buffer   return buffer -bindParamCStringLen :: StmtHandle -> Int -> SqlParamDirection -> Maybe CStringLen -> Int -> IO BindBuffer-bindParamCStringLen stmt pos direction Nothing bufsize = do+bindParamString :: StmtHandle -> Int -> SqlParamDirection -> Maybe String -> Int -> IO BindBuffer+bindParamString stmt pos direction Nothing bufsize = do+  charenc <- readIORef (stmtCharEnc stmt)   let bufsz = if bufsize < 8 then 8 else (fromIntegral bufsize)   ptr <- mallocBytes bufsz-  buffer <- wrapSizedBuffer ptr (-1) bufsz-  bindParam stmt pos direction sqlCTypeString sqlDTypeString 0 0 buffer+  buffer <- mkBindBuffer ptr sqlNullData bufsz charenc+  -- We have to use sqlDTypeVarchar; sqlDTypeChar doesn't marshal output values (fixed size).+  -- MS Access and SQL Server require buffer size in precision.+  bindParam stmt pos direction sqlCTypeString sqlDTypeVarchar (fromIntegral bufsz) 0 buffer   return buffer-bindParamCStringLen stmt pos direction (Just (cstr, clen)) bufsize = do-  let bufsz = 1 + if clen > bufsize then (fromIntegral clen) else (fromIntegral bufsize)-  mem <- mallocBytes bufsz-  copyBytes mem cstr (fromIntegral clen)-  pokeByteOff mem (fromIntegral clen) (0 :: Word8)-  --buffer <- wrapSizedBuffer mem (fromIntegral clen) bufsz-  buffer <- wrapSizedBuffer mem sqlNullTermedString bufsz-  bindParam stmt pos direction sqlCTypeString sqlDTypeString (fromIntegral clen) 0 buffer+bindParamString stmt pos direction (Just s) bufsize = do+  charenc <- readIORef (stmtCharEnc stmt)+  (mem, clen, bufsz) <- withEncStringLen charenc s makeStringBuffer+  -- Now wrap the malloc'd area wth a ForeignPtr, which should ensure+  -- it is GC'd when no longer used.+  buffer <- mkBindBuffer mem (fromIntegral clen) bufsz charenc+  -- We have to use sqlDTypeVarchar; sqlDTypeChar doesn't marshal output values (fixed size).+  -- MS Access and SQL Server require buffer size in precision.+  bindParam stmt pos direction sqlCTypeString sqlDTypeVarchar (fromIntegral bufsz) 0 buffer   return buffer+  where+    makeStringBuffer :: CStringLen -> IO (CString, Int, Int)+    makeStringBuffer (cstr, clen) = do+      -- The size we pass to bindParam is the max of string-length and buffer-size.+      -- This lets us be lazy and pass 0 as the buffer size in the input-only case.+      let bufsz = 1 + maximum [clen, bufsize]+      mem <- mallocBytes bufsz+      copyBytes mem cstr clen+      pokeByteOff mem clen (0 :: CChar)+      return (mem, clen, bufsz) -bindEncodedString :: StmtHandle -> Int -> SqlParamDirection -> Maybe String -> (String -> ((Ptr a, Int) -> IO BindBuffer) -> IO BindBuffer) -> Int -> IO BindBuffer-bindEncodedString stmt pos direction Nothing withEncoder bufsz =-  --bindNull stmt pos direction sqlCTypeString sqlDTypeString-  bindParamCStringLen stmt pos direction Nothing bufsz-bindEncodedString stmt pos direction (Just s) withEncoder bufsz =-  withEncoder s (\(cs, cl) -> bindParamCStringLen stmt pos direction (Just (castPtr cs, cl)) bufsz) -bindParamUTF8String :: StmtHandle -> Int -> SqlParamDirection -> Maybe String -> Int -> IO BindBuffer-bindParamUTF8String stmt pos direction val sz =-  debugStmt ("bindParamUTF8String: " ++ show val ++ ", size " ++ show sz) >>-  bindEncodedString stmt pos direction val withUTF8StringLen sz--bindParamCAString :: StmtHandle -> Int -> SqlParamDirection -> Maybe String -> Int -> IO BindBuffer-bindParamCAString stmt pos direction val sz =-  bindEncodedString stmt pos direction val withCAStringLen sz--bindParamCWString :: StmtHandle -> Int -> SqlParamDirection -> Maybe String -> Int -> IO BindBuffer-bindParamCWString stmt pos direction val sz =-  bindEncodedString stmt pos direction val withCWStringLen sz+-- Fun with dates+times...  pokeSmallInt :: Ptr a -> Int -> SqlSmallInt -> IO () pokeSmallInt buffer offset val = pokeByteOff buffer offset val@@ -828,7 +885,7 @@ makeUtcTimeBuffer utc = do   mem <- mallocBytes #{size TIMESTAMP_STRUCT}   writeUTCTimeToMemory (castPtr mem) utc-  wrapSizedBuffer mem #{size TIMESTAMP_STRUCT} (-1)+  mkBindBuffer mem #{size TIMESTAMP_STRUCT} #{size TIMESTAMP_STRUCT} EncUTF8  -- Marshal via String, for MS SQL Server. -- We have to drop the last 6 chars (nnn+nn) from the ISO datetime,@@ -842,7 +899,7 @@   withCStringLen s $ \(cstr, clen) -> do     copyBytes mem cstr (fromIntegral clen)     pokeByteOff mem (fromIntegral clen) (0 :: Word8)-    wrapSizedBuffer mem (fromIntegral clen) buffersize+    mkBindBuffer mem (fromIntegral clen) buffersize EncUTF8  bindParamUtcTime :: StmtHandle -> Int -> SqlParamDirection -> Maybe UTCTime -> IO BindBuffer bindParamUtcTime stmt pos direction Nothing = do@@ -864,7 +921,8 @@       -- For TimeStamp:       --   Size/Length should be 16 bytes.       --   Precision should be 8 (or 16?).-      --   Scale is the number of digits in the fraction component (SQL Server only allows 0-3).+      --   Scale is the number of digits in the fraction component+      --     (normally 9; SQL Server only allows 0-3).       buffer <- makeUtcTimeBuffer utc       bindParam stmt pos direction sqlCTypeTimestamp sqlDTypeTimestamp #{size TIMESTAMP_STRUCT} 9 buffer       return buffer@@ -880,6 +938,7 @@ --sizeOfMaybe v@Nothing = sizeOfMaybe (asTypeOf (Just undefined) v) --sizeOfMaybe (Just v) = sizeOf v + newtype OutParam a = OutParam a newtype InOutParam a = InOutParam a @@ -931,9 +990,10 @@           cdbl :: CDouble; cdbl = 0  instance OdbcBindBuffer (Maybe String) where-  bindColBuffer stmt pos size val = bindColumnBuffer stmt pos sqlDTypeString (fromIntegral size)-  getFromBuffer buffer = getUTF8StringFromBuffer buffer-  getData stmt pos = getDataUTF8String stmt pos+  -- We have to use sqlDTypeChar; sqlDTypeVarchar causes error "Program type out of range".+  bindColBuffer stmt pos size val = bindColumnBuffer stmt pos sqlDTypeChar (fromIntegral size)+  getFromBuffer buffer = getStringFromBuffer buffer+  getData stmt pos = getDataString stmt pos  instance OdbcBindBuffer (Maybe UTCTime) where   bindColBuffer stmt pos size val = bindColumnBuffer stmt pos sqlDTypeTimestamp #{size TIMESTAMP_STRUCT}@@ -952,7 +1012,7 @@     -> IO BindBuffer  -- ^ returns a 'BindBuffer' object  bindParamStorable stmt pos val dir ctype dtype precn scale = do-  buffer <- createBufferForStorable val+  buffer <- mkBindBufferForStorable val   bindParam stmt pos dir ctype dtype precn scale buffer   return buffer @@ -982,15 +1042,15 @@  instance OdbcBindParam (Maybe String) where   bindParamBuffer stmt pos val sz =-    bindParamUTF8String stmt pos sqlParamInput val 0+    bindParamString stmt pos sqlParamInput val 0  instance OdbcBindParam (OutParam (Maybe String)) where   bindParamBuffer stmt pos (OutParam val) sz =-    bindParamUTF8String stmt pos sqlParamOutput val sz+    bindParamString stmt pos sqlParamOutput val sz  instance OdbcBindParam (InOutParam (Maybe String)) where   bindParamBuffer stmt pos (InOutParam val) sz =-    bindParamUTF8String stmt pos sqlParamInputOutput val sz+    bindParamString stmt pos sqlParamInputOutput val sz  instance OdbcBindParam (Maybe UTCTime) where   bindParamBuffer stmt pos val _ =@@ -1022,9 +1082,9 @@   SqlHandleType  -- ^ enum: which handle type is the next parameter?   -> Handle  -- ^ generic handle ptr   -> SqlSmallInt  -- ^ row (or message) number-  -> MyCString  -- ^ OUT: state+  -> CString  -- ^ OUT: state   -> Ptr SqlInteger  -- ^ OUT: error number-  -> MyCString  -- ^ OUT: error message+  -> CString  -- ^ OUT: error message   -> SqlSmallInt  -- ^ IN: message buffer size   -> Ptr SqlSmallInt  -- ^ OUT: message length   -> IO SqlReturn@@ -1033,9 +1093,9 @@ foreign import #{CALLCONV} unsafe "sql.h SQLDriverConnect" sqlDriverConnect ::   ConnHdl   -> WindowHandle  -- ^ just pass nullPtr-  -> MyCString  -- ^ connection string+  -> CString  -- ^ connection string   -> SqlSmallInt  -- ^ connection string size-  -> MyCString  -- ^ OUT: buffer for normalised connection string+  -> CString  -- ^ OUT: buffer for normalised connection string   -> SqlSmallInt  -- ^ buffer size   -> Ptr SqlSmallInt  -- ^ OUT: length of returned string   -> SqlUSmallInt  -- ^ enum: should driver prompt user for missing info?@@ -1063,7 +1123,7 @@  -- SQLRETURN SQL_API SQLPrepare(SQLHSTMT,SQLCHAR*,SQLINTEGER); foreign import #{CALLCONV} unsafe "sql.h SQLPrepare" sqlPrepare ::-  StmtHdl -> MyCString -> SqlInteger -> IO SqlReturn+  StmtHdl -> CString -> SqlInteger -> IO SqlReturn  -- SQLRETURN SQL_API SQLBindParameter(SQLHSTMT,SQLUSMALLINT,SQLSMALLINT,SQLSMALLINT,SQLSMALLINT,SQLULEN,SQLSMALLINT,SQLPOINTER,SQLLEN,SQLLEN*); foreign import #{CALLCONV} unsafe "sql.h SQLBindParameter" sqlBindParameter ::@@ -1095,7 +1155,7 @@ foreign import #{CALLCONV} unsafe "sql.h SQLDescribeCol" sqlDescribeCol ::   StmtHdl   -> SqlUSmallInt  -- ^ position, 1-indexed-  -> MyCString  -- ^ buffer for column name+  -> CString  -- ^ buffer for column name   -> SqlSmallInt  -- ^ size of column name buffer   -> Ptr SqlSmallInt  -- ^ size of column name output string   -> Ptr SqlDataType  -- ^ SQL data type: string, int, long, date, etc@@ -1153,9 +1213,9 @@ -- SQLRETURN SQL_API SQLNativeSql(SQLHDBC,SQLCHAR*,SQLINTEGER,SQLCHAR*,SQLINTEGER,SQLINTEGER*); foreign import #{CALLCONV} unsafe "sql.h SQLNativeSql" sqlNativeSql ::   ConnHdl-  -> MyCString  -- ^ sql text in+  -> CString  -- ^ sql text in   -> SqlInteger  -- ^ size of sql text-  -> MyCString  -- ^ buffer for output text+  -> CString  -- ^ buffer for output text   -> SqlInteger  -- ^ size of output buffer   -> Ptr SqlInteger  -- ^ size of text in output buffer   -> IO SqlReturn

@@ -18,6 +18,7 @@ > import Control.Monad (liftM, when)
 > import Control.Monad.Trans (liftIO)
 > import Data.Char
+> import Data.Time
 > import Test.MiniUnit
 
 
@@ -41,6 +42,9 @@ 
 > runFixture :: DBLiteralValue a => a -> DBM mark Session ()
 > runFixture fns = do
+>   setStringEnc EncUTF8
+>   --dbmsname <- inquire InfoDbmsName
+>   --when (dbmsname == "postgres") (execDDL_ "set client_encoding = 'UTF8'")
 >   makeFixture execDrop execDDL_
 >   runTestTT "ODBC tests" (map (runOneTest fns) testList)
 >   destroyFixture execDDL_
@@ -52,7 +56,7 @@ >   makeFixture execDrop execDDL_
 >   beginTransaction ReadCommitted
 >   runTestTT "ODBC performance tests" (map (flip catchDB reportRethrow)
->     -- The PostgreSQL ODBC driver has genetric query optimisation disabled
+>     -- The PostgreSQL ODBC driver has genetic query optimisation disabled
 >     -- by default. This makes it really struggle with the query we use
 >     -- for performance testing - the memory used by the server process
 >     -- goes through the roof.
@@ -106,20 +110,26 @@ > selectBindDate _ = actionBindDate
 >   (prefetch 1 sqlBindDate (map bindP expectBindDate))
 
-> selectBindBoundaryDates _ = actionBindBoundaryDatesLocal
->   (prefetch 1 sqlBindBoundaryDates (map bindP expectBoundaryDatesLocal))
+Access doesn't seem to like bind variables with union; get:
+  22018 39: [Microsoft][ODBC Microsoft Access Driver]Invalid character value for cast specification on column number 1
+So we have our own local variation on the boundary dates test,
+where we select one row with three columns, rather than three rows with one column.
 
-> expectBoundaryDatesLocal =
->   -- 1753 seems to be about the earliest year MS SQL Server supports.
->   [ int64ToUTCTime   17530101000000
->   , int64ToUTCTime   20010102000000
->   , int64ToUTCTime   20010103000000
->   , int64ToUTCTime   99991231000000
->   ]
+> sqlBindBoundaryDatesLocal = "select ?, ?, ? from tdual"
+> iterBindBoundaryDatesLocal :: (Monad m) => UTCTime -> UTCTime -> UTCTime -> IterAct m [(UTCTime, UTCTime, UTCTime)]
+> iterBindBoundaryDatesLocal d1 d2 d3 acc = result $ (d1,d2,d3):acc
+> -- 1753 seems to be about the earliest year MS SQL Server supports.
+> expectBoundaryDatesLocal = [(int64ToUTCTime 17530101000000, int64ToUTCTime 19990102000000, int64ToUTCTime 99991231000000)]
 > actionBindBoundaryDatesLocal stmt = do
 >   withTransaction Serialisable $ do
->     actual <- doQuery stmt iterBindDate []
->     assertEqual sqlBindBoundaryDates expectBoundaryDatesLocal actual
+>     actual <- doQuery stmt iterBindBoundaryDatesLocal []
+>     assertEqual sqlBindBoundaryDatesLocal expectBoundaryDatesLocal actual
+> selectBindBoundaryDates _ = actionBindBoundaryDatesLocal
+>   (prefetch 1 sqlBindBoundaryDatesLocal
+>     [ bindP (int64ToUTCTime 17530101000000)
+>     , bindP (int64ToUTCTime 19990102000000)
+>     , bindP (int64ToUTCTime 99991231000000)
+>     ])
 
 
 > selectRebindStmt _ = actionRebind (prepareQuery (sql sqlRebind))
@@ -174,7 +184,7 @@ 
 
 > selectMultiResultSet _ = do
->   dbmsname <- liftM (map toLower) (inquire InfoDbmsName)
+>   dbmsname <- inquire InfoDbmsName
 >   when (dbmsname == "microsoft sql server") $ do
 >     execDrop dropFixtureMultiResultSet3
 >     execDrop dropFixtureMultiResultSet2
@@ -230,7 +240,7 @@ >     (x, s) <- doQuery qry iter undefined
 >     execDrop dropFixtureBindOutput
 >     assertEqual "bindOutput: int " 2468 x
->     assertEqual "bindOutput: string " "output message" s
+>     assertEqual "bindOutput: string " "output message xxx" s
 >   iter :: (Monad m) => Int -> String -> IterAct m (Int, String)
 >   iter i s _ = return (Left (i, s))
 

@@ -64,67 +64,57 @@ >   freeConn conn
 >   freeEnv env
 
+> execSql conn sql = do
+>   stmt <- allocStmt conn
+>   prepareStmt stmt sql
+>   executeStmt stmt
+>   freeStmt stmt
+
 > createConn connstr = do
 >   env <- allocEnv
 >   setOdbcVer env
 >   conn <- allocConn env
 >   connstr <- connect conn connstr
->   dbms <- getInfoDbmsName conn
->   return (env, conn { connDbms = map toLower dbms } )
+>   setConnEncoding conn EncUTF8
+>   dbmsname <- liftM (map toLower) (getInfoDbmsName conn)
+>   when (dbmsname == "postgresql") (execSql conn "set client_encoding = 'UTF8'")
+>   return (env, conn { connDbms = map toLower dbmsname } )
 
 > closeConn (env, conn) = do
 >   disconnect conn
 >   freeConn conn
 >   freeEnv env
 
-
 > createDual conn = do
->   stmt <- allocStmt conn
->   prepareStmt stmt "create table tdual (dummy varchar(1) primary key)"
->   executeStmt stmt
->   prepareStmt stmt "insert into tdual values ('X')"
->   executeStmt stmt
->   freeStmt stmt
-
-> dropDual conn = do
->   stmt <- allocStmt conn
->   prepareStmt stmt "drop table tdual"
->   executeStmt stmt
->   freeStmt stmt
+>   execSql conn "create table tdual (dummy varchar(1) primary key)"
+>   execSql conn "insert into tdual values ('X')"
+>   commit conn
 
+> dropDual conn = execSql conn "drop table tdual"
 
-> testCreateStmt conn = do
->   stmt <- allocStmt conn
->   prepareStmt stmt "select 'x' from tdual"
->   executeStmt stmt
->   freeStmt stmt
+> testCreateStmt conn = execSql conn "select 'x' from tdual"
 
 
-> testIsolationLevel conn = do
->   -- For PostgreSQL this fails with:
->   -- 206 HY009 Illegal parameter value for SQL_TXN_ISOLATION
->   --setTxnIsolation conn sqlTxnReadUncommitted
->   setTxnIsolation conn sqlTxnReadCommitted  -- This is OK
->   -- For PostgreSQL this fails with:
->   -- 206 HY009 Illegal parameter value for SQL_TXN_ISOLATION
->   --setTxnIsolation conn sqlTxnRepeatableRead
->   setTxnIsolation conn sqlTxnSerializable  -- This is OK
-
+> testIsolationLevelReadUncommitted conn = setTxnIsolation conn sqlTxnReadUncommitted
+> testIsolationLevelReadCommitted conn = setTxnIsolation conn sqlTxnReadCommitted
+> testIsolationLevelRepeatableRead conn = setTxnIsolation conn sqlTxnRepeatableRead
+> testIsolationLevelSerializable conn = setTxnIsolation conn sqlTxnSerializable
 
 Uses getData, rather than a buffer.
 
 > testFetchString conn = do
 >   stmt <- allocStmt conn
->   let string1 = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FFFF]
->   let string2 = "xyz" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FFFF]
+>   -- Oracle doesn't like codepoints > 0x10FF40; perhaps this is special in Unicode?
+>   let string1 = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FF40]
+>   let string2 = "xyz" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FF40]
 >   prepareStmt stmt ("select '" ++ string1
 >     ++ "' from tdual union select '" ++ string2 ++ "' from tdual order by 1")
 >   executeStmt stmt
 >   more <- fetch stmt
->   s <- getDataUTF8String stmt 1
+>   s <- getDataString stmt 1
 >   assertEqual "testFetchString" (Just string1) s
 >   more <- fetch stmt
->   s <- getDataUTF8String stmt 1
+>   s <- getDataString stmt 1
 >   assertEqual "testFetchString" (Just string2) s
 >   more <- fetch stmt
 >   assertBool "testFetchString: EOD" (not more)
@@ -132,17 +122,18 @@ 
 > testFetchStringWithBuffer conn = do
 >   stmt <- allocStmt conn
->   let string1 = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FFFF]
->   let string2 = "xyz" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FFFF]
+>   -- Oracle doesn't like codepoints > 0x10FF40; perhaps this is special in Unicode?
+>   let string1 = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FF40]
+>   let string2 = "xyz" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FF40]
 >   prepareStmt stmt ("select '" ++ string1
 >     ++ "' from tdual union select '" ++ string2 ++ "' from tdual order by 1")
 >   executeStmt stmt
 >   buffer <- bindColBuffer stmt 1 100 (Just "")
 >   more <- fetch stmt
->   s <- getUTF8StringFromBuffer buffer
+>   s <- getStringFromBuffer buffer
 >   assertEqual "testFetchStringWithBuffer" (Just string1) s
 >   more <- fetch stmt
->   s <- getUTF8StringFromBuffer buffer
+>   s <- getStringFromBuffer buffer
 >   assertEqual "testFetchStringWithBuffer" (Just string2) s
 >   more <- fetch stmt
 >   assertBool "testFetchStringWithBuffer: EOD" (not more)
@@ -153,8 +144,10 @@ >   prepareStmt stmt "select 101 from tdual"
 >   executeStmt stmt
 >   more <- fetch stmt
+>   putStrLn "testFetchInt: call getData"
 >   s <- getData stmt 1
 >   let expect :: Int; expect = 101
+>   putStrLn "testFetchInt: assert"
 >   assertEqual "testFetchInt" (Just expect) s
 >   more <- fetch stmt
 >   assertBool "testFetchInt: EOD" (not more)
@@ -177,10 +170,10 @@ >   stmt <- allocStmt conn
 >   prepareStmt stmt "select 123.456789 from tdual"
 >   executeStmt stmt
->   --buffer <- bindColBuffer stmt 1 sqlDTypeDouble 16
+>   buffer <- bindColBuffer stmt 1 0 (Just (0::Double))
 >   more <- fetch stmt
->   --s <- getFromBuffer buffer
->   s <- getData stmt 1
+>   s <- getFromBuffer buffer
+>   --s <- getData stmt 1
 >   let expect :: Double; expect = 123.456789
 >   assertEqual "testFetchDouble" (Just expect) s
 >   more <- fetch stmt
@@ -190,6 +183,7 @@ > testFetchDatetime conn = do
 >   stmt <- allocStmt conn
 >   dbmsname <- liftM (map toLower) (getInfoDbmsName conn)
+>   --putStrLn ("testFetchDatetime: dbmsname = " ++ dbmsname)
 >   flip finally (freeStmt stmt) ( do
 >     -- There is no common SQL standard for datetime literal text.
 >     -- Well, there is (timestamp), but MS SQL Server doesn't support it. Pah.
@@ -202,12 +196,25 @@ >     --
 >     -- PostgreSQL doesn't appear to support the {fn ...} escape sequences;
 >     -- the text seems to be passed through unchanged (according to SQLNativeSql, anyway).
+>     --getNativeSql conn "select {fn CONVERT('1916-10-01 02:25:21', SQL_TIMESTAMP)}, {fn CONVERT('2005-10-01 00:00:00', SQL_TIMESTAMP)} from tdual"
+>     --
 >     -- THe MS SQL Server ODBC driver's SQLNativeSql also returns the text unchanged,
 >     -- but it doesn't seem to cause any grief on the server.
->     --getNativeSql conn "select {fn CONVERT('1916-10-01 02:25:21', SQL_TIMESTAMP)}, {fn CONVERT('2005-10-01 00:00:00', SQL_TIMESTAMP)} from tdual" >>= putStrLn
+>     --getNativeSql conn "select {fn CONVERT('1916-10-01 02:25:21', SQL_DATETIME)}, {fn CONVERT('2005-10-01 00:00:00', SQL_DATETIME)}"
+>     --
+>     -- Access doesn't seem to like the {fn ...} escape sequences either,
+>     -- so we have to use VBA function CDate to convert text to datetime.
+>     --getNativeSql conn "select cdate('1916-10-01 02:25:21'), cdate('2005-10-01 00:00:00')"
+>     --  >>= putStrLn
+>     --getNativeSql conn "select {fn convert('1916-10-01 02:25:21', SQL_DATETIME)}"
+>     --  >>= putStrLn
 >     case dbmsname of
 >       "postgresql" -> 
->         prepareStmt stmt "select cast ('1916-10-01 02:25:21' as timestamp), cast ('2005-10-01 00:00:00' as timestamp) from tdual"
+>         prepareStmt stmt "select cast ('1916-10-01 02:25:21' as timestamp), cast ('2005-10-01 00:00:00' as timestamp)"
+>       -- MS Access doesn't like SQL_TIMESTAMP datatype, but accepts SQL_DATETIME.
+>       "access" ->
+>         prepareStmt stmt "select cdate('1916-10-01 02:25:21'), cdate('2005-10-01 00:00:00')"
+>         --prepareStmt stmt "select {fn CONVERT('1916-10-01 02:25:21', SQL_DATETIME)}, {fn CONVERT('2005-10-01 00:00:00', SQL_DATETIME)}"
 >       otherwise ->
 >         prepareStmt stmt "select {fn CONVERT('1916-10-01 02:25:21', SQL_TIMESTAMP)}, {fn CONVERT('2005-10-01 00:00:00', SQL_TIMESTAMP)} from tdual"
 >     executeStmt stmt
@@ -239,6 +246,31 @@ >   assertBool "testFetchInt: EOD" (not more)
 >   freeStmt stmt
 
+> testBindDouble conn = do
+>   stmt <- allocStmt conn
+>   prepareStmt stmt "select ? from tdual"
+>   -- null value first
+>   bindParamBuffer stmt 1 (Nothing :: Maybe Double) 0
+>   executeStmt stmt
+>   buffer <- bindColBuffer stmt 1 0 (Just (0::Double))
+>   more <- fetch stmt
+>   s <- getFromBuffer buffer
+>   assertEqual "testBindDouble" (Nothing :: Maybe Double) s
+>   -- non-null value
+>   closeCursor stmt
+>   bindParamBuffer stmt 1 (Just 101.101 :: Maybe Double) 0
+>   executeStmt stmt
+>   buffer <- bindColBuffer stmt 1 0 (Just (0::Double))
+>   more <- fetch stmt
+>   s <- getFromBuffer buffer
+>   let d :: Double; d = 101.101;
+>   assertEqual "testBindDouble" (Just d) s
+>   --
+>   more <- fetch stmt
+>   assertBool "testBindDouble: EOD" (not more)
+>   --
+>   freeStmt stmt
+
 > testBindString conn = do
 >   stmt <- allocStmt conn
 >   prepareStmt stmt "select ? from tdual"
@@ -247,7 +279,7 @@ >   executeStmt stmt
 >   buffer <- bindColBuffer stmt 1 1000 (Just expect)
 >   more <- fetch stmt
->   s <- getUTF8StringFromBuffer buffer
+>   s <- getStringFromBuffer buffer
 >   assertEqual "testBindString" (Just expect) s
 >   more <- fetch stmt
 >   assertBool "testBindString: EOD" (not more)
@@ -257,13 +289,16 @@ 
 > testBindStringUTF8 conn = do
 >   stmt <- allocStmt conn
+>   setStmtEncoding stmt EncUTF8  -- just in case UTF8 is not default
 >   prepareStmt stmt "select ? from tdual"
->   let expect = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FFFF]
+>   -- Oracle doesn't like codepoints > 0x10FF40; perhaps this is special in Unicode?
+>   --let expect = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FFFF]
+>   let expect = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FF40]
 >   bindParamBuffer stmt 1 (Just expect) 0
 >   executeStmt stmt
 >   buffer <- bindColBuffer stmt 1 1000 (Just expect)
 >   more <- fetch stmt
->   s <- getUTF8StringFromBuffer buffer
+>   s <- getStringFromBuffer buffer
 >   assertEqual "testBindStringUTF8 (PostgreSQL fails with Unicode driver, succeeds with ANSI)" (Just expect) s
 >   more <- fetch stmt
 >   assertBool "testBindStringUTF8: EOD" (not more)
@@ -318,7 +353,7 @@ >   executeStmt stmt
 >   buffer <- bindColBuffer stmt 1 100 (Just "")
 >   more <- fetch stmt
->   s <- getUTF8StringFromBuffer buffer
+>   s <- getStringFromBuffer buffer
 >   assertEqual "testRebind1" (Just expect) s
 >   more <- fetch stmt
 >   assertBool "testRebind1: EOD" (not more)
@@ -330,7 +365,7 @@ >   executeStmt stmt
 >   buffer <- bindColBuffer stmt 1 100 (Just "")
 >   more <- fetch stmt
->   s <- getUTF8StringFromBuffer buffer
+>   s <- getStringFromBuffer buffer
 >   assertEqual "testRebind2" (Just expect) s
 >   more <- fetch stmt
 >   assertBool "testRebind2: EOD" (not more)
@@ -345,18 +380,21 @@ 
 > testUTF8 conn = do
 >   stmt <- allocStmt conn
+>   setStmtEncoding stmt EncUTF8  -- just in case UTF8 is not default
 >   prepareStmt stmt "drop table t_utf8"
 >   ignoreError (executeStmt stmt)
 >   prepareStmt stmt "create table t_utf8(s varchar(50))"
 >   executeStmt stmt
->   let expect = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FFFF]
+>   --let expect = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FFFF]
+>   -- Oracle doesn't like codepoints > 0x10FF40; perhaps this is special in Unicode?
+>   let expect = "abc" ++ map chr [0x000080, 0x0007FF, 0x00FFFF, 0x10FF40]
 >   prepareStmt stmt ("insert into t_utf8 values ( '" ++ expect ++ "' )")
 >   executeStmt stmt
 >   prepareStmt stmt "select s from t_utf8"
 >   executeStmt stmt
 >   buffer <- bindColBuffer stmt 1 100 (Just expect)
 >   more <- fetch stmt
->   s <- getUTF8StringFromBuffer buffer
+>   s <- getStringFromBuffer buffer
 >   assertEqual "testUTF8" (Just expect) s
 >   freeStmt stmt
 
@@ -389,9 +427,9 @@ >   buffer1 <- bindColBuffer stmt 1 100 (Just "")
 >   buffer2 <- bindColBuffer stmt 2 100 (Just "")
 >   more <- fetch stmt
->   s1 <- getUTF8StringFromBuffer buffer1
+>   s1 <- getStringFromBuffer buffer1
 >   assertEqual "testMultiResultSet1" (Just "1") s1
->   s2 <- getUTF8StringFromBuffer buffer2
+>   s2 <- getStringFromBuffer buffer2
 >   assertEqual "testMultiResultSet2" (Just "2") s2
 >   more <- fetch stmt
 >   assertBool "testMultiResultSet1: EOD" (not more)
@@ -402,9 +440,9 @@ >   buffer1 <- bindColBuffer stmt 1 100 (Just "")
 >   buffer2 <- bindColBuffer stmt 2 100 (Just "")
 >   more <- fetch stmt
->   s1 <- getUTF8StringFromBuffer buffer1
+>   s1 <- getStringFromBuffer buffer1
 >   assertEqual "testMultiResultSet3" (Just "3") s1
->   s2 <- getUTF8StringFromBuffer buffer2
+>   s2 <- getStringFromBuffer buffer2
 >   assertEqual "testMultiResultSet4" (Just "4") s2
 >   more <- fetch stmt
 >   assertBool "testMultiResultSet3: EOD" (not more)
@@ -450,19 +488,21 @@ >   let input1 :: Int; input1 = 1234
 >   let input2 = "message"
 >   buffer1 <- bindParamBuffer stmt 1 (InOutParam (Just input1)) 0
->   buffer2 <- bindParamBuffer stmt 2 (InOutParam (Just input2)) 200
+>   -- max size for string out parameter is 8000 - SQL Server errors on anything >8000.
+>   -- bindParamString adds 1 to the size, so we can pass 7999 max.
+>   buffer2 <- bindParamBuffer stmt 2 (InOutParam (Just input2)) 7999
 >   executeStmt stmt
 >   --
 >   i <- getFromBuffer buffer1
 >   assertEqual "testBindOutput" (Just (2*input1)) i
->   s <- getUTF8StringFromBuffer buffer2
+>   s <- getStringFromBuffer buffer2
 >   assertEqual "testBindOutput" (Just "output message xxx") s
 >   --more <- fetch stmt  -- This will cause error:
 >   --
 >   --more <- moreResults stmt
 >   --assertBool "testBindOutput: more result-sets" (not more)
 >   --
->   prepareStmt stmt dropFixtureMultiResultSet
+>   prepareStmt stmt dropFixtureBindOutput
 >   executeStmt stmt
 >   freeStmt stmt
 
@@ -477,30 +517,31 @@ 
 > testlist =
 >   testCreateStmt :
->   testIsolationLevel :
+>   testIsolationLevelReadUncommitted :
+>   testIsolationLevelReadCommitted :
+>   testIsolationLevelRepeatableRead :
+>   testIsolationLevelSerializable :
 >   testFetchString :
->   testFetchStringWithBuffer :
 >   testFetchInt :
+>   testFetchStringWithBuffer :
 >   testFetchIntWithBuffer :
 >   testFetchDouble :
 >   testFetchDatetime :
 >   testBindInt :
+>   testBindDouble :
 >   testBindString :
 >   testBindStringUTF8 :
 >   testBindUTCTime :
 >   testBindUTCTimeBoundary :
 >   testUTF8 :
 >   testRebind :
->   --testDbmsName :
 >   testMultiResultSet :
 >   testBindOutput :
+>   --testDbmsName :
 >   []
 
-> testlist2 =
->   testBindOutput :
->   []
 
-> mkTestlist conn testlist = map (\testcase -> printIgnoreError (testcase conn)) testlist
+> mkTestlist conn testlist = map (\testcase -> printPropagateError (testcase conn)) testlist
 
 > parseArgs :: [String] -> IO String
 > parseArgs args = do

@@ -19,7 +19,8 @@ >   , prepareStmt, preparePrefetch
 >   , prepareQuery, prepareLargeQuery, prepareCommand
 >   , sql, sqlbind, prefetch, cmdbind
->   , bindType
+>   , bindType, DBAPI.byteaEsc, DBAPI.byteaUnesc
+>   , DBAPI.UUID, DBAPI.string2uuid, DBAPI.uuid2string
 >   , module Database.Enumerator
 >   )
 > where
@@ -36,6 +37,7 @@ > import Data.Int
 > import Data.List
 > import Data.Time
+> import Data.Word
 > import System.Time
 
 > {-# DEPRECATED prepareStmt "Use prepareQuery or prepareCommand instead" #-}
@@ -352,6 +354,12 @@ > instance DBBind (Maybe Double) Session PreparedStmtObj BindObj where
 >   bindP = makeBindAction
 
+> instance DBBind (Maybe [Word8]) Session PreparedStmtObj BindObj where
+>   bindP = makeBindAction
+
+> instance DBBind (Maybe DBAPI.UUID) Session PreparedStmtObj BindObj where
+>   bindP = makeBindAction
+
 > instance DBBind (Maybe a) Session PreparedStmtObj BindObj
 >     => DBBind a Session PreparedStmtObj BindObj where
 >   bindP x = bindP (Just x)
@@ -611,6 +619,14 @@ > instance DBType (Maybe Int64) Query ColumnBuffer where
 >   allocBufferFor _ q n = allocBuffer q n
 >   fetchCol = bufferToAny DBAPI.colValInt64
+
+> instance DBType (Maybe [Word8]) Query ColumnBuffer where
+>   allocBufferFor _ q n = allocBuffer q n
+>   fetchCol = bufferToAny DBAPI.colValBytea
+
+> instance DBType (Maybe DBAPI.UUID) Query ColumnBuffer where
+>   allocBufferFor _ q n = allocBuffer q n
+>   fetchCol = bufferToAny DBAPI.colValUUID
 
 |This single polymorphic instance replaces all of the type-specific non-Maybe instances
 e.g. String, Int, Double, etc.

@@ -18,8 +18,10 @@ 
 > import Prelude hiding (catch)
 > import Database.Util
+> import Control.Applicative
 > import Control.Monad
 > import Control.Exception.Extensible
+> import Data.Char
 > import Data.Dynamic
 > import Data.Int
 > import Data.Time
@@ -29,6 +31,7 @@ > import Foreign.Ptr
 > import System.IO
 > import System.Time
+> import Text.Printf
 
 
 > data DBHandleStruct = PGconn
@@ -191,7 +194,7 @@ >  = [0..] :: [ExecStatusType]
 
 > (textResultSet:binaryResultSet:_) = [0,1] :: [CInt]
-> (textParameters:__binaryParameters:_) = [0,1] :: [CInt]
+> (textParameters:binaryParameters:_) = [0,1] :: [CInt]
 
 > foreign import ccall "libpq-fe.h PQresultErrorMessage" fPQresultErrorMessage
 >   :: ResultSetHandle -> IO CString
@@ -343,6 +346,7 @@ 
 Types we'll map:
   16 bool
+  17 bytea
   18 char
   25 text
   21 int2
@@ -353,7 +357,10 @@ 1114 timestamp
 1184 timestamptz
 1700 numeric
+2950 uuid
 
+We are marshalling everything to and from Strings,
+so internal representations are irrelevant.
 
 For ints and doubles/floats, we need to check what size they are
 and choose the appropriate oid.
@@ -366,8 +373,41 @@ timestamp (sans time zone) = oid 1114  (8 bytes)
 timestamptz (with time zone) = oid 1184  (8 bytes)
 
+UUIDs are 128-bit values, with the pattern 8-4-4-4-12 e.g.
+  a0eebc99-9c0b-4ef8-bb6d-6bb9bd380a11
+Apparently Postgres will take any old crap as input
+i.e. surrounding braces optional, hyphens optional and anywhere.
+We'll take a sequence of 32 hex digits, interspersed with
+anything that's not a hex digit (we just strip them).
+
+We should have a newtype for UUID:
+
+> newtype UUID = UUID (Word64, Word64)
+>   deriving (Eq, Ord)
+
+> instance Show UUID where
+>   show (UUID (w1, w2)) = printf "UUID (0x%016x, 0x%016x)" w1 w2
+
+> uuid2string :: UUID -> String
+> uuid2string (UUID (w1, w2)) =
+>   tail (sub 0 8 ++ sub 8 4 ++ sub 12 4 ++ sub 16 4 ++ sub 20 12)
+>   where
+>     g = printf "%016x%016x" w1 w2
+>     sub i j = "-" ++ take j (drop i g)
+
+> string2uuid :: String -> UUID
+> string2uuid s =
+>   if length stripped /= 32
+>   then error "string2uuid: malformed UUID - not 32 digits"
+>   else UUID (read w1, read w2)
+>   where
+>     stripped = filter isHexDigit s
+>     w1 = "0x" ++ take 16 stripped
+>     w2 = "0x" ++ drop 16 stripped
+
+
 > class PGType a where
->   pgTypeFormat :: a -> Format  -- ^ 1 == binary (default), 0 == text
+>   pgTypeFormat :: a -> Format  -- ^ 0 == text, 1 == binary
 >   pgTypeOid :: a -> Oid
 >   pgNewValue :: a -> IO (Ptr Word8)
 >   pgPeek :: Ptr Word8 -> IO a
@@ -408,7 +448,7 @@ > instance PGType String where
 >   pgTypeOid _ = 25
 >   pgNewValue s = newUTF8String s >>= return . castPtr
->   pgPeek p = peekUTF8String (castPtr p) >>= return
+>   pgPeek p = peekUTF8String (castPtr p)
 >   pgSize s = lengthUTF8 s
 
 > instance PGType Bool where
@@ -418,6 +458,55 @@ >     where readBool s = if s == "t" then True else False
 >   pgSize _ = sizeOf 'a'
 
+> byteaUnesc :: [Word8] -> [Word8]
+> byteaUnesc [] = []
+> byteaUnesc (s:rest) = 
+>   if fromIntegral s == ord '\\'
+>     then let (w8, rest') = parseEsc rest in w8 : byteaUnesc rest'
+>     else s : byteaUnesc rest
+>   where
+>     parseEsc :: [Word8] -> (Word8, [Word8])
+>     parseEsc (a:rest)
+>       | a == fromIntegral (ord '\'') = (a, rest)
+>       | a == fromIntegral (ord '\\') = (a, rest)
+>     parseEsc (a:b:c:rest) = (fromIntegral ((f a * 8 + f b) * 8 + f c), rest)
+>       where f i = fromIntegral i - ord '0'
+>     parseEsc s = error ("byteaUnesc: incomplete escape sequence: " ++ map (toEnum . fromIntegral) s)
+
+> word8AsOctet :: Word8 -> [Word8]
+> word8AsOctet w = fromIntegral (ord '\\') : plus0 a : plus0 b : plus0 c : []
+>   where
+>     plus0 x = x + fromIntegral (ord '0')
+>     a = shiftR (w .&. 192) 6  -- 128 + 64
+>     b = shiftR (w .&. 56) 3  -- 32 + 16 + 8
+>     c = w .&. 7  -- 4 + 2 + 1
+
+> byteaEsc :: [Word8] -> [Word8]
+> byteaEsc (c:rest)
+>   | c == backslash = backslash : backslash : byteaEsc rest
+>   | c == quote = backslash : quote : byteaEsc rest
+>   | c >= 0 && c <= 31 = word8AsOctet c ++ byteaEsc rest
+>   | c >= 127 && c <= 255 = word8AsOctet c ++ byteaEsc rest
+>   | otherwise = c : byteaEsc rest
+>   where
+>     backslash = fromIntegral (ord '\\')
+>     quote = fromIntegral (ord '\'')
+> byteaEsc [] = []
+
+> instance PGType [Word8] where
+>   pgTypeOid _ = 17
+>   pgTypeFormat _ = binaryParameters
+>   pgNewValue v = newArray0 0 v
+>   -- byteaUnesc because the result is in bytea escaped format for some reason
+>   pgPeek p = byteaUnesc <$> peekArray0 0 p
+>   pgSize v = length v
+
+> instance PGType UUID where
+>   pgTypeOid _ = 2950
+>   pgNewValue v = pgNewValue (uuid2string v)
+>   pgPeek p = pgPeek p >>= return . string2uuid
+>   pgSize v = pgSize (uuid2string v)
+
 > instance PGType Char where
 >   pgTypeOid _ = 18
 >   -- need to cast to CChar because we don't know what the Storable instance
@@ -679,6 +768,12 @@ 
 > colValFloat :: ResultSetHandle -> Int -> Int -> IO Float
 > colValFloat = colVal
+
+> colValBytea :: ResultSetHandle -> Int -> Int -> IO [Word8]
+> colValBytea = colVal
+
+> colValUUID :: ResultSetHandle -> Int -> Int -> IO UUID
+> colValUUID = colVal
 
 > colValUTCTime :: ResultSetHandle -> Int -> Int -> IO UTCTime
 > colValUTCTime = colVal

@@ -93,6 +93,7 @@ > import Test.MiniUnit
 > import Data.Int
 > import Data.List
+> import Data.Word
 > import System.Time
 
 
@@ -199,6 +200,29 @@ > selectBindBool _ = actionBindBool
 >   (sqlbind sqlBindBool [bindP True, bindP False])
 
+> str2Word8 :: String -> [Word8]
+> str2Word8 s = map (fromIntegral . fromEnum) s
+> word8ToStr :: [Word8] -> String
+> word8ToStr s = map (toEnum . fromIntegral) s
+
+> selectBindBytea _ = do
+>   let input = str2Word8 "\\ \0 ' \255"
+>   let expect = input
+>   let iterBindBytea :: Monad m => [Word8] -> IterAct m [Word8]
+>       iterBindBytea w8 acc = result w8
+>   withTransaction Serialisable $ do
+>     actual <- doQuery (sqlbind sqlSingleValue [bindP input]) iterBindBytea []
+>     assertEqual "selectBindBytea" expect actual
+
+> selectBindUUID _ = do
+>   let input = string2uuid "11112222-3333-4444-5555-666677778888"
+>   let expect = input
+>   let iterBindUUID :: Monad m => UUID -> IterAct m UUID
+>       iterBindUUID uuid acc = result uuid
+>   withTransaction Serialisable $ do
+>     actual <- doQuery (sqlbind sqlSingleValue [bindP input]) iterBindUUID input
+>     assertEqual "selectBindUUID" expect actual
+
 > selectBindBoundaryDates _ = actionBindBoundaryDates
 >   (prefetch 1 sqlBindBoundaryDates (map bindP expectBoundaryDates))
 
@@ -345,7 +369,7 @@ >   [ selectNoRows, selectTerminatesEarly, selectFloatsAndInts
 >   , selectNullString, selectEmptyString, selectUnhandledNull
 >   , selectNullDate, selectDate, selectCalDate, selectBoundaryDates
->   , selectCursor, selectExhaustCursor
+>   , selectCursor, selectExhaustCursor, selectBindBytea, selectBindUUID
 >   , selectBindString, selectBindInt, selectBindIntDoubleString
 >   , selectBindDate, selectBindBool, selectBindBoundaryDates
 >   , selectRebindStmt, boundStmtDML, boundStmtDML2

@@ -19,7 +19,9 @@ > import Control.Exception.Extensible
 > import Data.Dynamic
 > import System.Environment (getArgs)
+> import System.Random
 > import Test.MiniUnit
+> import qualified Test.QuickCheck as QC
 > import Data.Char
 > import Data.Time
 
@@ -38,9 +40,13 @@ >   closeDb db
 
 > testlist db = map ($ db)
->   [ testSelectInts
+>   [ testByteaEsc
+>   , testUUIDMarshal
+>   , testSelectInts
 >   , testSelectDouble
 >   , testSelectBool
+>   , testSelectBytea
+>   , testSelectUUID
 >   , testSelectDate
 >   , testSelectDate2
 >   , testSelectDate3
@@ -71,7 +77,21 @@ 
 > testOpen connstr = openDb connstr >>= closeDb
 
+Bytea escaping:
+For a single backslash in the value sent to the database,
+we need two in the Haskell string.
+And if we want to send two backslashes (to start an escape)
+then we need to write four here.
+
+> byteaTestValIn = "\\\\\\\\ \\\\000 \\' \\\\377"
+> byteaTestValOut :: [Word8]
+> --byteaTestValOut = [92, 32, 0, 32, 39, 32, 255]
+> byteaTestValOut = str2Word8 "\\ \0 ' \255"
+
+i.e. backslash space zero space quote space 255
+
 > createFixture db = do
+>   -- temp tables - no need to drop
 >   -- ignoreError $ ddlExec db "drop table tdual"
 >   -- ignoreError $ ddlExec db "drop table t_natural"
 >   -- ignoreError $ ddlExec db "drop table t_blob"
@@ -85,7 +105,7 @@ >   printPropagateError $
 >       ddlExec db "create temp table t_blob (b bytea)"
 >   printPropagateError $
->       ddlExec db "insert into t_blob values ('blobtest')"
+>       ddlExec db ("insert into t_blob values ('" ++ byteaTestValIn ++ "')")
 
 > insertNatural db n = do
 >   ddlExec db $ "insert into t_natural values (" ++ (show n) ++ ")"
@@ -102,6 +122,43 @@ >   printPropagateError $ ddlExec db "insert into tdual values (1)"
 
 
+> instance QC.Arbitrary Word8 where
+>   arbitrary = QC.elements [minBound..maxBound]
+>   coarbitrary = undefined
+
+> instance QC.Arbitrary Char where
+>   --arbitrary = QC.choose (chr 1, chr 0x10FFFF)
+>   arbitrary = QC.choose (chr 32, chr 126)
+>   coarbitrary = undefined
+
+> str2Word8 :: String -> [Word8]
+> str2Word8 s = map (fromIntegral . fromEnum) s
+> word8ToStr :: [Word8] -> String
+> word8ToStr s = map (toEnum . fromIntegral) s
+
+> prop_byteaEscRoundTrip s = s == byteaUnesc (byteaEsc s)
+> prop_byteaEscRoundTripString s = s == word8ToStr (byteaUnesc (byteaEsc (str2Word8 s)))
+
+> testByteaEsc db = do
+>   assertEqual "testByteaEsc" (str2Word8 "\\000\\001\\002") (byteaEsc [0,1,2])
+>   assertEqual "testByteaEsc" (str2Word8 "\\037\\177\\377") (byteaEsc [31,127,255])
+>   QC.test prop_byteaEscRoundTripString
+>   QC.test prop_byteaEscRoundTrip
+
+> prop_uuidRoundTrip :: (Int, Int) -> Bool
+> prop_uuidRoundTrip (w1, w2) = uuid == string2uuid (uuid2string uuid)
+>   where uuid = UUID (fromIntegral w1, fromIntegral w2)
+
+> testUUIDMarshal db = do
+>   assertEqual "testUUIDMarshal"
+>     (UUID (0x0011223344556677, 0x8899AABBCCDDEEFF))
+>     (string2uuid "{00112233-44-55-66-778899aabbCCDDeEFF}")
+>   assertEqual "testUUIDMarshal"
+>     (UUID (0x1000000010000000, 0x1000000010000000))
+>     (string2uuid "{10000000-10000000-10000000-10000000}")
+>   QC.test prop_uuidRoundTrip
+
+
 > testSelectStrings db = do
 >   sn <- printPropagateError $
 >     stmtPrepare db "" "select text(n) from t_natural where n < 3 order by n;" []
@@ -152,6 +209,21 @@ >   assertEqual "testSelectDouble: True" True n
 >   stmtFinalise stmt
 
+> testSelectBytea db = do
+>   sn <- printPropagateError $ stmtPrepare db "" "select b from t_blob" []
+>   (stmt,ntuples) <- stmtExec0t db sn
+>   v <- colValBytea stmt 1 1
+>   assertEqual ("testSelectBytea") byteaTestValOut v
+>   stmtFinalise stmt
+
+> testSelectUUID db = do
+>   sn <- printPropagateError $ stmtPrepare db "" "select cast('{00112233-4455-6677-8899-aabbCCDDeEFF}' as uuid)" []
+>   (stmt,ntuples) <- stmtExec0t db sn
+>   v <- colValUUID stmt 1 1
+>   let expect = UUID (0x0011223344556677, 0x8899AABBCCDDEEFF)
+>   assertEqual ("testSelectUUID") expect v
+>   stmtFinalise stmt
+
 > testSelectDate db = do
 >   sn <- printPropagateError $ stmtPrepare db ""
 >     ("select timestamp with time zone '2000-01-01'"
@@ -265,7 +337,7 @@ If we don't specify the type, Postgres gives the number the NUMERIC type.
 I don't yet know what the internal binary rep is, nor how to
 convert it to an appropriate Haskell type.
-Best we can do is marshal/transmist everything as text.
+Best we can do is marshal/transmit everything as text.
 
 > testSelectNumeric db = do
 >   sn <- printPropagateError $ stmtPrepare db "" "select 1.2" []
@@ -281,7 +353,7 @@ 
 > testUnion db = do
 >   (stmt,ntuples) <- printPropagateError $
->     stmtExecImm db "select 'h1' from tdual union select 'h2' from tdual union select 'h3' from tdual" []
+>     stmtExecImm db "select 'h1' from tdual union select 'h2' from tdual union select 'h3' from tdual order by 1" []
 >   assertEqual "testUnion: ntuples" 3 ntuples
 >   s <- colValString stmt 1 1
 >   assertEqual "testUnion: h1" "h1" s

@@ -39,7 +39,7 @@ > sqlCreateDual = "create table tdual (dummy varchar(1) primary key)"
 > sqlInsertDual = "insert into tdual values ('X')"
 > sqlDropTest = "drop table " ++ testTable
-> sqlCreateTest = "create table " ++ testTable ++ " (id integer, v varchar(1000))"
+> sqlCreateTest = "create table " ++ testTable ++ " (id integer, v varchar(250))"
 
 > sqlInsertTest1 = "insert into " ++ testTable ++ " (id, v) values (1, '2')"
 > sqlInsertTest2 = "insert into " ++ testTable ++ " (id, v) values (2, '2')"
@@ -162,7 +162,7 @@ 
 
 
-> execDDL_ s = catchDB (execDDL s) reportRethrow
+> execDDL_ s = catchDB (execDDL s) (reportRethrowMsg ("sql: " ++ s ++ "\n"))
 > execDML_ s = execDDL_ s
 
 Use execDrop when the DDL is likely to raise an error.
@@ -186,7 +186,7 @@ >     doDDL sqlInsertTest2
 >     doDDL sqlInsertTest3
 
-> destroyFixture execDDL_ = flip catchDB reportRethrow $ do
+> destroyFixture execDDL_ = flip catchDB (reportRethrowMsg "destroyFixture: ") $ do
 >   execDDL_ sqlDropDual
 >   execDDL_ sqlDropTest
 >   catchDB commit (const (return ()))
@@ -207,14 +207,14 @@ > iterNoRows (c1::String) acc = result $ c1:acc
 > expectNoRows = []::[String]
 
-> sqlTermEarly = "select 'hello1' from tdual union select 'hello2' from tdual union select 'hello3' from tdual"
+> sqlTermEarly = "select 'hello1' from tdual union select 'hello2' from tdual union select 'hello3' from tdual order by 1"
 > iterTermEarly c1 acc = if c1 == "hello2"
 >       then return (Left (c1:acc))
 >       else result (c1:acc)
 > expectTermEarly = ["hello2", "hello1"]
 
 > sqlFloatsAndInts fns = "select " ++ (literalDouble fns 4841.3403490431) ++ ", "
->   ++ (literalInt fns (-22340234)) ++ " from tdual union select 33311.32332, 23789234 from tdual"
+>   ++ (literalInt fns (-22340234)) ++ " from tdual union select 33311.32332, 23789234 from tdual order by 1"
 > --iterFloatsAndInts :: (Monad m) => Double -> Int -> IterAct m [(Double, Int)]
 > iterFloatsAndInts (c1::Double) (c2::Int) acc = result $ (c1, c2):acc
 > expectFloatsAndInts :: [(Double, Int)]
@@ -226,11 +226,13 @@ > iterNullString c1 c2 c3 acc = result $ (c1, c2, c3):acc
 > expectNullString = [ ("hello1", "hello2", Nothing) ]
 
-> sqlEmptyString = "select 'hello1', 'hello2', '' from tdual /* Oracle always fails this test */"
+Access can't handle SQL comments (-- or /* */).
+
+> sqlEmptyString = "select 'hello1', 'Oracle always fails this test', '' from tdual"
 > iterEmptyString :: (Monad m) => String -> String -> Maybe String
 >                          -> IterAct m [(String, String, Maybe String)]
 > iterEmptyString c1 c2 c3 acc = result $ (c1, c2, c3):acc
-> expectEmptyString = [ ("hello1", "hello2", Just "") ]
+> expectEmptyString = [ ("hello1", "Oracle always fails this test", Just "") ]
 
 > sqlUnhandledNull = "select 'hello1', 'hello2', null from tdual"
 > iterUnhandledNull :: (Monad m) => String -> String -> UTCTime

@@ -265,12 +265,11 @@ 
 > printArrayContents :: Int -> Ptr Word8 -> IO ()
 > printArrayContents sz ptr = do
->   putStrLn ("printBufferContents: sz = " ++ show sz)
+>   putStrLn ("printArrayContents: sz = " ++ show sz)
 >   l <- peekArray sz ptr
 >   let
 >     toHex :: Word8 -> String;
 >     toHex i = (if i < 16 then "0" else "") ++ showHex i ""
->   --let h :: [String]; h = map toHex l
 >   putStrLn (concat (intersperse " " (map toHex l)))
 >   let
 >     toChar :: Word8 -> String

@@ -6,15 +6,15 @@ -- setup build
 -- setup install
 Name:           Takusen
-Version:        0.8.5
+Version:        0.8.6
 License:        BSD3
 License-file:   LICENSE
 Author:         Alistair Bayley, Oleg Kiselyov
 Copyright:      2003-2009, Alistair Bayley, Oleg Kiselyov
 Maintainer:     alistair@abayley.org, oleg@pobox.com
 Stability:      experimental
-Homepage:       http://darcs.haskell.org/takusen
-Package-url:    http://darcs.haskell.org/takusen
+Homepage:       http://code.haskell.org/takusen
+Package-url:    http://code.haskell.org/takusen
 Category:       Database
 Build-type:     Custom
 Cabal-Version:  >= 1.6
@@ -98,7 +98,7 @@       , Foreign.C.UTF8
       , Foreign.C.Test.UTF8
       , Test.MiniUnit
-  Build-Depends:  base, mtl, time, QuickCheck
+  Build-Depends:  base, mtl, time, QuickCheck==1.*, random
   -- ghc-6.6 has System.Time in base.
   -- Later versions has it in a separate package.
   if impl(ghc >= 6.8)