postgresql-orm 0.2.3 → 0.3.0
raw patch · 6 files changed
+91/−33 lines, 6 filesdep ~postgresql-simple
Dependency ranges changed: postgresql-simple
Files
- Database/PostgreSQL/Devel.hs +2/−2
- Database/PostgreSQL/Escape.hs +28/−23
- Database/PostgreSQL/Migrate.hs +0/−1
- Database/PostgreSQL/ORM/DBSelect.hs +15/−2
- Database/PostgreSQL/ORM/Model.hs +44/−3
- postgresql-orm.cabal +2/−2
Database/PostgreSQL/Devel.hs view
@@ -111,8 +111,8 @@ "pg_ctl -D " ++ showCommandForUser dir' [] ++ " stop -m immediate\n\n" version <- readFile (dir </> "PG_VERSION") case reads version of- [(v, _)] | v < (9.3 :: Double) -> configLocalDB dir $ pgDirectives92 dir- _ -> configLocalDB dir $ pgDirectives dir+ [(v, _)] | v < (9.3 :: Double) -> configLocalDB dir $ pgDirectives92 dir'+ _ -> configLocalDB dir $ pgDirectives dir' systemNoStdout :: String -> [String] -> IO ExitCode systemNoStdout prog args =
Database/PostgreSQL/Escape.hs view
@@ -3,10 +3,13 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE CPP #-} +#include "MachDeps.h"+ -- | This module deals with escaping and sanitizing SQL templates. module Database.PostgreSQL.Escape (- fmtSql, quoteIdent, Id(..)+ fmtSql, quoteIdent , buildSql, buildSqlFromActions , buildAction, buildLiteral, buildByteA, buildIdent ) where@@ -18,7 +21,6 @@ import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Unsafe as S import Data.Monoid-import Data.String import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.ToField import Database.PostgreSQL.Simple.ToRow@@ -26,7 +28,7 @@ import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Storable (pokeByteOff) import Foreign.Ptr-import GHC.Prim (Addr#, and#, geAddr#, geWord#, int2Word#+import GHC.Prim (Addr#, and#, geAddr#, geWord#, Int#, int2Word# , minusAddr#, ord# , plusAddr#, readWord8OffAddr# , State# , uncheckedShiftRL#, word2Int#, writeWord8OffAddr# , Word#)@@ -35,6 +37,20 @@ import GHC.Word (Word8(W8#)) import System.IO.Unsafe (unsafeDupablePerformIO) +{-# INLINE cmpres #-}+-- | Newer versions of GHC return an Int# instead of a Bool for+-- primitive comparison functions. The @cmpres@ function converts the+-- result of such a comparison to a @Bool@.+#if __GLASGOW_HASKELL__ >= 707+cmpres :: Int# -> Bool+cmpres 0# = False+cmpres _ = True+#else /* __GLASGOW_HASKELL__ < 707 */+cmpres :: Bool -> Bool+cmpres b = b+#define cmpres(b) b+#endif /* __GLASGOW_HASKELL__ < 707 */+ c2b :: Char -> Word8 c2b (C# i) = W8# (int2Word# (ord# i)) @@ -48,7 +64,7 @@ let bse = bsp0 `plusAddr#` bsl0 check bsp = IO $ \rw -> case readWord8OffAddr# bsp 0# rw of (# rw1, w #) -> (# rw1, test w #)- go bsp | bsp `geAddr#` bse = return Nothing+ go bsp | cmpres(bsp `geAddr#` bse) = return Nothing | otherwise = do match <- check bsp if match@@ -136,18 +152,6 @@ quoteIdent :: S.ByteString -> S.ByteString quoteIdent = toByteString . buildIdent --- | An identifier is a table or column name. When rendered into a--- SQL query by 'fmtSql', it will be double-quoted, rather than--- single-quoted. For example:------ >>> fmtSql "select * from ? where name = ?" (Id "MyTable", "A Name")--- "select * from \"MyTable\" where name = E'A Name'"-newtype Id = Id S.ByteString deriving Show-instance IsString Id where- fromString = Id . fromString-instance ToField Id where- toField (Id name) = Plain $ buildIdent name- hexNibblesPtr :: Ptr Word8 {-# NOINLINE hexNibblesPtr #-} hexNibblesPtr = unsafeDupablePerformIO $ do@@ -181,7 +185,7 @@ where isSpecial 39## = True -- '\'' isSpecial 63## = True -- '?' isSpecial 92## = True -- '\\'- isSpecial b = b `geWord#` 128##+ isSpecial b = cmpres(b `geWord#` 128##) esc b | b == c2b '\'' = copyByteString "''" | b == c2b '\\' = copyByteString "\\\\" | otherwise = hexCharEscBuilder b@@ -199,8 +203,8 @@ S.unsafeUseAsCStringLen bs $ \(Ptr inptr0, I# inlen0) -> do let ine = plusAddr# inptr0 inlen0 fill oute inp outp- | inp `geAddr#` ine = cont (BufRange (Ptr outp) (Ptr oute))- | plusAddr# outp 2# `geAddr#` oute = return $+ | cmpres(inp `geAddr#` ine) = cont (BufRange (Ptr outp) (Ptr oute))+ | cmpres(plusAddr# outp 2# `geAddr#` oute) = return $ bufferFull (2 * (I# (ine `minusAddr#` inp)) + 1) (Ptr outp) $ \(BufRange (Ptr bb) (Ptr be)) -> fill be inp bb | otherwise = do copyByteToNibbles inp outp@@ -211,10 +215,11 @@ buildAction :: Action -> Builder-buildAction (Plain b) = b-buildAction (Escape bs) = buildLiteral bs-buildAction (EscapeByteA bs) = buildByteA bs-buildAction (Many bs) = mconcat $ map buildAction bs+buildAction (Plain b) = b+buildAction (Escape bs) = buildLiteral bs+buildAction (EscapeByteA bs) = buildByteA bs+buildAction (EscapeIdentifier bs) = buildIdent bs+buildAction (Many bs) = mconcat $ map buildAction bs -- | A lower-level function used by 'buildSql' and 'fmtSql'. You -- probably don't need to call it directly.
Database/PostgreSQL/Migrate.hs view
@@ -23,7 +23,6 @@ import Database.PostgreSQL.Migrations import System.Exit import GHC.IO.Handle-import System.Cmd import System.Process import System.Directory import System.FilePath
Database/PostgreSQL/ORM/DBSelect.hs view
@@ -13,6 +13,7 @@ , dbSelectParams, dbSelect , Cursor(..), curSelect, curNext , dbFold, dbFoldM, dbFoldM_+ , dbCollect , renderDBSelect, buildDBSelect -- * Creating DBSelects , emptyDBSelect, expressionDBSelect@@ -283,14 +284,14 @@ dbSelectParams :: (Model a, ToRow p) => DBSelect a -> Connection -> p -> IO [a] {-# INLINE dbSelectParams #-} dbSelectParams dbs = \c p -> map lookupRow <$> query c q p- where {-# NOINLINE q #-}+ where -- {-# NOINLINE q #-} (crashes under GHC 7.8) q = renderDBSelect dbs -- | Run a 'DBSelect' query and return the resulting models. dbSelect :: (Model a) => Connection -> DBSelect a -> IO [a] {-# INLINE dbSelect #-} dbSelect c dbs = map lookupRow <$> query_ c q- where {-# NOINLINE q #-}+ where -- {-# NOINLINE q #-} (crashes under GHC 7.8) q = renderDBSelect dbs -- | Datatype that represents a connected cursor@@ -360,6 +361,18 @@ dbFoldM_ :: (MonadIO m, Model model) => Connection -> (model -> m ()) -> DBSelect model -> m () dbFoldM_ c act dbs = dbFoldM c (const act) () dbs++-- | Group the returned tuples by unique a's. Expects the query to return a's+-- in sequence -- all rows with the same value for a must be grouped together,+-- for example, by sorting the result on a's primary key column.+dbCollect :: (Model a, Model b)+ => Connection -> DBSelect (a :. b) -> IO [(a, [b])]+dbCollect c ab = dbFold c group [] ab+ where+ group :: (Model a, Model b) => [(a, [b])] -> (a :. b) -> [(a, [b])]+ group [] (a :. b) = [(a, [b])]+ group ls@(l:_) (a :. b) | primaryKey a /= primaryKey (fst l) = (a, [b]):ls+ group (l:ls) (_ :. b) = (fst l, b:(snd l)):ls -- | Create a join of the 'selFields', 'selFrom', and 'selWhere' -- clauses of two 'DBSelect' queries. Other fields are simply taken
Database/PostgreSQL/ORM/Model.hs view
@@ -805,23 +805,64 @@ degen_err :: a degen_err = error "Attempt to use degenerate ToRow instance as Model" #define DEGENERATE(ctx,t) \-instance ctx => Model t where \+instance ctx => Model t where { \ modelInfo = degen_err; \ modelIdentifiers = degen_err; \ modelRead = fromRow; \ modelWrite _ = degen_err; \- modelCreateInfo = degen_err;+ modelCreateInfo = degen_err; } DEGENERATE(FromField t, (Only t)) DEGENERATE(FromField t, [t]) DEGENERATE((FromField a, FromField b), (a, b)) DEGENERATE((FromField a, FromField b, FromField c), (a, b, c)) DEGENERATE((FromField a, FromField b, FromField c, FromField d), (a, b, c, d))-DEGENERATE((FromField a, FromField b, FromField c, FromField d, FromField e), +DEGENERATE((FromField a, FromField b, FromField c, FromField d, FromField e), (a, b, c, d, e)) #undef DEGEN_ERR #undef DEGENERATE++-- | A degenerate model that lifts any model to a Maybe version. Returns+-- 'Nothing' on a parse failure. Useful, for example, for performing outer+-- joins:+-- @+-- dbJoin modelDBSelect "LEFT OUTER JOIN"+-- (addWhere 'foo = 123' $ modelDBSelect)+-- "USING a.id = b.a_id" :: (A :. Maybe B)+-- @+--+instance forall a. Model a => Model (Maybe a) where+ modelInfo = mi_a { modelGetPrimaryKey = getPrimaryKey }+ where mi_a = modelInfo :: ModelInfo a+ getPrimaryKey Nothing = NullKey+ getPrimaryKey (Just a) = modelGetPrimaryKey mi_a a++ modelIdentifiers = mi_a { modelQTable = modelQTable mi_a }+ where mi_a = modelIdentifiers :: ModelIdentifiers a++ modelQueries = mi_a { modelLookupQuery = modelLookupQuery mi_a }+ where mi_a = modelQueries :: ModelQueries a++ modelCreateInfo = error+ "Attempt to use degenerate Maybe (Model a) instance for ModelCreateInfo"++ modelValid = maybe mempty modelValid++ modelWrite = maybe [] modelWrite++ modelRead =+ Just `fmap` (modelRead :: RowParser a)+ <|> do+ let n = length $ modelColumns (modelInfo :: ModelInfo a)+ replicateM_ n (field :: RowParser AnyField)+ return Nothing++-- | AnyField parses (simply by consuming) any SQL column.+data AnyField = AnyField++instance FromField AnyField where+ fromField _ _ = pure AnyField joinModelIdentifiers :: forall a b. (Model a, Model b) => ModelIdentifiers (a :. b)
postgresql-orm.cabal view
@@ -1,5 +1,5 @@ name: postgresql-orm-version: 0.2.3+version: 0.3.0 cabal-version: >= 1.14 build-type: Simple license: GPL@@ -25,7 +25,7 @@ , ghc-prim , mtl , old-locale- , postgresql-simple >= 0.3.2.0+ , postgresql-simple >= 0.4.1.0 , process , time