relational-query-HDBC-0.6.4.2/0000755000000000000000000000000013206461314014042 5ustar0000000000000000relational-query-HDBC-0.6.4.2/ChangeLog.md0000644000000000000000000000137413206461314016220 0ustar0000000000000000 ## 0.6.4.2 - add an upper bound of version constraint. ## 0.6.4.1 - apply integrated namespace with new exported symbols. ## 0.6.4.0 - add new function name definitions to execute bounded statement. ## 0.6.2.1 - add tested-with 8.2.1. ## 0.6.2.0 - Apply generic instances. ## 0.6.0.2 - Add tested-with. ## 0.6.0.1 - Update compatibility for GHC 8. - Drop old tests of Oracle. ## 0.6.0.0 - Use updated template of persistable-record. - Drop persistableSqlValue. ## 0.5.0.0 - Use updated template of relational-query. - Drop old examples of Oracle. ## 0.4.0.0 - TH quotation of derive class names. ## 0.3.0.0 - Hide chunksInsertActions. - Add withPrepareDelete. ## 0.2.0.0 - Add logging interface for schema driver. relational-query-HDBC-0.6.4.2/relational-query-HDBC.cabal0000644000000000000000000000635613206461314021033 0ustar0000000000000000name: relational-query-HDBC version: 0.6.4.2 synopsis: HDBC instance of relational-query and typed query interface for HDBC description: This package contains the HDBC instance of relational-query and the typed query interface for HDBC. Generating Database table definitions and functions for relational-query by reading table and index definitions from Database system catalogs. homepage: http://khibino.github.io/haskell-relational-record/ license: BSD3 license-file: LICENSE author: Kei Hibino, Shohei Murayama, Shohei Yasutake, Sho KURODA maintainer: ex8k.hibino@gmail.com, shohei.murayama@gmail.com, amutake.s@gmail.com, krdlab@gmail.com copyright: Copyright (c) 2013-2017 Kei Hibino, Shohei Murayama, Shohei Yasutake, Sho KURODA category: Database build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.2.1 , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3 , GHC == 7.4.1, GHC == 7.4.2 extra-source-files: ChangeLog.md library exposed-modules: Database.HDBC.Record.Persistable Database.HDBC.Record.TH Database.HDBC.Record.Statement Database.HDBC.Record.Query Database.HDBC.Record.Update Database.HDBC.Record.Insert Database.HDBC.Record.InsertQuery Database.HDBC.Record.Delete Database.HDBC.Record.KeyUpdate Database.HDBC.Record Database.HDBC.Query.TH Database.HDBC.SqlValueExtra Database.HDBC.Schema.Driver Database.HDBC.Schema.IBMDB2 Database.HDBC.Schema.PostgreSQL Database.HDBC.Schema.SQLServer Database.HDBC.Schema.SQLite3 Database.HDBC.Schema.Oracle Database.HDBC.Schema.MySQL other-modules: Database.HDBC.Record.InternalTH build-depends: base <5 , containers , transformers , convertible , template-haskell , dlist , th-data-compat , names-th , persistable-record >= 0.5 , relational-query >= 0.9.5 && < 0.10 , relational-schemas , HDBC >=2 , HDBC-session hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 source-repository head type: git location: https://github.com/khibino/haskell-relational-record source-repository head type: mercurial location: https://bitbucket.org/khibino/haskell-relational-record relational-query-HDBC-0.6.4.2/LICENSE0000644000000000000000000000275613206461314015061 0ustar0000000000000000Copyright (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. relational-query-HDBC-0.6.4.2/Setup.hs0000644000000000000000000000005613206461314015477 0ustar0000000000000000import Distribution.Simple main = defaultMain relational-query-HDBC-0.6.4.2/src/0000755000000000000000000000000013206461314014631 5ustar0000000000000000relational-query-HDBC-0.6.4.2/src/Database/0000755000000000000000000000000013206461314016335 5ustar0000000000000000relational-query-HDBC-0.6.4.2/src/Database/HDBC/0000755000000000000000000000000013206461314017035 5ustar0000000000000000relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record.hs0000644000000000000000000000206613206461314020613 0ustar0000000000000000-- | -- Module : Database.HDBC.Record -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides merged namespace of -- typed 'Query', 'Insert', 'InsertQuery', 'Update', 'KeyUpdate' and 'Delete' -- running sequences. module Database.HDBC.Record ( module Database.HDBC.Record.Query, module Database.HDBC.Record.Insert, module Database.HDBC.Record.InsertQuery, module Database.HDBC.Record.Update, module Database.HDBC.Record.KeyUpdate, module Database.HDBC.Record.Delete, module Database.HDBC.Record.Statement ) where import Database.HDBC.Record.Query hiding (prepare) import Database.HDBC.Record.Insert hiding (prepare) import Database.HDBC.Record.InsertQuery hiding (prepare) import Database.HDBC.Record.Update hiding (prepare) import Database.HDBC.Record.KeyUpdate hiding (prepare) import Database.HDBC.Record.Delete hiding (prepare) import Database.HDBC.Record.Statement {-# ANN module "HLint: ignore Use import/export shortcut" #-} relational-query-HDBC-0.6.4.2/src/Database/HDBC/SqlValueExtra.hs0000644000000000000000000000215313206461314022132 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS -fno-warn-orphans #-} -- | -- Module : Database.HDBC.SqlValueExtra -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.SqlValueExtra () where import Data.Convertible (Convertible(safeConvert), ConvertResult) import Data.Int (Int8, Int16, Int32) import Database.HDBC (SqlValue) -- Convert from narrower width than Int32 safeConvertFromIntegral32 :: Integral a => a -> ConvertResult SqlValue safeConvertFromIntegral32 i = safeConvert (fromIntegral i :: Int32) safeConvertToIntegral32 :: Integral a => SqlValue -> ConvertResult a safeConvertToIntegral32 v = fmap fromIntegral (safeConvert v :: ConvertResult Int32) instance Convertible Int8 SqlValue where safeConvert = safeConvertFromIntegral32 instance Convertible SqlValue Int8 where safeConvert = safeConvertToIntegral32 instance Convertible Int16 SqlValue where safeConvert = safeConvertFromIntegral32 instance Convertible SqlValue Int16 where safeConvert = safeConvertToIntegral32 relational-query-HDBC-0.6.4.2/src/Database/HDBC/Query/0000755000000000000000000000000013206461314020142 5ustar0000000000000000relational-query-HDBC-0.6.4.2/src/Database/HDBC/Query/TH.hs0000644000000000000000000001642513206461314021021 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Query.TH -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains templates to generate Haskell record types -- and HDBC instances correspond to RDB table schema. module Database.HDBC.Query.TH ( makeRelationalRecord, makeRecordPersistableDefault, defineTableDefault', defineTableDefault, defineTableFromDB', defineTableFromDB, inlineVerifiedQuery ) where import Data.Maybe (listToMaybe, fromMaybe) import qualified Data.Map as Map import Control.Applicative ((<$>), (<*>)) import Control.Monad (when, void) import Database.HDBC (IConnection, SqlValue, prepare) import Language.Haskell.TH (Q, runIO, Name, TypeQ, Dec) import Language.Haskell.TH.Name.CamelCase (varCamelcaseName) import Language.Haskell.TH.Lib.Extra (reportWarning, reportError) import Database.Record (ToSql, FromSql) import Database.Record.TH (recordTemplate, reifyRecordType) import Database.Relational.Query (Config, nameConfig, recordConfig, verboseAsCompilerWarning, defaultConfig, Relation, relationalQuerySQL, QuerySuffix) import qualified Database.Relational.Query.TH as Relational import Database.HDBC.Session (withConnectionIO) import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver (runLog, newLogChan, takeLogs, Driver, getFields, getPrimaryKey) defineInstancesForSqlValue :: TypeQ -- ^ Record type constructor. -> Q [Dec] -- ^ Instance declarations. defineInstancesForSqlValue typeCon = do [d| instance FromSql SqlValue $typeCon instance ToSql SqlValue $typeCon |] -- | Generate all persistable templates against defined record like type constructor. makeRelationalRecord :: Name -- ^ Type constructor name -> Q [Dec] -- ^ Result declaration makeRelationalRecord recTypeName = do rr <- Relational.makeRelationalRecordDefault recTypeName ((typeCon, _), _) <- reifyRecordType recTypeName ps <- defineInstancesForSqlValue typeCon return $ rr ++ ps {-# DEPRECATED makeRecordPersistableDefault "Use makeRelationalRecord instead of this." #-} -- | Deprecated. use 'makeRelationalRecord'. makeRecordPersistableDefault :: Name -- ^ Type constructor name -> Q [Dec] -- ^ Result declaration makeRecordPersistableDefault = makeRelationalRecord -- | 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 <- defineInstancesForSqlValue . 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 sqlvD <- defineInstancesForSqlValue . fst $ recordTemplate (recordConfig $ nameConfig config) schema table return $ modelD ++ sqlvD -- | Generate all HDBC templates using system catalog informations with specified config. defineTableFromDB' :: IConnection conn => IO conn -- ^ Connect action to system catalog database -> Config -- ^ Configuration to generate query with -> Driver conn -- ^ Driver definition -> String -- ^ Schema name -> String -- ^ Table name -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration defineTableFromDB' connect config drv scm tbl derives = do let getDBinfo = do logChan <- newLogChan $ verboseAsCompilerWarning config infoP <- withConnectionIO connect (\conn -> (,) <$> getFields drv conn logChan scm tbl <*> getPrimaryKey drv conn logChan scm tbl) (,) infoP <$> takeLogs logChan (((cols, notNullIdxs), primaryCols), logs) <- runIO getDBinfo mapM_ (runLog 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 defineTableDefault config scm tbl cols derives primaryIxs (listToMaybe notNullIdxs) -- | Generate all HDBC templates using system catalog informations. defineTableFromDB :: IConnection conn => IO conn -- ^ Connect action to system catalog database -> Driver conn -- ^ Driver definition -> String -- ^ Schema name -> String -- ^ Table name -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration defineTableFromDB connect = defineTableFromDB' connect defaultConfig -- | Verify composed 'Query' and inline it in compile type. inlineVerifiedQuery :: IConnection conn => IO conn -- ^ 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 -> QuerySuffix -- ^ suffix SQL words -> String -- ^ Variable name to define as inlined query -> Q [Dec] -- ^ Result declarations inlineVerifiedQuery connect relVar rel config sufs qns = do (p, r) <- Relational.reifyRelation relVar let sql = relationalQuerySQL config rel sufs when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql void . runIO $ withConnectionIO connect (\conn -> prepare conn sql) Relational.unsafeInlineQuery (return p) (return r) sql (varCamelcaseName qns) relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/0000755000000000000000000000000013206461314020253 5ustar0000000000000000relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/Delete.hs0000644000000000000000000000350113206461314022010 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Delete -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'Delete' running sequence -- which intermediate structures are typed. module Database.HDBC.Record.Delete ( PreparedDelete, prepare, prepareDelete, withPrepareDelete, runPreparedDelete, runDelete ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational.Query (Delete) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch) -- | Typed prepared delete type. type PreparedDelete p = PreparedStatement p () -- | Typed prepare delete operation. prepare :: IConnection conn => conn -> Delete p -> IO (PreparedDelete p) prepare = prepareNoFetch -- | Same as 'prepare'. prepareDelete :: IConnection conn => conn -> Delete p -> IO (PreparedDelete p) prepareDelete = prepare -- | Bracketed prepare operation. withPrepareDelete :: IConnection conn => conn -> Delete p -> (PreparedDelete p -> IO a) -> IO a withPrepareDelete = withPrepareNoFetch -- | Bind parameters, execute statement and get execution result. runPreparedDelete :: ToSql SqlValue p => PreparedDelete p -> p -> IO Integer runPreparedDelete = runPreparedNoFetch -- | Prepare delete statement, bind parameters, -- execute statement and get execution result. runDelete :: (IConnection conn, ToSql SqlValue p) => conn -> Delete p -> p -> IO Integer runDelete = runNoFetch relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/Persistable.hs0000644000000000000000000000162013206461314023063 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Database.HDBC.Record.Persistable -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides HDBC instance definitions of DB-record. module Database.HDBC.Record.Persistable () where import Database.Record (PersistableType (..)) import Database.Record.Persistable (unsafePersistableSqlTypeFromNull) import Database.HDBC.Record.InternalTH (derivePersistableInstancesFromConvertibleSqlValues) import Database.HDBC (SqlValue(SqlNull)) instance PersistableType SqlValue where persistableType = unsafePersistableSqlTypeFromNull SqlNull $(derivePersistableInstancesFromConvertibleSqlValues) relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/Insert.hs0000644000000000000000000000705313206461314022060 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Insert -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'Insert' running sequence -- which intermediate structures are typed. module Database.HDBC.Record.Insert ( PreparedInsert, prepare, prepareInsert, runPreparedInsert, runInsert, mapInsert, chunksInsert, ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational.Query (Insert (..), untypeChunkInsert, chunkSizeOfInsert) import Database.Record (ToSql, fromRecord) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, withUnsafePrepare, PreparedStatement, untypePrepared, BoundStatement (..), runPreparedNoFetch, runNoFetch, mapNoFetch, executeNoFetch) -- | Typed prepared insert type. type PreparedInsert a = PreparedStatement a () -- | Typed prepare insert operation. prepare :: IConnection conn => conn -> Insert a -> IO (PreparedInsert a) prepare = prepareNoFetch -- | Same as 'prepare'. prepareInsert :: IConnection conn => conn -> Insert a -> IO (PreparedInsert a) prepareInsert = prepare -- | Bind parameters, execute statement and get execution result. runPreparedInsert :: ToSql SqlValue a => PreparedInsert a -> a -> IO Integer runPreparedInsert = runPreparedNoFetch -- | Prepare insert statement, bind parameters, -- execute statement and get execution result. runInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> a -> IO Integer runInsert = runNoFetch -- | Prepare and insert each record. mapInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO [Integer] mapInsert = mapNoFetch -- | Unsafely bind chunk of records. chunkBind :: ToSql SqlValue p => PreparedStatement [p] () -> [p] -> BoundStatement () chunkBind q ps = BoundStatement { bound = untypePrepared q, params = ps >>= fromRecord } chunks :: Int -> [a] -> [Either [a] [a]] chunks n = rec' where rec' xs | null tl = [ if length c == n then Right c else Left c ] | otherwise = Right c : rec' tl where (c, tl) = splitAt n xs withPrepareChunksInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> (PreparedInsert a -> PreparedStatement [p] () -> Int -> IO b) -> IO b withPrepareChunksInsert conn i0 body = withPrepareNoFetch conn i0 (\ins -> withUnsafePrepare conn (untypeChunkInsert i0) (\iChunk -> body ins iChunk $ chunkSizeOfInsert i0) ) -- Prepare and insert with chunk insert statement. chunksInsertActions :: ToSql SqlValue a => [a] -> PreparedInsert a -> PreparedStatement [a] () -> Int -> IO [[Integer]] chunksInsertActions rs ins iChunk size = mapM insert $ chunks size rs where insert (Right c) = do rv <- executeNoFetch $ chunkBind iChunk c return [rv] insert (Left c) = mapM (runPreparedInsert ins) c -- | Prepare and insert with chunk insert statement. chunksInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO [[Integer]] chunksInsert conn ins rs = withPrepareChunksInsert conn ins $ chunksInsertActions rs relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/TH.hs0000644000000000000000000000231013206461314021116 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -- | -- Module : Database.HDBC.Record.TH -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides DB-record templates depends on HDBC. module Database.HDBC.Record.TH ( derivePersistableInstanceFromConvertible, ) where import Data.Convertible (convert) import Language.Haskell.TH (Q, Dec, Type) import Database.HDBC (SqlValue) import Database.HDBC.SqlValueExtra () import Database.Record (FromSql (..), ToSql(..)) import Database.Record.FromSql (valueRecordFromSql) import Database.Record.ToSql (valueRecordToSql) -- | Template to declare HDBC instances of DB-record against single value type. derivePersistableInstanceFromConvertible :: Q Type -- ^ Type to implement instances -> Q [Dec] -- ^ Result declarations derivePersistableInstanceFromConvertible typ = [d| instance FromSql SqlValue $(typ) where recordFromSql = valueRecordFromSql convert instance ToSql SqlValue $(typ) where recordToSql = valueRecordToSql convert |] relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/InternalTH.hs0000644000000000000000000001034413206461314022621 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -- | -- Module : Database.HDBC.Record.InternalTH -- Copyright : 2013,2014,2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides internal definitions used from DB-record templates. module Database.HDBC.Record.InternalTH ( -- * Persistable instances along with 'Convertible' instances derivePersistableInstancesFromConvertibleSqlValues ) where import Data.Maybe (catMaybes) import Data.Set (Set) import qualified Data.Set as Set import Language.Haskell.TH (Q, Dec, Type(AppT, ConT), Info (ClassI), reify) import Language.Haskell.TH.Compat.Data (unInstanceD) import Data.Convertible (Convertible) import Database.HDBC (SqlValue) import Database.HDBC.SqlValueExtra () import Database.Record (PersistableWidth) import Database.Record.TH (deriveNotNullType) import Database.Record.Instances () import Database.Relational.Query.TH (defineScalarDegree) import Database.HDBC.Record.TH (derivePersistableInstanceFromConvertible) -- | Wrapper type which represents type constructor. newtype TypeCon = TypeCon { unTypeCon :: Type } deriving Eq -- | Ord instance for type constructor. instance Ord TypeCon where TypeCon (ConT an) `compare` TypeCon (ConT bn) = an `compare` bn TypeCon (ConT _) `compare` TypeCon _ = LT TypeCon _ `compare` TypeCon (ConT _) = GT a `compare` b | a == b = EQ | otherwise = EQ -- | Set of 'TypeCon'. type TConSet = Set TypeCon -- | From 'Type' list into 'TConSet'. fromList :: [Type] -> TConSet fromList = Set.fromList . map TypeCon -- | From 'TConSet' into 'Type' list. toList :: TConSet -> [Type] toList = map unTypeCon . Set.toList -- | 'SqlValue' type 'Q'. sqlValueType :: Q Type sqlValueType = [t| SqlValue |] -- | 'Convertble' pairs with 'SqlValue'. convertibleSqlValues' :: Q [(Type, Type)] convertibleSqlValues' = cvInfo >>= d0 where cvInfo = reify ''Convertible unknownDeclaration = fail . ("convertibleSqlValues: Unknown declaration pattern: " ++) d0 (ClassI _ is) = fmap catMaybes $ mapM (d1 . unInstanceD) is where d1 (Just (_cxt, (AppT (AppT (ConT _n) a) b), _ds)) = do qvt <- sqlValueType return $ if qvt == a || qvt == b then case (a, b) of (ConT _, ConT _) -> Just (a, b) _ -> Nothing else Nothing d1 _ = unknownDeclaration $ show is d0 cls = unknownDeclaration $ show cls -- | Get types which are 'Convertible' with. convertibleSqlValues :: Q TConSet convertibleSqlValues = do qvt <- sqlValueType vs <- convertibleSqlValues' let from = fromList . map snd . filter ((== qvt) . fst) $ vs to = fromList . map fst . filter ((== qvt) . snd) $ vs return $ Set.intersection from to -- | Get types which are instance of 'PersistableWith'. persistableWidthTypes :: Q TConSet persistableWidthTypes = cvInfo >>= d0 where cvInfo = reify ''PersistableWidth unknownDeclaration = fail . ("persistableWidthTypes: Unknown declaration pattern: " ++) d0 (ClassI _ is) = fmap fromList $ mapM (d1 . unInstanceD) is where d1 (Just (_cxt, (AppT (ConT _n) a), _ds)) = return a d1 _ = unknownDeclaration $ show is d0 cls = unknownDeclaration $ show cls -- | Map instance declarations. mapInstanceD :: (Q Type -> Q [Dec]) -- ^ Template to declare instances from a type -> [Type] -- ^ Types -> Q [Dec] -- ^ Result declaration template. mapInstanceD fD = fmap concat . mapM (fD . return) -- | Template to declare HDBC instances of DB-record along with 'Convertible' instances. derivePersistableInstancesFromConvertibleSqlValues :: Q [Dec] derivePersistableInstancesFromConvertibleSqlValues = do wds <- persistableWidthTypes svs <- convertibleSqlValues ws <- mapInstanceD deriveNotNullType (toList $ Set.difference svs wds) let svl = toList svs ps <- mapInstanceD derivePersistableInstanceFromConvertible svl ss <- mapInstanceD defineScalarDegree svl return $ ws ++ ps ++ ss relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/KeyUpdate.hs0000644000000000000000000000573113206461314022510 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.KeyUpdate -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'KeyUpdate' running sequence -- which intermediate structures are typed. module Database.HDBC.Record.KeyUpdate ( PreparedKeyUpdate, prepare, prepareKeyUpdate, withPrepareKeyUpdate, bindKeyUpdate, runPreparedKeyUpdate, runKeyUpdate ) where import Control.Exception (bracket) import Database.HDBC (IConnection, SqlValue, Statement) import qualified Database.HDBC as HDBC import Database.Relational.Query (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi) import qualified Database.Relational.Query as Query import Database.Record (ToSql) import Database.HDBC.Record.Statement (BoundStatement (BoundStatement, bound, params), executeNoFetch) -- | Typed prepared key-update type. data PreparedKeyUpdate p a = PreparedKeyUpdate { -- | Key to specify update target records. updateKey :: Pi a p -- | Untyped prepared statement before executed. , preparedKeyUpdate :: Statement } -- | Typed prepare key-update operation. prepare :: IConnection conn => conn -> KeyUpdate p a -> IO (PreparedKeyUpdate p a) prepare conn ku = fmap (PreparedKeyUpdate key) . HDBC.prepare conn $ sql where sql = untypeKeyUpdate ku key = Query.updateKey ku -- | Same as 'prepare'. prepareKeyUpdate :: IConnection conn => conn -> KeyUpdate p a -> IO (PreparedKeyUpdate p a) prepareKeyUpdate = prepare -- | Bracketed prepare operation. withPrepareKeyUpdate :: IConnection conn => conn -> KeyUpdate p a -> (PreparedKeyUpdate p a -> IO b) -> IO b withPrepareKeyUpdate conn ku body = bracket (HDBC.prepare conn sql) HDBC.finish $ body . PreparedKeyUpdate key where sql = untypeKeyUpdate ku key = Query.updateKey ku -- | Typed operation to bind parameters for 'PreparedKeyUpdate' type. bindKeyUpdate :: ToSql SqlValue a => PreparedKeyUpdate p a -> a -> BoundStatement () bindKeyUpdate pre a = BoundStatement { bound = preparedKeyUpdate pre, params = updateValuesWithKey key a } where key = updateKey pre -- | Bind parameters, execute statement and get execution result. runPreparedKeyUpdate :: ToSql SqlValue a => PreparedKeyUpdate p a -> a -> IO Integer runPreparedKeyUpdate pre = executeNoFetch . bindKeyUpdate pre -- | Prepare insert statement, bind parameters, -- execute statement and get execution result. runKeyUpdate :: (IConnection conn, ToSql SqlValue a) => conn -> KeyUpdate p a -> a -> IO Integer runKeyUpdate conn q a = withPrepareKeyUpdate conn q (`runPreparedKeyUpdate` a) relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/Update.hs0000644000000000000000000000406713206461314022040 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Update -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'Update' running sequence -- which intermediate structures are typed. module Database.HDBC.Record.Update ( PreparedUpdate, prepare, prepareUpdate, withPrepareUpdate, runPreparedUpdate, runUpdate, mapUpdate ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational.Query (Update) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch, mapNoFetch) -- | Typed prepared update type. type PreparedUpdate p = PreparedStatement p () -- | Typed prepare update operation. prepare :: IConnection conn => conn -> Update p -> IO (PreparedUpdate p) prepare = prepareNoFetch -- | Same as 'prepare'. prepareUpdate :: IConnection conn => conn -> Update p -> IO (PreparedUpdate p) prepareUpdate = prepare -- | Bracketed prepare operation. withPrepareUpdate :: IConnection conn => conn -> Update p -> (PreparedUpdate p -> IO a) -> IO a withPrepareUpdate = withPrepareNoFetch -- | Bind parameters, execute statement and get execution result. runPreparedUpdate :: ToSql SqlValue p => PreparedUpdate p -> p -> IO Integer runPreparedUpdate = runPreparedNoFetch -- | Prepare update statement, bind parameters, -- execute statement and get execution result. runUpdate :: (IConnection conn, ToSql SqlValue p) => conn -> Update p -> p -> IO Integer runUpdate = runNoFetch -- | Prepare and update with each parameter list. mapUpdate :: (IConnection conn, ToSql SqlValue a) => conn -> Update a -> [a] -> IO [Integer] mapUpdate = mapNoFetch relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/Statement.hs0000644000000000000000000001412313206461314022554 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Statement -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed statement running sequence -- which intermediate structures are typed. module Database.HDBC.Record.Statement ( PreparedStatement, untypePrepared, unsafePrepare, finish, withUnsafePrepare, withPrepareNoFetch, BoundStatement (..), bind', bind, bindTo, ExecutedStatement, executed, result, executeBound, execute, executePrepared, prepareNoFetch, executeBoundNoFetch, executeNoFetch, runPreparedNoFetch, runNoFetch, mapNoFetch, ) where import Control.Exception (bracket) import Database.Relational.Query (UntypeableNoFetch (untypeNoFetch)) import Database.HDBC (IConnection, Statement, SqlValue) import qualified Database.HDBC as HDBC import Database.Record (RecordToSql, ToSql(recordToSql), runFromRecord) -- | Typed prepared statement type. newtype PreparedStatement p a = PreparedStatement { -- | Untyped prepared statement before executed. prepared :: Statement } -- | Typed prepared statement which has bound placeholder parameters. data BoundStatement a = BoundStatement { -- | Untyped prepared statement before executed. bound :: Statement -- | Bound parameters. , params :: [SqlValue] } -- | Typed executed statement. data ExecutedStatement a = ExecutedStatement { -- | Untyped executed statement. executed :: Statement -- | Result of HDBC execute. , result :: Integer } -- | Unsafely untype prepared statement. untypePrepared :: PreparedStatement p a -> Statement untypePrepared = prepared -- | Run prepare and unsafely make Typed prepared statement. unsafePrepare :: IConnection conn => conn -- ^ Database connection -> String -- ^ Raw SQL String -> IO (PreparedStatement p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' unsafePrepare conn = fmap PreparedStatement . HDBC.prepare conn -- | Generalized prepare inferred from 'UntypeableNoFetch' instance. prepareNoFetch :: (UntypeableNoFetch s, IConnection conn) => conn -> s p -> IO (PreparedStatement p ()) prepareNoFetch conn = unsafePrepare conn . untypeNoFetch -- | Close PreparedStatement. Useful for connection pooling cases. finish :: PreparedStatement p a -> IO () finish = HDBC.finish . prepared -- | Bracketed prepare operation. -- Unsafely make Typed prepared statement. withUnsafePrepare :: IConnection conn => conn -- ^ Database connection -> String -- ^ Raw SQL String -> (PreparedStatement p a -> IO b) -> IO b withUnsafePrepare conn qs = bracket (unsafePrepare conn qs) finish -- | Bracketed prepare operation. -- Generalized prepare inferred from 'UntypeableNoFetch' instance. withPrepareNoFetch :: (UntypeableNoFetch s, IConnection conn) => conn -> s p -> (PreparedStatement p () -> IO a) -> IO a withPrepareNoFetch conn s = bracket (prepareNoFetch conn s) finish -- | Typed operation to bind parameters. bind' :: RecordToSql SqlValue p -- ^ Proof object to convert from parameter type 'p' into 'SqlValue' list. -> PreparedStatement p a -- ^ Prepared query to bind to -> p -- ^ Parameter to bind -> BoundStatement a -- ^ Result parameter bound statement bind' toSql q p = BoundStatement { bound = prepared q, params = runFromRecord toSql p } -- | Typed operation to bind parameters. Inferred 'RecordToSql' is used. bind :: ToSql SqlValue p => PreparedStatement p a -> p -> BoundStatement a bind = bind' recordToSql -- | Same as 'bind' except for argument is flipped. bindTo :: ToSql SqlValue p => p -> PreparedStatement p a -> BoundStatement a bindTo = flip bind -- | Typed execute operation. executeBound :: BoundStatement a -> IO (ExecutedStatement a) executeBound bs = do let stmt = bound bs n <- HDBC.execute stmt (params bs) return $ ExecutedStatement stmt n {-# WARNING execute "Use 'executeBound' instead of this. This name will be used for executePrepared function in future release." #-} -- | Use 'executeBound' instead of this. -- WARNING! This name will be used for executePrepared function in future release. execute :: BoundStatement a -> IO (ExecutedStatement a) execute = executeBound -- | Bind parameters, execute prepared statement and get executed statement. executePrepared :: ToSql SqlValue p => PreparedStatement p a -> p -> IO (ExecutedStatement a) executePrepared st = executeBound . bind st -- | Typed execute operation. Only get result. executeBoundNoFetch :: BoundStatement () -> IO Integer executeBoundNoFetch = fmap result . executeBound {- WARNING executeNoFetch "Use 'executeBoundNoFetch' instead of this. This name will be used for runPreparedNoFetch function in future release." -} -- | Use 'executeBoundNoFetch' instead of this. -- WARNING! This name will be used for runPreparedNoFetch function in future release. executeNoFetch :: BoundStatement () -> IO Integer executeNoFetch = executeBoundNoFetch -- | Bind parameters, execute prepared statement and get execution result. runPreparedNoFetch :: ToSql SqlValue a => PreparedStatement a () -> a -> IO Integer runPreparedNoFetch p = executeBoundNoFetch . (p `bind`) -- | Prepare and run sequence for polymorphic no-fetch statement. runNoFetch :: (UntypeableNoFetch s, IConnection conn, ToSql SqlValue a) => conn -> s a -> a -> IO Integer runNoFetch conn s p = withPrepareNoFetch conn s (`runPreparedNoFetch` p) -- | Prepare and run it against each parameter list. mapNoFetch :: (UntypeableNoFetch s, IConnection conn, ToSql SqlValue a) => conn -> s a -> [a] -> IO [Integer] mapNoFetch conn s rs = withPrepareNoFetch conn s (\ps -> mapM (runPreparedNoFetch ps) rs) relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/InsertQuery.hs0000644000000000000000000000404313206461314023102 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.InsertQuery -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'InsertQuery' running sequence -- which intermediate structures are typed. module Database.HDBC.Record.InsertQuery ( PreparedInsertQuery, prepare, prepareInsertQuery, withPrepareInsertQuery, runPreparedInsertQuery, runInsertQuery ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational.Query (InsertQuery) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch) -- | Typed prepared insert query type. type PreparedInsertQuery p = PreparedStatement p () -- | Typed prepare insert-query operation. prepare :: IConnection conn => conn -> InsertQuery p -> IO (PreparedInsertQuery p) prepare = prepareNoFetch -- | Same as 'prepare'. prepareInsertQuery :: IConnection conn => conn -> InsertQuery p -> IO (PreparedInsertQuery p) prepareInsertQuery = prepare -- | Bracketed prepare operation. withPrepareInsertQuery :: IConnection conn => conn -> InsertQuery p -> (PreparedInsertQuery p -> IO a) -> IO a withPrepareInsertQuery = withPrepareNoFetch -- | Bind parameters, execute statement and get execution result. runPreparedInsertQuery :: ToSql SqlValue p => PreparedInsertQuery p -> p -> IO Integer runPreparedInsertQuery = runPreparedNoFetch -- | Prepare insert statement, bind parameters, -- execute statement and get execution result. runInsertQuery :: (IConnection conn, ToSql SqlValue p) => conn -> InsertQuery p -> p -> IO Integer runInsertQuery = runNoFetch relational-query-HDBC-0.6.4.2/src/Database/HDBC/Record/Query.hs0000644000000000000000000001317113206461314021717 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Query -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'Query' running sequence -- which intermediate structures are typed. module Database.HDBC.Record.Query ( PreparedQuery, prepare, prepareQuery, withPrepareQuery, fetch, fetchAll, fetchAll', listToUnique, fetchUnique, fetchUnique', runStatement, runStatement', runPreparedQuery, runPreparedQuery', runQuery, runQuery' ) where import Data.Maybe (listToMaybe) import Database.HDBC (IConnection, Statement, SqlValue) import qualified Database.HDBC as HDBC import Database.Relational.Query (Query, untypeQuery) import Database.Record (ToSql, RecordFromSql, FromSql(recordFromSql), runToRecord) import Database.HDBC.Record.Statement (unsafePrepare, withUnsafePrepare, PreparedStatement, bind, BoundStatement, executeBound, ExecutedStatement, executed) -- | Typed prepared query type. type PreparedQuery p a = PreparedStatement p a -- | Typed prepare query operation. prepare :: IConnection conn => conn -- ^ Database connection -> Query p a -- ^ Typed query -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' prepare conn = unsafePrepare conn . untypeQuery -- | Same as 'prepare'. prepareQuery :: IConnection conn => conn -- ^ Database connection -> Query p a -- ^ Typed query -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' prepareQuery = prepare -- | Bracketed prepare operation. withPrepareQuery :: IConnection conn => conn -- ^ Database connection -> Query p a -- ^ Typed query -> (PreparedQuery p a -> IO b) -- ^ Body action to use prepared statement -> IO b -- ^ Result action withPrepareQuery conn = withUnsafePrepare conn . untypeQuery -- | Polymorphic fetch operation. fetchRecordsExplicit :: Functor f => (Statement -> IO (f [SqlValue]) ) -> RecordFromSql SqlValue a -> ExecutedStatement a -> IO (f a) fetchRecordsExplicit fetchs fromSql es = do rows <- fetchs (executed es) return $ fmap (runToRecord fromSql) rows -- | Fetch a record. fetch :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetch = fetchRecordsExplicit HDBC.fetchRow recordFromSql -- | Lazily Fetch all records. fetchAll :: FromSql SqlValue a => ExecutedStatement a -> IO [a] fetchAll = fetchRecordsExplicit HDBC.fetchAllRows recordFromSql -- | Strict version of 'fetchAll'. fetchAll' :: FromSql SqlValue a => ExecutedStatement a -> IO [a] fetchAll' = fetchRecordsExplicit HDBC.fetchAllRows' recordFromSql -- | Fetch all records but get only first record. -- Expecting result records is unique. fetchUnique :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetchUnique es = do recs <- fetchAll es let z' = listToMaybe recs z <- z' `seq` return z' HDBC.finish $ executed es return z -- | Fetch expecting result records is unique. listToUnique :: [a] -> IO (Maybe a) listToUnique = d where d [] = return Nothing d [r] = return $ Just r d (_:_:_) = fail "fetchUnique': more than one record found." -- | Fetch all records but get only first record. -- Expecting result records is unique. -- Error when records count is more than one. fetchUnique' :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetchUnique' es = do recs <- fetchAll es z <- listToUnique recs HDBC.finish $ executed es return z -- | Execute statement and lazily fetch all records. runStatement :: FromSql SqlValue a => BoundStatement a -> IO [a] runStatement = (>>= fetchAll) . executeBound -- | Strict version of 'runStatement'. runStatement' :: FromSql SqlValue a => BoundStatement a -> IO [a] runStatement' = (>>= fetchAll') . executeBound -- | Bind parameters, execute statement and lazily fetch all records. runPreparedQuery :: (ToSql SqlValue p, FromSql SqlValue a) => PreparedQuery p a -- ^ Statement to bind to -> p -- ^ Parameter type -> IO [a] -- ^ Action to get records runPreparedQuery ps = runStatement . bind ps -- | Strict version of 'runPreparedQuery'. runPreparedQuery' :: (ToSql SqlValue p, FromSql SqlValue a) => PreparedQuery p a -- ^ Statement to bind to -> p -- ^ Parameter type -> IO [a] -- ^ Action to get records runPreparedQuery' ps = runStatement' . bind ps -- | Prepare SQL, bind parameters, execute statement and lazily fetch all records. runQuery :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a) => conn -- ^ Database connection -> Query p a -- ^ Query to get record type 'a' requires parameter 'p' -> p -- ^ Parameter type -> IO [a] -- ^ Action to get records runQuery conn q p = prepare conn q >>= (`runPreparedQuery` p) -- | Strict version of 'runQuery'. runQuery' :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a) => conn -- ^ Database connection -> Query p a -- ^ Query to get record type 'a' requires parameter 'p' -> p -- ^ Parameter type -> IO [a] -- ^ Action to get records runQuery' conn q p = withPrepareQuery conn q (`runPreparedQuery'` p) relational-query-HDBC-0.6.4.2/src/Database/HDBC/Schema/0000755000000000000000000000000013206461314020235 5ustar0000000000000000relational-query-HDBC-0.6.4.2/src/Database/HDBC/Schema/Driver.hs0000644000000000000000000001063113206461314022025 0ustar0000000000000000-- | -- Module : Database.HDBC.Schema.Driver -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides driver interface -- to load database system catalog via HDBC. module Database.HDBC.Schema.Driver ( TypeMap, Log, runLog, LogChan, newLogChan, takeLogs, putWarning, putError, putVerbose, failWith, hoistMaybe, maybeIO, Driver(Driver, typeMap, getFieldsWithMap, getPrimaryKey), emptyDriver, getFields ) where import Database.HDBC (IConnection) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.Monoid (mempty, (<>)) import Data.DList (DList, toList) import Control.Applicative ((<$>), pure, (<*>)) import Control.Monad (MonadPlus, mzero) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..)) import Language.Haskell.TH (TypeQ) -- | 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 = Warning String | Error String -- | Folding operation of 'Log' type. runLog :: (String -> t) -> (String -> t) -> Log -> t runLog wf ef = d where d (Warning m) = wf m d (Error m) = ef m -- | Channel to store compile-time warning messages. data LogChan = LogChan { chan :: IORef (DList Log) , verboseAsWarning :: Bool } -- | Build and return a new instance of 'LogChan'. newLogChan :: Bool -> IO LogChan newLogChan v = LogChan <$> newIORef mempty <*> pure v -- | 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 . Warning -- | 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 -- | Put verbose compile-time message as warning when 'verboseAsWarning'. putVerbose :: LogChan -> String -> IO () putVerbose lchan | verboseAsWarning lchan = putWarning lchan . ("info: " ++) | otherwise = const $ pure () -- | Interface type to load database system catalog via HDBC. data Driver conn = Driver { -- | Custom type mapping of this driver typeMap :: TypeMap -- | Get column name and Haskell type pairs and not-null columns index. , getFieldsWithMap :: TypeMap -- Custom type mapping -> conn -- 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 :: conn -- Connection to query system catalog -> LogChan -> String -- Schema name string -> String -- Table name string -> IO [String] -- Action to get column names of primary key } -- | Empty definition of 'Driver' emptyDriver :: IConnection conn => Driver conn emptyDriver = Driver [] (\_ _ _ _ _ -> return ([],[])) (\_ _ _ _ -> return []) -- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'. getFields :: IConnection conn => Driver conn -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getFields drv = getFieldsWithMap drv (typeMap drv) relational-query-HDBC-0.6.4.2/src/Database/HDBC/Schema/SQLite3.hs0000644000000000000000000001065213206461314022021 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.SQLite3 -- Copyright : 2013 Shohei Murayama -- License : BSD3 -- -- Maintainer : shohei.murayama@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.SQLite3 ( driverSQLite3 ) where import qualified Database.Relational.Schema.SQLite3Syscat.IndexInfo as IndexInfo import qualified Database.Relational.Schema.SQLite3Syscat.IndexList as IndexList import qualified Database.Relational.Schema.SQLite3Syscat.TableInfo as TableInfo import Control.Applicative ((<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Data.List (isPrefixOf, sort, sortBy) import Data.Map (fromList) import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) import Database.Record (FromSql, ToSql) import Database.Relational.Schema.SQLite3 (getType, indexInfoQuerySQL, indexListQuerySQL, normalizeColumn, normalizeType, notNull, tableInfoQuerySQL) import Database.Relational.Schema.SQLite3Syscat.IndexInfo (IndexInfo) import Database.Relational.Schema.SQLite3Syscat.IndexList (IndexList) import Database.Relational.Schema.SQLite3Syscat.TableInfo (TableInfo) import Language.Haskell.TH (TypeQ) instance FromSql SqlValue TableInfo instance ToSql SqlValue TableInfo instance FromSql SqlValue IndexList instance ToSql SqlValue IndexList instance FromSql SqlValue IndexInfo instance ToSql SqlValue IndexInfo logPrefix :: String -> String logPrefix = ("SQLite3: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm tbl = do tblinfo <- runQuery' conn (tableInfoQuerySQL scm tbl) () let primColumns = [ normalizeColumn $ TableInfo.name ti | ti <- tblinfo, TableInfo.pk ti == 1 ] if length primColumns <= 1 then do putLog lchan $ "getPrimaryKey: key=" ++ show primColumns return primColumns else do idxlist <- runQuery' conn (indexListQuerySQL scm tbl) () let idxNames = filter (isPrefixOf "sqlite_autoindex_") . map IndexList.name . filter ((1 ==) . IndexList.unique) $ idxlist idxInfos <- mapM (\ixn -> runQuery' conn (indexInfoQuerySQL scm ixn) ()) idxNames let isPrimaryKey = (sort primColumns ==) . sort . map (normalizeColumn . IndexInfo.name) let idxInfo = concat . take 1 . filter isPrimaryKey $ idxInfos let comp x y = compare (IndexInfo.seqno x) (IndexInfo.seqno y) let primColumns' = map IndexInfo.name . sortBy comp $ idxInfo putLog lchan $ "getPrimaryKey: keys=" ++ show primColumns' return primColumns' getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do rows <- lift $ runQuery' conn (tableInfoQuerySQL scm tbl) () guard (not $ null rows) <|> compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl) let columnId = TableInfo.cid let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows lift . putLog lchan $ "getFields: num of columns = " ++ show (length rows) ++ ", not null columns = " ++ show notNullIdxs let getType' ti = hoistMaybe (getType (fromList tmap) ti) <|> compileError lchan ("Type mapping is not defined against SQLite3 type: " ++ normalizeType (TableInfo.ctype ti)) types <- mapM getType' rows return (types, notNullIdxs) -- | Driver implementation driverSQLite3 :: IConnection conn => Driver conn driverSQLite3 = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } relational-query-HDBC-0.6.4.2/src/Database/HDBC/Schema/IBMDB2.hs0000644000000000000000000000632313206461314021474 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.IBMDB2 -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides driver implementation -- to load IBM-DB2 system catalog via HDBC. module Database.HDBC.Schema.IBMDB2 ( driverIBMDB2 ) where import Prelude hiding (length) import Language.Haskell.TH (TypeQ) import qualified Data.List as List import Data.Char (toUpper) import Data.Map (fromList) import Control.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.Record (FromSql, ToSql) import Database.Relational.Schema.IBMDB2 (normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL) import Database.Relational.Schema.DB2Syscat.Columns (Columns) import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) instance FromSql SqlValue Columns instance ToSql SqlValue Columns logPrefix :: String -> String logPrefix = ("IBMDB2: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm' tbl' = do let tbl = map toUpper tbl' scm = map toUpper scm' primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl) let primaryKeyCols = normalizeColumn <$> primCols putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols return primaryKeyCols getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm' tbl' = maybeIO ([], []) id $ do let tbl = map toUpper tbl' scm = map toUpper scm' cols <- lift $ runQuery' conn columnsQuerySQL (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 (List.length cols) ++ ", not null columns = " ++ show notNullIdxs let getType' col = hoistMaybe (getType (fromList tmap) col) <|> compileError lchan ("Type mapping is not defined against DB2 type: " ++ Columns.typename col) types <- mapM getType' cols return (types, notNullIdxs) -- | Driver implementation driverIBMDB2 :: IConnection conn => Driver conn driverIBMDB2 = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } relational-query-HDBC-0.6.4.2/src/Database/HDBC/Schema/PostgreSQL.hs0000644000000000000000000000725713206461314022607 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.PostgreSQL -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides driver implementation -- to load PostgreSQL system catalog via HDBC. module Database.HDBC.Schema.PostgreSQL ( driverPostgreSQL ) where import Language.Haskell.TH (TypeQ) import Data.Char (toLower) import Data.Map (fromList) import Control.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.Record (FromSql, ToSql) import Database.Relational.Schema.PostgreSQL (normalizeColumn, notNull, getType, columnQuerySQL, primaryKeyLengthQuerySQL, primaryKeyQuerySQL) import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute) import Database.Relational.Schema.PgCatalog.PgType (PgType) import qualified Database.Relational.Schema.PgCatalog.PgType as Type import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) instance FromSql SqlValue PgAttribute instance ToSql SqlValue PgAttribute instance FromSql SqlValue PgType instance ToSql SqlValue PgType 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' :: IConnection conn => conn -> 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 [] -> do putLog lchan "getPrimaryKey: Primary key not found." 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' :: IConnection conn => TypeMap -> conn -> 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' cols <- lift $ 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 driverPostgreSQL :: IConnection conn => Driver conn driverPostgreSQL = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } relational-query-HDBC-0.6.4.2/src/Database/HDBC/Schema/Oracle.hs0000644000000000000000000000634713206461314022010 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.MySQL -- Copyright : 2013 Shohei Yasutake -- License : BSD3 -- -- Maintainer : amutake.s@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.Oracle ( driverOracle ) where import Control.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Data.Char (toUpper) import Data.Map (fromList) import Data.Maybe (catMaybes) import Language.Haskell.TH (TypeQ) import Database.HDBC (IConnection, SqlValue) import Database.Record (FromSql, ToSql) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver ( TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver ) import Database.Relational.Schema.Oracle ( normalizeColumn, notNull, getType , columnsQuerySQL, primaryKeyQuerySQL ) import Database.Relational.Schema.OracleDataDictionary.TabColumns (DbaTabColumns) import qualified Database.Relational.Schema.OracleDataDictionary.TabColumns as Cols instance FromSql SqlValue DbaTabColumns instance ToSql SqlValue DbaTabColumns logPrefix :: String -> String logPrefix = ("Oracle: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -- ^ owner name -> String -- ^ table name -> IO [String] -- ^ primary key names getPrimaryKey' conn lchan owner' tbl' = do let owner = map toUpper owner' tbl = map toUpper tbl' prims <- map normalizeColumn . catMaybes <$> runQuery' conn primaryKeyQuerySQL (owner, tbl) putLog lchan $ "getPrimaryKey: keys = " ++ show prims return prims getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan owner' tbl' = maybeIO ([], []) id $ do let owner = map toUpper owner' tbl = map toUpper tbl' cols <- lift $ runQuery' conn columnsQuerySQL (owner, tbl) guard (not $ null cols) <|> compileError lchan ("getFields: No columns found: owner = " ++ owner ++ ", 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 Oracle DB type: " ++ show (Cols.dataType col)) types <- mapM getType' cols return (types, notNullIdxs) -- | Driver for Oracle DB driverOracle :: IConnection conn => Driver conn driverOracle = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } relational-query-HDBC-0.6.4.2/src/Database/HDBC/Schema/SQLServer.hs0000644000000000000000000000655613206461314022433 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.SQLServer -- Copyright : 2013 Shohei Murayama -- License : BSD3 -- -- Maintainer : shohei.murayama@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.SQLServer ( driverSQLServer, ) where import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types import Control.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Data.Map (fromList) import Data.Maybe (catMaybes) import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) import Database.Record (FromSql, ToSql) import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn, notNull, primaryKeyQuerySQL) import Database.Relational.Schema.SQLServerSyscat.Columns (Columns) import Database.Relational.Schema.SQLServerSyscat.Types (Types) import Language.Haskell.TH (TypeQ) instance FromSql SqlValue Columns instance ToSql SqlValue Columns instance FromSql SqlValue Types instance ToSql SqlValue Types logPrefix :: String -> String logPrefix = ("SQLServer: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm tbl = do prims <- catMaybes <$> runQuery' conn primaryKeyQuerySQL (scm,tbl) let primColumns = map normalizeColumn prims putLog lchan $ "getPrimaryKey: keys=" ++ show primColumns return primColumns getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do rows <- lift $ runQuery' conn columnTypeQuerySQL (scm, tbl) guard (not $ null rows) <|> compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl) let columnId ((cols,_),_) = Columns.columnId cols - 1 let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows lift . putLog lchan $ "getFields: num of columns = " ++ show (length rows) ++ ", not null columns = " ++ show notNullIdxs let getType' rec'@((_,typs),typScms) = hoistMaybe (getType (fromList tmap) rec') <|> compileError lchan ("Type mapping is not defined against SQLServer type: " ++ typScms ++ "." ++ Types.name typs) types <- mapM getType' rows return (types, notNullIdxs) -- | Driver implementation driverSQLServer :: IConnection conn => Driver conn driverSQLServer = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } relational-query-HDBC-0.6.4.2/src/Database/HDBC/Schema/MySQL.hs0000644000000000000000000001025313206461314021537 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.MySQL -- Copyright : 2013 Sho KURODA -- License : BSD3 -- -- Maintainer : krdlab@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.MySQL ( driverMySQL ) where import Prelude hiding (length) 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 qualified Data.List as List import Data.Map (fromList) import Database.HDBC (IConnection, SqlValue) import Database.Record (FromSql, ToSql) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver ( TypeMap , LogChan , putVerbose , failWith , maybeIO , hoistMaybe , Driver , getFieldsWithMap , getPrimaryKey , emptyDriver ) import Database.Relational.Schema.MySQL ( normalizeColumn , notNull , getType , columnsQuerySQL , primaryKeyQuerySQL ) import Database.Relational.Schema.MySQLInfo.Columns (Columns) import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns instance FromSql SqlValue Columns instance ToSql SqlValue Columns logPrefix :: String -> String logPrefix = ("MySQL: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm tbl = do primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl) let primaryKeyCols = normalizeColumn <$> primCols putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols return primaryKeyCols getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do cols <- lift $ runQuery' conn columnsQuerySQL (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 (List.length cols) ++ ", not null columns = " ++ show notNullIdxs types <- mapM getType' cols return (types, notNullIdxs) where getType' col = hoistMaybe (getType (fromList tmap) col) <|> compileError lchan ("Type mapping is not defined against MySQL type: " ++ Columns.dataType col) -- | Driver implementation driverMySQL :: IConnection conn => Driver conn driverMySQL = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' }