persistent-odbc 0.1.2.2 → 0.2.0.0
raw patch · 12 files changed
+560/−227 lines, 12 filesdep +persistent-odbcdep ~basedep ~bytestringdep ~esqueletonew-component:exe:TestODBC
Dependencies added: persistent-odbc
Dependency ranges changed: base, bytestring, esqueleto, persistent, persistent-template, text
Files
- examples/Employment.hs +9/−0
- examples/Test1.hs +276/−0
- examples/TestODBC.hs +31/−15
- persistent-odbc.cabal +36/−8
- src/Database/Persist/MigrateDB2.hs +22/−23
- src/Database/Persist/MigrateMSSQL.hs +20/−21
- src/Database/Persist/MigrateMySQL.hs +21/−22
- src/Database/Persist/MigrateOracle.hs +22/−23
- src/Database/Persist/MigratePostgres.hs +24/−23
- src/Database/Persist/MigrateSqlite.hs +67/−64
- src/Database/Persist/ODBC.hs +30/−26
- src/Database/Persist/ODBCTypes.hs +2/−2
+ examples/Employment.hs view
@@ -0,0 +1,9 @@+-- @Employment.hs +{-# LANGUAGE TemplateHaskell #-} +module Employment where + +import Database.Persist.TH + +data Employment = Employed | Unemployed | Retired + deriving (Show, Read, Eq) +derivePersistField "Employment"
+ examples/Test1.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE GADTs, FlexibleContexts #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveGeneric #-} +module Test1 where + +import qualified Database.Persist as P +import Database.Persist.TH +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger +import Control.Monad.Trans.Resource (runResourceT,MonadResource) +import Control.Monad.Trans.Reader (ask) +import Data.Text (Text) +import qualified Data.Text as T +import Database.Persist.ODBC +--import Data.Conduit +import Data.Aeson +import System.Environment (getArgs) + +import qualified Database.Esqueleto as E +import Database.Esqueleto (select,where_,(^.),from,Value(..)) +import Control.Applicative ((<$>),(<*>)) +import Data.Int +import Debug.Trace +import Control.Monad (when) + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +G0 + g1 String + g2 String + g3 String + deriving Show Eq +G1 + g1 String maxlen=20 + g2 String + g3 String + Primary g1 + deriving Show Eq +G2 + g1 String maxlen=20 + g2 String maxlen=20 + g3 String + Primary g1 g2 + deriving Show Eq +G3 + g1 G0Id + g2 String + g3 String maxlen=20 + Primary g1 g3 -- what does this mean? g1 is a foreign key + deriving Show Eq +TestA + name1 String + name2 String + Unique MyNames name1 name2 + deriving Show Eq +TestBool + mybool Bool + deriving Show Eq +TestTwoStrings + firstname String + lastname String + deriving Show Eq +TableOne json + nameone String + deriving Show Eq +TableTwo json + nametwo String + deriving Show Eq +TableThree json + namethree String + deriving Show Eq +TableFour + namefour Int + deriving Show Eq +TableMany json + refone TableOneId + reftwo TableTwoId + Primary refone reftwo + deriving Show Eq +TableManyMany json + refone TableOneId + reftwo TableTwoId + refthree TableThreeId + Primary refone reftwo refthree + deriving Show Eq +TableU + refone TableOneId + name String + Unique SomeName name + +|] + +updatePersistValue :: Update v -> PersistValue +updatePersistValue (Update a1 v a2) = trace ("updatePersistValue a2="++show a2) $ toPersistValue v + +main :: IO () +main = do + [arg] <- getArgs + let (dbtype',dsn) = + case arg of -- odbc system dsn + "d" -> (DB2,"dsn=db2_test") + "p" -> (Postgres,"dsn=pg_test") + "m" -> (MySQL,"dsn=mysql_test") + "s" -> (MSSQL True,"dsn=mssql_test; Trusted_Connection=True") -- mssql 2012 [full limit and offset support] + "so" -> (MSSQL False,"dsn=mssql_test; Trusted_Connection=True") -- mssql pre 2012 [limit support only] + "o" -> (Oracle False,"dsn=oracle_test") -- pre oracle 12c [no support for limit and offset] + "on" -> (Oracle True,"dsn=oracle_test") -- >= oracle 12c [full limit and offset support] + "q" -> (Sqlite False,"dsn=sqlite_test") + "qn" -> (Sqlite True,"dsn=sqlite_test") + xs -> error $ "unknown option:choose p m s so o on d q qn found[" ++ xs ++ "]" + + runResourceT $ runNoLoggingT $ withODBCConn Nothing dsn $ runSqlConn $ do + conn <- ask + let dbtype::DBType + dbtype=read $ T.unpack $ connRDBMS conn + liftIO $ putStrLn $ "original:" ++ show dbtype' ++ " calculated:" ++ show dbtype + liftIO $ putStrLn "\nbefore migration\n" + runMigration migrateAll + liftIO $ putStrLn "after migration" + + doesq + when True $ dostuff dbtype + +dostuff dbtype = do + z1 <- insert $ TableOne "test1 aa" + z2 <- insert $ TableOne "test1 bb" + a1 <- insert $ TableOne "test1 cc" + liftIO $ putStrLn $ "a1=" ++ show a1 + a2 <- insert $ TableTwo "test2" + liftIO $ putStrLn $ "a2=" ++ show a2 + aa <- selectList ([]::[Filter TableOne]) [] + liftIO $ putStrLn $ "aa=" ++ show aa + + let b=encode $ head aa + liftIO $ putStrLn $ "\ntojson for tableone " ++ show b + + let c=decode' b::Maybe (Entity TableOne) + liftIO $ putStrLn $ "\nfromjson for tableone " ++ show c + + a3 <- insert $ TableMany a1 a2 + liftIO $ putStrLn $ "a3=" ++ show a3 + + bb <- selectList ([]::[Filter TableMany]) [] + liftIO $ putStrLn $ "bb=" ++ show bb ++"\n\n" ++ show (toPersistValue z1) + + zz <- selectList [TableManyRefone <. a1] [Asc TableManyRefone] + liftIO $ putStrLn $ "\n\n!!!TESTING FILTER zz=" ++ show zz ++"\n\n" + + let x=toJSON $ head bb + liftIO $ putStrLn $ "\njson for a single tablemany " ++ show x + + let b=encode $ head bb + liftIO $ putStrLn $ "\ntojson for a single tablemany " ++ show b + + let c=decode' b::Maybe (Entity TableMany) + liftIO $ putStrLn $ "fromjson for tablemany " ++ show c + + let b1=encode bb + liftIO $ putStrLn $ "\ntojson for a list of tablemany " ++ show b1 + + let c1=decode' b1::Maybe [Entity TableMany] + liftIO $ putStrLn $ "\nfromjson for list of tablemany " ++ show c1 + + liftIO $ putStrLn $ "dude=" ++ show (updatePersistValue (TableManyRefone =. z1)) + + p5 <- get a3 + liftIO $ putStrLn $ "after get!!!" + liftIO $ print p5 + + update a3 [TableManyRefone =. z1] + + p5 <- get a1 + liftIO $ putStrLn $ "after normal get!!!" + liftIO $ print p5 + + c1 <- insert $ TableOne "testa" + c2 <- insert $ TableTwo "testb" + c3 <- insert $ TableThree "testc" + m3 <- insert $ TableManyMany c1 c2 c3 + liftIO $ putStrLn $ "m3=" ++ show m3 + + liftIO $ putStrLn $ "before get zzz" + zzz <- get m3 + liftIO $ putStrLn $ "before delete zzz=" ++ show zzz + delete m3 + liftIO $ putStrLn $ "after delete m3" + --zzz <- get m3 + --liftIO $ putStrLn $ "after get again : should have failed zzz=" ++ show zzz + + bb <- selectList ([]::[Filter TableManyMany]) [] + liftIO $ putStrLn $ "bb=" ++ show bb ++"\n\n" +{- + xs <- select $ + from $ \ln -> do + where_ (ln ^. TableManyRefone E.<=. E.val a1) + E.orderBy [E.asc (ln ^. TableManyRefone)] +-- E.limit 3 +-- E.offset 2 + return ln + liftIO $ putStrLn $ show (length xs) ++ " rows: limit=3 offset=2 xs=" ++ show xs +-} + xs <- select $ + from $ \ln -> do + where_ (ln ^. TableOneNameone E.<=. E.val "test1 bb") + E.orderBy [E.asc (ln ^. TableOneNameone)] +-- E.limit 4 +-- E.offset 1 + return ln + liftIO $ putStrLn $ show (length xs) ++ " rows: limit=2 offset=3 xs=" ++ show xs + + a11 <- updateGet a1 [TableOneNameone =. "freee"] + liftIO $ putStrLn $ "a11=" ++ show a11 + case dbtype of + Oracle False -> liftIO $ putStrLn $ "oracle so no selectfirst" + _ -> do + a22 <- selectFirst [TableOneNameone ==. "freee"] [Desc TableOneNameone] + liftIO $ putStrLn $ "a22=" ++ show a22 + a33 <- count [TableOneNameone >=. "a"] + liftIO $ putStrLn $ "a33=" ++ show a33 + + m3 <- insert $ TableManyMany c1 c2 c3 + + a11 <- updateGet m3 [TableManyManyRefone =. c1] + liftIO $ putStrLn $ "a11=" ++ show a11 + case dbtype of + Oracle False -> liftIO $ putStrLn $ "oracle so no selectfirst" + _ -> do + a22 <- selectFirst [TableManyManyReftwo ==. c2] [Desc TableManyManyRefone] + liftIO $ putStrLn $ "a22=" ++ show a22 + a33 <- count [TableManyManyReftwo <=. c2] + liftIO $ putStrLn $ "a33=" ++ show a33 + + a33 <- count ([]::[Filter TableOne]) + liftIO $ putStrLn $ "before =" ++ show a33 + updateWhere [TableOneNameone ==. "freee"] [TableOneNameone =. "dude"] + deleteWhere [TableOneNameone ==. "dude"] + a33 <- count ([]::[Filter TableOne]) + liftIO $ putStrLn $ "after =" ++ show a33 + + p4 <- selectList [TableOneNameone >=. "a"] [] + liftIO $ print p4 + + liftIO $ putStrLn $ "before selectKeys List 111" + p4 <- selectKeysList [TableOneNameone >=. "a"] [] + liftIO $ print p4 + + liftIO $ putStrLn $ "before selectKeys List 222" + p4 <- selectKeysList [TableManyManyReftwo <=. c2] [] + liftIO $ print p4 + +--doesq::IO () +doesq = do + deleteWhere ([]::[Filter G3]) + deleteWhere ([]::[Filter G2]) + deleteWhere ([]::[Filter G1]) + deleteWhere ([]::[Filter G0]) + + g1 <- insert $ G1 "aaa1" "bbb1" "ccc1" + liftIO $ putStrLn $ "g1=" ++ show g1 + g2 <- insert $ G2 "aaa2" "bbb2" "ccc2" + liftIO $ putStrLn $ "g2=" ++ show g2 + + gg1 <- selectList [] [Desc G1G1] + gg2 <- selectList [] [Desc G2G3] + liftIO $ putStrLn $ "gg1=" ++ show gg1 + liftIO $ putStrLn $ "gg2=" ++ show gg2 + + g0 <- insert $ G0 "aaa0" "bbb0" "ccc0" + liftIO $ putStrLn $ "g1=" ++ show g1 + g3 <- insert $ G3 g0 "bbb3" "ccc3" + liftIO $ putStrLn $ "g3=" ++ show g3 + gg3a <- selectList [] [Desc G3G1] + liftIO $ putStrLn $ "gg3a=" ++ show gg3a + gg3b <- selectList [] [Desc G3G3] + liftIO $ putStrLn $ "gg3b=" ++ show gg3b
examples/TestODBC.hs view
@@ -2,11 +2,13 @@ {-# LANGUAGE GADTs, FlexibleContexts #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-} module TestODBC where import Database.Persist import Database.Persist.ODBC import Database.Persist.TH +import Control.Monad.Trans.Reader (ask) import Control.Monad.Trans.Resource (runResourceT,MonadResource,ResourceT) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger @@ -32,7 +34,7 @@ import Text.Blaze.Html --import Debug.Trace -share [mkPersist sqlOnlySettings, mkMigrate "migrateAll", mkDeleteCascade sqlOnlySettings] [persistLowerCase| +share [mkPersist sqlSettings, mkMigrate "migrateAll", mkDeleteCascade sqlOnlySettings] [persistLowerCase| Test0 mybool Bool deriving Show @@ -76,33 +78,33 @@ deriving Show BlogPost title String - authorId PersonzId + refPersonz PersonzId deriving Show Asm - name Text - description Text + name String + description String Unique MyUniqueAsm name -- deriving Typeable deriving Show Xsd - name Text - description Text + name String + description String asmid AsmId Unique MyUniqueXsd name -- global -- deriving Typeable deriving Show Ftype - name Text + name String Unique MyUniqueFtype name -- deriving Typeable deriving Show Line - name Text - description Text + name String + description String pos Int ftypeid FtypeEnum xsdid XsdId @@ -113,8 +115,8 @@ Interface - name Text - fname Text + name String + fname String ftypeid FtypeId iname FtypeEnum Unique MyUniqueInterface name @@ -145,13 +147,27 @@ deriving Show Testlen - txt Text maxlen=5 -- default='xx12' + txt String maxlen=5 -- default='xx12' str String maxlen=5 bs ByteString maxlen=5 - mtxt Text Maybe maxlen=5 + mtxt String Maybe maxlen=5 mstr String Maybe maxlen=5 mbs ByteString Maybe maxlen=5 deriving Show + +Aaaa + name String maxlen=100 + deriving Show Eq + +Bbbb + name String maxlen=100 + deriving Show Eq + +Both + refAaaa AaaaId + refBbbb BbbbId + Primary refAaaa refBbbb + deriving Show Eq |] main :: IO () @@ -172,7 +188,7 @@ xs -> error $ "unknown option:choose p m s so o on d q qn found[" ++ xs ++ "]" runResourceT $ runNoLoggingT $ withODBCConn Nothing dsn $ runSqlConn $ do - conn <- askSqlConn + conn <- ask let dbtype=read $ T.unpack $ connRDBMS conn liftIO $ putStrLn $ "original:" ++ show dbtype' ++ " calculated:" ++ show dbtype liftIO $ putStrLn "\nbefore migration\n" @@ -239,7 +255,7 @@ unless (length aa == 2) $ error $ "wrong number of Testnum rows " ++ show aa delete janeId - deleteWhere [BlogPostAuthorId ==. johnId] + deleteWhere [BlogPostRefPersonz ==. johnId] test0 test1 dbtype test2
persistent-odbc.cabal view
@@ -1,5 +1,5 @@ name: persistent-odbc -version: 0.1.2.2 +version: 0.2.0.0 synopsis: Backend for the persistent library using ODBC license: MIT license-file: LICENSE @@ -38,8 +38,8 @@ ghc-options: -Wall hs-source-dirs: src - build-depends: base >= 4 && < 5 - , text >= 0.7 + build-depends: base >= 4.5 && < 5 + , text >= 0.11.2 && < 1.3 , aeson >= 0.6 , time >= 1.1 , conduit >= 1.0 @@ -51,17 +51,45 @@ , monad-logger , resourcet , monad-control - , persistent-template >= 1.2 && < 1.4 - , persistent >= 1.2 && < 1.4 - , bytestring >= 0.9 + , persistent-template >= 2.1 && < 3 + , persistent >= 2.1 && < 3 + , bytestring >= 0.9 && < 0.11 + if flag(tester) hs-source-dirs: examples exposed-modules: TestODBC , FtypeEnum + , Employment build-depends: blaze-html - , esqueleto - + , esqueleto >= 2.1 && < 3 +Executable TestODBC + if flag(tester) + build-depends: base >= 4.5 && < 5 + , persistent-odbc + , blaze-html + , esqueleto >= 2.1 && < 3 + , text >= 0.11.2 && < 1.3 + , aeson >= 0.6 + , time >= 1.1 + , conduit >= 1.0 + , containers >= 0.4 + , transformers >= 0.3 + , convertible >= 1.0 + , HDBC >= 2.2 + , HDBC-odbc >= 2.2 + , monad-logger + , resourcet + , monad-control + , persistent-template >= 2.1 && < 3 + , persistent >= 2.1 && < 3 + , bytestring >= 0.9 && < 0.11 + else + buildable: False + Main-Is: TestODBC.hs + Hs-Source-Dirs: examples + Other-Modules: FtypeEnum, Employment,Test1 + source-repository head type: git location: git://github.com/gbwey/persistent-odbc.git
src/Database/Persist/MigrateDB2.hs view
@@ -25,6 +25,7 @@ import Database.Persist.Sql import Database.Persist.ODBCTypes +import Data.Acquire (with) #if DEBUG import Debug.Trace @@ -48,10 +49,9 @@ -- | Create the migration plan for the given 'PersistEntity' -- @val@. -migrate' :: Show a - => [EntityDef a] +migrate' :: [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = do let name = entityDB val @@ -66,10 +66,10 @@ ([], [], _) -> do let idtxt = case entityPrimary val of Just pdef -> tracex ("found it!!! val=" ++ show val) $ - concat [" CONSTRAINT ", escapeDBName (pkeyName (entityDB val)), " PRIMARY KEY (", intercalate "," $ map (escapeDBName . snd) $ primaryFields pdef, ")"] + concat [" CONSTRAINT ", escapeDBName (pkeyName (entityDB val)), " PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef, ")"] Nothing -> tracex ("not found val=" ++ show val) $ - concat [escapeDBName $ entityID val - , " BIGINT NOT NULL GENERATED ALWAYS AS IDENTITY (START WITH 1, INCREMENT BY 1) PRIMARY KEY "] + concat [escapeDBName $ fieldDB $ entityId val + , " SMALLINT NOT NULL GENERATED ALWAYS AS IDENTITY (START WITH 1, INCREMENT BY 1) PRIMARY KEY "] let addTable = AddTable $ concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " @@ -89,7 +89,7 @@ tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) - let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\(_,b,_,d) -> (b,d)) (foreignFields fdef)) + let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ map showAlterDb $ addTable : uniques ++ foreigns ++ foreignsAlt @@ -113,7 +113,7 @@ DBName $ T.concat [table, "_pkey"] -- | Find out the type of a column. -findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -124,8 +124,8 @@ return (fieldType fieldDef) --- | Helper for 'AddRefence' that finds out the 'entityID'. -addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +-- | Helper for 'AddRefence' that finds out the 'entityId'. +addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ AddReference reftable fkeyname [cname] [id_] where @@ -133,7 +133,7 @@ ++ " (allDefs = " ++ show allDefs ++ ")") id $ do entDef <- find ((== reftable) . entityDB) allDefs - return (entityID entDef) + return (fieldDB (entityId entDef)) data AlterColumn = Change Column | IsNull @@ -165,7 +165,7 @@ -- | Returns all of the 'Column'@s@ in the given table currently -- in the database. getColumns :: (Text -> IO Statement) - -> EntityDef a + -> EntityDef -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column , [Either Text (Either Column (DBName, [DBName]))] -- everything else ) @@ -184,7 +184,7 @@ ,"AND tabname=? " ,"AND colname <> ?"] - inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries -- Find out all columns. @@ -200,7 +200,7 @@ ,"WHERE tabschema=current_schema " ,"AND tabname=? " ,"AND colname <> ?"] - inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries -- Find out the constraints. @@ -224,13 +224,13 @@ ,"AND trim(pk_colnames) <> ? " ,"ORDER BY constraint_name, column_name"] - us <- runResourceT $ stmtQuery stmtCntrs (vals++vals) $$ helperCntrs + us <- with (stmtQuery stmtCntrs (vals++vals)) ($$ helperCntrs) liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us -- Return both return (ids, cs ++ us) where vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ entityID def ] + , PersistText $ unDBName $ fieldDB $ entityId def ] helperClmns = CL.mapM getIt =$ CL.consume where @@ -289,7 +289,7 @@ let vars = [ PersistText $ unDBName tname , PersistByteString cname ] - cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> @@ -321,7 +321,7 @@ parseType "DATE" _ _ = return SqlDay parseType "CHARACTER" _ _ = return SqlBool parseType "TIMESTAMP" _ _ = return SqlDayTime -parseType "TIMESTAMP WITH TIMEZONE" _ _ = return SqlDayTimeZoned +--parseType "TIMESTAMP WITH TIMEZONE" _ _ = return SqlDayTimeZoned parseType "FLOAT" _ _ = return SqlReal parseType "DOUBLE" _ _ = return SqlReal parseType "DECIMAL" _ _ = return SqlReal @@ -340,8 +340,7 @@ -- | @getAlters allDefs tblName new old@ finds out what needs to -- be changed from @old@ to become @new@. -getAlters :: Show a - => [EntityDef a] +getAlters :: [EntityDef] -> DBName -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) @@ -378,7 +377,7 @@ -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of @@ -454,7 +453,7 @@ showSqlType SqlDay _ = "DATE" showSqlType SqlTime _ = "TIME" showSqlType SqlDayTime _ = "TIMESTAMP" -showSqlType SqlDayTimeZoned _ = "TIMESTAMP WITH TIME ZONE" +--showSqlType SqlDayTimeZoned _ = "TIMESTAMP WITH TIME ZONE" showSqlType SqlBlob _ = "BLOB" showSqlType SqlBool Nothing = "CHARACTER" showSqlType SqlBool (Just 1) = "CHARACTER" @@ -601,7 +600,7 @@ go ( x :xs) = x : go xs go "" = "\"" -- | SQL code to be executed when inserting an entity. -insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of Just _pdef ->
src/Database/Persist/MigrateMSSQL.hs view
@@ -26,6 +26,7 @@ import Database.Persist.Sql import Database.Persist.ODBCTypes +import Data.Acquire (with) #if DEBUG import Debug.Trace @@ -49,10 +50,9 @@ -- | Create the migration plan for the given 'PersistEntity' -- @val@. -migrate' :: Show a - => [EntityDef a] +migrate' :: [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = do let name = entityDB val @@ -66,8 +66,8 @@ -- Nothing found, create everything ([], [], _) -> do let idtxt = case entityPrimary val of - Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . snd) $ primaryFields pdef, ")"] - Nothing -> concat [escapeDBName $ entityID val, " BIGINT NOT NULL IDENTITY(1,1) PRIMARY KEY "] + Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef, ")"] + Nothing -> concat [escapeDBName $ fieldDB $ entityId val, " INT NOT NULL IDENTITY(1,1) PRIMARY KEY "] let addTable = AddTable $ concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " @@ -87,7 +87,7 @@ tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) - let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\(_,b,_,d) -> (b,d)) (foreignFields fdef)) + let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ map showAlterDb $ addTable : uniques ++ foreigns ++ foreignsAlt @@ -108,7 +108,7 @@ -- | Find out the type of a column. -findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -119,8 +119,8 @@ return (fieldType fieldDef) --- | Helper for 'AddRefence' that finds out the 'entityID'. -addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +-- | Helper for 'AddRefence' that finds out the 'entityId'. +addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ AddReference reftable fkeyname [cname] [id_] where @@ -128,7 +128,7 @@ ++ " (allDefs = " ++ show allDefs ++ ")") id $ do entDef <- find ((== reftable) . entityDB) allDefs - return (entityID entDef) + return (fieldDB $ entityId entDef) data AlterColumn = Change Column | Add' Column @@ -158,7 +158,7 @@ -- | Returns all of the 'Column'@s@ in the given table currently -- in the database. getColumns :: (Text -> IO Statement) - -> EntityDef a + -> EntityDef -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column , [Either Text (Either Column (DBName, [DBName]))] -- everything else ) @@ -172,7 +172,7 @@ ,"FROM INFORMATION_SCHEMA.COLUMNS " ,"WHERE TABLE_NAME = ? " ,"AND COLUMN_NAME = ?"] - inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries -- Find out all columns. @@ -192,7 +192,7 @@ ] --liftIO $ putStrLn $ "sql=" ++ show sql stmtClmns <- getter sql - inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries -- Find out the constraints. @@ -206,13 +206,13 @@ ,"AND not exists (select 1 from INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC where rc.CONSTRAINT_NAME=p.CONSTRAINT_NAME) " ,"ORDER BY CONSTRAINT_NAME, " ,"COLUMN_NAME"] - us <- runResourceT $ stmtQuery stmtCntrs vals $$ helperCntrs + us <- with (stmtQuery stmtCntrs vals) ($$ helperCntrs) liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us -- Return both return (ids, cs ++ us) where vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ entityID def ] + , PersistText $ unDBName $ fieldDB $ entityId def ] helperClmns = CL.mapM getIt =$ CL.consume where @@ -288,7 +288,7 @@ let vars = [ PersistText $ unDBName tname , PersistByteString cname ] - cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> @@ -356,8 +356,7 @@ -- | @getAlters allDefs tblName new old@ finds out what needs to -- be changed from @old@ to become @new@. -getAlters :: Show a - => [EntityDef a] +getAlters :: [EntityDef] -> DBName -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) @@ -394,7 +393,7 @@ -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of @@ -462,7 +461,7 @@ showSqlType SqlBool _ = "TINYINT" showSqlType SqlDay _ = "DATE" showSqlType SqlDayTime _ = "DATETIME2" -showSqlType SqlDayTimeZoned _ = "VARCHAR(50)" +--showSqlType SqlDayTimeZoned _ = "VARCHAR(50)" showSqlType SqlInt32 _ = "INT" showSqlType SqlInt64 _ = "BIGINT" showSqlType SqlReal _ = "REAL" @@ -588,7 +587,7 @@ go ( x :xs) = x : go xs go "" = "]" -- | SQL code to be executed when inserting an entity. -insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of Just _pdef ->
src/Database/Persist/MigrateMySQL.hs view
@@ -26,6 +26,7 @@ import Database.Persist.Sql import Database.Persist.ODBCTypes +import Data.Acquire (with) #if DEBUG import Debug.Trace @@ -50,10 +51,9 @@ -- | Create the migration plan for the given 'PersistEntity' -- @val@. -migrate' :: Show a - => [EntityDef a] +migrate' :: [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = do let name = entityDB val @@ -67,8 +67,8 @@ -- Nothing found, create everything ([], [], _) -> do let idtxt = case entityPrimary val of - Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . snd) $ primaryFields pdef, ")"] - Nothing -> concat [escapeDBName $ entityID val, " BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"] + Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef, ")"] + Nothing -> concat [escapeDBName $ fieldDB $ entityId val, " int NOT NULL AUTO_INCREMENT PRIMARY KEY"] let addTable = AddTable $ concat -- Lower case e: see Database.Persist.Sql.Migration @@ -89,7 +89,7 @@ tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) - let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\(_,b,_,d) -> (b,d)) (foreignFields fdef)) + let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ map showAlterDb $ addTable : uniques ++ foreigns ++ foreignsAlt @@ -110,7 +110,7 @@ -- | Find out the type of a column. -findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -121,8 +121,8 @@ return (fieldType fieldDef) --- | Helper for 'AddRefence' that finds out the 'entityID'. -addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +-- | Helper for 'AddRefence' that finds out the 'entityId'. +addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ AddReference reftable fkeyname [cname] [id_] where @@ -130,7 +130,7 @@ ++ " (allDefs = " ++ show allDefs ++ ")") id $ do entDef <- find ((== reftable) . entityDB) allDefs - return (entityID entDef) + return (fieldDB $ entityId entDef) data AlterColumn = Change Column | Add' Column @@ -160,7 +160,7 @@ -- | Returns all of the 'Column'@s@ in the given table currently -- in the database. getColumns :: (Text -> IO Statement) - -> EntityDef a + -> EntityDef -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column , [Either Text (Either Column (DBName, [DBName]))] -- everything else ) @@ -175,7 +175,7 @@ ,"WHERE table_schema=schema() " ,"AND TABLE_NAME = ? " ,"AND COLUMN_NAME = ?"] - inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries -- Find out all columns. @@ -188,7 +188,7 @@ ,"WHERE table_schema=schema() " ,"AND TABLE_NAME = ? " ,"AND COLUMN_NAME <> ?"] - inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries -- Find out the constraints. @@ -203,13 +203,13 @@ ,"AND REFERENCED_TABLE_SCHEMA IS NULL " ,"ORDER BY CONSTRAINT_NAME, " ,"COLUMN_NAME"] - us <- runResourceT $ stmtQuery stmtCntrs vals $$ helperCntrs + us <- with (stmtQuery stmtCntrs vals) ($$ helperCntrs) liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us -- Return both return (ids, cs ++ us) where vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ entityID def ] + , PersistText $ unDBName $ fieldDB $ entityId def ] helperClmns = CL.mapM getIt =$ CL.consume where @@ -269,7 +269,7 @@ let vars = [ PersistText $ unDBName tname , PersistByteString cname ] - cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> @@ -338,8 +338,7 @@ -- | @getAlters allDefs tblName new old@ finds out what needs to -- be changed from @old@ to become @new@. -getAlters :: Show a - => [EntityDef a] +getAlters :: [EntityDef] -> DBName -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) @@ -376,7 +375,7 @@ -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of @@ -448,8 +447,8 @@ showSqlType SqlBlob (Just i) = "VARBINARY(" ++ show i ++ ")" showSqlType SqlBool _ = "TINYINT(1)" showSqlType SqlDay _ = "DATE" -showSqlType SqlDayTime _ = "VARCHAR(50) CHARACTER SET utf8" -- "DATETIME" -showSqlType SqlDayTimeZoned _ = "VARCHAR(50) CHARACTER SET utf8" +showSqlType SqlDayTime _ = "DATETIME" -- "VARCHAR(50) CHARACTER SET utf8" +--showSqlType SqlDayTimeZoned _ = "VARCHAR(50) CHARACTER SET utf8" showSqlType SqlInt32 _ = "INT" showSqlType SqlInt64 _ = "BIGINT" showSqlType SqlReal _ = "DOUBLE PRECISION" @@ -583,7 +582,7 @@ go ( x :xs) = x : go xs go "" = "`" -- | SQL code to be executed when inserting an entity. -insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of Just _pdef ->
src/Database/Persist/MigrateOracle.hs view
@@ -25,6 +25,7 @@ import Data.Monoid ((<>)) import Database.Persist.Sql import Database.Persist.ODBCTypes +import Data.Acquire (with) #if DEBUG import Debug.Trace @@ -47,10 +48,9 @@ getMigrationStrategy dbtype = error $ "Oracle: calling with invalid dbtype " ++ show dbtype -- | Create the migration plan for the given 'PersistEntity' -- @val@. -migrate' :: Show a - => [EntityDef a] +migrate' :: [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = do let name = entityDB val @@ -66,8 +66,8 @@ -- Nothing found, create everything ([], [], _, _) -> do let idtxt = case entityPrimary val of - Just pdef -> " CONSTRAINT " <> escapeDBName (pkeyName (entityDB val)) <> " PRIMARY KEY (" <> (intercalate "," $ map (escapeDBName . snd) $ primaryFields pdef) <> ")" - Nothing -> concat [escapeDBName $ entityID val, " NUMBER NOT NULL PRIMARY KEY "] + Just pdef -> " CONSTRAINT " <> escapeDBName (pkeyName (entityDB val)) <> " PRIMARY KEY (" <> (intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef) <> ")" + Nothing -> concat [escapeDBName $ fieldDB $ entityId val, " NUMBER NOT NULL PRIMARY KEY "] let addTable = AddTable $ concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " @@ -87,7 +87,7 @@ tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ return $ AlterColumn name (refTblName, addReference allDefs (refName name cname) refTblName cname) - let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\(_,b,_,d) -> (b,d)) (foreignFields fdef)) + let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ map showAlterDb $ addTable : addSequence : uniques ++ foreigns ++ foreignsAlt @@ -108,7 +108,7 @@ -- | Find out the type of a column. -findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn :: [EntityDef] -> DBName -> DBName -> (DBName, FieldType) findTypeOfColumn allDefs name col = maybe (error $ "Could not find type of column " ++ show col ++ " on table " ++ show name ++ @@ -119,8 +119,8 @@ return (fieldType fieldDef) --- | Helper for 'AddRefence' that finds out the 'entityID'. -addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +-- | Helper for 'AddRefence' that finds out the 'entityId'. +addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ AddReference reftable fkeyname [cname] [id_] where @@ -128,7 +128,7 @@ ++ " (allDefs = " ++ show allDefs ++ ")") id $ do entDef <- find ((== reftable) . entityDB) allDefs - return (entityID entDef) + return (fieldDB $ entityId entDef) data AlterColumn = Change Column | Add' Column @@ -158,7 +158,7 @@ -- | Returns all of the 'Column'@s@ in the given table currently -- in the database. getColumns :: (Text -> IO Statement) - -> EntityDef a + -> EntityDef -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column , [Either Text (Either Column (DBName, [DBName]))] -- everything else , Maybe PersistValue -- sequence name @@ -173,14 +173,14 @@ ,"FROM user_tab_cols " ,"WHERE TABLE_NAME = ? " ,"AND COLUMN_NAME = ?"] - inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries -- Find if sequence already exists. stmtSeq <- getter $ T.concat ["SELECT sequence_name " ,"FROM user_sequences " ,"WHERE sequence_name = ?"] - seqlist <- runResourceT $ stmtQuery stmtSeq [PersistText $ getSeqNameUnescaped $ entityDB def] $$ CL.consume + seqlist <- with (stmtQuery stmtSeq [PersistText $ getSeqNameUnescaped $ entityDB def]) ($$ CL.consume) --liftIO $ putStrLn $ "seqlist=" ++ show seqlist -- Find out all columns. @@ -191,7 +191,7 @@ ,"FROM user_tab_cols " ,"WHERE TABLE_NAME = ? " ,"AND COLUMN_NAME <> ?"] - inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries -- Find out the constraints. @@ -207,7 +207,7 @@ ,"AND a.COLUMN_NAME <> ? " ,"ORDER BY b.CONSTRAINT_NAME, " ,"a.COLUMN_NAME"] - us <- runResourceT $ stmtQuery stmtCntrs vals $$ helperCntrs + us <- with (stmtQuery stmtCntrs vals) ($$ helperCntrs) -- Return both return (ids, cs ++ us, listAsMaybe seqlist) @@ -217,7 +217,7 @@ listAsMaybe xs = error $ "returned to many sequences xs=" ++ show xs vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ entityID def ] + , PersistText $ unDBName $ fieldDB $ entityId def ] helperClmns = CL.mapM getIt =$ CL.consume where @@ -284,7 +284,7 @@ let vars = [ PersistText $ unDBName tname , PersistByteString cname ] - cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref]] -> @@ -353,8 +353,7 @@ -- | @getAlters allDefs tblName new old@ finds out what needs to -- be changed from @old@ to become @new@. -getAlters :: Show a - => [EntityDef a] +getAlters :: [EntityDef] -> DBName -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) @@ -391,7 +390,7 @@ -- | @findAlters newColumn oldColumns@ finds out what needs to be -- changed in the columns @oldColumns@ for @newColumn@ to be -- supported. -findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters :: DBName -> [EntityDef] -> Column -> [Column] -> ([AlterColumn'], [Column]) findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of @@ -466,7 +465,7 @@ showSqlType SqlBool _ = "CHAR" showSqlType SqlDay _ = "DATE" showSqlType SqlDayTime _ = "TIMESTAMP(6)" -showSqlType SqlDayTimeZoned _ = "VARCHAR2(50)" +--showSqlType SqlDayTimeZoned _ = "VARCHAR2(50)" showSqlType SqlInt32 _ = "NUMBER" showSqlType SqlInt64 _ = "NUMBER" showSqlType SqlReal _ = "FLOAT" @@ -608,7 +607,7 @@ go ( x :xs) = x : go xs go "" = "\"" -- | SQL code to be executed when inserting an entity. -insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of Just _pdef -> @@ -628,7 +627,7 @@ [ "INSERT INTO " , escapeDBName $ entityDB ent , "(" - , escapeDBName $ entityID ent + , escapeDBName $ fieldDB $ entityId ent , if null (entityFields ent) then "" else "," , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent , ") VALUES("
src/Database/Persist/MigratePostgres.hs view
@@ -26,6 +26,7 @@ import qualified Data.Text.Encoding as T import Database.Persist.ODBCTypes +import Data.Acquire (with) #if DEBUG import Debug.Trace @@ -47,9 +48,9 @@ } getMigrationStrategy dbtype = error $ "Postgres: calling with invalid dbtype " ++ show dbtype -migrate' :: [EntityDef a] +migrate' :: [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do let name = entityDB val @@ -64,8 +65,8 @@ if null old then do let idtxt = case entityPrimary val of - Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (T.unpack . escape . snd) $ primaryFields pdef, ")"] - Nothing -> concat [T.unpack $ escape $ entityID val + Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (T.unpack . escape . fieldDB) $ compositeFields pdef, ")"] + Nothing -> concat [T.unpack $ escape $ fieldDB $ entityId val , " SERIAL PRIMARY KEY UNIQUE"] let addTable = AddTable $ concat -- Lower case e: see Database.Persist.Sql.Migration @@ -80,7 +81,7 @@ let uniques = flip concatMap udspair $ \(uname, ucols) -> [AlterTable name $ AddUniqueConstraint uname ucols] references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } -> getAddReference allDefs name refTblName cname (cReference c)) $ filter (\c -> cReference c /= Nothing) newcols - foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\(_,b,_,d) -> (b,d)) (foreignFields fdef)) + foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs return $ Right $ addTable : uniques ++ references ++ foreignsAlt else do @@ -106,7 +107,7 @@ -- | Returns all of the columns in the given table currently in the database. getColumns :: (Text -> IO Statement) - -> EntityDef a + -> EntityDef -> IO [Either Text (Either Column (DBName, [DBName]))] getColumns getter def = do let sqlv=concat ["SELECT " @@ -125,9 +126,9 @@ stmt <- getter $ pack sqlv let vals = [ PersistText $ unDBName $ entityDB def - , PersistText $ unDBName $ entityID def + , PersistText $ unDBName $ fieldDB $ entityId def ] - cs <- runResourceT $ stmtQuery stmt vals $$ helperClmns + cs <- with (stmtQuery stmt vals) ($$ helperClmns) let sqlc=concat ["SELECT " ,"c.constraint_name, " ,"c.column_name " @@ -147,7 +148,7 @@ stmt' <- getter $ pack sqlc - us <- runResourceT $ stmtQuery stmt' vals $$ helperU + us <- with (stmtQuery stmt' vals) ($$ helperU) liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us return $ cs ++ us where @@ -183,14 +184,14 @@ -} -- | Check if a column name is listed as the "safe to remove" in the entity -- list. -safeToRemove :: EntityDef a -> DBName -> Bool +safeToRemove :: EntityDef -> DBName -> Bool safeToRemove def (DBName colName) = any (elem "SafeToRemove" . fieldAttrs) $ filter ((== (DBName colName)) . fieldDB) $ entityFields def -getAlters :: [EntityDef a] - -> EntityDef SqlType +getAlters :: [EntityDef] + -> EntityDef -> ([Column], [(DBName, [DBName])]) -> ([Column], [(DBName, [DBName])]) -> ([AlterColumn'], [AlterTable]) @@ -270,17 +271,17 @@ let ref = refName tname cname stmt <- getter sql - runResourceT $ stmtQuery stmt + with (stmtQuery stmt [ PersistText $ unDBName tname , PersistText $ unDBName ref - ] $$ do + ]) ($$ do m <- CL.head return $ case m of Just [PersistText _table, PersistText _col, PersistText reftable, PersistText _refcol, PersistInt64 _pos] -> Just (DBName reftable, ref) Just [PersistByteString _table, PersistByteString _col, PersistByteString reftable, PersistByteString _refcol, PersistInt64 _pos] -> Just (DBName (T.decodeUtf8 reftable), ref) Nothing -> Nothing - _ -> error $ "unexpected result found ["++ show m ++ "]" + _ -> error $ "unexpected result found ["++ show m ++ "]" ) d' = case d of PersistNull -> Right Nothing PersistText t -> Right $ Just t @@ -292,7 +293,7 @@ getType "date" = Right $ SqlDay getType "bool" = Right $ SqlBool getType "timestamp" = Right $ SqlDayTime - getType "timestamptz" = Right $ SqlDayTimeZoned +-- getType "timestamptz" = Right $ SqlDayTimeZoned getType "float4" = Right $ SqlReal getType "float8" = Right $ SqlReal getType "bytea" = Right $ SqlBlob @@ -305,7 +306,7 @@ getColumn _ a2 x = return $ Left $ pack $ "Invalid result from information_schema: " ++ show x ++ " a2[" ++ show a2 ++ "]" -findAlters :: [EntityDef a] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters :: [EntityDef] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column]) findAlters defs tablename col@(Column name isNull sqltype def _defConstraintName _maxLen ref) cols = tracex ("\n\n\nfindAlters tablename="++show tablename++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of [] -> ([(name, Add' col)], cols) @@ -316,7 +317,7 @@ refAdd Nothing = [] refAdd (Just (tname, a)) = tracex ("\n\n\n33333 findAlters adding fkey defConstraintName'="++show defConstraintName' ++" name="++show name++" tname="++show tname++" a="++show a++" tablename="++show tablename++"\n\n\n") $ case find ((==tname) . entityDB) defs of - Just refdef -> [(tname, AddReference a [name] [entityID refdef])] + Just refdef -> [(tname, AddReference a [name] [fieldDB $ entityId refdef])] Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]" modRef = tracex ("modType: sqltype[" ++ show sqltype ++ "] sqltype'[" ++ show sqltype' ++ "] name=" ++ show name) $ if fmap snd ref == fmap snd ref' @@ -354,7 +355,7 @@ cmpdef _ _ = False -- | Get the references to be added to a table for the given column. -getAddReference :: [EntityDef a] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB +getAddReference :: [EntityDef] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB getAddReference allDefs table reftable cname ref = case ref of Nothing -> Nothing @@ -364,7 +365,7 @@ id_ = maybe (error $ "Could not find ID of entity " ++ show reftable) id $ do entDef <- find ((== reftable) . entityDB) allDefs - return (entityID entDef) + return (fieldDB $ entityId entDef) showColumn :: Column -> String @@ -389,7 +390,7 @@ showSqlType SqlDay _ = "DATE" showSqlType SqlTime _ = "TIME" showSqlType SqlDayTime _ = "TIMESTAMP" -showSqlType SqlDayTimeZoned _ = "TIMESTAMP WITH TIME ZONE" +--showSqlType SqlDayTimeZoned _ = "TIMESTAMP WITH TIME ZONE" showSqlType SqlBlob _ = "BYTEA" showSqlType SqlBool _ = "BOOLEAN" showSqlType (SqlOther t) _ = T.unpack t @@ -523,7 +524,7 @@ udToPair :: UniqueDef -> (DBName, [DBName]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) -insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = tracex ("\n\n\nGBTEST " ++ show (entityFields ent) ++ "\n\n\n") $ case entityPrimary ent of Just _pdef -> @@ -546,5 +547,5 @@ , ") VALUES(" , intercalate "," (map (const "?") $ entityFields ent) , ") RETURNING " - , T.unpack $ escape $ entityID ent + , T.unpack $ escape $ fieldDB $ entityId ent ]
src/Database/Persist/MigrateSqlite.hs view
@@ -10,7 +10,6 @@ import Data.List (intercalate) import Data.Text (Text, pack) -import Control.Monad.Trans.Resource (runResourceT) import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Text as T @@ -18,6 +17,8 @@ import Database.Persist.Sql import Database.Persist.ODBCTypes +import Data.Acquire (with) +import Data.Monoid ((<>)) getMigrationStrategy :: DBType -> MigrationStrategy getMigrationStrategy dbtype@Sqlite { sqlite3619 = _fksupport } = @@ -30,7 +31,7 @@ } getMigrationStrategy dbtype = error $ "Sqlite: calling with invalid dbtype " ++ show dbtype -insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of Just _ -> @@ -65,22 +66,21 @@ showSqlType (SqlNumeric precision scale) = pack $ "NUMERIC(" ++ show precision ++ "," ++ show scale ++ ")" showSqlType SqlDay = "DATE" showSqlType SqlTime = "TIME" -showSqlType SqlDayTimeZoned = "TIMESTAMP" +--showSqlType SqlDayTimeZoned = "TIMESTAMP" showSqlType SqlDayTime = "TIMESTAMP" showSqlType SqlBlob = "BLOB" showSqlType SqlBool = "BOOLEAN" showSqlType (SqlOther t) = t -migrate' :: [EntityDef a] +migrate' :: [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = do let (cols, uniqs, _fdefs) = mkColumns allDefs val let newSql = mkCreateTable False def (filter (not . safeToRemove val . cName) cols, uniqs) stmt <- getter "SELECT sql FROM sqlite_master WHERE type='table' AND name=?" - oldSql' <- runResourceT - $ stmtQuery stmt [PersistText $ unDBName table] $$ go + oldSql' <- with (stmtQuery stmt [PersistText $ unDBName table]) ($$ go) case oldSql' of Nothing -> return $ Right [(False, newSql)] Just oldSql -> do @@ -102,42 +102,31 @@ -- | Check if a column name is listed as the "safe to remove" in the entity -- list. -safeToRemove :: EntityDef a -> DBName -> Bool +safeToRemove :: EntityDef -> DBName -> Bool safeToRemove def (DBName colName) = any (elem "SafeToRemove" . fieldAttrs) $ filter ((== (DBName colName)) . fieldDB) $ entityFields def -getCopyTable :: [EntityDef a] +getCopyTable :: [EntityDef] -> (Text -> IO Statement) - -> EntityDef SqlType + -> EntityDef -> IO [(Bool, Text)] -getCopyTable allDefs getter val = do +getCopyTable allDefs getter def = do stmt <- getter $ pack $ "PRAGMA table_info(" ++ escape' table ++ ")" - oldCols' <- runResourceT $ stmtQuery stmt [] $$ getCols + oldCols' <- with (stmtQuery stmt []) ($$ getCols) let oldCols = map DBName $ filter (/= "id") oldCols' -- need to update for table id attribute ? let newCols = filter (not . safeToRemove def) $ map cName cols let common = filter (`elem` oldCols) newCols - let id_ = entityID val - let ret = case entityPrimary val of - Just _ -> [ (False, tmpSql) - , (False, copyToTemp common) - , (common /= filter (not . safeToRemove def) oldCols, pack dropOld) - , (False, newSql) - , (False, copyToFinal newCols) - , (False, pack dropTmp) - ] - Nothing -> [ (False, tmpSql) + let id_ = fieldDB (entityId def) + return [ (False, tmpSql) , (False, copyToTemp $ id_ : common) - , (common /= filter (not . safeToRemove def) oldCols, pack dropOld) + , (common /= filter (not . safeToRemove def) oldCols, dropOld) , (False, newSql) , (False, copyToFinal $ id_ : newCols) - , (False, pack dropTmp) + , (False, dropTmp) ] - return ret where - - def = val getCols = do x <- CL.head case x of @@ -145,62 +134,76 @@ Just (_:PersistText name:_) -> do names <- getCols return $ name : names - Just (_:PersistByteString name:_) -> do - names <- getCols - return $ T.decodeUtf8 name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y table = entityDB def - tableTmp = DBName $ unDBName table `T.append` "_backup" - (cols, uniqs, _fdefs) = mkColumns allDefs val + tableTmp = DBName $ unDBName table <> "_backup" + (cols, uniqs, _) = mkColumns allDefs def cols' = filter (not . safeToRemove def . cName) cols newSql = mkCreateTable False def (cols', uniqs) tmpSql = mkCreateTable True def { entityDB = tableTmp } (cols', uniqs) - dropTmp = "DROP TABLE " ++ escape' tableTmp - dropOld = "DROP TABLE " ++ escape' table - copyToTemp common = pack $ concat + dropTmp = "DROP TABLE " <> escape tableTmp + dropOld = "DROP TABLE " <> escape table + copyToTemp common = T.concat [ "INSERT INTO " - , escape' tableTmp + , escape tableTmp , "(" - , intercalate "," $ map escape' common + , T.intercalate "," $ map escape common , ") SELECT " - , intercalate "," $ map escape' common + , T.intercalate "," $ map escape common , " FROM " - , escape' table + , escape table ] - copyToFinal newCols = pack $ concat + copyToFinal newCols = T.concat [ "INSERT INTO " - , T.unpack $ escape table + , escape table , " SELECT " - , intercalate "," $ map escape' newCols + , T.intercalate "," $ map escape newCols , " FROM " - , escape' tableTmp + , escape tableTmp ] + escape' :: DBName -> String escape' = T.unpack . escape -mkCreateTable :: Bool -> EntityDef a -> ([Column], [UniqueDef]) -> Text -mkCreateTable isTemp entity (cols, uniqs) = T.concat - [ "CREATE" - , if isTemp then " TEMP" else "" - , " TABLE " - , escape $ entityDB entity - , "(" - , T.drop 1 $ T.concat $ map sqlColumn cols - , "," - , idx - , T.concat $ map sqlUnique uniqs - , ")" - ] - -- gb convert to use text directly - where idx=case entityPrimary entity of - Just pdef -> T.pack $ concat [" PRIMARY KEY (", intercalate "," $ map (T.unpack . escape . snd) $ primaryFields pdef, ")"] - Nothing -> T.pack $ concat [T.unpack $ escape $ entityID entity - ," INTEGER PRIMARY KEY "] - --cols' = case entityPrimary entity of - -- Just _ -> drop 1 cols - -- Nothing -> cols +mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef]) -> Text +mkCreateTable isTemp entity (cols, uniqs) = + case entityPrimary entity of + Just pdef -> + T.concat + [ "CREATE" + , if isTemp then " TEMP" else "" + , " TABLE " + , escape $ entityDB entity + , "(" + , T.drop 1 $ T.concat $ map sqlColumn cols + , ", PRIMARY KEY " + , "(" + , T.intercalate "," $ map (escape . fieldDB) $ compositeFields pdef + , ")" + , ")" + ] + Nothing -> T.concat + [ "CREATE" + , if isTemp then " TEMP" else "" + , " TABLE " + , escape $ entityDB entity + , "(" + , escape $ fieldDB (entityId entity) + , " " + , showSqlType $ fieldSqlType $ entityId entity + ," PRIMARY KEY" + , mayDefault $ defaultAttribute $ fieldAttrs $ entityId entity + , T.concat $ map sqlColumn cols + , T.concat $ map sqlUnique uniqs + , ")" + ] +mayDefault :: Maybe Text -> Text +mayDefault def = case def of + Nothing -> "" + Just d -> " DEFAULT " <> d + sqlColumn :: Column -> Text sqlColumn (Column name isNull typ def _cn _maxLen ref) = T.concat [ ","
src/Database/Persist/ODBC.hs view
@@ -25,7 +25,7 @@ import qualified Database.Persist.MigrateDB2 as DB2 import qualified Database.Persist.MigrateSqlite as SQLITE -import Data.Time(ZonedTime(..), LocalTime(..), Day(..)) +import Data.Time(ZonedTime(..)) import qualified Database.HDBC.ODBC as O import qualified Database.HDBC as O @@ -41,12 +41,14 @@ import Data.Aeson -- (Object(..), (.:)) import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Resource (MonadResource) +--import Control.Monad.Trans.Resource (MonadResource) +import Control.Monad.Logger import Data.Int (Int64) import Data.Conduit import Database.Persist.ODBCTypes import qualified Data.List as L +import Data.Acquire (Acquire, mkAcquire) -- | An @HDBC-odbc@ connection string. A simple example of connection -- string would be @DSN=hdbctest1@. type ConnectionString = String @@ -56,7 +58,7 @@ -- finishes using it. Note that you should not use the given -- 'ConnectionPool' outside the action since it may be already -- been released. -withODBCPool :: MonadIO m +withODBCPool :: (MonadBaseControl IO m, MonadLogger m, MonadIO m) => Maybe DBType -> ConnectionString -- ^ Connection string to the database. @@ -67,14 +69,14 @@ -- ^ Action to be executed that uses the -- connection pool. -> m a -withODBCPool dbt ci = withSqlPool $ open' dbt ci +withODBCPool dbt ci = withSqlPool (\lg -> open' lg dbt ci) -- | Create an ODBC connection pool. Note that it's your -- responsibility to properly close the connection pool when -- unneeded. Use 'withODBCPool' for an automatic resource -- control. -createODBCPool :: MonadIO m +createODBCPool :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) => Maybe DBType -> ConnectionString -- ^ Connection string to the database. @@ -82,18 +84,18 @@ -- ^ Number of connections to be kept open -- in the pool. -> m ConnectionPool -createODBCPool dbt ci = createSqlPool $ open' dbt ci +createODBCPool dbt ci = createSqlPool (\lg -> open' lg dbt ci) -- | Same as 'withODBCPool', but instead of opening a pool -- of connections, only one connection is opened. -withODBCConn :: (MonadIO m, MonadBaseControl IO m) - => Maybe DBType -> ConnectionString -> (Connection -> m a) -> m a -withODBCConn dbt cs = withSqlConn (open' dbt cs) +withODBCConn :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) + => Maybe DBType -> ConnectionString -> (SqlBackend -> m a) -> m a +withODBCConn dbt cs = withSqlConn (\lg -> open' lg dbt cs) -- | helper function that returns a connection based on the database type -open' :: Maybe DBType -> ConnectionString -> IO Connection -open' mdbtype cstr = - O.connectODBC cstr >>= openSimpleConn mdbtype +open' :: LogFunc -> Maybe DBType -> ConnectionString -> IO SqlBackend +open' logFunc mdbtype cstr = + O.connectODBC cstr >>= openSimpleConn logFunc mdbtype -- | returns a supported database type based on its version -- if the user does not provide the database type explicitly I look it up based on connection metadata @@ -116,15 +118,16 @@ -- | Generate a persistent 'Connection' from an odbc 'O.Connection' -openSimpleConn :: Maybe DBType -> O.Connection -> IO Connection -openSimpleConn mdbtype conn = do +openSimpleConn :: LogFunc -> Maybe DBType -> O.Connection -> IO SqlBackend +openSimpleConn logFunc mdbtype conn = do let mig=case mdbtype of Nothing -> getMigrationStrategy $ findDBMS (O.proxiedClientName conn, O.proxiedClientVer conn, O.dbServerVer conn) Just dbtype -> getMigrationStrategy dbtype smap <- newIORef Map.empty - return Connection - { connPrepare = prepare' conn + return SqlBackend + { connLogFunc = logFunc + , connPrepare = prepare' conn , connStmtMap = smap , connInsertSql = dbmsInsertSql mig , connClose = O.disconnect conn @@ -168,15 +171,17 @@ execute' :: O.Statement -> [PersistValue] -> IO Int64 execute' query vals = fmap fromInteger $ O.execute query $ map (HSV.toSql . P) vals -withStmt' :: MonadResource m +withStmt' :: MonadIO m => O.Statement -> [PersistValue] - -> Source m [PersistValue] + -> Acquire (Source m [PersistValue]) withStmt' stmt vals = do #if DEBUG liftIO $ putStrLn $ "withStmt': vals: " ++ show vals #endif - bracketP openS closeS pull + result <- mkAcquire openS closeS + return $ pull result + --bracketP openS closeS pull where openS = execute' stmt vals >> return () closeS _ = O.finish stmt @@ -207,7 +212,7 @@ instance PersistConfig OdbcConf where type PersistConfigBackend OdbcConf = SqlPersistT type PersistConfigPool OdbcConf = ConnectionPool - createPoolConfig (OdbcConf cs size dbtype) = createODBCPool (read dbtype) cs size + createPoolConfig (OdbcConf cs size dbtype) = runNoLoggingT $ createODBCPool (read dbtype) cs size runPool _ = runSqlPool loadConfig (Object o) = do cstr <- o .: "connStr" @@ -232,7 +237,7 @@ safeConvert (P (PersistDay d)) = Right $ HSV.toSql d safeConvert (P (PersistTimeOfDay t)) = Right $ HSV.toSql t safeConvert (P (PersistUTCTime t)) = Right $ HSV.toSql t - safeConvert (P (PersistZonedTime (ZT t))) = Right $ HSV.toSql t +-- safeConvert (P (PersistZonedTime (ZT t))) = Right $ HSV.toSql t safeConvert (P PersistNull) = Right HSV.SqlNull safeConvert (P (PersistList l)) = Right $ HSV.toSql $ listToJSON l safeConvert (P (PersistMap m)) = Right $ HSV.toSql $ mapToJSON m @@ -267,10 +272,9 @@ safeConvert (HSV.SqlRational r) = Right $ P $ PersistRational r safeConvert (HSV.SqlLocalDate d) = Right $ P $ PersistDay d safeConvert (HSV.SqlLocalTimeOfDay t)= Right $ P $ PersistTimeOfDay t - safeConvert (HSV.SqlZonedLocalTimeOfDay td tz) - = Right $ P $ PersistZonedTime $ ZT $ ZonedTime (LocalTime (ModifiedJulianDay 0) td) tz + safeConvert (HSV.SqlZonedLocalTimeOfDay td _) = Right $ P $ PersistTimeOfDay td safeConvert (HSV.SqlLocalTime t) = Right $ P $ PersistUTCTime $ localTimeToUTC utc t - safeConvert (HSV.SqlZonedTime zt) = Right $ P $ PersistZonedTime $ ZT zt + safeConvert (HSV.SqlZonedTime zt) = Right $ P $ PersistUTCTime $ localTimeToUTC utc (zonedTimeToLocalTime zt) safeConvert (HSV.SqlUTCTime t) = Right $ P $ PersistUTCTime t safeConvert (HSV.SqlDiffTime ndt) = Right $ P $ PersistDouble $ fromRational $ toRational ndt safeConvert (HSV.SqlPOSIXTime pt) = Right $ P $ PersistDouble $ fromRational $ toRational pt @@ -279,6 +283,6 @@ safeConvert (HSV.SqlNull) = Right $ P PersistNull charChk :: Char -> PersistValue -charChk '\0' = PersistBool True -charChk '\1' = PersistBool False +charChk '\0' = PersistBool False +charChk '\1' = PersistBool True charChk c = PersistText $ T.singleton c
src/Database/Persist/ODBCTypes.hs view
@@ -21,8 +21,8 @@ data MigrationStrategy = MigrationStrategy { dbmsLimitOffset :: (Int,Int) -> Bool -> Text -> Text - ,dbmsMigrate :: Show a => [EntityDef a] -> (Text -> IO Statement) -> EntityDef SqlType -> IO (Either [Text] [(Bool, Text)]) - ,dbmsInsertSql :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult + ,dbmsMigrate :: [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) + ,dbmsInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult ,dbmsEscape :: DBName -> Text ,dbmsType :: DBType }