packages feed

postgresql-typed 0.4.1 → 0.4.2

raw patch · 11 files changed

+165/−35 lines, 11 files

Files

Database/PostgreSQL/Typed.hs view
@@ -32,6 +32,7 @@   -- $run   , pgQuery   , pgExecute+  , pgTransaction    -- **TemplatePG compatibility   -- $templatepg
Database/PostgreSQL/Typed/Array.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds, OverloadedStrings #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, DataKinds, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Array@@ -10,13 +10,18 @@  module Database.PostgreSQL.Typed.Array where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (*>), (<*))+#endif import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC import Data.Char (toLower) import Data.List (intersperse)-import Data.Monoid ((<>), mconcat)+import Data.Monoid ((<>))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mconcat)+#endif  import Database.PostgreSQL.Typed.Types
Database/PostgreSQL/Typed/Dynamic.hs view
@@ -14,7 +14,9 @@   , pgSubstituteLiterals   ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))+#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.Monoid ((<>))@@ -56,6 +58,7 @@   pgDecodeRep (PGTextValue v) = pgDecode (PGTypeProxy :: PGTypeName t) v   pgDecodeRep _ = error $ "pgDecodeRep " ++ pgTypeName (PGTypeProxy :: PGTypeName t) ++ ": unsupported PGValue" +-- |Produce a raw SQL literal from a value. Using 'pgSafeLiteral' is usually safer when interpolating in a SQL statement. pgLiteralString :: PGRep t a => a -> String pgLiteralString = BSC.unpack . pgLiteralRep @@ -63,6 +66,7 @@ pgSafeLiteral :: PGRep t a => a -> BS.ByteString pgSafeLiteral x = pgLiteralRep x <> BSC.pack "::" <> fromString (pgTypeName (pgTypeOf x)) +-- |Identical to @'BSC.unpack' . 'pgSafeLiteral'@ but more efficient. pgSafeLiteralString :: PGRep t a => a -> String pgSafeLiteralString x = pgLiteralString x ++ "::" ++ pgTypeName (pgTypeOf x)
Database/PostgreSQL/Typed/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms, PatternGuards, TemplateHaskell, GADTs, KindSignatures, DataKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.PostgreSQL.Typed.Internal   ( stringE   , pattern StringE@@ -12,14 +13,17 @@ import qualified Language.Haskell.TH as TH import Numeric (readDec) +-- |@'TH.LitE' . 'TH.stringL'@ stringE :: String -> TH.Exp stringE = TH.LitE . TH.StringL +-- |Pattern match for 'stringE'. pattern StringE s = TH.LitE (TH.StringL s)  instance IsString TH.Exp where   fromString = stringE +-- |Parsed representation of a SQL statement containing placeholders. data SQLSplit a (literal :: Bool) where   SQLLiteral :: String -> SQLSplit a 'False -> SQLSplit a 'True   SQLPlaceholder :: a -> SQLSplit a 'True -> SQLSplit a 'False@@ -29,6 +33,7 @@ sqlCons c (SQLLiteral s l) = SQLLiteral (c : s) l sqlCons c SQLSplitEnd = SQLLiteral [c] SQLSplitEnd +-- |Parse a SQL stamement with ${string} placeholders into a 'SQLSplit'. sqlSplitExprs :: String -> SQLSplit String 'True sqlSplitExprs ('$':'$':'{':s) = sqlCons '$' $ sqlCons '{' $ sqlSplitExprs s sqlSplitExprs ('$':'{':s)@@ -37,6 +42,7 @@ sqlSplitExprs (c:s) = sqlCons c $ sqlSplitExprs s sqlSplitExprs [] = SQLSplitEnd +-- |Parse a SQL stamement with $numeric placeholders into a 'SQLSplit'. sqlSplitParams :: String -> SQLSplit Int 'True sqlSplitParams ('$':'$':d:s) | isDigit d = sqlCons '$' $ sqlCons d $ sqlSplitParams s sqlSplitParams ('$':s@(d:_)) | isDigit d, [(n, r)] <- readDec s = SQLLiteral "" $ SQLPlaceholder n $ sqlSplitParams r
Database/PostgreSQL/Typed/Protocol.hs view
@@ -16,18 +16,26 @@   , pgConnect   , pgDisconnect   , pgReconnect+  -- * Query operations   , pgDescribe   , pgSimpleQuery   , pgSimpleQueries_   , pgPreparedQuery   , pgPreparedLazyQuery   , pgCloseStatement+  -- * Transactions+  , pgBegin+  , pgCommit+  , pgRollback+  , pgTransaction   ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$))-import Control.Arrow (second)-import Control.Exception (Exception, throwIO)-import Control.Monad (liftM2, replicateM, when, unless)+#endif+import Control.Arrow ((&&&), second)+import Control.Exception (Exception, throwIO, onException)+import Control.Monad (void, liftM2, replicateM, when, unless) #ifdef USE_MD5 import qualified Crypto.Hash as Hash #endif@@ -37,14 +45,21 @@ import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.ByteString.Lazy.Internal (smallChunkSize) import qualified Data.Foldable as Fold import Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef, modifyIORef') import Data.Int (Int32, Int16) import qualified Data.Map.Lazy as Map import Data.Maybe (fromMaybe)-import Data.Monoid (mempty, (<>))+import Data.Monoid ((<>))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mempty)+#endif import Data.Typeable (Typeable)+#if !MIN_VERSION_base(4,8,0)+import Data.Word (Word)+#endif import Data.Word (Word32) import Network (HostName, PortID(..), connectTo) import System.IO (Handle, hFlush, hClose, stderr, hPutStrLn, hSetBuffering, BufferMode(BlockBuffering))@@ -92,6 +107,7 @@   , connPreparedStatements :: IORef (Integer, Map.Map (BS.ByteString, [OID]) Integer)   , connState :: IORef PGState   , connInput :: IORef (G.Decoder PGBackendMessage)+  , connTransaction :: IORef Word   }  data ColDescription = ColDescription@@ -388,6 +404,7 @@   state <- newIORef StateUnknown   prep <- newIORef (0, Map.empty)   input <- newIORef getMessage+  tr <- newIORef 0   h <- connectTo (pgDBHost db) (pgDBPort db)   hSetBuffering h (BlockBuffering Nothing)   let c = PGConnection@@ -400,6 +417,7 @@         , connState = state         , connTypeEnv = unknownPGTypeEnv         , connInput = input+        , connTransaction = tr         }   pgSend c $ StartupMessage     [ (BSC.pack "user", pgDBUser db)@@ -640,3 +658,35 @@     pgFlush c     CloseComplete <- pgReceive c     return ()++-- |Begin a new transaction. If there is already a transaction in progress (created with 'pgBegin' or 'pgTransaction') instead creates a savepoint.+pgBegin :: PGConnection -> IO ()+pgBegin c@PGConnection{ connTransaction = tr } = do+  t <- atomicModifyIORef' tr (succ &&& id)+  void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "BEGIN" else "SAVEPOINT pgt" ++ show t++predTransaction :: Word -> (Word, Word)+predTransaction 0 = (0, error "pgTransaction: no transactions")+predTransaction x = (x', x') where x' = pred x++-- |Rollback to the most recent 'pgBegin'.+pgRollback :: PGConnection -> IO ()+pgRollback c@PGConnection{ connTransaction = tr } = do+  t <- atomicModifyIORef' tr predTransaction+  void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "ROLLBACK" else "ROLLBACK TO SAVEPOINT pgt" ++ show t++-- |Commit the most recent 'pgBegin'.+pgCommit :: PGConnection -> IO ()+pgCommit c@PGConnection{ connTransaction = tr } = do+  t <- atomicModifyIORef' tr predTransaction+  void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "COMMIT" else "RELEASE SAVEPOINT pgt" ++ show t++-- |Wrap a computation in a 'pgBegin', 'pgCommit' block, or 'pgRollback' on exception.+pgTransaction :: PGConnection -> IO a -> IO a+pgTransaction c f = do+  pgBegin c+  onException (do+    r <- f+    pgCommit c+    return r)+    (pgRollback c)
Database/PostgreSQL/Typed/Query.hs view
@@ -15,7 +15,9 @@   , pgLazyQuery   ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))+#endif import Control.Arrow ((***), first, second) import Control.Exception (try) import Control.Monad (void, when, mapAndUnzipM)@@ -23,7 +25,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL-import Data.Char (isSpace)+import Data.Char (isSpace, isAlphaNum) import qualified Data.Foldable as Fold import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe, isNothing)@@ -62,12 +64,14 @@   unsafeModifyQuery q f = f q  newtype SimpleQuery = SimpleQuery BS.ByteString+  deriving (Show) instance PGQuery SimpleQuery PGValues where   pgRunQuery c (SimpleQuery sql) = pgSimpleQuery c (BSL.fromStrict sql)   unsafeModifyQuery (SimpleQuery sql) f = SimpleQuery $ f sql instance PGRawQuery SimpleQuery  data PreparedQuery = PreparedQuery BS.ByteString [OID] PGValues [Bool]+  deriving (Show) instance PGQuery PreparedQuery PGValues where   pgRunQuery c (PreparedQuery sql types bind bc) = pgPreparedQuery c sql types bind bc   unsafeModifyQuery (PreparedQuery sql types bind bc) f = PreparedQuery (f sql) types bind bc@@ -82,6 +86,10 @@ instance Functor (QueryParser q) where   fmap f (QueryParser q p) = QueryParser q (\e -> f . p e) +instance Show q => Show (QueryParser q a) where+  showsPrec p (QueryParser q _) = showParen (p > 10) $+    showString "QueryParser " . showsPrec 11 (q unknownPGTypeEnv)+ rawParser :: q -> QueryParser q PGValues rawParser q = QueryParser (const q) (const id) @@ -160,6 +168,9 @@ simpleQueryFlags :: QueryFlags simpleQueryFlags = QueryFlags True Nothing Nothing +newName :: Char -> BS.ByteString -> TH.Q TH.Name+newName pre = TH.newName . ('_':) . (pre:) . filter (\c -> isAlphaNum c || c == '_') . BSC.unpack+ -- |Construct a 'PGQuery' from a SQL string. makePGQuery :: QueryFlags -> String -> TH.ExpQ makePGQuery QueryFlags{ flagQuery = False } sqle = pgSubstituteLiterals sqle@@ -169,13 +180,13 @@    e <- TH.newName "_tenv"   (vars, vals) <- mapAndUnzipM (\t -> do-    v <- TH.newName $ 'p':BSC.unpack (tpgValueName t)+    v <- newName 'p' $ tpgValueName t     return        ( TH.VarP v       , tpgTypeEncoder (isNothing prep) t e `TH.AppE` TH.VarE v       )) pt   (pats, conv, bins) <- unzip3 <$> mapM (\t -> do-    v <- TH.newName $ 'c':BSC.unpack (tpgValueName t)+    v <- newName 'c' $ tpgValueName t     return        ( TH.VarP v       , tpgTypeDecoder (Fold.and nulls) t e `TH.AppE` TH.VarE v
Database/PostgreSQL/Typed/Range.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FunctionalDependencies, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: Database.PostgreSQL.Typed.Range@@ -10,12 +10,17 @@  module Database.PostgreSQL.Typed.Range where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$))+#endif import Control.Monad (guard) import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BSC-import Data.Monoid (Monoid(..), (<>))+import Data.Monoid ((<>))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+#endif  import Database.PostgreSQL.Typed.Types
Database/PostgreSQL/Typed/TH.hs view
@@ -18,7 +18,10 @@   , tpgTypeBinary   ) where -import Control.Applicative ((<$>), (<$), (<|>))+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<$))+#endif+import Control.Applicative ((<|>)) import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, modifyMVar_) import Control.Exception (onException, finally) import Control.Monad (liftM2)
Database/PostgreSQL/Typed/TemplatePG.hs view
@@ -22,7 +22,7 @@   , PG.pgDisconnect   ) where -import Control.Exception (onException, catchJust)+import Control.Exception (catchJust) import Control.Monad (liftM, void, guard) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC@@ -76,12 +76,7 @@ -- Monad for now due to the use of 'onException'. I'm debating adding a -- 'MonadPeelIO' version. withTransaction :: PG.PGConnection -> IO a -> IO a-withTransaction h a =-  onException (do void $ PG.pgSimpleQuery h $ BSLC.pack "BEGIN"-                  c <- a-                  void $ PG.pgSimpleQuery h $ BSLC.pack "COMMIT"-                  return c)-              (void $ PG.pgSimpleQuery h $ BSLC.pack "ROLLBACK")+withTransaction = PG.pgTransaction  -- |Roll back a transaction. rollback :: PG.PGConnection -> IO ()
Database/PostgreSQL/Typed/Types.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, FlexibleInstances, OverlappingInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, UndecidableInstances #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif -- | -- Module: Database.PostgreSQL.Typed.Types -- Copyright: 2015 Dylan Simon@@ -34,7 +37,9 @@   , buildPGValue   ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<$), (<*), (*>))+#endif #ifdef USE_AESON import qualified Data.Aeson as JSON #endif@@ -53,7 +58,10 @@ import Data.Int import Data.List (intersperse) import Data.Maybe (fromMaybe)-import Data.Monoid ((<>), mconcat, mempty)+import Data.Monoid ((<>))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mempty, mconcat)+#endif import Data.Ratio ((%), numerator, denominator) #ifdef USE_SCIENTIFIC import Data.Scientific (Scientific)@@ -181,6 +189,7 @@ pgQuote :: BS.ByteString -> BS.ByteString pgQuote = pgQuoteUnsafe . BSC.intercalate (BSC.pack "''") . BSC.split '\'' +-- |Shorthand for @'BSL.toStrict' . 'BSB.toLazyByteString'@ buildPGValue :: BSB.Builder -> BS.ByteString buildPGValue = BSL.toStrict . BSB.toLazyByteString @@ -318,17 +327,33 @@   pgDecode _ = BSU.toString   BIN_DEC((T.unpack .) . binDec BinD.text) -instance {-# OVERLAPPABLE #-} PGStringType t => PGParameter t BS.ByteString where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPABLE #-}+#endif+    PGStringType t => PGParameter t BS.ByteString where   pgEncode _ = id   BIN_ENC(BinE.text . Left . TE.decodeUtf8)-instance {-# OVERLAPPABLE #-} PGStringType t => PGColumn t BS.ByteString where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPABLE #-}+#endif+    PGStringType t => PGColumn t BS.ByteString where   pgDecode _ = id   BIN_DEC((TE.encodeUtf8 .) . binDec BinD.text) -instance {-# OVERLAPPABLE #-} PGStringType t => PGParameter t BSL.ByteString where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPABLE #-}+#endif+    PGStringType t => PGParameter t BSL.ByteString where   pgEncode _ = BSL.toStrict   BIN_ENC(BinE.text . Right . TLE.decodeUtf8)-instance {-# OVERLAPPABLE #-} PGStringType t => PGColumn t BSL.ByteString where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPABLE #-}+#endif+    PGStringType t => PGColumn t BSL.ByteString where   pgDecode _ = BSL.fromStrict   BIN_DEC((BSL.fromStrict .) . (TE.encodeUtf8 .) . binDec BinD.text) @@ -373,28 +398,53 @@   unhex = fromIntegral . digitToInt . w2c  instance PGType "bytea" where BIN_COL-instance {-# OVERLAPPING #-} PGParameter "bytea" BSL.ByteString where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPING #-}+#endif+    PGParameter "bytea" BSL.ByteString where   pgEncode _ = encodeBytea . BSB.lazyByteStringHex   pgLiteral t = pgQuoteUnsafe . pgEncode t   BIN_ENC(BinE.bytea . Right)-instance {-# OVERLAPPING #-} PGColumn "bytea" BSL.ByteString where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPING #-}+#endif+    PGColumn "bytea" BSL.ByteString where   pgDecode _ = BSL.pack . decodeBytea   BIN_DEC((BSL.fromStrict .) . binDec BinD.bytea)-instance {-# OVERLAPPING #-} PGParameter "bytea" BS.ByteString where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPING #-}+#endif+    PGParameter "bytea" BS.ByteString where   pgEncode _ = encodeBytea . BSB.byteStringHex   pgLiteral t = pgQuoteUnsafe . pgEncode t   BIN_ENC(BinE.bytea . Left)-instance {-# OVERLAPPING #-} PGColumn "bytea" BS.ByteString where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPING #-}+#endif+    PGColumn "bytea" BS.ByteString where   pgDecode _ = BS.pack . decodeBytea   BIN_DEC(binDec BinD.bytea) +readTime :: Time.ParseTime t => String -> String -> t+readTime =+#if MIN_VERSION_time(1,5,0)+  Time.parseTimeOrError False+#else+  Time.readTime+#endif+    defaultTimeLocale+ instance PGType "date" where BIN_COL instance PGParameter "date" Time.Day where   pgEncode _ = BSC.pack . Time.showGregorian   pgLiteral t = pgQuoteUnsafe . pgEncode t   BIN_ENC(BinE.date) instance PGColumn "date" Time.Day where-  pgDecode _ = Time.readTime defaultTimeLocale "%F" . BSC.unpack+  pgDecode _ = readTime "%F" . BSC.unpack   BIN_DEC(binDec BinD.date)  binColDatetime :: PGTypeEnv -> PGTypeName t -> Bool@@ -420,7 +470,7 @@   pgEncodeValue = binEncDatetime BinE.time #endif instance PGColumn "time without time zone" Time.TimeOfDay where-  pgDecode _ = Time.readTime defaultTimeLocale "%T%Q" . BSC.unpack+  pgDecode _ = readTime "%T%Q" . BSC.unpack #ifdef USE_BINARY   pgDecodeBinary = binDecDatetime BinD.time #endif@@ -434,7 +484,7 @@   pgEncodeValue = binEncDatetime BinE.timestamp #endif instance PGColumn "timestamp without time zone" Time.LocalTime where-  pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q" . BSC.unpack+  pgDecode _ = readTime "%F %T%Q" . BSC.unpack #ifdef USE_BINARY   pgDecodeBinary = binDecDatetime BinD.timestamp #endif@@ -458,7 +508,7 @@   pgEncodeValue = binEncDatetime BinE.timestamptz #endif instance PGColumn "timestamp with time zone" Time.UTCTime where-  pgDecode _ = Time.readTime defaultTimeLocale "%F %T%Q%z" . fixTZ . BSC.unpack+  pgDecode _ = readTime "%F %T%Q%z" . fixTZ . BSC.unpack #ifdef USE_BINARY   pgDecodeBinary = binDecDatetime BinD.timestamptz #endif
postgresql-typed.cabal view
@@ -1,5 +1,5 @@ Name:          postgresql-typed-Version:       0.4.1+Version:       0.4.2 Cabal-Version: >= 1.8 License:       BSD3 License-File:  COPYING@@ -16,7 +16,7 @@                Allows not only syntax verification of your SQL but also full type safety between your SQL and Haskell.                Supports many built-in PostgreSQL types already, including arrays and ranges, and can be easily extended in user code to support any other types.                Originally based on Chris Forno's templatepg library.-Tested-With:   GHC == 7.8.4+Tested-With:   GHC == 7.8.4, GHC == 7.10.2 Build-Type:    Simple  source-repository head