relational-query-postgresql-pure (empty) → 0.1.0.0
raw patch · 14 files changed
+782/−0 lines, 14 filesdep +HDBCdep +HDBC-postgresqldep +HDBC-sessionsetup-changed
Dependencies added: HDBC, HDBC-postgresql, HDBC-session, Only, base, containers, data-default-class, dlist, homotuple, hspec, list-tuple, names-th, persistable-record, postgresql-placeholder-converter, postgresql-pure, product-isomorphic, relational-query, relational-query-HDBC, relational-query-postgresql-pure, relational-schemas, sql-words, template-haskell, transformers, utf8-string
Files
- ChangeLog.md +7/−0
- LICENSE +63/−0
- README.md +3/−0
- Setup.hs +4/−0
- relational-query-postgresql-pure.cabal +84/−0
- src/Database/Relational/PostgreSQL/Pure/Query.hs +49/−0
- src/Database/Relational/PostgreSQL/Pure/TH.hs +202/−0
- src/Database/Schema/PostgreSQL/Pure.hs +111/−0
- src/Database/Schema/PostgreSQL/Pure/Driver.hs +130/−0
- test-db/DataSource.hs +17/−0
- test-db/DataSource/Pure.hs +28/−0
- test-db/Relation/Person.hs +17/−0
- test-db/Relation/Pure/Person.hs +44/−0
- test-db/Spec.hs +23/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for relational-query-postgresql-pure++## 0.1.0.0++2020.07.14++- Release.
+ LICENSE view
@@ -0,0 +1,63 @@+Copyright 2020 Kazuki Okamoto (岡本和樹)++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kazuki Okamoto nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++---------------------------------------------------------------------------++Copyright (c) 2013, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kei Hibino nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+# relational-query-postgresql-pure++[](http://hackage.haskell.org/package/relational-query-postgresql-pure) [](https://github.com/kakkun61/relational-query-postgresql-pure/actions?query=workflow%3Abuild) [](https://github.com/kakkun61/relational-query-postgresql-pure/actions?query=workflow%3Atest) [](https://gitter.im/relational-query-postgresql-pure/community)
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ relational-query-postgresql-pure.cabal view
@@ -0,0 +1,84 @@+cabal-version: 1.12 ++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 89378bd34b17a07ca7e04f4abc58ef676ab42e969ba1cce5f7d4bdb4681e7abd++name: relational-query-postgresql-pure+version: 0.1.0.0+synopsis: The connector of relational-record and postgresql-pure.+description: You can use postgresql-pure as the backend of relational-record without the HDBC interface.+category: Database+homepage: https://github.com/kakkun61/relational-query-postgresql-pure#readme+bug-reports: https://github.com/kakkun61/relational-query-postgresql-pure/issues+author: Kazuki Okamoto (岡本和樹)+maintainer: kazuki.okamoto@kakkun61.com+copyright: 2020 Kazuki Okamoto (岡本和樹), 2013 Kei Hibino+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/kakkun61/relational-query-postgresql-pure++library+ exposed-modules:+ Database.Relational.PostgreSQL.Pure.Query+ Database.Relational.PostgreSQL.Pure.TH+ Database.Schema.PostgreSQL.Pure+ Database.Schema.PostgreSQL.Pure.Driver+ other-modules:+ Paths_relational_query_postgresql_pure+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-exported-signatures -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-name-shadowing -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-import-lists -Wmonomorphism-restriction+ build-depends:+ HDBC+ , Only+ , base >=4 && <5+ , containers+ , dlist+ , homotuple >=0.1.2.0+ , list-tuple >=0.1.3.0+ , names-th+ , persistable-record+ , postgresql-placeholder-converter+ , postgresql-pure+ , product-isomorphic+ , relational-query+ , relational-schemas+ , sql-words+ , template-haskell+ , transformers+ , utf8-string+ default-language: Haskell2010++test-suite db+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ DataSource+ DataSource.Pure+ Relation.Person+ Relation.Pure.Person+ Paths_relational_query_postgresql_pure+ hs-source-dirs:+ test-db+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-exported-signatures -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HDBC-postgresql+ , HDBC-session+ , base >=4 && <5+ , data-default-class+ , hspec+ , postgresql-pure+ , relational-query+ , relational-query-HDBC+ , relational-query-postgresql-pure+ default-language: Haskell2010
+ src/Database/Relational/PostgreSQL/Pure/Query.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Relational.PostgreSQL.Pure.Query+ ( runQuery'+ ) where++import qualified Data.ByteString.UTF8 as BSU+import Data.String (IsString (fromString))+import Data.Tuple.Homotuple (Homotuple, IsHomolisttuple, IsHomotupleItem)+import Data.Tuple.List (HasLength)+import Database.PostgreSQL.Placeholder.Convert (convertQuestionMarkStyleToDollarSignStyle)+import Database.PostgreSQL.Pure (ColumnInfo, Connection, FormatCode (BinaryFormat), FromRecord,+ Length, Oid, ToRecord, bind, execute, parameters, parse,+ records, sync)+import qualified Database.PostgreSQL.Pure as Pure+import Database.Relational (Query, untypeQuery)+import GHC.TypeLits (KnownNat)++-- | Prepare SQL, bind parameters, execute statement and strictly fetch all records.+runQuery' :: forall p r.+ ( ToRecord p+ , FromRecord r+ , KnownNat (Length p)+ , KnownNat (Length r)+ , HasLength (Homotuple (Length r) ColumnInfo)+ , IsHomotupleItem (Length p) Oid+ , IsHomotupleItem (Length r) Oid+ , IsHomotupleItem (Length r) ColumnInfo+ , IsHomolisttuple (Length p) Oid+ , IsHomolisttuple (Length r) Oid+ , IsHomolisttuple (Length r) ColumnInfo+ )+ => Connection -- ^ Database connection+ -> Query p r -- ^ Query to get record type 'a' requires parameter 'p'+ -> p -- ^ Parameter type+ -> IO [r] -- ^ Action to get records+runQuery' conn q p =+ case convertQuestionMarkStyleToDollarSignStyle $ fromString $ untypeQuery q of+ Left err -> fail err+ Right q' -> do+ let psp = parse "" (Pure.Query q') Nothing+ pp <- bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) p psp+ let ep = execute 0 (pure . BSU.toString) pp+ ((_, _, e, _), _) <- sync conn ep+ pure $ records e
+ src/Database/Relational/PostgreSQL/Pure/TH.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Relational.PostgreSQL.Pure.TH (+ makeRelationalRecord,+ makeRelationalRecord',++ defineTableDefault',+ defineTableDefault,++ defineTableFromDB',+ defineTableFromDB,++ inlineVerifiedQuery+ ) where++import Control.Monad (void, when)+import Data.Functor.ProductIsomorphic.TH (reifyRecordType)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, listToMaybe)+import Data.String (fromString)++import Database.HDBC (SqlValue)+import Database.PostgreSQL.Pure (ColumnInfo, Connection, Oid, disconnect, parse, sync)++import Language.Haskell.TH (Dec, Name, Q, Type (AppT, ConT), TypeQ, runIO)+import Language.Haskell.TH.Lib.Extra (reportError, reportWarning)+import Language.Haskell.TH.Name.CamelCase (varCamelcaseName)++import Database.Record.TH (defineSqlPersistableInstances, recordTemplate)+import Database.Relational (Config, Relation, defaultConfig, enableWarning, nameConfig,+ recordConfig, relationalQuery_, untypeQuery,+ verboseAsCompilerWarning)+import qualified Database.Relational.TH as Relational+import Language.SQL.Keyword (Keyword)++import Database.Schema.PostgreSQL.Pure.Driver (Driver, driverConfig, emptyLogChan, foldLog, getFields,+ getPrimaryKey, takeLogs)++import Data.Tuple.Homotuple (IsHomolisttuple, IsHomotupleItem)+import Data.Tuple.List (Length)+import GHC.TypeLits (KnownNat)++-- | Generate all persistable templates against defined record like type constructor.+makeRelationalRecord' :: Config+ -> Name -- ^ Type constructor name+ -> Q [Dec] -- ^ Result declaration+makeRelationalRecord' config recTypeName = do+ rr <- Relational.makeRelationalRecordDefault' config recTypeName+ (((typeCon, avs), _), _) <- reifyRecordType recTypeName+ ps <- defineSqlPersistableInstances [t| SqlValue |] typeCon avs+ return $ rr ++ ps++-- | Generate all persistable templates against defined record like type constructor.+makeRelationalRecord :: Name -- ^ Type constructor name+ -> Q [Dec] -- ^ Result declaration+makeRelationalRecord = makeRelationalRecord' defaultConfig++-- | Generate all HDBC templates about table except for constraint keys.+defineTableDefault' :: Config -- ^ Configuration to generate query with+ -> String -- ^ Schema name+ -> String -- ^ Table name+ -> [(String, TypeQ)] -- ^ List of column name and type+ -> [Name] -- ^ Derivings+ -> Q [Dec] -- ^ Result declaration+defineTableDefault' config schema table columns derives = do+ modelD <- Relational.defineTableTypesAndRecord config schema table columns derives+ sqlvD <- defineSqlPersistableInstances [t| SqlValue |]+ (fst $ recordTemplate (recordConfig $ nameConfig config) schema table)+ []+ return $ modelD ++ sqlvD++-- | Generate all HDBC templates about table.+defineTableDefault :: Config -- ^ Configuration to generate query with+ -> String -- ^ Schema name+ -> String -- ^ Table name+ -> [(String, TypeQ)] -- ^ List of column name and type+ -> [Name] -- ^ Derivings+ -> [Int] -- ^ Indexes to represent primary key+ -> Maybe Int -- ^ Index of not-null key+ -> Q [Dec] -- ^ Result declaration+defineTableDefault config schema table columns derives primary notNull = do+ modelD <- Relational.defineTable config schema table columns derives primary notNull+ return modelD++tableAlongWithSchema :: IO Connection -- ^ Connect action to system catalog database+ -> Driver -- ^ Driver definition+ -> String -- ^ Schema name+ -> String -- ^ Table name+ -> [(String, TypeQ)] -- ^ Additional column-name and column-type mapping to overwrite default+ -> [Name] -- ^ Derivings+ -> Q [Dec] -- ^ Result declaration+tableAlongWithSchema connect drv scm tbl cmap derives = do+ let config = driverConfig drv+ getDBinfo = do+ logChan <- emptyLogChan+ infoP <- do+ conn <- connect+ p <-+ (,)+ <$> getFields drv conn logChan scm tbl+ <*> getPrimaryKey drv conn logChan scm tbl+ disconnect conn+ pure p+ (,) infoP <$> takeLogs logChan++ (((cols, notNullIdxs), primaryCols), logs) <- runIO getDBinfo+ let reportWarning'+ | enableWarning config = reportWarning+ | otherwise = const $ pure ()+ reportVerbose+ | verboseAsCompilerWarning config = reportWarning+ | otherwise = const $ pure ()+ mapM_ (foldLog reportVerbose reportWarning' reportError) logs+ when (null primaryCols) . reportWarning'+ $ "getPrimaryKey: Primary key not found for table: " ++ scm ++ "." ++ tbl++ let colIxMap = Map.fromList $ zip [c | (c, _) <- cols] [(0 :: Int) .. ]+ ixLookups = [ (k, Map.lookup k colIxMap) | k <- primaryCols ]+ warnLk k = maybe+ (reportWarning $ "defineTableFromDB: fail to find index of pkey - " ++ k ++ ". Something wrong!!")+ (const $ return ())+ primaryIxs = fromMaybe [] . sequence $ map snd ixLookups+ mapM_ (uncurry warnLk) ixLookups++ let liftMaybe tyQ sty = do+ ty <- tyQ+ case ty of+ (AppT (ConT n) _) | n == ''Maybe -> [t| Maybe $(sty) |]+ _ -> sty+ cols1 = [ (,) cn . maybe ty (liftMaybe ty) . Map.lookup cn $ Map.fromList cmap | (cn, ty) <- cols ]+ defineTableDefault config scm tbl cols1 derives primaryIxs (listToMaybe notNullIdxs)++-- | Generate all HDBC templates using system catalog informations with specified config.+defineTableFromDB' :: IO Connection -- ^ Connect action to system catalog database+ -> Driver -- ^ Driver definition+ -> String -- ^ Schema name+ -> String -- ^ Table name+ -> [(String, TypeQ)] -- ^ Additional column-name and column-type mapping to overwrite default+ -> [Name] -- ^ Derivings+ -> Q [Dec] -- ^ Result declaration+defineTableFromDB' = tableAlongWithSchema++-- | Generate all HDBC templates using system catalog informations.+defineTableFromDB :: IO Connection -- ^ Connect action to system catalog database+ -> Driver -- ^ Driver definition+ -> String -- ^ Schema name+ -> String -- ^ Table name+ -> [Name] -- ^ Derivings+ -> Q [Dec] -- ^ Result declaration+defineTableFromDB connect driver scm tbl = tableAlongWithSchema connect driver scm tbl []++-- | Verify composed 'Query' and inline it in compile type.+inlineVerifiedQuery :: forall p r.+ ( KnownNat (Length p)+ , KnownNat (Length r)+ , IsHomotupleItem (Length p) Oid+ , IsHomotupleItem (Length r) Oid+ , IsHomotupleItem (Length r) ColumnInfo+ , IsHomolisttuple (Length p) Oid+ , IsHomolisttuple (Length r) Oid+ , IsHomolisttuple (Length r) ColumnInfo+ )+ => IO Connection -- ^ Connect action to system catalog database+ -> Name -- ^ Top-level variable name which has 'Relation' type+ -> Relation p r -- ^ Object which has 'Relation' type+ -> Config -- ^ Configuration to generate SQL+ -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ...+ -> String -- ^ Variable name to define as inlined query+ -> Q [Dec] -- ^ Result declarations+#if MIN_VERSION_relational_query(0,13,0)+inlineVerifiedQuery connect relVar rel config sufs declName =+ Relational.inlineQuery_ check relVar rel config sufs declName+ where+ check sql = do+ when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql+ void . runIO $ do+ conn <- connect+ let psProc = parse @(Length p) @(Length r) "" (fromString sql) Nothing+ void $ sync conn psProc+ disconnect conn+#else+inlineVerifiedQuery connect relVar rel config sufs qns = do+ (p, r) <- Relational.reifyRelation relVar+ let sql = untypeQuery $ relationalQuery_ config rel sufs+ when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql+ void . runIO $ do+ conn <- connect+ let psProc = parse @(Length p) @(Length r) "" (fromString sql) Nothing+ void $ sync conn psProc+ disconnect conn+ Relational.unsafeInlineQuery (return p) (return r) sql (varCamelcaseName qns)+#endif
+ src/Database/Schema/PostgreSQL/Pure.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Schema.PostgreSQL.Pure+ ( driver+ ) where++import Language.Haskell.TH (TypeQ)++import Control.Applicative ((<|>))+import Control.Monad (guard)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT)+import Data.Char (toLower)+import Data.Map (fromList)++import Database.Relational.PostgreSQL.Pure.Query (runQuery')++import Database.Relational.Schema.PostgreSQL (config, getType, normalizeColumn, notNull,+ primaryKeyLengthQuerySQL, primaryKeyQuerySQL)+import qualified Database.Relational.Schema.PostgreSQL as Schema+import Database.Relational.Schema.PostgreSQL.PgAttribute (PgAttribute (PgAttribute))+import Database.Relational.Schema.PostgreSQL.PgType (PgType (PgType))+import qualified Database.Relational.Schema.PostgreSQL.PgType as Type++import Database.Schema.PostgreSQL.Pure.Driver (Driver, LogChan, TypeMap, driverConfig, emptyDriver,+ failWith, getFieldsWithMap, getPrimaryKey,+ hoistMaybe, maybeIO, putVerbose)++import Data.Tuple.Homotuple.Only ()+import Data.Tuple.List.Only ()+import Database.PostgreSQL.Pure (Connection)+import Database.PostgreSQL.Pure.Oid (Oid (Oid))+import Database.Relational (Query)+import GHC.Int (Int16, Int32)+import Unsafe.Coerce (unsafeCoerce)+++type Column = (Oid, String, Oid, Int32, Int16, Int16, Int32, Int32, Int32, Bool, Char, Char, Bool, Bool, Bool, Bool, Int32, Oid, Oid, String, Oid, Oid, Int16, Bool, Char, Char, Bool, Bool, Char, Oid, Oid, Oid, Char, Char, Bool, Oid, Int32, Int32, Oid, Maybe String)++originalColumn :: Column -> Schema.Column+originalColumn (Oid i0, i1, Oid i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, Oid i17, Oid i100, i101, Oid i102, Oid i103, i104, i105, i106, i107, i108, i109, i110, Oid i111, Oid i112, Oid i113, i114, i115, i116, Oid i117, i118, i119, Oid i120, i121) =+ ( PgAttribute i0 i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13 i14 i15 i16 i17+ , PgType i100 i101 i102 i103 i104 i105 i106 i107 i108 i109 i110 i111 i112 i113 i114 i115 i116 i117 i118 i119 i120 i121+ )++logPrefix :: String -> String+logPrefix = ("PostgreSQL: " ++)++putLog :: LogChan -> String -> IO ()+putLog lchan = putVerbose lchan . logPrefix++compileError :: LogChan -> String -> MaybeT IO a+compileError lchan = failWith lchan . logPrefix++getPrimaryKey' :: Connection+ -> LogChan+ -> String+ -> String+ -> IO [String]+getPrimaryKey' conn lchan scm' tbl' = do+ let scm = map toLower scm'+ tbl = map toLower tbl'+ mayKeyLen <- runQuery' conn primaryKeyLengthQuerySQL (scm, tbl)+ case mayKeyLen of+ [] ->+ return []+ [keyLen] -> do+ primCols <- runQuery' conn (primaryKeyQuerySQL keyLen) (scm, tbl)+ let primaryKeyCols = normalizeColumn <$> primCols+ putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols+ return primaryKeyCols+ _:_:_ -> do+ putLog lchan "getPrimaryKey: Fail to detect primary key. Something wrong."+ return []++getColumns' :: TypeMap+ -> Connection+ -> LogChan+ -> String+ -> String+ -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn lchan scm' tbl' = maybeIO ([], []) id $ do+ let scm = map toLower scm'+ tbl = map toLower tbl'+ columnQuerySQL :: Query (String, String) Column+ columnQuerySQL = unsafeCoerce Schema.columnQuerySQL+ cols <- lift $ (originalColumn <$>) <$> runQuery' conn columnQuerySQL (scm, tbl)+ guard (not $ null cols) <|>+ compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl)++ let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols+ lift . putLog lchan+ $ "getFields: num of columns = " ++ show (length cols)+ ++ ", not null columns = " ++ show notNullIdxs+ let getType' col =+ hoistMaybe (getType (fromList tmap) col) <|>+ compileError lchan ("Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col))++ types <- mapM getType' cols+ return (types, notNullIdxs)++-- | Driver implementation+driver :: Driver+driver =+ emptyDriver { getFieldsWithMap = getColumns' }+ { getPrimaryKey = getPrimaryKey' }+ { driverConfig = config }
+ src/Database/Schema/PostgreSQL/Pure/Driver.hs view
@@ -0,0 +1,130 @@+module Database.Schema.PostgreSQL.Pure.Driver (+ TypeMap,++ Log, foldLog,+ LogChan, emptyLogChan, takeLogs, putWarning, putError, putVerbose,+ failWith, hoistMaybe, maybeIO,++ Driver(Driver, typeMap, driverConfig, getFieldsWithMap, getPrimaryKey),+ emptyDriver,+ getFields,+ ) where++import Control.Monad (MonadPlus, mzero)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))+import Data.DList (DList, toList)+import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)+import Language.Haskell.TH (TypeQ)++import Database.PostgreSQL.Pure (Connection)+import Database.Relational (Config, defaultConfig)+++-- | Mapping between type name string of DBMS and type in Haskell.+-- Type name string depends on specification of DBMS system catalogs.+type TypeMap = [(String, TypeQ)]++-- | Log string type for compile time.+data Log+ = Verbose String+ | Warning String+ | Error String++-- | Folding operation of 'Log' type.+foldLog :: (String -> t) -> (String -> t) -> (String -> t) -> Log -> t+foldLog vf wf ef = d where+ d (Verbose m) = vf m+ d (Warning m) = wf m+ d (Error m) = ef m++-- | Channel to store compile-time warning messages.+newtype LogChan = LogChan { chan :: IORef (DList Log) }++-- | Build and return a new instance of 'LogChan'.+emptyLogChan :: IO LogChan+emptyLogChan = LogChan <$> newIORef mempty++-- | Take all logs list from channel.+takeLogs :: LogChan -> IO [Log]+takeLogs lchan = do+ xs <- readIORef $ chan lchan+ writeIORef (chan lchan) mempty+ return $ toList xs++putLog :: LogChan -> Log -> IO ()+putLog lchan m = chan lchan `modifyIORef` (<> pure m)++-- | Push a warning string into 'LogChan'.+putWarning :: LogChan -> String -> IO ()+putWarning lchan = putLog lchan . Warning++-- | Push an error string into 'LogChan'.+putError :: LogChan -> String -> IO ()+putError lchan = putLog lchan . Error++-- | Put verbose compile-time message as warning when 'verboseAsWarning'.+putVerbose :: LogChan -> String -> IO ()+putVerbose lchan = putLog lchan . Verbose++-- | Push an error string into 'LogChan' and return failed context.+failWith :: LogChan -> String -> MaybeT IO a+failWith lchan m = do+ lift $ putError lchan m+ mzero++hoistM :: MonadPlus m => Maybe a -> m a+hoistM = maybe mzero return++-- | Hoist from 'Maybe' context into 'MaybeT'.+hoistMaybe :: Monad m => Maybe a -> MaybeT m a+hoistMaybe = hoistM++maybeT :: Functor f => b -> (a -> b) -> MaybeT f a -> f b+maybeT zero f = (maybe zero f <$>) . runMaybeT++-- | Run 'MaybeT' with default value.+maybeIO :: b -> (a -> b) -> MaybeT IO a -> IO b+maybeIO = maybeT++-- | Interface type to load database system catalog via HDBC.+data Driver =+ Driver+ { -- | Custom type mapping of this driver+ typeMap :: TypeMap++ -- | Custom configuration for this driver+ , driverConfig :: Config++ -- | Get column name and Haskell type pairs and not-null columns index.+ , getFieldsWithMap :: TypeMap -- Custom type mapping+ -> Connection -- Connection to query system catalog+ -> LogChan+ -> String -- Schema name string+ -> String -- Table name string+ -> IO ([(String, TypeQ)], [Int]) {- Action to get column name and Haskell type pairs+ and not-null columns index. -}++ -- | Get primary key column name.+ , getPrimaryKey :: Connection -- Connection to query system catalog+ -> LogChan+ -> String -- Schema name string+ -> String -- Table name string+ -> IO [String] -- Action to get column names of primary key+ -- , getStringEncoder :: StringEncoder+ -- , getStringDecoder :: StringDecoder+ }++-- | Empty definition of 'Driver'+emptyDriver :: Driver+emptyDriver = Driver [] defaultConfig (\_ _ _ _ _ -> return ([],[])) (\_ _ _ _ -> return []) -- (const $ fail "empty encoder") (const $ fail "empty decoder")++-- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'.+getFields :: Driver -- ^ driver record+ -> Connection -- ^ connection+ -> LogChan -- ^ log channel+ -> String -- ^ schema name string+ -> String -- ^ table name string+ -> IO ([(String, TypeQ)], [Int])+getFields drv conn log scm tbl =+ getFieldsWithMap drv (typeMap drv) conn log scm tbl
+ test-db/DataSource.hs view
@@ -0,0 +1,17 @@+module DataSource (connect) where++import Data.Maybe (fromMaybe)+import Database.HDBC.PostgreSQL (Connection, connectPostgreSQL)+import System.Environment (lookupEnv)++connect :: IO Connection+connect = do+ host <- getEnvDef "PURE_HOST" "127.0.0.1"+ port <- getEnvDef "PURE_PORT" "5432"+ user <- getEnvDef "PURE_USER" "postgres"+ password <- getEnvDef "PURE_PASSWORD" ""+ database <- getEnvDef "PURE_DATABASE" "postgres"+ connectPostgreSQL $ "host='" ++ host ++ "' port='" ++ port ++ "'user='" ++ user ++"' password = '" ++ password ++ "' dbname = '" ++ database ++ "'"++getEnvDef :: String -> String -> IO String+getEnvDef name value = fromMaybe value <$> lookupEnv name
+ test-db/DataSource/Pure.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE NamedFieldPuns #-}++module DataSource.Pure (connect) where++import Data.Default.Class (def)+import Data.Maybe (fromMaybe)+import qualified Database.PostgreSQL.Pure as Pure+import System.Environment (lookupEnv)++connect :: IO Pure.Connection+connect = do+ host <- getEnvDef "PURE_HOST" "127.0.0.1"+ port <- getEnvDef "PURE_PORT" "5432"+ user <- getEnvDef "PURE_USER" "postgres"+ password <- getEnvDef "PURE_PASSWORD" ""+ database <- getEnvDef "PURE_DATABASE" "postgres"+ let+ config =+ def+ { Pure.address = Pure.AddressNotResolved host port+ , Pure.user+ , Pure.password+ , Pure.database+ }+ Pure.connect config++getEnvDef :: String -> String -> IO String+getEnvDef name value = fromMaybe value <$> lookupEnv name
+ test-db/Relation/Person.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++module Relation.Person where++import DataSource (connect)++import Prelude (Show)++import Database.HDBC.Query.TH (defineTableFromDB)+import Database.HDBC.Schema.PostgreSQL (driverPostgreSQL)+import GHC.Generics (Generic)++defineTableFromDB connect driverPostgreSQL "public" "person" [''Show, ''Generic]
+ test-db/Relation/Pure/Person.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Relation.Pure.Person where++import DataSource.Pure (connect)++import Prelude (Maybe (Just, Nothing), Show (show), fail, length, sequence,+ ($), (<$>), (<*>), (<>))++import Database.PostgreSQL.Pure (FromRecord (fromRecord), Length, ToField (toField),+ ToRecord (toRecord))+import Database.PostgreSQL.Pure.Parser (column)+import Database.Relational.PostgreSQL.Pure.TH (defineTableFromDB)+import Database.Schema.PostgreSQL.Pure (driver)+import GHC.Generics (Generic)++defineTableFromDB connect driver "public" "person" [''Show, ''Generic]++instance FromRecord Person where+ fromRecord decode [i0, i1] = Person <$> column decode i0 <*> column decode i1+ fromRecord _ is = fail $ "length mismatch: expected 2: actual: " <> show (length is)++instance ToRecord Person where+ toRecord backendParams encode Nothing [f0, f1] (Person v0 v1) =+ sequence+ [ toField backendParams encode Nothing f0 v0+ , toField backendParams encode Nothing f1 v1+ ]+ toRecord backendParams encode (Just [o0, o1]) [f0, f1] (Person v0 v1) =+ sequence+ [ toField backendParams encode (Just o0) f0 v0+ , toField backendParams encode (Just o1) f1 v1+ ]+ toRecord _ _ (Just os) [_] _ =+ fail $ "the number of OIDs must be 2, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 2, actually " <> show (length fs)++type instance Length Person = 2
+ test-db/Spec.hs view
@@ -0,0 +1,23 @@+import Database.HDBC.Record (runQuery)+import Database.HDBC.Session (handleSqlError', withConnectionIO)+import Database.PostgreSQL.Pure as Pure+import Database.Relational (relationalQuery)+import Database.Relational.PostgreSQL.Pure.Query as Pure+import Test.Hspec++import qualified DataSource as DS+import qualified DataSource.Pure as DSP+import qualified Relation.Person as Person+import qualified Relation.Pure.Person as PersonPure++{-# ANN module "HLint: ignore Redundant do" #-}++main :: IO ()+main = hspec $ do+ it "run" $ do+ handleSqlError' $ withConnectionIO DS.connect $ \conn -> do+ connPure <- DSP.connect+ persons <- ((\(Person.Person id name) -> (id, name)) <$>) <$> runQuery conn (relationalQuery Person.person) ()+ personsPure <- ((\(PersonPure.Person id name) -> (id, name)) <$>) <$> Pure.runQuery' connPure (relationalQuery PersonPure.person) ()+ Pure.disconnect connPure+ personsPure `shouldBe` persons