seakale-postgresql 0.1.0.0 → 0.1.1.0

raw patch · 4 files changed

+35/−21 lines, 4 filesdep ~seakalePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: seakale

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• seakale-postgresql.cabal +3/−3
• src/Database/Seakale/PostgreSQL.hs +22/−14
• src/Database/Seakale/PostgreSQL/FromRow.hs +6/−4

@@ -1,5 +1,9 @@ # Revision history for seakale-postgresql +## 0.1.1.0 -- 2017-02-17++* PSQL now takes a Bool to specify whether to log the queries to stderr+ ## 0.1.0.0 -- 2017-01-31  * First version.

@@ -1,5 +1,5 @@ name:                  seakale-postgresql-version:               0.1.0.0+version:               0.1.1.0 synopsis:              PostgreSQL backend for Seakale description:           This package provides a way to run code written with Seakale with a PostgreSQL database. license:               BSD3@@ -14,7 +14,7 @@ source-repository head   type:                darcs   location:            http://darcs.redspline.com/seakale-  tag:                 0.1.0.0+  tag:                 seakale-postgresql-0.1.1.0  library   ghc-options:         -Wall@@ -37,7 +37,7 @@                        Database.Seakale.PostgreSQL.ToRow    build-depends:       base >=4.8 && <4.10-                     , seakale+                     , seakale ==0.1.*                      , postgresql-libpq                      , bytestring                      , mtl

@@ -18,6 +18,7 @@   , runStoreT   , HasConnection(..)   , PSQL(..)+  , defaultPSQL   , SeakaleError(..)   , T.Query(..) -- prefixed to export EmptyQuery   , Field(..)@@ -52,6 +53,8 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BSL +import           System.IO+ import           Database.PostgreSQL.LibPQ hiding (Row, status)  import           Database.Seakale.Types@@ -115,8 +118,11 @@  type TypeCache = [(Oid, BS.ByteString)] -data PSQL = PSQL+data PSQL = PSQL { psqlLogQueries :: Bool } +defaultPSQL :: PSQL+defaultPSQL = PSQL False+ instance Backend PSQL where   type ColumnType PSQL = BS.ByteString @@ -125,20 +131,20 @@                              , MonadIO m                              ) -  runQuery   _ = runExceptT . runQuery-  runExecute _ = runExceptT . runExecute+  runQuery   backend = runExceptT . runQuery   backend+  runExecute backend = runExceptT . runExecute backend  type RequestT = I.RequestT PSQL type Request  = I.Request  PSQL -runRequestT :: (HasConnection m, MonadIO m) => RequestT m a+runRequestT :: (HasConnection m, MonadIO m) => PSQL -> RequestT m a             -> m (Either SeakaleError a)-runRequestT =-  fmap fst . flip runStateT [] . I.runRequestT PSQL . hoistFreeT lift+runRequestT backend =+  fmap fst . flip runStateT [] . I.runRequestT backend . hoistFreeT lift -runRequest :: (HasConnection m, MonadIO m) => Request a+runRequest :: (HasConnection m, MonadIO m) => PSQL -> Request a            -> m (Either SeakaleError a)-runRequest = runRequestT . hoistFreeT (return . runIdentity)+runRequest backend = runRequestT backend . hoistFreeT (return . runIdentity)  type SelectT = I.SelectT PSQL type Select  = I.Select  PSQL@@ -158,10 +164,11 @@ runStore :: Store a -> Request a runStore = I.runStore -runQuery :: MonadBackend PSQL m => BSL.ByteString+runQuery :: MonadBackend PSQL m => PSQL -> BSL.ByteString          -> ExceptT BS.ByteString m ([ColumnInfo PSQL], [Row PSQL])-runQuery lazyReq = do-  let req = mconcat $ BSL.toChunks lazyReq+runQuery PSQL{..} lazyReq = do+  let req = BSL.toStrict lazyReq+  when psqlLogQueries $ liftIO $ BS.hPutStrLn stderr $ "runQuery: " <> req   res <- exec' req    let _until i = takeWhile (/= i) $ iterate (+1) 0@@ -185,10 +192,11 @@    return (cols, rows) -runExecute :: MonadBackend PSQL m => BSL.ByteString+runExecute :: MonadBackend PSQL m => PSQL -> BSL.ByteString            -> ExceptT BS.ByteString m Integer-runExecute lazyReq = do-  let req = mconcat $ BSL.toChunks lazyReq+runExecute PSQL{..} lazyReq = do+  let req = BSL.toStrict lazyReq+  when psqlLogQueries $ liftIO $ BS.hPutStrLn stderr $ "runExecute: " <> req   res <- exec' req    mBS <- liftIO $ cmdTuples res

@@ -39,14 +39,16 @@ instance {-# OVERLAPPABLE #-} FromRow PSQL One a => FromRow PSQL One [a] where   fromRow = pconsume `pbind` \(col@ColumnInfo{..}, Field{..}) ->     case (BS.splitAt 1 colInfoType, fieldValue) of-      (("_", typ), Just bs) -> arrayParser (col { colInfoType = typ }) bs+      (("_", typ), Just bs) ->+        pbackend `pbind` \backend ->+        arrayParser backend (col { colInfoType = typ }) bs       (_, Just _) -> pfail $ "invalid type for list: " ++ BS.unpack colInfoType       (_, Nothing) -> pfail "unexpected NULL for list"  -- FIXME: What about \n for example?-arrayParser :: FromRow PSQL One a => ColumnInfo PSQL -> BS.ByteString+arrayParser :: FromRow PSQL One a => PSQL -> ColumnInfo PSQL -> BS.ByteString             -> RowParser PSQL Zero [a]-arrayParser col = either pfail preturn . go+arrayParser backend col = either pfail preturn . go   where     go :: FromRow PSQL One a => BS.ByteString -> Either String [a]     go bs = case BS.splitAt 1 bs of@@ -59,7 +61,7 @@     readValues f bs = do       (valBS, bs') <- readByteString bs       let mValBS = if valBS == "NULL" then Nothing else Just valBS-      val <- parseRow fromRow PSQL [col] [Field mValBS]+      val <- parseRow fromRow backend [col] [Field mValBS]       case BS.splitAt 1 bs' of         (",", bs'') -> readValues (f . (val :)) bs''         ("}", "")   -> return $! f [val]