persistent-odbc 0.2.0.1 → 0.2.1.0
raw patch · 13 files changed
+677/−719 lines, 13 filesdep ~HDBCdep ~HDBC-odbcdep ~aeson
Dependency ranges changed: HDBC, HDBC-odbc, aeson, bytestring, conduit, containers, convertible, esqueleto, persistent, persistent-template, text, time, transformers
Files
- examples/Employment.hs +1/−0
- examples/FtypeEnum.hs +3/−29
- examples/Test1.hs +99/−86
- examples/TestODBC.hs +285/−328
- persistent-odbc.cabal +29/−31
- src/Database/Persist/MigrateDB2.hs +40/−39
- src/Database/Persist/MigrateMSSQL.hs +50/−47
- src/Database/Persist/MigrateMySQL.hs +38/−37
- src/Database/Persist/MigrateOracle.hs +43/−42
- src/Database/Persist/MigratePostgres.hs +36/−35
- src/Database/Persist/MigrateSqlite.hs +9/−8
- src/Database/Persist/ODBC.hs +39/−32
- src/Database/Persist/ODBCTypes.hs +5/−5
examples/Employment.hs view
@@ -1,4 +1,5 @@ -- @Employment.hs +{-# OPTIONS -Wall #-} {-# LANGUAGE TemplateHaskell #-} module Employment where
examples/FtypeEnum.hs view
@@ -1,12 +1,13 @@+{-# OPTIONS -Wall #-} {-# LANGUAGE TemplateHaskell #-} --- this creates a field type so you can use it as a type on a entity column +-- this creates a field type so you can use it as a type on a entity column -- not so useful for ftype module FtypeEnum where import Database.Persist.TH import qualified Prelude as P -data FtypeEnum = +data FtypeEnum = Xsd_string | Xsd_boolean | Xsd_decimal @@ -31,32 +32,5 @@ deriving (P.Read, P.Eq, P.Show) derivePersistField "FtypeEnum" - -{- -instance Show FtypeEnum where - show Xsd_string = "string" - show Xsd_boolean = "boolean" - show Xsd_decimal = "decimal" - show Xsd_float = "float" - show Xsd_double = "double" - show Xsd_duration = "duration" - show Xsd_dateTime = "dateTime" - show Xsd_time = "time" - show Xsd_date = "date" - show Xsd_hexBinary = "hexBinary" - show Xsd_base64Binary = "base64Binary" - show Xsd_anyURI = "anyURI" - show Xsd_QName = "QName" - --} - -{- -gYearMonth -gYear -gMonthDay -gDay -gMonth -NOTATION --}
examples/Test1.hs view
@@ -1,39 +1,42 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} -{-# LANGUAGE GADTs, FlexibleContexts #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveGeneric #-} +{-# OPTIONS -Wall #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} module Test1 where - import qualified Database.Persist as P import Database.Persist.TH -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger -import Control.Monad.Trans.Resource (runResourceT,MonadResource) -import Control.Monad.Trans.Reader (ask) -import Data.Text (Text) +import Control.Monad.Trans.Resource (runResourceT, ResourceT) +import Control.Monad.Trans.Reader (ask,ReaderT) 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 Database.Esqueleto (select,where_,(^.),from) import Debug.Trace import Control.Monad (when) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| G0 - g1 String - g2 String + g1 String + g2 String g3 String deriving Show Eq G1 g1 String maxlen=20 - g2 String + g2 String g3 String Primary g1 deriving Show Eq @@ -45,19 +48,19 @@ deriving Show Eq G3 g1 G0Id - g2 String + 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 + name1 String + name2 String Unique MyNames name1 name2 deriving Show Eq -TestBool +TestBool mybool Bool deriving Show Eq -TestTwoStrings +TestTwoStrings firstname String lastname String deriving Show Eq @@ -84,7 +87,7 @@ refthree TableThreeId Primary refone reftwo refthree deriving Show Eq -TableU +TableU refone TableOneId name String Unique SomeName name @@ -92,19 +95,20 @@ |] updatePersistValue :: Update v -> PersistValue -updatePersistValue (Update a1 v a2) = trace ("updatePersistValue a2="++show a2) $ toPersistValue v +updatePersistValue (Update _ v a2) = trace ("updatePersistValue a2="++show a2) $ toPersistValue v +updatePersistValue _ = error "updatePersistValue: expected an Update but found" main :: IO () main = do [arg] <- getArgs - let (dbtype',dsn) = + 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] + "s" -> (MSSQL True,"dsn=mssql_test") -- mssql 2012 [full limit and offset support] + "so" -> (MSSQL False,"dsn=mssql_test") -- 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") @@ -112,19 +116,28 @@ runResourceT $ runNoLoggingT $ withODBCConn Nothing dsn $ runSqlConn $ do conn <- ask - let dbtype::DBType + 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 + when True $ testJson dbtype -dostuff dbtype = do +testJson :: ( MonadIO m + , BackendCompatible SqlBackend backend + , PersistUniqueRead backend + , PersistQueryWrite backend + , BaseBackend backend ~ SqlBackend) + => DBType + -> ReaderT backend m () +testJson dbtype = do z1 <- insert $ TableOne "test1 aa" + liftIO $ print z1 z2 <- insert $ TableOne "test1 bb" + liftIO $ print z2 a1 <- insert $ TableOne "test1 cc" liftIO $ putStrLn $ "a1=" ++ show a1 a2 <- insert $ TableTwo "test2" @@ -132,36 +145,36 @@ 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 + let b1=encode $ head aa + liftIO $ putStrLn $ "\ntojson for tableone " ++ show b1 + let c1=decode' b1 :: Maybe (Entity TableOne) + liftIO $ putStrLn $ "\nfromjson for tableone " ++ show c1 + 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 b2=encode $ head bb + liftIO $ putStrLn $ "\ntojson for a single tablemany " ++ show b2 - 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 + let c2=decode' b2 :: Maybe (Entity TableMany) + liftIO $ putStrLn $ "fromjson for tablemany " ++ show c2 + let b3=encode bb + liftIO $ putStrLn $ "\ntojson for a list of tablemany " ++ show b3 + + let c3=decode' b3 :: Maybe [Entity TableMany] + liftIO $ putStrLn $ "\nfromjson for list of tablemany " ++ show c3 + liftIO $ putStrLn $ "dude=" ++ show (updatePersistValue (TableManyRefone =. z1)) p5 <- get a3 @@ -170,14 +183,14 @@ update a3 [TableManyRefone =. z1] - p5 <- get a1 + p6 <- get a1 liftIO $ putStrLn $ "after normal get!!!" - liftIO $ print p5 + liftIO $ print p6 - c1 <- insert $ TableOne "testa" - c2 <- insert $ TableTwo "testb" - c3 <- insert $ TableThree "testc" - m3 <- insert $ TableManyMany c1 c2 c3 + c4 <- insert $ TableOne "testa" + c5 <- insert $ TableTwo "testb" + c6 <- insert $ TableThree "testc" + m3 <- insert $ TableManyMany c4 c5 c6 liftIO $ putStrLn $ "m3=" ++ show m3 liftIO $ putStrLn $ "before get zzz" @@ -187,11 +200,11 @@ 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" + + bb1 <- selectList ([]::[Filter TableManyMany]) [] + liftIO $ putStrLn $ "bb1=" ++ show bb1 ++"\n\n" {- - xs <- select $ + xs <- select $ from $ \ln -> do where_ (ln ^. TableManyRefone E.<=. E.val a1) E.orderBy [E.asc (ln ^. TableManyRefone)] @@ -200,7 +213,7 @@ return ln liftIO $ putStrLn $ show (length xs) ++ " rows: limit=3 offset=2 xs=" ++ show xs -} - xs <- select $ + xs <- select $ from $ \ln -> do where_ (ln ^. TableOneNameone E.<=. E.val "test1 bb") E.orderBy [E.asc (ln ^. TableOneNameone)] @@ -209,47 +222,47 @@ return ln liftIO $ putStrLn $ show (length xs) ++ " rows: limit=2 offset=3 xs=" ++ show xs - a11 <- updateGet a1 [TableOneNameone =. "freee"] + a11 <- updateGet a1 [TableOneNameone =. "freee"] liftIO $ putStrLn $ "a11=" ++ show a11 - case dbtype of + 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"] + a33 <- count [TableOneNameone >=. "a"] liftIO $ putStrLn $ "a33=" ++ show a33 - m3 <- insert $ TableManyMany c1 c2 c3 + m4 <- insert $ TableManyMany c4 c5 c6 - a11 <- updateGet m3 [TableManyManyRefone =. c1] - liftIO $ putStrLn $ "a11=" ++ show a11 - case dbtype of + a44 <- updateGet m4 [TableManyManyRefone =. c4] + liftIO $ putStrLn $ "a44=" ++ show a44 + case dbtype of Oracle False -> liftIO $ putStrLn $ "oracle so no selectfirst" _ -> do - a22 <- selectFirst [TableManyManyReftwo ==. c2] [Desc TableManyManyRefone] + a22 <- selectFirst [TableManyManyReftwo ==. c5] [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 + a55 <- count [TableManyManyReftwo <=. c5] + liftIO $ putStrLn $ "a55=" ++ show a55 + + a66 <- count ([]::[Filter TableOne]) + liftIO $ putStrLn $ "before =" ++ show a66 updateWhere [TableOneNameone ==. "freee"] [TableOneNameone =. "dude"] - deleteWhere [TableOneNameone ==. "dude"] - a33 <- count ([]::[Filter TableOne]) - liftIO $ putStrLn $ "after =" ++ show a33 + deleteWhere [TableOneNameone ==. "dude"] + a77 <- count ([]::[Filter TableOne]) + liftIO $ putStrLn $ "after =" ++ show a77 - p4 <- selectList [TableOneNameone >=. "a"] [] - liftIO $ print p4 - + p7 <- selectList [TableOneNameone >=. "a"] [] + liftIO $ print p7 + liftIO $ putStrLn $ "before selectKeys List 111" - p4 <- selectKeysList [TableOneNameone >=. "a"] [] - liftIO $ print p4 + p8 <- selectKeysList [TableOneNameone >=. "a"] [] + liftIO $ print p8 liftIO $ putStrLn $ "before selectKeys List 222" - p4 <- selectKeysList [TableManyManyReftwo <=. c2] [] - liftIO $ print p4 + p9 <- selectKeysList [TableManyManyReftwo <=. c5] [] + liftIO $ print p9 ---doesq::IO () +doesq :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) () doesq = do deleteWhere ([]::[Filter G3]) deleteWhere ([]::[Filter G2])
examples/TestODBC.hs view
@@ -1,27 +1,33 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} -{-# LANGUAGE GADTs, FlexibleContexts #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-} -module TestODBC where - +{-# OPTIONS -Wall #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +module Main 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.Trans.Resource (runResourceT, ResourceT) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger -import Data.Text (Text) import qualified Data.Text as T - +import Data.Functor import Data.Time (getCurrentTime,UTCTime) import System.Environment (getArgs) import Employment import Data.Conduit import qualified Data.Conduit.List as CL -import Control.Monad (when,unless) +import Control.Monad (when,unless,forM_) import qualified Database.HDBC as H import qualified Database.HDBC.ODBC as H @@ -34,26 +40,26 @@ import Text.Blaze.Html --import Debug.Trace -share [mkPersist sqlSettings, mkMigrate "migrateAll", mkDeleteCascade sqlOnlySettings] [persistLowerCase| -Test0 +share [mkPersist sqlSettings, mkMigrate "migrateAll", mkDeleteCascade sqlSettings] [persistLowerCase| +Test0 mybool Bool deriving Show -Test1 +Test1 flag Bool flag1 Bool Maybe - dbl Double + dbl Double db2 Double Maybe deriving Show - + Test2 dt UTCTime deriving Show - + Persony name String employment Employment deriving Show - + Personx name String Eq Ne Desc age Int Lt Asc @@ -64,7 +70,7 @@ Testnum bar Int znork Int Maybe - znork1 String + znork1 String znork2 String Maybe znork3 UTCTime name String Maybe @@ -85,21 +91,18 @@ name String description String Unique MyUniqueAsm name --- deriving Typeable deriving Show - + Xsd name String description String asmid AsmId Unique MyUniqueXsd name -- global --- deriving Typeable deriving Show - + Ftype name String Unique MyUniqueFtype name --- deriving Typeable deriving Show Line @@ -109,41 +112,39 @@ ftypeid FtypeEnum xsdid XsdId Unique EinzigName xsdid name -- within an xsd:so can repeat fieldnames in different xsds - Unique EinzigPos xsdid pos --- deriving Typeable + Unique EinzigPos xsdid pos deriving Show - + Interface name String fname String ftypeid FtypeId iname FtypeEnum Unique MyUniqueInterface name --- deriving Typeable deriving Show Testother -- json -- no FromJSON instance in aeson anymore for bytestring bs1 ByteString Maybe - bs2 ByteString + bs2 ByteString deriving Show Testrational json rat Rational deriving Show -Testhtml +Testhtml myhtml Html -- deriving Show -Testblob +Testblob bs1 ByteString Maybe deriving Show -Testblob3 - bs1 ByteString - bs2 ByteString - bs3 ByteString +Testblob3 + bs1 ByteString + bs2 ByteString + bs3 ByteString deriving Show Testlen @@ -173,18 +174,18 @@ main :: IO () main = do [arg] <- getArgs - let (dbtype',dsn) = + let (dbtype',dsn) = case arg of -- odbc system dsn "d" -> (DB2,"dsn=db2_test") "p" -> (Postgres,"dsn=pg_test") "m" -> (MySQL,"dsn=mysql_test") -- have to pass UID=..; PWD=..; or use Trusted_Connection or Trusted Connection depending on the driver and environment - "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] + "s" -> (MSSQL True,"dsn=mssql_test") -- mssql 2012 [full limit and offset support] + "so" -> (MSSQL False,"dsn=mssql_test") -- 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") + "q" -> (Sqlite False,"dsn=sqlite_test;NoWCHAR=1") + "qn" -> (Sqlite True,"dsn=sqlite_test;NoWCHAR=1") xs -> error $ "unknown option:choose p m s so o on d q qn found[" ++ xs ++ "]" runResourceT $ runNoLoggingT $ withODBCConn Nothing dsn $ runSqlConn $ do @@ -194,51 +195,57 @@ liftIO $ putStrLn "\nbefore migration\n" runMigration migrateAll liftIO $ putStrLn "after migration" - case dbtype of + case dbtype of MSSQL {} -> do -- deleteCascadeWhere Asm causes seg fault for mssql only - deleteWhere ([]::[Filter Line]) - deleteWhere ([]::[Filter Xsd]) - deleteWhere ([]::[Filter Asm]) + deleteWhere ([] :: [Filter Line]) + deleteWhere ([] :: [Filter Xsd]) + deleteWhere ([] :: [Filter Asm]) _ -> do - deleteCascadeWhere ([]::[Filter Asm]) - deleteCascadeWhere ([]::[Filter Personz]) + deleteCascadeWhere ([] :: [Filter Asm]) + deleteCascadeWhere ([] :: [Filter Personz]) - deleteWhere ([]::[Filter Personz]) - deleteWhere ([]::[Filter Persony]) - deleteWhere ([]::[Filter Personx]) - deleteWhere ([]::[Filter Testother]) - deleteWhere ([]::[Filter Testrational]) - deleteWhere ([]::[Filter Testblob]) - deleteWhere ([]::[Filter Testblob3]) - deleteWhere ([]::[Filter Testother]) - deleteWhere ([]::[Filter Testnum]) - deleteWhere ([]::[Filter Testhtml]) - deleteWhere ([]::[Filter Testblob3]) - deleteWhere ([]::[Filter Test1]) - deleteWhere ([]::[Filter Test0]) - deleteWhere ([]::[Filter Testlen]) + deleteWhere ([] :: [Filter Personz]) + deleteWhere ([] :: [Filter Persony]) + deleteWhere ([] :: [Filter Personx]) + deleteWhere ([] :: [Filter Testother]) + deleteWhere ([] :: [Filter Testrational]) + deleteWhere ([] :: [Filter Testblob]) + deleteWhere ([] :: [Filter Testblob3]) + deleteWhere ([] :: [Filter Testother]) + deleteWhere ([] :: [Filter Testnum]) + deleteWhere ([] :: [Filter Testhtml]) + deleteWhere ([] :: [Filter Testblob3]) + deleteWhere ([] :: [Filter Test1]) + deleteWhere ([] :: [Filter Test0]) + deleteWhere ([] :: [Filter Testlen]) when True $ testbase dbtype - + liftIO $ putStrLn "Ended tests" + + testbase :: DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () -testbase dbtype = do +testbase dbtype = do liftIO $ putStrLn "\n*** in testbase\n" a1 <- insert $ Foo "test" liftIO $ putStrLn $ "a1=" ++ show a1 - aa <- selectList ([]::[Filter Foo]) [] - liftIO $ putStrLn $ "aa=" ++ show aa + a2 <- selectList ([] :: [Filter Foo]) [] + liftIO $ putStrLn $ "a2=" ++ show a2 johnId <- insert $ Personz "John Doe" $ Just 35 liftIO $ putStrLn $ "johnId[" ++ show johnId ++ "]" janeId <- insert $ Personz "Jane Doe" Nothing liftIO $ putStrLn $ "janeId[" ++ show janeId ++ "]" - aa <- selectList ([]::[Filter Personz]) [] - unless (length aa == 2) $ error $ "wrong number of Personz rows " ++ show aa + a3 <- selectList ([] :: [Filter Personz]) [] + unless (length a3 == 2) $ error $ "wrong number of Personz rows " ++ show a3 + liftIO $ putStrLn $ "a3=" ++ show a3 - _ <- insert $ BlogPost "My fr1st p0st" johnId - _ <- insert $ BlogPost "One more for good measure" johnId - aa <- selectList ([]::[Filter BlogPost]) [] - unless (length aa == 2) $ error $ "wrong number of BlogPost rows " ++ show aa + void $ insert $ BlogPost "My fr1st p0st" johnId + liftIO $ putStrLn $ "after insert johnId" + void $ insert $ BlogPost "One more for good measure" johnId + liftIO $ putStrLn $ "after insert johnId 2" + a4 <- selectList ([] :: [Filter BlogPost]) [] + liftIO $ putStrLn $ "a4=" ++ show a4 + unless (length a4 == 2) $ error $ "wrong number of BlogPost rows " ++ show a4 --oneJohnPost <- selectList [BlogPostAuthorId ==. johnId] [LimitTo 1] --liftIO $ print (oneJohnPost :: [Entity BlogPost]) @@ -251,28 +258,37 @@ liftIO $ putStrLn $ "v1=" ++ show v1 liftIO $ putStrLn $ "v2=" ++ show v2 - aa <- selectList ([]::[Filter Testnum]) [] - unless (length aa == 2) $ error $ "wrong number of Testnum rows " ++ show aa + a5 <- selectList ([] :: [Filter Testnum]) [] + unless (length a5 == 2) $ error $ "wrong number of Testnum rows " ++ show a5 delete janeId deleteWhere [BlogPostRefPersonz ==. johnId] test0 test1 dbtype - test2 - test3 + test2 + test3 test4 - test5 dbtype + case dbtype of + MSSQL {} -> return () + _ -> test5 dbtype test6 when (limitoffset dbtype) test7 when (limitoffset dbtype) test8 + case dbtype of Oracle { oracle12c=False } -> return () _ -> test9 - test10 dbtype - test11 dbtype + + case dbtype of + MSSQL {} -> return () + _ -> test10 dbtype + + case dbtype of + MSSQL {} -> return () + _ -> test11 dbtype test12 dbtype - -test0::SqlPersistT (NoLoggingT (ResourceT IO)) () + +test0 :: SqlPersistT (NoLoggingT (ResourceT IO)) () test0 = do liftIO $ putStrLn "\n*** in test0\n" pid <- insert $ Personx "Michael" 25 Nothing @@ -312,10 +328,10 @@ _ <- insert $ Personx "Abe1" 31 $ Just "brown" p9 <- selectList [PersonxName ==. "Abe1"] [] liftIO $ print p9 - - aa <- selectList ([]::[Filter Personx]) [] - unless (length aa == 4) $ error $ "wrong number of Personx rows " ++ show aa + a6 <- selectList ([] :: [Filter Personx]) [] + unless (length a6 == 4) $ error $ "wrong number of Personx rows " ++ show a6 + p10 <- getBy $ PersonxNameKey "Michael" liftIO $ print p10 @@ -332,38 +348,38 @@ plast <- get pid liftIO $ print plast -test1::DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () +test1 :: DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () test1 dbtype = do liftIO $ putStrLn "\n*** in test1\n" - pid <- insert $ Persony "Dude" Retired - liftIO $ print pid - pid <- insert $ Persony "Dude1" Employed - liftIO $ print pid - pid <- insert $ Persony "Snoyman aa" Unemployed - liftIO $ print pid - pid <- insert $ Persony "bbb Snoyman" Employed - liftIO $ print pid + pid1 <- insert $ Persony "Dude" Retired + liftIO $ print pid1 + pid2 <- insert $ Persony "Dude1" Employed + liftIO $ print pid2 + pid3 <- insert $ Persony "Snoyman aa" Unemployed + liftIO $ print pid3 + pid4 <- insert $ Persony "bbb Snoyman" Employed + liftIO $ print pid4 - aa <- selectList ([]::[Filter Persony]) [] - unless (length aa == 4) $ error $ "wrong number of Personz rows " ++ show aa - liftIO $ putStrLn $ "persony " ++ show aa - let sql = case dbtype of + a1 <- selectList ([] :: [Filter Persony]) [] + unless (length a1 == 4) $ error $ "wrong number of Personz rows " ++ show a1 + liftIO $ putStrLn $ "persony " ++ show a1 + let sql = case dbtype of MSSQL {} -> "SELECT [name] FROM [persony] WHERE [name] LIKE '%Snoyman%'" MySQL {} -> "SELECT `name` FROM `persony` WHERE `name` LIKE '%Snoyman%'" _ -> "SELECT \"name\" FROM \"persony\" WHERE \"name\" LIKE '%Snoyman%'" - rawQuery sql [] $$ CL.mapM_ (liftIO . print) - -test2::SqlPersistT (NoLoggingT (ResourceT IO)) () + runConduit $ rawQuery sql [] .| CL.mapM_ (liftIO . print) + +test2 :: SqlPersistT (NoLoggingT (ResourceT IO)) () test2 = do liftIO $ putStrLn "\n*** in test2\n" - aaa <- insert $ Test0 False + aaa <- insert $ Test0 False liftIO $ print aaa - aa <- selectList ([]::[Filter Test0]) [] - unless (length aa == 1) $ error $ "wrong number of Personz rows " ++ show aa - -test3::SqlPersistT (NoLoggingT (ResourceT IO)) () -test3 = do + a1 <- selectList ([] :: [Filter Test0]) [] + unless (length a1 == 1) $ error $ "wrong number of Personz rows " ++ show a1 + +test3 :: SqlPersistT (NoLoggingT (ResourceT IO)) () +test3 = do liftIO $ putStrLn "\n*** in test3\n" a1 <- insert $ Test1 True (Just False) 100.3 Nothing liftIO $ putStrLn $ "a1=" ++ show a1 @@ -373,112 +389,130 @@ liftIO $ putStrLn $ "a3=" ++ show a3 a4 <- insert $ Test1 False Nothing 100.3 Nothing liftIO $ putStrLn $ "a4=" ++ show a4 - ret <- selectList ([]::[Filter Test1]) [] + ret <- selectList ([] :: [Filter Test1]) [] liftIO $ putStrLn $ "ret=" ++ show ret - aa <- selectList ([]::[Filter Test1]) [] - unless (length aa == 4) $ error $ "wrong number of Test1 rows " ++ show aa + a5 <- selectList ([] :: [Filter Test1]) [] + unless (length a5 == 4) $ error $ "wrong number of Test1 rows " ++ show a5 -test4::SqlPersistT (NoLoggingT (ResourceT IO)) () +test4 :: SqlPersistT (NoLoggingT (ResourceT IO)) () test4 = do liftIO $ putStrLn "\n*** in test4\n" - a1 <- insert $ Asm "NewAsm1" "description for newasm1" + a1 <- insert $ Asm "NewAsm1" "description for newasm1" x11 <- insert $ Xsd "NewXsd11" "description for newxsd11" a1 + liftIO $ putStrLn $ "x11=" ++ show x11 l111 <- insert $ Line "NewLine111" "description for newline111" 10 Xsd_string x11 + liftIO $ putStrLn $ "l111=" ++ show l111 l112 <- insert $ Line "NewLine112" "description for newline112" 11 Xsd_boolean x11 + liftIO $ putStrLn $ "l112=" ++ show l112 l113 <- insert $ Line "NewLine113" "description for newline113" 12 Xsd_decimal x11 + liftIO $ putStrLn $ "l113=" ++ show l113 l114 <- insert $ Line "NewLine114" "description for newline114" 15 Xsd_int x11 + liftIO $ putStrLn $ "l114=" ++ show l114 x12 <- insert $ Xsd "NewXsd12" "description for newxsd12" a1 + liftIO $ putStrLn $ "x12=" ++ show x12 l121 <- insert $ Line "NewLine121" "description for newline1" 12 Xsd_int x12 + liftIO $ putStrLn $ "l121=" ++ show l121 l122 <- insert $ Line "NewLine122" "description for newline2" 19 Xsd_boolean x12 + liftIO $ putStrLn $ "l122=" ++ show l122 l123 <- insert $ Line "NewLine123" "description for newline3" 13 Xsd_string x12 + liftIO $ putStrLn $ "l123=" ++ show l123 l124 <- insert $ Line "NewLine124" "description for newline4" 99 Xsd_double x12 + liftIO $ putStrLn $ "l124=" ++ show l124 l125 <- insert $ Line "NewLine125" "description for newline5" 2 Xsd_boolean x12 + liftIO $ putStrLn $ "l125=" ++ show l125 - a2 <- insert $ Asm "NewAsm2" "description for newasm2" + a2 <- insert $ Asm "NewAsm2" "description for newasm2" + liftIO $ putStrLn $ "a2=" ++ show a2 - a3 <- insert $ Asm "NewAsm3" "description for newasm3" + a3 <- insert $ Asm "NewAsm3" "description for newasm3" + liftIO $ putStrLn $ "a3=" ++ show a3 x31 <- insert $ Xsd "NewXsd31" "description for newxsd311" a3 - - aa <- selectList ([]::[Filter Asm]) [] - unless (length aa == 3) $ error $ "wrong number of Asm rows " ++ show aa - aa <- selectList ([]::[Filter Xsd]) [] - unless (length aa == 3) $ error $ "wrong number of Xsd rows " ++ show aa - aa <- selectList ([]::[Filter Line]) [] - unless (length aa == 9) $ error $ "wrong number of Line rows " ++ show aa + liftIO $ putStrLn $ "x31=" ++ show x31 + a4 <- selectList ([] :: [Filter Asm]) [] + liftIO $ putStrLn $ "a4=" ++ show a4 + unless (length a4 == 3) $ error $ "wrong number of Asm rows " ++ show a4 + a5 <- selectList ([] :: [Filter Xsd]) [] + liftIO $ putStrLn $ "a5=" ++ show a5 + unless (length a5 == 3) $ error $ "wrong number of Xsd rows " ++ show a5 + a6 <- selectList ([] :: [Filter Line]) [] + liftIO $ putStrLn $ "a6=" ++ show a6 + unless (length a6 == 9) $ error $ "wrong number of Line rows " ++ show a6 - [Value mpos] <- select $ + [Value mpos] <- select $ from $ \ln -> do where_ (ln ^. LineXsdid E.==. E.val x11) return $ E.joinV $ E.max_ (E.just (ln ^. LinePos)) - liftIO $ putStrLn $ "mpos=" ++ show mpos + liftIO $ putStrLn $ "mpos=" ++ show mpos -test5::DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () +test5 :: DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () test5 dbtype = do liftIO $ putStrLn "\n*** in test5\n" - a1 <- insert $ Testother (Just "abc") "zzzz" - case dbtype of - MSSQL {} -> liftIO $ putStrLn $ show dbtype ++ " insert multiple blob fields with a null fails" + a1 <- insert $ Testother (Just "abc") "zzzz" + liftIO $ putStrLn $ "a1=" ++ show a1 + case dbtype of DB2 {} -> liftIO $ putStrLn $ show dbtype ++ " insert multiple blob fields with a null fails" _ -> do - a2 <- insert $ Testother Nothing "aaa" + a2 <- insert $ Testother Nothing "aaa" liftIO $ putStrLn $ "a2=" ++ show a2 - a3 <- insert $ Testother (Just "nnn") "bbb" - a4 <- insert $ Testother (Just "ddd") "mmm" - xs <- case dbtype of - Oracle {} -> selectList ([]::[Filter Testother]) [] -- cannot sort blobs in oracle - DB2 {} -> selectList ([]::[Filter Testother]) [] -- cannot sort blobs in db2? - _ -> selectList [] [Desc TestotherBs1] + a3 <- insert $ Testother (Just "nnn") "bbb" + liftIO $ putStrLn $ "a3=" ++ show a3 + a4 <- insert $ Testother (Just "ddd") "mmm" + liftIO $ putStrLn $ "a4=" ++ show a4 + xs <- case dbtype of + Oracle {} -> selectList ([] :: [Filter Testother]) [] -- cannot sort blobs in oracle + DB2 {} -> selectList ([] :: [Filter Testother]) [] -- cannot sort blobs in db2? + _ -> selectList [] [Desc TestotherBs1] liftIO $ putStrLn $ "xs=" ++ show xs - case dbtype of + case dbtype of Oracle {} -> return () DB2 {} -> return () _ -> do - ys <- selectList [] [Desc TestotherBs2] + ys <- selectList [] [Desc TestotherBs2] liftIO $ putStrLn $ "ys=" ++ show ys - - aa <- selectList ([]::[Filter Testother]) [] + + a7 <- selectList ([] :: [Filter Testother]) [] case dbtype of - MSSQL {} -> unless (length aa == 3) $ error $ show dbtype ++ " :wrong number of Testother rows " ++ show aa - DB2 {} -> unless (length aa == 3) $ error $ show dbtype ++ " :wrong number of Testother rows " ++ show aa - _ -> unless (length aa == 4) $ error $ "wrong number of Testother rows " ++ show aa - - -test6::SqlPersistT (NoLoggingT (ResourceT IO)) () + DB2 {} -> unless (length a7 == 3) $ error $ show dbtype ++ " :wrong number of Testother rows " ++ show a7 + _ -> unless (length a7 == 4) $ error $ "wrong number of Testother rows " ++ show a7 + + liftIO $ putStrLn "end of test5" + +test6 :: SqlPersistT (NoLoggingT (ResourceT IO)) () test6 = do liftIO $ putStrLn "\n*** in test6\n" r1 <- insert $ Testrational (4%6) r2 <- insert $ Testrational (13 % 14) liftIO $ putStrLn $ "r1=" ++ show r1 liftIO $ putStrLn $ "r2=" ++ show r2 - zs <- selectList [] [Desc TestrationalRat] + zs <- selectList [] [Desc TestrationalRat] liftIO $ putStrLn $ "zs=" ++ show zs h1 <- insert $ Testhtml $ preEscapedToMarkup ("<p>hello</p>"::String) liftIO $ putStrLn $ "h1=" ++ show h1 - aa <- selectList ([]::[Filter Testrational]) [] - unless (length aa == 2) $ error $ "wrong number of Testrational rows " ++ show aa + a1 <- selectList ([] :: [Filter Testrational]) [] + unless (length a1 == 2) $ error $ "wrong number of Testrational rows " ++ show a1 - aa <- selectList ([]::[Filter Testhtml]) [] - unless (length aa == 1) $ error $ "wrong number of Testhtml rows " - -test7::SqlPersistT (NoLoggingT (ResourceT IO)) () + a2 <- selectList ([] :: [Filter Testhtml]) [] + unless (length a2 == 1) $ error $ "wrong number of Testhtml rows " + +test7 :: SqlPersistT (NoLoggingT (ResourceT IO)) () test7 = do liftIO $ putStrLn "\n*** in test7\n" - xs <- selectList [] [Desc LinePos, LimitTo 2, OffsetBy 3] - liftIO $ putStrLn $ show (length xs) ++ " rows: limit=2,offset=3 xs=" ++ show xs - xs <- selectList [] [Desc LinePos, LimitTo 2] - liftIO $ putStrLn $ show (length xs) ++ " rows: limit=2 xs=" ++ show xs - xs <- selectList [] [Desc LinePos, OffsetBy 3] - liftIO $ putStrLn $ show (length xs) ++ " rows: offset=3 xs=" ++ show xs + a1 <- selectList [] [Desc LinePos, LimitTo 2, OffsetBy 3] + liftIO $ putStrLn $ show (length a1) ++ " rows: limit=2,offset=3 a1=" ++ show a1 + a2 <- selectList [] [Desc LinePos, LimitTo 2] + liftIO $ putStrLn $ show (length a2) ++ " rows: limit=2 a2=" ++ show a2 + a3 <- selectList [] [Desc LinePos, OffsetBy 3] + liftIO $ putStrLn $ show (length a3) ++ " rows: offset=3 a3=" ++ show a3 -test8::SqlPersistT (NoLoggingT (ResourceT IO)) () +test8 :: SqlPersistT (NoLoggingT (ResourceT IO)) () test8 = do liftIO $ putStrLn "\n*** in test8\n" - xs <- select $ + xs <- select $ from $ \ln -> do where_ (ln ^. LinePos E.>=. E.val 0) E.orderBy [E.asc (ln ^. LinePos)] @@ -487,79 +521,81 @@ return ln liftIO $ putStrLn $ show (length xs) ++ " rows: limit=2 offset=3 xs=" ++ show xs -test9::SqlPersistT (NoLoggingT (ResourceT IO)) () +test9 :: SqlPersistT (NoLoggingT (ResourceT IO)) () test9 = do liftIO $ putStrLn "\n*** in test9\n" - xs <- selectList [] [Desc LinePos, LimitTo 2] - liftIO $ putStrLn $ show (length xs) ++ " rows: limit=2,offset=0 xs=" ++ show xs - xs <- selectList [] [Desc LinePos, LimitTo 4] - liftIO $ putStrLn $ show (length xs) ++ " rows: limit=4,offset=0 xs=" ++ show xs + a1 <- selectList [] [Desc LinePos, LimitTo 2] + liftIO $ putStrLn $ show (length a1) ++ " rows: limit=2,offset=0 a1=" ++ show a1 + a2 <- selectList [] [Desc LinePos, LimitTo 4] + liftIO $ putStrLn $ show (length a2) ++ " rows: limit=4,offset=0 a2=" ++ show a2 -test10::DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () +test10 :: DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () test10 dbtype = do liftIO $ putStrLn "\n*** in test10\n" - a1 <- insert $ Testblob3 "abc1" "def1" "zzzz1" - a2 <- insert $ Testblob3 "abc2" "def2" "test2" - case dbtype of + a1 <- insert $ Testblob3 "abc1" "def1" "zzzz1" + liftIO $ putStrLn $ "a1=" ++ show a1 + a2 <- insert $ Testblob3 "abc2" "def2" "test2" + liftIO $ putStrLn $ "a2=" ++ show a2 + case dbtype of Oracle {} -> liftIO $ putStrLn "skipping insert empty string into oracle blob column (treated as a null)" {- - *** Exception: SqlError {seState = "[\"HY000\"]", seNativeError = -1, + *** Exception: SqlError {seState = "[\"HY000\"]", seNativeError = -1, seErrorMsg = "execute execute: [\"1400: [Oracle][ODBC][Ora]ORA-01400: cannot insert NULL into (\\\"SYSTEM\\\".\\\"testblob3\\\".\\\"bs1\\\")\\n\"]"} -} - _ -> do - a3 <- insert $ Testblob3 "" "hello3" "world3" - return () - ys <- selectList ([]::[Filter Testblob3]) [] + _ -> void $ insert $ Testblob3 "" "hello3" "world3" + ys <- selectList ([] :: [Filter Testblob3]) [] liftIO $ putStrLn $ "ys=" ++ show ys - aa <- selectList ([]::[Filter Testblob3]) [] + a3 <- selectList ([] :: [Filter Testblob3]) [] case dbtype of - Oracle {} -> unless (length aa == 2) $ error $ show dbtype ++ " :wrong number of Testblob3 rows " ++ show aa - _ -> unless (length aa == 3) $ error $ "wrong number of Testblob3 rows " ++ show aa + Oracle {} -> unless (length a3 == 2) $ error $ show dbtype ++ " :wrong number of Testblob3 rows " ++ show a3 + _ -> unless (length a3 == 3) $ error $ "wrong number of Testblob3 rows " ++ show a3 + liftIO $ print a3 -test11::DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () +test11 :: DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () test11 dbtype = do liftIO $ putStrLn "\n*** in test11\n" - case dbtype of + case dbtype of MSSQL {} -> liftIO $ putStrLn $ show dbtype ++ ":inserting null in a blob not supported so skipping" DB2 {} -> liftIO $ putStrLn $ show dbtype ++ ":inserting null in a blob not supported so skipping" _ -> do - _ <- insert $ Testblob Nothing + _ <- insert $ Testblob Nothing return () _ <- insert $ Testblob $ Just "some data for testing" _ <- insert $ Testblob $ Just "world" liftIO $ putStrLn "after testblob inserts" - xs <- selectList ([]::[Filter Testblob]) [] -- mssql fails if there is a null in a blog column + xs <- selectList ([] :: [Filter Testblob]) [] -- mssql fails if there is a null in a blog column liftIO $ putStrLn $ "testblob xs=" ++ show xs - aa <- selectList ([]::[Filter Testblob]) [] + a1 <- selectList ([] :: [Filter Testblob]) [] case dbtype of - MSSQL {} -> unless (length aa == 2) $ error $ show dbtype ++ " :wrong number of Testblob rows " ++ show aa - DB2 {} -> unless (length aa == 2) $ error $ show dbtype ++ " :wrong number of Testblob rows " ++ show aa - _ -> unless (length aa == 3) $ error $ "wrong number of Testblob rows " ++ show aa + MSSQL {} -> unless (length a1 == 2) $ error $ show dbtype ++ " :wrong number of Testblob rows " ++ show a1 + DB2 {} -> unless (length a1 == 2) $ error $ show dbtype ++ " :wrong number of Testblob rows " ++ show a1 + _ -> unless (length a1 == 3) $ error $ "wrong number of Testblob rows " ++ show a1 -test12::DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () +test12 :: DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () test12 dbtype = do liftIO $ putStrLn "\n*** in test12\n" - a1 <- insert $ Testlen "txt1" "str1" "bs1" (Just "txt1m") (Just "str1m") (Just "bs1m") - a2 <- insert $ Testlen "txt2" "str2" "bs2" (Just "aaaa") (Just "str2m") (Just "bs2m") - - aa <- selectList ([]::[Filter Testlen]) [] + a1 <- insert $ Testlen "txt1" "str1" "bs1" (Just "txt1m") (Just "str1m") (Just "bs1m") + liftIO $ putStrLn $ "a1=" ++ show a1 + a2 <- insert $ Testlen "txt2" "str2" "bs2" (Just "aaaa") (Just "str2m") (Just "bs2m") + liftIO $ putStrLn $ "a2=" ++ show a2 + a3 <- selectList ([] :: [Filter Testlen]) [] case dbtype of - -- Oracle {} -> unless (length aa == 2) $ error $ show dbtype ++ " :wrong number of Testlen rows " ++ show aa - _ -> unless (length aa == 2) $ error $ "wrong number of Testlen rows " ++ show aa + -- Oracle {} -> unless (length a3 == 2) $ error $ show dbtype ++ " :wrong number of Testlen rows " ++ show a3 + _ -> unless (length a3 == 2) $ error $ "wrong number of Testlen rows " ++ show a3 - liftIO $ putStrLn $ "aa=" ++ show aa + liftIO $ putStrLn $ "a3=" ++ show a3 limitoffset :: DBType -> Bool limitoffset dbtype = -- trace ("limitoffset dbtype=" ++ show dbtype) $ - case dbtype of + case dbtype of Oracle False -> False MSSQL False -> False _ -> True - -main2::IO () + +main2 :: IO () main2 = do -- let connectionString = "dsn=mssql_test; Trusted_Connection=True" let connectionString = "dsn=db2_test" @@ -567,54 +603,59 @@ putStrLn "\n1\n" stmt1 <- H.prepare conn "select * from test93" putStrLn "\n2\n" - vals <- H.execute stmt1 [] + vals1 <- H.execute stmt1 [] + print vals1 putStrLn "\n3\n" - results <- H.fetchAllRowsAL stmt1 + results1 <- H.fetchAllRowsAL stmt1 putStrLn "\n4\n" - mapM_ print results + forM_ (zip [1::Int ..] results1) $ \(i,x) -> putStrLn $ "i=" ++ show i ++ " result=" ++ show x putStrLn "\na\n" --stmt1 <- H.prepare conn "create table test93 (bs1 blob)" --putStrLn "\nb\n" - --vals <- H.execute stmt1 [] + --vals <- H.execute stmt1 [] --putStrLn "\nc\n" - stmt1 <- H.prepare conn "insert into test93 values(blob(?))" + stmt2 <- H.prepare conn "insert into test93 values(blob(?))" putStrLn "\nd\n" - vals <- H.execute stmt1 [H.SqlByteString "hello world"] + vals2 <- H.execute stmt2 [H.SqlByteString "hello world"] putStrLn "\ne\n" --- _ <- H.commit conn + print vals2 +-- _ <- H.commit conn -- error "we are done!!" - + -- a <- H.quickQuery' conn "select * from testblob" [] -- hangs here in both mssql drivers [not all the time] -- putStrLn $ "\n5\n" -- print a - stmt <- H.prepare conn "insert into testblob (bs1) values(?)" + stmt3 <- H.prepare conn "insert into testblob (bs1) values(?)" putStrLn "\n6\n" - vals <- H.execute stmt [H.SqlNull] + vals3a <- H.execute stmt3 [H.SqlNull] + putStrLn $ "vals3a=" ++ show vals3a putStrLn "\n7\n" - vals <- H.execute stmt [H.SqlNull] + vals3b <- H.execute stmt3 [H.SqlNull] + putStrLn $ "vals3b=" ++ show vals3b putStrLn "\n8\n" - vals <- H.execute stmt [H.SqlNull] + vals3c <- H.execute stmt3 [H.SqlNull] + putStrLn $ "vals3c=" ++ show vals3c putStrLn "\n9\n" - - results <- H.fetchAllRowsAL stmt1 - mapM_ print results + + results2 <- H.fetchAllRowsAL stmt2 + forM_ (zip [1::Int ..] results2) $ \(i,x) -> putStrLn $ "i=" ++ show i ++ " result=" ++ show x putStrLn "\nTESTBLOB worked\n" - --stmt <- H.prepare conn "insert into testother (bs1,bs2) values(convert(varbinary(max),?),convert(varbinary(max),?))" - stmt <- H.prepare conn "insert into testother (bs1,bs2) values(convert(varbinary(max), cast (? as varchar(100))),convert(varbinary(max), cast (? as varchar(100))))" - vals <- H.execute stmt [H.SqlByteString "hello",H.SqlByteString "test"] + --stmt <- H.prepare conn "insert into testother (bs1,bs2) values(convert(varbinary(max),?),convert(varbinary(max),?))" + stmt4 <- H.prepare conn "insert into testother (bs1,bs2) values(convert(varbinary(max), cast (? as varchar(100))),convert(varbinary(max), cast (? as varchar(100))))" + vals4 <- H.execute stmt4 [H.SqlByteString "hello",H.SqlByteString "test"] + putStrLn $ "vals4=" ++ show vals4 - --vals <- H.execute stmt [H.SqlNull,H.SqlByteString "test"] + --vals <- H.execute stmt3 [H.SqlNull,H.SqlByteString "test"] putStrLn "\nTESTOTHER worked\n" H.commit conn - print vals - -main3::IO () + +main3 :: IO () main3 = do --let connectionString = "dsn=pg_test" let connectionString = "dsn=mysql_test" @@ -633,19 +674,20 @@ --let lenfn="length" a <- H.describeTable conn "persony" print a - stmt <- H.prepare conn ("update \"persony\" set \"name\" = ? where \"id\" >= ?") + stmt1 <- H.prepare conn ("update \"persony\" set \"name\" = ? where \"id\" >= ?") putStrLn "\n2\n" - vals <- H.execute stmt [H.SqlString "dooble and stuff", H.toSql (1::Integer)] - print vals + vals1 <- H.execute stmt1 [H.SqlString "dooble and stuff", H.toSql (1 :: Integer)] + print vals1 putStrLn "\n3\n" - stmt <- H.prepare conn ("select \"id\","++lenfn++"(\"name\"),\"name\" from \"persony\"") + stmt2 <- H.prepare conn ("select \"id\","++lenfn++"(\"name\"),\"name\" from \"persony\"") putStrLn "\n4\n" - vals <- H.execute stmt [] - results <- H.fetchAllRowsAL' stmt + vals2 <- H.execute stmt2 [] + print vals2 + results <- H.fetchAllRowsAL' stmt2 mapM_ print results H.commit conn - -main4::IO () + +main4 :: IO () main4 = do --let connectionString = "dsn=pg_test" let connectionString = "dsn=mysql_test" @@ -654,120 +696,35 @@ --let connectionString = "dsn=db2_test" conn <- H.connectODBC connectionString putStrLn "\nbefore create\n" - stmt <- H.prepare conn "create table fred (nm varchar(100) not null)" - a <- H.execute stmt [] - print a + stmt1 <- H.prepare conn "create table fred (nm varchar(100) not null)" + a1 <- H.execute stmt1 [] + print a1 putStrLn "\nbefore insert\n" - stmt <- H.prepare conn "insert into fred values(?)" - a <- H.execute stmt [H.SqlString "hello"] - print a - + stmt2 <- H.prepare conn "insert into fred values(?)" + a2 <- H.execute stmt2 [H.SqlString "hello"] + print a2 + putStrLn "\nbefore select\n" - stmt <- H.prepare conn "select nm,length(nm) from fred" - vals <- H.execute stmt [] - results <- H.fetchAllRowsAL' stmt + stmt3 <- H.prepare conn "select nm,length(nm) from fred" + vals3 <- H.execute stmt3 [] + print vals3 + results3 <- H.fetchAllRowsAL' stmt3 putStrLn "select after insert" - print results + print results3 putStrLn "\nbefore update\n" - stmt <- H.prepare conn "update fred set nm=?" - a <- H.execute stmt [H.SqlString "worldly"] + stmt4 <- H.prepare conn "update fred set nm=?" + a4 <- H.execute stmt4 [H.SqlString "worldly"] + print a4 putStrLn "\nbefore select #2\n" - stmt <- H.prepare conn "select nm,length(nm) from fred" - vals <- H.execute stmt [] - results <- H.fetchAllRowsAL' stmt + stmt5 <- H.prepare conn "select nm,length(nm) from fred" + vals5 <- H.execute stmt5 [] + print vals5 + results <- H.fetchAllRowsAL' stmt5 putStrLn "select after update" print results - - H.commit conn - -{- -drivername=odbc -clientver=03.80.0000 -proxied drivername=PostgreSQL -proxied clientver=09.02.0100 -serverver=9.3.0 -[("id",SqlColDesc {colType = SqlIntegerT, colSize = Just 10, colOctetLength -= Nothing, colDecDigits = Nothing, colNullable = Just False}),("name",SqlCol -Desc {colType = SqlVarCharT, colSize = Just 255, colOctetLength = Nothing, c -olDecDigits = Nothing, colNullable = Just False}),("employment",SqlColDesc { -colType = SqlVarCharT, colSize = Just 255, colOctetLength = Nothing, colDecD -igits = Nothing, colNullable = Just False})] - -drivername=odbc -clientver=03.80.0000 -proxied drivername=MySQL -proxied clientver=05.02.0005 -serverver=5.6.13-log - -[("id",SqlColDesc {colType = SqlBigIntT, colSize = Just 19, colOctetLength = - Nothing, colDecDigits = Nothing, colNullable = Just True}),("name",SqlColDe -sc {colType = SqlLongVarCharT, colSize = Just 65535, colOctetLength = Nothin -g, colDecDigits = Nothing, colNullable = Just False}),("employment",SqlColDe -sc {colType = SqlLongVarCharT, colSize = Just 65535, colOctetLength = Nothin -g, colDecDigits = Nothing, colNullable = Just False})] - -drivername=odbc -clientver=03.80.0000 -proxied drivername=Microsoft SQL Server -proxied clientver=06.01.7601 -serverver=11.00.2100 -[("id",SqlColDesc {colType = SqlBigIntT, colSize = Just 19, colOctetLength = - Nothing, colDecDigits = Nothing, colNullable = Just False}),("name",SqlColD -esc {colType = SqlVarCharT, colSize = Just 1000, colOctetLength = Nothing, c -olDecDigits = Nothing, colNullable = Just False}),("employment",SqlColDesc { -colType = SqlVarCharT, colSize = Just 1000, colOctetLength = Nothing, colDec -Digits = Nothing, colNullable = Just False})] - -drivername=odbc -clientver=03.80.0000 -proxied drivername=DB2/NT -proxied clientver=10.05.0000 -serverver=10.05.0000 -[("id",SqlColDesc {colType = SqlBigIntT, colSize = Just 19, colOctetLength = - Nothing, colDecDigits = Nothing, colNullable = Just False}),("name",SqlColD -esc {colType = SqlVarCharT, colSize = Just 1000, colOctetLength = Nothing, c -olDecDigits = Nothing, colNullable = Just False}),("employment",SqlColDesc { -colType = SqlVarCharT, colSize = Just 1000, colOctetLength = Nothing, colDec -Digits = Nothing, colNullable = Just False}),("id",SqlColDesc {colType = Sql -BigIntT, colSize = Just 19, colOctetLength = Nothing, colDecDigits = Nothing -, colNullable = Just False}),("name",SqlColDesc {colType = SqlVarCharT, colS -ize = Just 1000, colOctetLength = Nothing, colDecDigits = Nothing, colNullab -le = Just False}),("employment",SqlColDesc {colType = SqlVarCharT, colSize = - Just 1000, colOctetLength = Nothing, colDecDigits = Nothing, colNullable = -Just False})] - -drivername=odbc -clientver=03.80.0000 -proxied drivername=DB2/NT -proxied clientver=10.05.0000 -serverver=10.05.0000 - -[("id",SqlColDesc {colType = SqlBigIntT, colSize = Just 19, colOctetLength = - Nothing, colDecDigits = Nothing, colNullable = Just False}),("name",SqlColD -esc {colType = SqlVarCharT, colSize = Just 1000, colOctetLength = Nothing, c -olDecDigits = Nothing, colNullable = Just False}),("employment",SqlColDesc { -colType = SqlVarCharT, colSize = Just 1000, colOctetLength = Nothing, colDec -Digits = Nothing, colNullable = Just False}),("id",SqlColDesc {colType = Sql -BigIntT, colSize = Just 19, colOctetLength = Nothing, colDecDigits = Nothing -, colNullable = Just False}),("name",SqlColDesc {colType = SqlVarCharT, colS -ize = Just 1000, colOctetLength = Nothing, colDecDigits = Nothing, colNullab -le = Just False}),("employment",SqlColDesc {colType = SqlVarCharT, colSize = - Just 1000, colOctetLength = Nothing, colDecDigits = Nothing, colNullable = -Just False})] + H.commit conn -drivername=odbc -clientver=03.80.0000 -proxied drivername=Oracle -proxied clientver=11.02.0002 -serverver=11.02.0020 -[("id",SqlColDesc {colType = SqlFloatT, colSize = Just 38, colOctetLength = -Nothing, colDecDigits = Nothing, colNullable = Just False}),("name",SqlColDe -sc {colType = SqlVarCharT, colSize = Just 1000, colOctetLength = Nothing, co -lDecDigits = Nothing, colNullable = Just False}),("employment",SqlColDesc {c -olType = SqlVarCharT, colSize = Just 1000, colOctetLength = Nothing, colDecD -igits = Nothing, colNullable = Just False})] --}
persistent-odbc.cabal view
@@ -1,5 +1,5 @@ name: persistent-odbc -version: 0.2.0.1 +version: 0.2.1.0 synopsis: Backend for the persistent library using ODBC license: MIT license-file: LICENSE @@ -38,52 +38,50 @@ ghc-options: -Wall hs-source-dirs: src - build-depends: base >= 4.5 && < 5 - , 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.4 + build-depends: base >= 4.5 && < 5 + , text + , aeson + , time + , conduit + , containers + , transformers + , convertible + , HDBC >= 2.1.0 + , HDBC-odbc >= 2.6.0.0 , monad-logger , resourcet - , monad-control - , persistent-template >= 2.1 && < 3 - , persistent >= 2.1 && < 3 - , bytestring >= 0.9 && < 0.11 + , persistent-template >= 2.6.0 + , persistent >= 2.6.0 + , bytestring if flag(tester) hs-source-dirs: examples - exposed-modules: TestODBC - , FtypeEnum + exposed-modules: FtypeEnum , Employment build-depends: blaze-html - , esqueleto >= 2.1 && < 3 + , esqueleto >= 2.1 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.4 + , esqueleto + , text + , aeson + , time + , conduit + , containers + , transformers + , convertible + , HDBC >= 2.1.0 + , HDBC-odbc >= 2.6.0.0 , monad-logger , resourcet , monad-control - , persistent-template >= 2.1 && < 3 - , persistent >= 2.1 && < 3 - , bytestring >= 0.9 && < 0.11 + , persistent-template >= 2.6.0 + , persistent >= 2.6.0 + , bytestring else buildable: False Main-Is: TestODBC.hs
src/Database/Persist/MigrateDB2.hs view
@@ -1,16 +1,17 @@+{-# OPTIONS -Wall #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} -- | A DB2 backend for @persistent@. module Database.Persist.MigrateDB2 - ( getMigrationStrategy + ( getMigrationStrategy ) where import Control.Arrow import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) import Data.Either (partitionEithers) @@ -18,7 +19,7 @@ import Data.List (find, intercalate, sort, groupBy) import Data.Text (Text, pack) -import Data.Conduit +import Data.Conduit (connect, (.|)) import qualified Data.Conduit.List as CL import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -29,20 +30,20 @@ #if DEBUG import Debug.Trace -tracex::String -> a -> a +tracex :: String -> a -> a tracex = trace #else -tracex::String -> a -> a +tracex :: String -> a -> a tracex _ b = b #endif getMigrationStrategy :: DBType -> MigrationStrategy -getMigrationStrategy dbtype@DB2 {} = +getMigrationStrategy dbtype@DB2 {} = MigrationStrategy - { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT 99999999" + { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT 99999999" ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=T.pack . escapeDBName + ,dbmsEscape=T.pack . escapeDBName ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "DB2: calling with invalid dbtype " ++ show dbtype @@ -59,13 +60,13 @@ let (newcols, udefs, fdefs) = mkColumns allDefs val liftIO $ putStrLn $ "\n\nold="++show old liftIO $ putStrLn $ "\n\nfdefs="++show fdefs - + let udspair = map udToPair udefs case (idClmn, old, partitionEithers old) of -- Nothing found, create everything ([], [], _) -> do let idtxt = case entityPrimary val of - Just pdef -> tracex ("found it!!! val=" ++ show val) $ + Just pdef -> tracex ("found it!!! val=" ++ show val) $ concat [" CONSTRAINT ", escapeDBName (pkeyName (entityDB val)), " PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef, ")"] Nothing -> tracex ("not found val=" ++ show val) $ concat [escapeDBName $ fieldDB $ entityId val @@ -86,18 +87,18 @@ map (findTypeOfColumn allDefs name) ucols ] let foreigns = tracex ("in migrate' newcols=" ++ show newcols) $ do Column { cName=cname, cReference=Just (refTblName, a) } <- newcols - tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ + 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 -- No errors and something found, migrate (_, _, ([], old')) -> do let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of - Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ + Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ c { cReference = Nothing } Nothing -> c Nothing -> c) xs,ys) @@ -126,8 +127,8 @@ -- | 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_] +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 id_ = maybe (error $ "Could not find ID of entity " ++ show reftable ++ " (allDefs = " ++ show allDefs ++ ")") @@ -136,8 +137,8 @@ return (fieldDB (entityId entDef)) data AlterColumn = Change Column - | IsNull - | NotNull + | IsNull + | NotNull | Add' Column | Drop | Default String @@ -171,7 +172,7 @@ ) getColumns getter def = do -- Find out ID column. - stmtIdClmn <- getter $ T.concat + stmtIdClmn <- getter $ T.concat ["SELECT " ,"colname column_name " ,",nulls is_nullable " @@ -183,12 +184,12 @@ ,"WHERE tabschema=current_schema " ,"AND tabname=? " ,"AND colname <> ?"] - - inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) - ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + inter1 <- with (stmtQuery stmtIdClmn vals) (`connect` CL.consume) + ids <- runResourceT $ CL.sourceList inter1 `connect` helperClmns -- avoid nested queries + -- Find out all columns. - stmtClmns <- getter $ T.concat + stmtClmns <- getter $ T.concat ["SELECT " ,"colname column_name " ,",nulls is_nullable " @@ -200,8 +201,8 @@ ,"WHERE tabschema=current_schema " ,"AND tabname=? " ,"AND colname <> ?"] - inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) - cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + inter2 <- with (stmtQuery stmtClmns vals) (`connect` CL.consume) + cs <- runResourceT $ CL.sourceList inter2 `connect` helperClmns -- avoid nested queries -- Find out the constraints. stmtCntrs <- getter $ T.concat ["SELECT " @@ -224,7 +225,7 @@ ,"AND trim(pk_colnames) <> ? " ,"ORDER BY constraint_name, column_name"] - us <- with (stmtQuery stmtCntrs (vals++vals)) ($$ helperCntrs) + us <- with (stmtQuery stmtCntrs (vals++vals)) (`connect` helperCntrs) liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us -- Return both return (ids, cs ++ us) @@ -232,7 +233,7 @@ vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ fieldDB $ entityId def ] - helperClmns = CL.mapM getIt =$ CL.consume + helperClmns = CL.mapM getIt .| CL.consume where getIt = fmap (either Left (Right . Left)) . liftIO . @@ -260,7 +261,7 @@ , npre , nscl] = fmap (either (Left . pack) Right) $ - runErrorT $ do + runExceptT $ do -- Default value default_ <- case default' of PersistNull -> return Nothing @@ -289,11 +290,11 @@ let vars = [ PersistText $ unDBName tname , PersistByteString cname ] - cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) + cntrs <- liftIO $ with (stmtQuery stmt vars) (`connect` CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> - tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ + tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) a1 -> fail $ "DB2.getColumn/getRef: never here error[" ++ show a1 ++ "]" @@ -383,17 +384,17 @@ case filter ((name ==) . cName) cols of [] -> case ref of Nothing -> ([(name, Add' col)], []) - Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ + Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ [addReference allDefs (refName tblName name) tname name] in (map ((,) name) (Add' col : cnstr), cols) Column _ isNull' type_' def' _defConstraintName' _maxLen' ref':_ -> let -- Foreign key refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ + (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ [(name, DropReference cname)] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ + (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ [(tname, addReference allDefs (refName tblName name) tname name)] _ -> [] -- Type and nullability @@ -409,10 +410,10 @@ , filter ((name /=) . cName) cols ) -cmpdef::Maybe Text -> Maybe Text -> Bool +cmpdef :: Maybe Text -> Maybe Text -> Bool cmpdef Nothing Nothing = True cmpdef (Just def) (Just def') | def==def' = True - | otherwise = + | otherwise = let (a,_)=T.breakOnEnd ":" def' in case T.stripSuffix "::" a of Just xs -> def==xs @@ -603,7 +604,7 @@ insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of - Just _pdef -> + Just _pdef -> ISRManyKeys sql vals where sql = pack $ concat [ "INSERT INTO " @@ -614,8 +615,8 @@ , intercalate "," (map (const "?") $ entityFields ent) , ")" ] - Nothing -> - ISRInsertGet doInsert "select IDENTITY_VAL_LOCAL() as last_cod from sysibm.sysdummy1" + Nothing -> + ISRInsertGet doInsert "select IDENTITY_VAL_LOCAL() as last_cod from sysibm.sysdummy1" where doInsert = pack $ concat [ "INSERT INTO "
src/Database/Persist/MigrateMSSQL.hs view
@@ -1,16 +1,17 @@+{-# OPTIONS -Wall #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} -- | A MSSQL backend for @persistent@. module Database.Persist.MigrateMSSQL - ( getMigrationStrategy + ( getMigrationStrategy ) where import Control.Arrow import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) import Data.Either (partitionEithers) @@ -19,7 +20,7 @@ import Data.Text (Text, pack) import Data.Monoid ((<>), mconcat) -import Data.Conduit +import Data.Conduit (connect, (.|)) import qualified Data.Conduit.List as CL import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -30,15 +31,15 @@ #if DEBUG import Debug.Trace -tracex::String -> a -> a +tracex :: String -> a -> a tracex = trace #else -tracex::String -> a -> a +tracex :: String -> a -> a tracex _ b = b #endif getMigrationStrategy :: DBType -> MigrationStrategy -getMigrationStrategy dbtype@MSSQL { mssql2012=ok } = +getMigrationStrategy dbtype@MSSQL { mssql2012=ok } = MigrationStrategy { dbmsLimitOffset=limitOffset ok ,dbmsMigrate=migrate' @@ -60,14 +61,14 @@ let (newcols, udefs, fdefs) = mkColumns allDefs val liftIO $ putStrLn $ "\n\nold="++show old liftIO $ putStrLn $ "\n\nfdefs="++show fdefs - + let udspair = map udToPair udefs case (idClmn, old, partitionEithers old) of -- Nothing found, create everything ([], [], _) -> do let idtxt = case entityPrimary val of 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 "] + Nothing -> concat [escapeDBName $ fieldDB $ entityId val, " BIGINT NOT NULL IDENTITY(1,1) PRIMARY KEY "] let addTable = AddTable $ concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " @@ -84,18 +85,18 @@ map (findTypeOfColumn allDefs name) ucols ] let foreigns = tracex ("in migrate' newcols=" ++ show newcols) $ do Column { cName=cname, cReference=Just (refTblName, a) } <- newcols - tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ + 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 -- No errors and something found, migrate (_, _, ([], old')) -> do let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of - Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ + Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ c { cReference = Nothing } Nothing -> c Nothing -> c) xs,ys) @@ -121,8 +122,8 @@ -- | 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_] +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 id_ = maybe (error $ "Could not find ID of entity " ++ show reftable ++ " (allDefs = " ++ show allDefs ++ ")") @@ -164,7 +165,7 @@ ) getColumns getter def = do -- Find out ID column. - stmtIdClmn <- getter $ mconcat $ + stmtIdClmn <- getter $ mconcat $ ["SELECT COLUMN_NAME, " ,"IS_NULLABLE, " ,"DATA_TYPE, " @@ -172,8 +173,8 @@ ,"FROM INFORMATION_SCHEMA.COLUMNS " ,"WHERE TABLE_NAME = ? " ,"AND COLUMN_NAME = ?"] - inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) - ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + inter1 <- with (stmtQuery stmtIdClmn vals) (`connect` CL.consume) + ids <- runResourceT $ CL.sourceList inter1 `connect` helperClmns -- avoid nested queries -- Find out all columns. let sql=mconcat [ @@ -189,14 +190,14 @@ ," AND COLUMN_NAME <> ?" ," LEFT OUTER JOIN sysconstraints con " ," ON con.constid=col.default_object_id " - ] - --liftIO $ putStrLn $ "sql=" ++ show sql - stmtClmns <- getter sql - inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) - cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + ] + --liftIO $ putStrLn $ "sql=" ++ show sql + stmtClmns <- getter sql + inter2 <- with (stmtQuery stmtClmns vals) (`connect` CL.consume) + cs <- runResourceT $ CL.sourceList inter2 `connect` helperClmns -- avoid nested queries -- Find out the constraints. - stmtCntrs <- getter $ mconcat $ + stmtCntrs <- getter $ mconcat $ ["SELECT CONSTRAINT_NAME, " ,"COLUMN_NAME " ,"FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE p " @@ -206,7 +207,7 @@ ,"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 <- with (stmtQuery stmtCntrs vals) ($$ helperCntrs) + us <- with (stmtQuery stmtCntrs vals) (`connect` helperCntrs) liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us -- Return both return (ids, cs ++ us) @@ -214,7 +215,7 @@ vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ fieldDB $ entityId def ] - helperClmns = CL.mapM getIt =$ CL.consume + helperClmns = CL.mapM getIt .| CL.consume where getIt = fmap (either Left (Right . Left)) . liftIO . @@ -241,7 +242,7 @@ , default' , defaultConstraintName'] = fmap (either (Left . pack) Right) $ - runErrorT $ do + runExceptT $ do -- Default value default_ <- case default' of PersistNull -> return Nothing @@ -273,12 +274,12 @@ ["SELECT KCU2.TABLE_NAME AS REFERENCED_TABLE_NAME, " ,"KCU1.CONSTRAINT_NAME AS CONSTRAINT_NAME, 1 " ,"FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC " - ,"INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU1 " - ,"ON KCU1.CONSTRAINT_CATALOG = RC.CONSTRAINT_CATALOG " - ,"AND KCU1.CONSTRAINT_SCHEMA = RC.CONSTRAINT_SCHEMA " - ,"AND KCU1.CONSTRAINT_NAME = RC.CONSTRAINT_NAME " - ,"INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU2 " - ,"ON KCU2.CONSTRAINT_CATALOG = RC.UNIQUE_CONSTRAINT_CATALOG " + ,"INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU1 " + ,"ON KCU1.CONSTRAINT_CATALOG = RC.CONSTRAINT_CATALOG " + ,"AND KCU1.CONSTRAINT_SCHEMA = RC.CONSTRAINT_SCHEMA " + ,"AND KCU1.CONSTRAINT_NAME = RC.CONSTRAINT_NAME " + ,"INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU2 " + ,"ON KCU2.CONSTRAINT_CATALOG = RC.UNIQUE_CONSTRAINT_CATALOG " ,"AND KCU2.CONSTRAINT_SCHEMA = RC.UNIQUE_CONSTRAINT_SCHEMA " ,"AND KCU2.CONSTRAINT_NAME = RC.UNIQUE_CONSTRAINT_NAME " ,"AND KCU2.ORDINAL_POSITION = KCU1.ORDINAL_POSITION " @@ -288,11 +289,11 @@ let vars = [ PersistText $ unDBName tname , PersistText $ T.decodeUtf8 cname ] - cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) + cntrs <- liftIO $ with (stmtQuery stmt vars) (`connect` CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> - tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ + tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) a1 -> fail $ "MSSQL.getColumn/getRef: never here error[" ++ show a1 ++ "]" @@ -331,6 +332,8 @@ -- Text parseType "varchar" = return SqlString parseType "varstring" = return SqlString +parseType "nvarchar" = return SqlString +parseType "nvarstring" = return SqlString parseType "string" = return SqlString parseType "text" = return SqlString parseType "tinytext" = return SqlString @@ -399,17 +402,17 @@ case filter ((name ==) . cName) cols of [] -> case ref of Nothing -> ([(name, Add' col)], []) - Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ + Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ [addReference allDefs (refName tblName name) tname name] in (map ((,) name) (Add' col : cnstr), cols) Column _ isNull' type_' def' defConstraintName' _maxLen' ref':_ -> let -- Foreign key refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ + (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ [(name, DropReference cname)] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ + (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ [(tname, addReference allDefs (refName tblName name) tname name)] _ -> [] -- Type and nullability @@ -417,14 +420,14 @@ | otherwise = [(name, Change col)] -- Default value modDef | def == def' = [] - | otherwise = tracex ("\n\nfindAlters modDef col=" ++ show col ++ " name=" ++ show name ++ " def=" ++ show def ++ " def'=" ++ show def' ++ " defConstraintName=" ++ show defConstraintName++" defConstraintName'=" ++ show defConstraintName' ++ "\n\n") $ + | otherwise = tracex ("\n\nfindAlters modDef col=" ++ show col ++ " name=" ++ show name ++ " def=" ++ show def ++ " def'=" ++ show def' ++ " defConstraintName=" ++ show defConstraintName++" defConstraintName'=" ++ show defConstraintName' ++ "\n\n") $ case def of Nothing -> [(name, NoDefault $ maybe (error $ "expected a constraint name col="++show name) id defConstraintName')] Just s -> if cmpdef def def' then [] else [(name, Default $ T.unpack s)] in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols ) -cmpdef::Maybe Text -> Maybe Text -> Bool +cmpdef :: Maybe Text -> Maybe Text -> Bool cmpdef Nothing Nothing = True cmpdef (Just def) (Just def') = "(" <> def <> ")" == def' cmpdef _ _ = False @@ -590,7 +593,7 @@ insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of - Just _pdef -> + Just _pdef -> ISRManyKeys sql vals where sql = pack $ concat [ "INSERT INTO " @@ -601,7 +604,7 @@ , intercalate "," (map (const "?") $ entityFields ent) , ")" ] - Nothing -> + Nothing -> -- should use scope_identity() but doesnt work :gives null ISRInsertGet doInsert "SELECT @@identity" where @@ -623,14 +626,14 @@ -- doValue (FieldDef { fieldSqlType = SqlBlob }, PersistNull) = tracex "\n\nin blob with null\n\n" "isnull(?,convert(varbinary(max),''))" doValue _ _ = "?" - -limitOffset::Bool -> (Int,Int) -> Bool -> Text -> Text -limitOffset mssql2012' (limit,offset) hasOrder sql + +limitOffset :: Bool -> (Int,Int) -> Bool -> Text -> Text +limitOffset mssql2012' (limit,offset) hasOrder sql | limit==0 && offset==0 = sql | mssql2012' && hasOrder && limit==0 = sql <> " offset " <> T.pack (show offset) <> " rows" | mssql2012' && hasOrder = sql <> " offset " <> T.pack (show offset) <> " rows fetch next " <> T.pack (show limit) <> " rows only" | not mssql2012' && offset==0 = case "select " `T.isPrefixOf` T.toLower (T.take 7 sql) of - True -> let (a,b) = T.splitAt 7 sql + True -> let (a,b) = T.splitAt 7 sql ret=a <> T.pack "top " <> T.pack (show limit) <> " " <> b in ret -- tracex ("ret="++show ret) ret False -> if T.null sql then error "MSSQL: not 2012 so trying to add 'top n' but the sql is empty" @@ -638,7 +641,7 @@ | mssql2012' = error $ "MS SQL Server 2012 requires an order by statement for limit and offset sql=" ++ T.unpack sql | otherwise = error $ "MSSQL does not support limit and offset until MS SQL Server 2012 sql=" ++ T.unpack sql ++ " mssql2012=" ++ show mssql2012' ++ " hasOrder=" ++ show hasOrder {- -limitOffset True (limit,offset) False sql = error "MS SQL Server 2012 requires an order by statement for limit and offset" +limitOffset True (limit,offset) False sql = error "MS SQL Server 2012 requires an order by statement for limit and offset" limitOffset False (limit,offset) _ sql = error "MSSQL does not support limit and offset until MS SQL Server 2012" limitOffset True (limit,offset) True sql = undefined -}
src/Database/Persist/MigrateMySQL.hs view
@@ -1,16 +1,17 @@+{-# OPTIONS -Wall #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} -- | A MySQL backend for @persistent@. module Database.Persist.MigrateMySQL - ( getMigrationStrategy + ( getMigrationStrategy ) where import Control.Arrow import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) import Data.Either (partitionEithers) @@ -19,7 +20,7 @@ import Data.Text (Text, pack) import Data.Monoid ((<>)) -import Data.Conduit +import Data.Conduit (connect, (.|)) import qualified Data.Conduit.List as CL import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -30,21 +31,21 @@ #if DEBUG import Debug.Trace -tracex::String -> a -> a +tracex :: String -> a -> a tracex = trace #else -tracex::String -> a -> a +tracex :: String -> a -> a tracex _ b = b #endif getMigrationStrategy :: DBType -> MigrationStrategy -getMigrationStrategy dbtype@MySQL {} = +getMigrationStrategy dbtype@MySQL {} = MigrationStrategy - { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT 18446744073709551615" + { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT 18446744073709551615" ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=T.pack . escapeDBName + ,dbmsEscape=T.pack . escapeDBName ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "MySQL: calling with invalid dbtype " ++ show dbtype @@ -61,14 +62,14 @@ let (newcols, udefs, fdefs) = mkColumns allDefs val liftIO $ putStrLn $ "\n\nold="++show old liftIO $ putStrLn $ "\n\nfdefs="++show fdefs - + let udspair = map udToPair udefs case (idClmn, old, partitionEithers old) of -- Nothing found, create everything ([], [], _) -> do let idtxt = case entityPrimary val of Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (escapeDBName . fieldDB) $ compositeFields pdef, ")"] - Nothing -> concat [escapeDBName $ fieldDB $ entityId val, " int NOT NULL AUTO_INCREMENT PRIMARY KEY"] + Nothing -> concat [escapeDBName $ fieldDB $ entityId val, " bigint NOT NULL AUTO_INCREMENT PRIMARY KEY"] let addTable = AddTable $ concat -- Lower case e: see Database.Persist.Sql.Migration @@ -86,18 +87,18 @@ map (findTypeOfColumn allDefs name) ucols ] let foreigns = tracex ("in migrate' newcols=" ++ show newcols) $ do Column { cName=cname, cReference=Just (refTblName, a) } <- newcols - tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ + 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 -- No errors and something found, migrate (_, _, ([], old')) -> do let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of - Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ + Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ c { cReference = Nothing } Nothing -> c Nothing -> c) xs,ys) @@ -123,8 +124,8 @@ -- | 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_] +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 id_ = maybe (error $ "Could not find ID of entity " ++ show reftable ++ " (allDefs = " ++ show allDefs ++ ")") @@ -166,7 +167,7 @@ ) getColumns getter def = do -- Find out ID column. - stmtIdClmn <- getter $ T.concat $ + stmtIdClmn <- getter $ T.concat $ ["SELECT COLUMN_NAME, " ,"IS_NULLABLE, " ,"DATA_TYPE, " @@ -175,11 +176,11 @@ ,"WHERE table_schema=schema() " ,"AND TABLE_NAME = ? " ,"AND COLUMN_NAME = ?"] - inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) - ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + inter1 <- with (stmtQuery stmtIdClmn vals) (`connect` CL.consume) + ids <- runResourceT $ CL.sourceList inter1 `connect` helperClmns -- avoid nested queries -- Find out all columns. - stmtClmns <- getter $ T.concat $ + stmtClmns <- getter $ T.concat $ ["SELECT COLUMN_NAME, " ,"IS_NULLABLE, " ,"DATA_TYPE, " @@ -188,11 +189,11 @@ ,"WHERE table_schema=schema() " ,"AND TABLE_NAME = ? " ,"AND COLUMN_NAME <> ?"] - inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) - cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + inter2 <- with (stmtQuery stmtClmns vals) (`connect` CL.consume) + cs <- runResourceT $ CL.sourceList inter2 `connect` helperClmns -- avoid nested queries -- Find out the constraints. - stmtCntrs <- getter $ T.concat $ + stmtCntrs <- getter $ T.concat $ ["SELECT CONSTRAINT_NAME, " ,"COLUMN_NAME " ,"FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE " @@ -203,7 +204,7 @@ ,"AND REFERENCED_TABLE_SCHEMA IS NULL " ,"ORDER BY CONSTRAINT_NAME, " ,"COLUMN_NAME"] - us <- with (stmtQuery stmtCntrs vals) ($$ helperCntrs) + us <- with (stmtQuery stmtCntrs vals) (`connect` helperCntrs) liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us -- Return both return (ids, cs ++ us) @@ -211,7 +212,7 @@ vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ fieldDB $ entityId def ] - helperClmns = CL.mapM getIt =$ CL.consume + helperClmns = CL.mapM getIt .| CL.consume where getIt = fmap (either Left (Right . Left)) . liftIO . @@ -237,7 +238,7 @@ , PersistByteString type' , default'] = fmap (either (Left . pack) Right) $ - runErrorT $ do + runExceptT $ do -- Default value default_ <- case default' of PersistNull -> return Nothing @@ -254,7 +255,7 @@ type_ <- parseType type' -- Foreign key (if any) - stmt <- lift $ getter $ T.concat $ + stmt <- lift $ getter $ T.concat $ ["SELECT REFERENCED_TABLE_NAME, " ,"CONSTRAINT_NAME, " ,"ORDINAL_POSITION " @@ -269,11 +270,11 @@ let vars = [ PersistText $ unDBName tname , PersistByteString cname ] - cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) + cntrs <- liftIO $ with (stmtQuery stmt vars) (`connect` CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> - tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ + tracex ("\n\n\nGBREF "++show (tab,ref,pos)++"\n\n") $ return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) a1 -> fail $ "MySQL.getColumn/getRef: never here error[" ++ show a1 ++ "]" @@ -381,17 +382,17 @@ case filter ((name ==) . cName) cols of [] -> case ref of Nothing -> ([(name, Add' col)], []) - Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ + Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ [addReference allDefs (refName tblName name) tname name] in (map ((,) name) (Add' col : cnstr), cols) Column _ isNull' type_' def' defConstraintName' _maxLen' ref':_ -> let -- Foreign key refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ + (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ [(name, DropReference cname)] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ + (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ [(tname, addReference allDefs (refName tblName name) tname name)] _ -> [] -- Type and nullability @@ -399,7 +400,7 @@ | otherwise = [(name, Change col)] -- Default value modDef | cmpdef def def' = [] - | otherwise = tracex ("\n\nfindAlters modDef col=" ++ show col ++ " name=" ++ show name ++ " def=" ++ show def ++ " def'=" ++ show def' ++ " defConstraintName=" ++ show defConstraintName++" defConstraintName'=" ++ show defConstraintName' ++ "\n\n") $ + | otherwise = tracex ("\n\nfindAlters modDef col=" ++ show col ++ " name=" ++ show name ++ " def=" ++ show def ++ " def'=" ++ show def' ++ " defConstraintName=" ++ show defConstraintName++" defConstraintName'=" ++ show defConstraintName' ++ "\n\n") $ case def of Nothing -> [(name, NoDefault)] Just s -> [(name, Default $ T.unpack s)] @@ -407,7 +408,7 @@ , filter ((name /=) . cName) cols ) -cmpdef::Maybe Text -> Maybe Text -> Bool +cmpdef :: Maybe Text -> Maybe Text -> Bool cmpdef Nothing Nothing = True cmpdef (Just def) (Just def') = def == "'" <> def' <> "'" cmpdef _ _ = False @@ -447,7 +448,7 @@ showSqlType SqlBlob (Just i) = "VARBINARY(" ++ show i ++ ")" showSqlType SqlBool _ = "TINYINT(1)" showSqlType SqlDay _ = "DATE" -showSqlType SqlDayTime _ = "DATETIME" -- "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" @@ -585,7 +586,7 @@ insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of - Just _pdef -> + Just _pdef -> ISRManyKeys sql vals where sql = pack $ concat [ "INSERT INTO "
src/Database/Persist/MigrateOracle.hs view
@@ -1,16 +1,17 @@+{-# OPTIONS -Wall #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} -- | A Oracle backend for @persistent@. module Database.Persist.MigrateOracle - ( getMigrationStrategy + ( getMigrationStrategy ) where import Control.Arrow import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) import Data.Either (partitionEithers) @@ -18,7 +19,7 @@ import Data.List (find, intercalate, sort, groupBy) import Data.Text (Text, pack) -import Data.Conduit +import Data.Conduit (connect, (.|)) import qualified Data.Conduit.List as CL import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -29,20 +30,20 @@ #if DEBUG import Debug.Trace -tracex::String -> a -> a +tracex :: String -> a -> a tracex = trace #else -tracex::String -> a -> a +tracex :: String -> a -> a tracex _ b = b #endif getMigrationStrategy :: DBType -> MigrationStrategy -getMigrationStrategy dbtype@Oracle { oracle12c=ok} = +getMigrationStrategy dbtype@Oracle { oracle12c=ok} = MigrationStrategy { dbmsLimitOffset=limitOffset ok ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' - ,dbmsEscape=T.pack . escapeDBName + ,dbmsEscape=T.pack . escapeDBName ,dbmsType=dbtype } getMigrationStrategy dbtype = error $ "Oracle: calling with invalid dbtype " ++ show dbtype @@ -58,7 +59,7 @@ let (newcols, udefs, fdefs) = mkColumns allDefs val let udspair = map udToPair udefs let addSequence = AddSequence $ concat - [ "CREATE SEQUENCE " + [ "CREATE SEQUENCE " ,getSeqNameEscaped name , " START WITH 1 INCREMENT BY 1" ] @@ -84,10 +85,10 @@ map (findTypeOfColumn allDefs name) ucols ] let foreigns = tracex ("in migrate' newcols=" ++ show newcols) $ do Column { cName=cname, cReference=Just (refTblName, a) } <- newcols - tracex ("\n\n111foreigns cname="++show cname++" name="++show name++" refTblName="++show refTblName++" a="++show a) $ + 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 @@ -95,14 +96,14 @@ (_, _, ([], old'),mseq') -> do let excludeForeignKeys (xs,ys) = (map (\c -> case cReference c of Just (_,fk) -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of - Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ + Just _ -> tracex ("\n\n\nremoving cos a composite fk="++show fk) $ c { cReference = Nothing } Nothing -> c Nothing -> c) xs,ys) (acs, ats) = getAlters allDefs name (newcols, udspair) $ excludeForeignKeys $ partitionEithers old' acs' = map (AlterColumn name) acs ats' = map (AlterTable name) ats - return $ Right $ map showAlterDb $ acs' ++ ats' ++ (maybe [addSequence] (const []) mseq') + return $ Right $ map showAlterDb $ acs' ++ ats' ++ (maybe [addSequence] (const []) mseq') -- Errors (_, _, (errs, _), _) -> return $ Left errs @@ -121,8 +122,8 @@ -- | 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_] +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 id_ = maybe (error $ "Could not find ID of entity " ++ show reftable ++ " (allDefs = " ++ show allDefs ++ ")") @@ -165,7 +166,7 @@ ) getColumns getter def = do -- Find out ID column. - stmtIdClmn <- getter $ T.concat + stmtIdClmn <- getter $ T.concat ["SELECT COLUMN_NAME, " ,"cast(NULLABLE as CHAR) as IS_NULLABLE, " ,"DATA_TYPE, " @@ -173,14 +174,14 @@ ,"FROM user_tab_cols " ,"WHERE TABLE_NAME = ? " ,"AND COLUMN_NAME = ?"] - inter1 <- with (stmtQuery stmtIdClmn vals) ($$ CL.consume) - ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + inter1 <- with (stmtQuery stmtIdClmn vals) (`connect` CL.consume) + ids <- runResourceT $ CL.sourceList inter1 `connect` helperClmns -- avoid nested queries -- Find if sequence already exists. stmtSeq <- getter $ T.concat ["SELECT sequence_name " ,"FROM user_sequences " ,"WHERE sequence_name = ?"] - seqlist <- with (stmtQuery stmtSeq [PersistText $ getSeqNameUnescaped $ entityDB def]) ($$ CL.consume) + seqlist <- with (stmtQuery stmtSeq [PersistText $ getSeqNameUnescaped $ entityDB def]) (`connect` CL.consume) --liftIO $ putStrLn $ "seqlist=" ++ show seqlist -- Find out all columns. @@ -191,12 +192,12 @@ ,"FROM user_tab_cols " ,"WHERE TABLE_NAME = ? " ,"AND COLUMN_NAME <> ?"] - inter2 <- with (stmtQuery stmtClmns vals) ($$ CL.consume) - cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + inter2 <- liftIO $ with (stmtQuery stmtClmns vals) (`connect` CL.consume) + cs <- runResourceT $ CL.sourceList inter2 `connect` helperClmns -- avoid nested queries - -- Find out the constraints. + -- Find out the constraints. - stmtCntrs <- getter $ T.concat + stmtCntrs <- getter $ T.concat ["SELECT a.CONSTRAINT_NAME, " ,"a.COLUMN_NAME " ,"FROM user_cons_columns a,user_constraints b " @@ -207,7 +208,7 @@ ,"AND a.COLUMN_NAME <> ? " ,"ORDER BY b.CONSTRAINT_NAME, " ,"a.COLUMN_NAME"] - us <- with (stmtQuery stmtCntrs vals) ($$ helperCntrs) + us <- with (stmtQuery stmtCntrs vals) (`connect` helperCntrs) -- Return both return (ids, cs ++ us, listAsMaybe seqlist) @@ -215,11 +216,11 @@ listAsMaybe [] = Nothing listAsMaybe [[x]] = Just x listAsMaybe xs = error $ "returned to many sequences xs=" ++ show xs - + vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ fieldDB $ entityId def ] - helperClmns = CL.mapM getIt =$ CL.consume + helperClmns = CL.mapM getIt .| CL.consume where getIt = fmap (either Left (Right . Left)) . liftIO . @@ -245,7 +246,7 @@ , PersistByteString type' , default'] = fmap (either (Left . pack) Right) $ - runErrorT $ do + runExceptT $ do -- Default value default_ <- case default' of PersistNull -> return Nothing @@ -262,7 +263,7 @@ type_ <- parseType type' -- Foreign key (if any) - stmt <- lift $ getter $ T.concat + stmt <- lift $ getter $ T.concat ["SELECT " ,"UCC.TABLE_NAME as REFERENCED_TABLE_NAME, " ,"UC.CONSTRAINT_NAME as CONSTRAINT_NAME " @@ -282,9 +283,9 @@ ,"UCC.COLUMN_NAME"] let vars = [ PersistText $ unDBName tname - , PersistByteString cname + , PersistByteString cname ] - cntrs <- with (stmtQuery stmt vars) ($$ CL.consume) + cntrs <- liftIO $ with (stmtQuery stmt vars) (`connect` CL.consume) ref <- case cntrs of [] -> return Nothing [[PersistByteString tab, PersistByteString ref]] -> @@ -345,7 +346,7 @@ --parseType "newdate" = return SqlDay --parseType "year" = return SqlDay -- Other -parseType b = error $ "oracle: parseType no idea how to parse this b="++show b +parseType b = error $ "oracle: parseType no idea how to parse this b="++show b ---------------------------------------------------------------------- @@ -396,17 +397,17 @@ case filter ((name ==) . cName) cols of [] -> case ref of Nothing -> ([(name, Add' col)], []) - Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ + Just (tname, b) -> let cnstr = tracex ("\n\ncols="++show cols++"\n\n2222findalters new foreignkey col["++showColumn col++"] name["++show name++"] tname["++show tname++"] b["++show b ++ "]") $ [addReference allDefs (refName tblName name) tname name] in (map ((,) name) (Add' col : cnstr), cols) Column _ isNull' type_' def' _defConstraintName' _maxLen' ref':_ -> let -- Foreign key refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ + (False, Just (_, cname)) -> tracex ("\n\n44444findalters dropping foreignkey cname[" ++ show cname ++ "] ref[" ++ show ref ++"]") $ [(name, DropReference cname)] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ + (False, Just (tname, cname)) -> tracex ("\n\n33333 findalters foreignkey has changed cname["++show cname++"] name["++show name++"] tname["++show tname++"] ref["++show ref++"] ref'["++show ref' ++ "]") $ [(tname, addReference allDefs (refName tblName name) tname name)] _ -> [] -- Type and nullability @@ -422,10 +423,10 @@ , filter ((name /=) . cName) cols ) -cmpdef::Maybe Text -> Maybe Text -> Bool +cmpdef :: Maybe Text -> Maybe Text -> Bool --cmpdef Nothing Nothing = True cmpdef = (==) ---cmpdef (Just def) (Just def') = tracex ("def[" ++ show (T.concatMap (T.pack . show . ord) def) ++ "] def'[" ++ show (T.concatMap (T.pack . show . ord) def') ++ "]") $ def == def' +--cmpdef (Just def) (Just def') = tracex ("def[" ++ show (T.concatMap (T.pack . show . ord) def) ++ "] def'[" ++ show (T.concatMap (T.pack . show . ord) def') ++ "]") $ def == def' --cmpdef _ _ = False tpcheck :: SqlType -> SqlType -> Bool @@ -461,7 +462,7 @@ -> Maybe Integer -- ^ @maxlen@ -> String showSqlType SqlBlob Nothing = "BLOB" -showSqlType SqlBlob (Just _i) = "BLOB" -- cannot specify the size +showSqlType SqlBlob (Just _i) = "BLOB" -- cannot specify the size showSqlType SqlBool _ = "CHAR" showSqlType SqlDay _ = "DATE" showSqlType SqlDayTime _ = "TIMESTAMP(6)" @@ -583,7 +584,7 @@ ] -- ORA-00972: identifier is too long -refName :: DBName -> DBName -> DBName +refName :: DBName -> DBName -> DBName refName (DBName table) (DBName column) = DBName $ T.take 30 $ T.concat [table, "_", column, "_fkey"] @@ -610,7 +611,7 @@ insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of - Just _pdef -> + Just _pdef -> ISRManyKeys sql vals where sql = pack $ concat [ "INSERT INTO " @@ -640,11 +641,11 @@ getSeqNameEscaped :: DBName -> String getSeqNameEscaped d = escapeDBName $ DBName $ getSeqNameUnescaped d -getSeqNameUnescaped::DBName -> Text +getSeqNameUnescaped :: DBName -> Text getSeqNameUnescaped (DBName s) = "seq_" <> s <> "_id" -limitOffset::Bool -> (Int,Int) -> Bool -> Text -> Text -limitOffset oracle12c' (limit,offset) hasOrder sql +limitOffset :: Bool -> (Int,Int) -> Bool -> Text -> Text +limitOffset oracle12c' (limit,offset) hasOrder sql | limit==0 && offset==0 = sql | oracle12c' && hasOrder && limit==0 = sql <> " offset " <> T.pack (show offset) <> " rows" | oracle12c' && hasOrder = sql <> " offset " <> T.pack (show offset) <> " rows fetch next " <> T.pack (show limit) <> " rows only"
src/Database/Persist/MigratePostgres.hs view
@@ -1,17 +1,18 @@+{-# OPTIONS -Wall #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | An ODBC backend for persistent. module Database.Persist.MigratePostgres - ( getMigrationStrategy + ( getMigrationStrategy ) where import Database.Persist.Sql import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Text as T import Data.Text (pack,Text) @@ -19,7 +20,7 @@ import Control.Arrow import Data.List (find, intercalate, sort, groupBy) import Data.Function (on) -import Data.Conduit +import Data.Conduit (connect, (.|)) import qualified Data.Conduit.List as CL import Data.Maybe (mapMaybe) @@ -30,24 +31,24 @@ #if DEBUG import Debug.Trace -tracex::String -> a -> a +tracex :: String -> a -> a tracex = trace #else -tracex::String -> a -> a +tracex :: String -> a -> a tracex _ b = b #endif getMigrationStrategy :: DBType -> MigrationStrategy -getMigrationStrategy dbtype@Postgres {} = +getMigrationStrategy dbtype@Postgres {} = MigrationStrategy - { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT ALL" - ,dbmsMigrate=migrate' - ,dbmsInsertSql=insertSql' - ,dbmsEscape=escape + { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT ALL" + ,dbmsMigrate=migrate' + ,dbmsInsertSql=insertSql' + ,dbmsEscape=escape ,dbmsType=dbtype - } + } getMigrationStrategy dbtype = error $ "Postgres: calling with invalid dbtype " ++ show dbtype - + migrate' :: [EntityDef] -> (Text -> IO Statement) -> EntityDef @@ -81,7 +82,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 @@ -122,13 +123,13 @@ ,"AND table_schema=current_schema() " ,"AND table_name=? " ,"AND column_name <> ?"] - + stmt <- getter $ pack sqlv let vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ fieldDB $ entityId def ] - cs <- with (stmtQuery stmt vals) ($$ helperClmns) + cs <- with (stmtQuery stmt vals) (`connect` helperClmns) let sqlc=concat ["SELECT " ,"c.constraint_name, " ,"c.column_name " @@ -147,8 +148,8 @@ ,"ORDER BY c.constraint_name, c.column_name"] stmt' <- getter $ pack sqlc - - us <- with (stmtQuery stmt' vals) ($$ helperU) + + us <- with (stmtQuery stmt' vals) (`connect` helperU) liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us return $ cs ++ us where @@ -157,14 +158,14 @@ case x of Nothing -> return $ front [] Just [PersistText con, PersistText col] -> getAll (front . (:) (con, col)) - Just [PersistByteString con, PersistByteString col] -> getAll (front . (:) (T.decodeUtf8 con, T.decodeUtf8 col)) + Just [PersistByteString con, PersistByteString col] -> getAll (front . (:) (T.decodeUtf8 con, T.decodeUtf8 col)) Just xx -> error $ "oops: unexpected datatype returned odbc postgres xx="++show xx helperU = do rows <- getAll id return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) $ groupBy ((==) `on` fst) rows - helperClmns = CL.mapM getIt =$ CL.consume + helperClmns = CL.mapM getIt .| CL.consume where getIt = fmap (either Left (Right . Left)) . liftIO . @@ -266,7 +267,7 @@ ,"AND tc.table_schema=current_schema() " ,"AND tc.table_schema=kcu.table_schema " ,"AND tc.table_schema=ccu.table_schema " - ,"order by tc.table_name,tc.constraint_name, kcu.ordinal_position " + ,"order by tc.table_name,tc.constraint_name, kcu.ordinal_position " ] let ref = refName tname cname @@ -274,7 +275,7 @@ with (stmtQuery stmt [ PersistText $ unDBName tname , PersistText $ unDBName ref - ]) ($$ do + ]) (`connect` do m <- CL.head return $ case m of @@ -312,17 +313,17 @@ [] -> ([(name, Add' col)], cols) Column _ isNull' sqltype' def' defConstraintName' _maxLen' ref':_ -> let refDrop Nothing = [] - refDrop (Just (_, cname)) = tracex ("\n\n\n44444 findAlters dropping fkey defConstraintName'="++show defConstraintName' ++" name="++show name++" cname="++show cname++" tablename="++show tablename++"\n\n\n") $ + refDrop (Just (_, cname)) = tracex ("\n\n\n44444 findAlters dropping fkey defConstraintName'="++show defConstraintName' ++" name="++show name++" cname="++show cname++" tablename="++show tablename++"\n\n\n") $ [(name, DropReference cname)] 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") $ + 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] [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) $ + modRef = tracex ("modType: sqltype[" ++ show sqltype ++ "] sqltype'[" ++ show sqltype' ++ "] name=" ++ show name) $ if fmap snd ref == fmap snd ref' then [] - else tracex ("\n\n\nmodRef findAlters drop/add cos ref doesnt match ref[" ++ show ref ++ "] ref'[" ++ show ref' ++ "] tablename="++show tablename++"\n\n\n") $ + else tracex ("\n\n\nmodRef findAlters drop/add cos ref doesnt match ref[" ++ show ref ++ "] ref'[" ++ show ref' ++ "] tablename="++show tablename++"\n\n\n") $ refDrop ref' ++ refAdd ref modNull = case (isNull, isNull') of (True, False) -> [(name, IsNull)] @@ -332,7 +333,7 @@ Just s -> (:) (name, Update' $ T.unpack s) in up [(name, NotNull)] _ -> [] - modType = tracex ("modType: sqltype[" ++ show sqltype ++ "] sqltype'[" ++ show sqltype' ++ "] name=" ++ show name) $ + modType = tracex ("modType: sqltype[" ++ show sqltype ++ "] sqltype'[" ++ show sqltype' ++ "] name=" ++ show name) $ if sqltype == sqltype' then [] else [(name, Type sqltype)] modDef = tracex ("modDef col=" ++ show col ++ " def=" ++ show def ++ " def'=" ++ show def') $ if cmpdef def def' @@ -343,12 +344,12 @@ in (modRef ++ modDef ++ modNull ++ modType, filter (\c -> cName c /= name) cols) -cmpdef::Maybe Text -> Maybe Text -> Bool +cmpdef :: Maybe Text -> Maybe Text -> Bool cmpdef Nothing Nothing = True cmpdef (Just def) (Just def') | def==def' = True - | otherwise = + | otherwise = let (a,_)=T.breakOnEnd ":" def' - in -- tracex ("cmpdef def[" ++ show def ++ "] def'[" ++ show def' ++ "] a["++show a++"]") $ + in -- tracex ("cmpdef def[" ++ show def ++ "] def'[" ++ show def' ++ "] a["++show a++"]") $ case T.stripSuffix "::" a of Just xs -> def==xs Nothing -> False @@ -359,15 +360,15 @@ getAddReference allDefs table reftable cname ref = case ref of Nothing -> Nothing - Just (s, z) -> tracex ("\n\ngetaddreference table="++ show table++" reftable="++show reftable++" s="++show s++" z=" ++ show z++"\n\n") $ + Just (s, z) -> tracex ("\n\ngetaddreference table="++ show table++" reftable="++show reftable++" s="++show s++" z=" ++ show z++"\n\n") $ Just $ AlterColumn table (s, AddReference (refName table cname) [cname] [id_]) where id_ = maybe (error $ "Could not find ID of entity " ++ show reftable) id $ do entDef <- find ((== reftable) . entityDB) allDefs return (fieldDB $ entityId entDef) - + showColumn :: Column -> String showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = concat [ T.unpack $ escape n @@ -400,7 +401,7 @@ showAlterDb (AlterColumn t (c, ac)) = (isUnsafe ac, pack $ showAlter t (c, ac)) where - isUnsafe (Drop safeToRemove) = not safeToRemove + isUnsafe (Drop safeToRem) = not safeToRem isUnsafe _ = False showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) @@ -527,7 +528,7 @@ insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = tracex ("\n\n\nGBTEST " ++ show (entityFields ent) ++ "\n\n\n") $ case entityPrimary ent of - Just _pdef -> + Just _pdef -> ISRManyKeys sql vals where sql = pack $ concat [ "INSERT INTO " @@ -538,7 +539,7 @@ , intercalate "," (map (const "?") $ entityFields ent) , ")" ] - Nothing -> + Nothing -> ISRSingle $ pack $ concat [ "INSERT INTO " , T.unpack $ escape $ entityDB ent
src/Database/Persist/MigrateSqlite.hs view
@@ -1,16 +1,17 @@ -- add foreign key support?? +{-# OPTIONS -Wall #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} -- | A Sqlite backend for @persistent@. module Database.Persist.MigrateSqlite - ( getMigrationStrategy + ( getMigrationStrategy ) where import Data.List (intercalate) import Data.Text (Text, pack) -import Data.Conduit +import Data.Conduit (connect) import qualified Data.Conduit.List as CL import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -21,9 +22,9 @@ import Data.Monoid ((<>)) getMigrationStrategy :: DBType -> MigrationStrategy -getMigrationStrategy dbtype@Sqlite { sqlite3619 = _fksupport } = +getMigrationStrategy dbtype@Sqlite { sqlite3619 = _fksupport } = MigrationStrategy - { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT -1" + { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT -1" ,dbmsMigrate=migrate' ,dbmsInsertSql=insertSql' ,dbmsEscape=escape @@ -34,7 +35,7 @@ insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult insertSql' ent vals = case entityPrimary ent of - Just _ -> + Just _ -> ISRManyKeys sql vals where sql = pack $ concat [ "INSERT INTO " @@ -80,7 +81,7 @@ 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' <- with (stmtQuery stmt [PersistText $ unDBName table]) ($$ go) + oldSql' <- with (stmtQuery stmt [PersistText $ unDBName table]) (`connect` go) case oldSql' of Nothing -> return $ Right [(False, newSql)] Just oldSql -> do @@ -114,7 +115,7 @@ -> IO [(Bool, Text)] getCopyTable allDefs getter def = do stmt <- getter $ pack $ "PRAGMA table_info(" ++ escape' table ++ ")" - oldCols' <- with (stmtQuery stmt []) ($$ getCols) + oldCols' <- with (stmtQuery stmt []) (`connect` 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 @@ -198,7 +199,7 @@ , T.concat $ map sqlUnique uniqs , ")" ] - + mayDefault :: Maybe Text -> Text mayDefault def = case def of Nothing -> ""
src/Database/Persist/ODBC.hs view
@@ -1,8 +1,10 @@+{-# OPTIONS -Wall #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | An ODBC backend for persistent. module Database.Persist.ODBC ( withODBCPool @@ -33,6 +35,7 @@ import qualified Data.Convertible as DC import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Resource (MonadUnliftIO) import Data.IORef(newIORef) import qualified Data.Map as Map import qualified Data.Text as T @@ -40,7 +43,6 @@ import Data.Text (Text) import Data.Aeson -- (Object(..), (.:)) import Control.Monad (mzero) -import Control.Monad.Trans.Control (MonadBaseControl) --import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Logger @@ -50,7 +52,7 @@ 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@. +-- string would be @DSN=hdbctest1@. type ConnectionString = String -- | Create an ODBC connection pool and run the given @@ -58,8 +60,8 @@ -- finishes using it. Note that you should not use the given -- 'ConnectionPool' outside the action since it may be already -- been released. -withODBCPool :: (MonadBaseControl IO m, MonadLogger m, MonadIO m) - => Maybe DBType +withODBCPool :: (MonadUnliftIO m, MonadLogger m) + => Maybe DBType -> ConnectionString -- ^ Connection string to the database. -> Int @@ -76,8 +78,8 @@ -- responsibility to properly close the connection pool when -- unneeded. Use 'withODBCPool' for an automatic resource -- control. -createODBCPool :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) - => Maybe DBType +createODBCPool :: (MonadUnliftIO m, MonadLogger m) + => Maybe DBType -> ConnectionString -- ^ Connection string to the database. -> Int @@ -88,30 +90,30 @@ -- | Same as 'withODBCPool', but instead of opening a pool -- of connections, only one connection is opened. -withODBCConn :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) +withODBCConn :: (MonadUnliftIO m, MonadLogger 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' :: LogFunc -> Maybe DBType -> ConnectionString -> IO SqlBackend -open' logFunc mdbtype cstr = +open' logFunc mdbtype cstr = O.connectODBC cstr >>= openSimpleConn logFunc mdbtype --- | returns a supported database type based on its version +-- | 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 findDBMS::(String, String, String) -> DBType -findDBMS dvs@(driver,ver,serverver) +findDBMS dvs@(driver,ver,serverver) | driver=="Oracle" = Oracle $ getServerVersionNumber dvs>=12 - | "DB2" `L.isPrefixOf` driver = DB2 + | "DB2" `L.isPrefixOf` driver = DB2 | driver=="Microsoft SQL Server" = MSSQL $ getServerVersionNumber dvs>=11 - | driver=="MySQL" = MySQL - | "PostgreSQL" `L.isPrefixOf` driver = Postgres + | driver=="MySQL" = MySQL + | "PostgreSQL" `L.isPrefixOf` driver = Postgres | "SQLite" `L.isPrefixOf` driver = Sqlite False | otherwise = error $ "unknown or unsupported driver[" ++ driver ++ "] ver[" ++ ver ++ "] serverver[" ++ serverver ++ "]\nExplicitly set the type of dbms using DBType and try again!" --- | extracts the server version number +-- | extracts the server version number getServerVersionNumber::(String, String, String) -> Integer -getServerVersionNumber (driver, ver, serverver) = +getServerVersionNumber (driver, ver, serverver) = case reads $ takeWhile (/='.') serverver of [(a,"")] -> a xs -> error $ "getServerVersionNumber of findDBMS:cannot tell the version xs=" ++show xs ++ ":" ++ "driver[" ++ driver ++ "] ver[" ++ ver ++ "] serverver[" ++ serverver ++ "]" @@ -120,20 +122,22 @@ -- | Generate a persistent 'Connection' from an odbc 'O.Connection' 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) + 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 SqlBackend { connLogFunc = logFunc , connPrepare = prepare' conn , connStmtMap = smap , connInsertSql = dbmsInsertSql mig + , connInsertManySql = Nothing + , connRepsertManySql = Nothing , connClose = O.disconnect conn , connMigrateSql = dbmsMigrate mig - , connBegin = const - $ E.catch (O.commit conn) (\(_ :: E.SomeException) -> return ()) + , connBegin = (const . const) + $ E.catch (O.commit conn) (\(_ :: E.SomeException) -> return ()) -- there is no nested transactions. -- Transaction begining means that previous commited , connCommit = const $ O.commit conn @@ -142,10 +146,13 @@ , connNoLimit = "" -- esqueleto uses this but needs to use connLimitOffset then we can dump this field , connRDBMS = T.pack $ show (dbmsType mig) , connLimitOffset = dbmsLimitOffset mig + , connMaxParams = Nothing + , connUpsertSql = Nothing + , connPutManySql = Nothing } -- | Choose the migration strategy based on the user provided database type -getMigrationStrategy::DBType -> MigrationStrategy -getMigrationStrategy dbtype = +getMigrationStrategy :: DBType -> MigrationStrategy +getMigrationStrategy dbtype = case dbtype of Postgres -> PG.getMigrationStrategy dbtype MySQL -> MYSQL.getMigrationStrategy dbtype @@ -160,7 +167,7 @@ putStrLn $ "Database.Persist.ODBC.prepare': sql = " ++ T.unpack sql #endif stmt <- O.prepare conn $ T.unpack sql - + return Statement { stmtFinalize = O.finish stmt , stmtReset = return () -- rollback conn ? @@ -174,20 +181,20 @@ withStmt' :: MonadIO m => O.Statement -> [PersistValue] - -> Acquire (Source m [PersistValue]) + -> Acquire (ConduitT () [PersistValue] m ()) withStmt' stmt vals = do #if DEBUG liftIO $ putStrLn $ "withStmt': vals: " ++ show vals #endif result <- mkAcquire openS closeS - return $ pull result + return $ pull result --bracketP openS closeS pull where openS = execute' stmt vals >> return () closeS _ = O.finish stmt pull x = do mr <- liftIO $ O.fetchRow stmt - maybe (return ()) + maybe (return ()) (\r -> do #if DEBUG liftIO $ putStrLn $ "withStmt': yield: " ++ show r @@ -198,7 +205,7 @@ ) mr --- | Information required to connect to a PostgreSQL database +-- | Information required to connect to an ODBC database -- using @persistent@'s generic facilities. These values are the -- same that are given to 'withODBCPool'. data OdbcConf = OdbcConf @@ -231,7 +238,7 @@ safeConvert (P (PersistText t)) = Right $ HSV.toSql t safeConvert (P (PersistByteString bs)) = Right $ HSV.toSql bs safeConvert (P (PersistInt64 i)) = Right $ HSV.toSql i - safeConvert (P (PersistRational r)) = Right $ HSV.toSql (fromRational r::Double) + safeConvert (P (PersistRational r)) = Right $ HSV.toSql (fromRational r :: Double) safeConvert (P (PersistDouble d)) = Right $ HSV.toSql d safeConvert (P (PersistBool b)) = Right $ HSV.SqlInteger (if b then 1 else 0) safeConvert (P (PersistDay d)) = Right $ HSV.toSql d @@ -241,16 +248,16 @@ safeConvert (P PersistNull) = Right HSV.SqlNull safeConvert (P (PersistList l)) = Right $ HSV.toSql $ listToJSON l safeConvert (P (PersistMap m)) = Right $ HSV.toSql $ mapToJSON m - safeConvert p@(P (PersistObjectId _)) = Left DC.ConvertError + safeConvert p@(P (PersistObjectId _)) = Left DC.ConvertError { DC.convSourceValue = show p - , DC.convSourceType = "P (PersistValue)" + , DC.convSourceType = "P (PersistValue)" , DC.convDestType = "SqlValue" , DC.convErrorMessage = "Refusing to serialize a PersistObjectId to an ODBC value" } safeConvert xs = error $ "unhandled safeConvert xs=" ++ show xs -- FIXME: check if those are correct and complete. -instance DC.Convertible HSV.SqlValue P where +instance DC.Convertible HSV.SqlValue P where safeConvert (HSV.SqlString s) = Right $ P $ PersistText $ T.pack s safeConvert (HSV.SqlByteString bs) = Right $ P $ PersistByteString bs safeConvert v@(HSV.SqlWord32 _) = Left DC.ConvertError
src/Database/Persist/ODBCTypes.hs view
@@ -5,22 +5,22 @@ import Database.Persist.Sql -- | List of DBMS that are supported -data DBType = MySQL | Postgres | MSSQL { mssql2012::Bool} | Oracle { oracle12c::Bool } | DB2 | Sqlite { sqlite3619::Bool } deriving (Show,Read) +data DBType = MySQL | Postgres | MSSQL { mssql2012 :: Bool} | Oracle { oracle12c :: Bool } | DB2 | Sqlite { sqlite3619 :: Bool } deriving (Show,Read) -mysql,postgres,mssqlMin2012,mssql,oracleMin12c,oracle,db2,sqlite,sqliteMin3619::DBType +mysql,postgres,mssqlMin2012,mssql,oracleMin12c,oracle,db2,sqlite,sqliteMin3619 :: DBType mysql = MySQL postgres = Postgres mssqlMin2012 = MSSQL True mssql = MSSQL False -oracleMin12c = Oracle True +oracleMin12c = Oracle True oracle = Oracle False db2 = DB2 sqlite = Sqlite False sqliteMin3619 = Sqlite True --load up the dbmsMigration depending on the dbms then somehow pass in the partially apply if it is limitoffset-capable to dbmsLimitOffset -data MigrationStrategy = MigrationStrategy { - dbmsLimitOffset :: (Int,Int) -> Bool -> Text -> Text +data MigrationStrategy = MigrationStrategy { + dbmsLimitOffset :: (Int,Int) -> Bool -> Text -> Text ,dbmsMigrate :: [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) ,dbmsInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult ,dbmsEscape :: DBName -> Text