persistent-odbc (empty) → 0.1.2.0
raw patch · 13 files changed
+4539/−0 lines, 13 filesdep +HDBCdep +HDBC-odbcdep +aesonsetup-changed
Dependencies added: HDBC, HDBC-odbc, aeson, base, blaze-html, bytestring, conduit, containers, convertible, esqueleto, monad-logger, persistent, persistent-template, resourcet, text, time, transformers
Files
- LICENSE +21/−0
- Setup.lhs +7/−0
- examples/FtypeEnum.hs +62/−0
- examples/TestODBC.hs +756/−0
- persistent-odbc.cabal +66/−0
- src/Database/Persist/MigrateDB2.hs +631/−0
- src/Database/Persist/MigrateMSSQL.hs +644/−0
- src/Database/Persist/MigrateMySQL.hs +609/−0
- src/Database/Persist/MigrateOracle.hs +651/−0
- src/Database/Persist/MigratePostgres.hs +549/−0
- src/Database/Persist/MigrateSqlite.hs +234/−0
- src/Database/Persist/ODBC.hs +281/−0
- src/Database/Persist/ODBCTypes.hs +28/−0
+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2013 Dmitry Olshansky, OlshanskyDR@gmail.com + 2014 Grant Weyburne, gbwey9@gmail.com + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
+ examples/FtypeEnum.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-} +-- 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 = + Xsd_string + | Xsd_boolean + | Xsd_decimal + | Xsd_float + | Xsd_double + | Xsd_duration + | Xsd_dateTime + | Xsd_time + | Xsd_date + | Xsd_hexBinary + | Xsd_base64Binary + | Xsd_anyURI + | Xsd_QName + +-- derived types + + | Xsd_integer + | Xsd_int + | Xsd_short + | Xsd_byte + | Xsd_long + 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/TestODBC.hs view
@@ -0,0 +1,756 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE GADTs, FlexibleContexts #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +module TestODBC where + +import Database.Persist +import Database.Persist.ODBC +import Database.Persist.TH +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger +import Data.Text (Text) +import qualified Data.Text as T + +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 qualified Database.HDBC as H +import qualified Database.HDBC.ODBC as H + +import FtypeEnum +import qualified Database.Esqueleto as E +import Database.Esqueleto (select,where_,(^.),from,Value(..)) + +import Data.ByteString (ByteString) +import Data.Ratio +import Text.Blaze.Html +--import Debug.Trace + +share [mkPersist sqlOnlySettings, mkMigrate "migrateAll", mkDeleteCascade sqlOnlySettings] [persistLowerCase| +Test0 + mybool Bool + deriving Show +Test1 + flag Bool + flag1 Bool Maybe + 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 + color String Maybe Eq Ne + Unique PersonxNameKey name + deriving Show + +Testnum + bar Int + znork Int Maybe + znork1 String + znork2 String Maybe + znork3 UTCTime + name String Maybe + deriving Show +Foo + bar String + deriving Show +Personz + name String + age Int Maybe + deriving Show +BlogPost + title String + authorId PersonzId + deriving Show + +Asm + name Text + description Text + Unique MyUniqueAsm name +-- deriving Typeable + deriving Show + +Xsd + name Text + description Text + asmid AsmId + Unique MyUniqueXsd name -- global +-- deriving Typeable + deriving Show + +Ftype + name Text + Unique MyUniqueFtype name +-- deriving Typeable + deriving Show + +Line + name Text + description Text + pos Int + ftypeid FtypeEnum + xsdid XsdId + Unique EinzigName xsdid name -- within an xsd:so can repeat fieldnames in different xsds + Unique EinzigPos xsdid pos +-- deriving Typeable + deriving Show + + +Interface + name Text + fname Text + 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 + deriving Show + +Testrational json + rat Rational + deriving Show + +Testhtml + myhtml Html + -- deriving Show + +Testblob + bs1 ByteString Maybe + deriving Show + +Testblob3 + bs1 ByteString + bs2 ByteString + bs3 ByteString + deriving Show + +Testlen + txt Text maxlen=5 -- default='xx12' + str String maxlen=5 + bs ByteString maxlen=5 + mtxt Text Maybe maxlen=5 + mstr String Maybe maxlen=5 + mbs ByteString Maybe maxlen=5 + deriving Show +|] + +main :: IO () +main = do + [arg] <- getArgs + let (dbtype',dsn) = + case arg of -- odbc system dsn + "d" -> (DB2,"dsn=db2_test") + "p" -> (Postgres,"dsn=pg_test") + "m" -> (MySQL,"dsn=mysql_test") +-- 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] + "on" -> (Oracle True,"dsn=oracle_test") -- >= oracle 12c [full limit and offset support] + "q" -> (Sqlite False,"dsn=sqlite_test") + "qn" -> (Sqlite True,"dsn=sqlite_test") + xs -> error $ "unknown option:choose p m s so o on d q qn found[" ++ xs ++ "]" + + runResourceT $ runNoLoggingT $ withODBCConn Nothing dsn $ runSqlConn $ do + conn <- askSqlConn + let 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" + case dbtype of + MSSQL {} -> do -- deleteCascadeWhere Asm causes seg fault for mssql only + deleteWhere ([]::[Filter Line]) + deleteWhere ([]::[Filter Xsd]) + deleteWhere ([]::[Filter Asm]) + _ -> do + 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]) + + when True $ testbase dbtype + +testbase :: DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () +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 + 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 + + _ <- 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 + + --oneJohnPost <- selectList [BlogPostAuthorId ==. johnId] [LimitTo 1] + --liftIO $ print (oneJohnPost :: [Entity BlogPost]) + + john <- get johnId + liftIO $ print (john :: Maybe Personz) + dt <- liftIO getCurrentTime + v1 <- insert $ Testnum 100 Nothing "hello" (Just "world") dt Nothing + v2 <- insert $ Testnum 100 (Just 222) "dude" Nothing dt (Just "something") + 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 + + delete janeId + deleteWhere [BlogPostAuthorId ==. johnId] + test0 + test1 dbtype + test2 + test3 + test4 + test5 dbtype + test6 + when (limitoffset dbtype) test7 + when (limitoffset dbtype) test8 + case dbtype of + Oracle { oracle12c=False } -> return () + _ -> test9 + test10 dbtype + test11 dbtype + test12 dbtype + +test0::SqlPersistT (NoLoggingT (ResourceT IO)) () +test0 = do + liftIO $ putStrLn "\n*** in test0\n" + pid <- insert $ Personx "Michael" 25 Nothing + liftIO $ print pid + + p1 <- get pid + liftIO $ print p1 + + replace pid $ Personx "Michael" 26 Nothing + p2 <- get pid + liftIO $ print p2 + + p3 <- selectList [PersonxName ==. "Michael"] [] + liftIO $ print p3 + + _ <- insert $ Personx "Michael2" 27 Nothing + deleteWhere [PersonxName ==. "Michael2"] + p4 <- selectList [PersonxAge <. 28] [] + liftIO $ print p4 + + update pid [PersonxAge =. 28] + p5 <- get pid + liftIO $ print p5 + + updateWhere [PersonxName ==. "Michael"] [PersonxAge =. 29] + p6 <- get pid + liftIO $ print p6 + + _ <- insert $ Personx "Eliezer" 2 $ Just "blue" + p7 <- selectList [] [Asc PersonxAge] + liftIO $ print p7 + + _ <- insert $ Personx "Abe" 30 $ Just "black" + p8 <- selectList [PersonxAge <. 30] [Desc PersonxName] + liftIO $ print p8 + + _ <- 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 + + p10 <- getBy $ PersonxNameKey "Michael" + liftIO $ print p10 + + p11 <- selectList [PersonxColor ==. Just "blue"] [] + liftIO $ print p11 + + p12 <- selectList [PersonxColor ==. Nothing] [] + liftIO $ print p12 + + p13 <- selectList [PersonxColor !=. Nothing] [] + liftIO $ print p13 + + delete pid + plast <- get pid + liftIO $ print plast + +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 + + 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 + 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)) () +test2 = do + liftIO $ putStrLn "\n*** in test2\n" + 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 + liftIO $ putStrLn "\n*** in test3\n" + a1 <- insert $ Test1 True (Just False) 100.3 Nothing + liftIO $ putStrLn $ "a1=" ++ show a1 + a2 <- insert $ Test1 False Nothing 100.3 (Just 12.44) + liftIO $ putStrLn $ "a2=" ++ show a2 + a3 <- insert $ Test1 True (Just True) 100.3 (Just 11.11) + liftIO $ putStrLn $ "a3=" ++ show a3 + a4 <- insert $ Test1 False Nothing 100.3 Nothing + liftIO $ putStrLn $ "a4=" ++ show a4 + 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 + +test4::SqlPersistT (NoLoggingT (ResourceT IO)) () +test4 = do + liftIO $ putStrLn "\n*** in test4\n" + a1 <- insert $ Asm "NewAsm1" "description for newasm1" + + x11 <- insert $ Xsd "NewXsd11" "description for newxsd11" a1 + l111 <- insert $ Line "NewLine111" "description for newline111" 10 Xsd_string x11 + l112 <- insert $ Line "NewLine112" "description for newline112" 11 Xsd_boolean x11 + l113 <- insert $ Line "NewLine113" "description for newline113" 12 Xsd_decimal x11 + l114 <- insert $ Line "NewLine114" "description for newline114" 15 Xsd_int x11 + + x12 <- insert $ Xsd "NewXsd12" "description for newxsd12" a1 + l121 <- insert $ Line "NewLine121" "description for newline1" 12 Xsd_int x12 + l122 <- insert $ Line "NewLine122" "description for newline2" 19 Xsd_boolean x12 + l123 <- insert $ Line "NewLine123" "description for newline3" 13 Xsd_string x12 + l124 <- insert $ Line "NewLine124" "description for newline4" 99 Xsd_double x12 + l125 <- insert $ Line "NewLine125" "description for newline5" 2 Xsd_boolean x12 + + a2 <- insert $ Asm "NewAsm2" "description for newasm2" + + a3 <- insert $ Asm "NewAsm3" "description for newasm3" + 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 + + + [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 + +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" + DB2 {} -> liftIO $ putStrLn $ show dbtype ++ " insert multiple blob fields with a null fails" + _ -> do + 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] + liftIO $ putStrLn $ "xs=" ++ show xs + case dbtype of + Oracle {} -> return () + DB2 {} -> return () + _ -> do + ys <- selectList [] [Desc TestotherBs2] + liftIO $ putStrLn $ "ys=" ++ show ys + + aa <- 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)) () +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] + 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 + + aa <- selectList ([]::[Filter Testhtml]) [] + unless (length aa == 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 + +test8::SqlPersistT (NoLoggingT (ResourceT IO)) () +test8 = do + liftIO $ putStrLn "\n*** in test8\n" + xs <- select $ + from $ \ln -> do + where_ (ln ^. LinePos E.>=. E.val 0) + E.orderBy [E.asc (ln ^. LinePos)] + E.limit 2 + E.offset 3 + return ln + liftIO $ putStrLn $ show (length xs) ++ " rows: limit=2 offset=3 xs=" ++ show xs + +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 + +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 + Oracle {} -> liftIO $ putStrLn "skipping insert empty string into oracle blob column (treated as a null)" + {- + *** 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]) [] + liftIO $ putStrLn $ "ys=" ++ show ys + + aa <- 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 + +test11::DBType -> SqlPersistT (NoLoggingT (ResourceT IO)) () +test11 dbtype = do + liftIO $ putStrLn "\n*** in test11\n" + 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 + 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 + liftIO $ putStrLn $ "testblob xs=" ++ show xs + + aa <- 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 + +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]) [] + 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 + + liftIO $ putStrLn $ "aa=" ++ show aa + +limitoffset :: DBType -> Bool +limitoffset dbtype = -- trace ("limitoffset dbtype=" ++ show dbtype) $ + case dbtype of + Oracle False -> False + MSSQL False -> False + _ -> True + +main2::IO () +main2 = do +-- let connectionString = "dsn=mssql_test; Trusted_Connection=True" + let connectionString = "dsn=db2_test" + conn <- H.connectODBC connectionString + putStrLn "\n1\n" + stmt1 <- H.prepare conn "select * from test93" + putStrLn "\n2\n" + vals <- H.execute stmt1 [] + putStrLn "\n3\n" + results <- H.fetchAllRowsAL stmt1 + putStrLn "\n4\n" + mapM_ print results + + putStrLn "\na\n" + --stmt1 <- H.prepare conn "create table test93 (bs1 blob)" + --putStrLn "\nb\n" + --vals <- H.execute stmt1 [] + --putStrLn "\nc\n" + stmt1 <- H.prepare conn "insert into test93 values(blob(?))" + putStrLn "\nd\n" + vals <- H.execute stmt1 [H.SqlByteString "hello world"] + putStrLn "\ne\n" +-- _ <- 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(?)" + putStrLn "\n6\n" + vals <- H.execute stmt [H.SqlNull] + putStrLn "\n7\n" + vals <- H.execute stmt [H.SqlNull] + putStrLn "\n8\n" + vals <- H.execute stmt [H.SqlNull] + putStrLn "\n9\n" + + results <- H.fetchAllRowsAL stmt1 + mapM_ print results + 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"] + + --vals <- H.execute stmt [H.SqlNull,H.SqlByteString "test"] + putStrLn "\nTESTOTHER worked\n" + + H.commit conn + print vals + + +main3::IO () +main3 = do + --let connectionString = "dsn=pg_test" + let connectionString = "dsn=mysql_test" + --let connectionString = "dsn=mssql_test; Trusted_Connection=True" + --let connectionString = "dsn=oracle_test" + --let connectionString = "dsn=db2_test" + conn <- H.connectODBC connectionString + putStrLn "\n1\n" + + putStrLn $ "drivername=" ++ H.hdbcDriverName conn + putStrLn $ "clientver=" ++ H.hdbcClientVer conn + putStrLn $ "proxied drivername=" ++ H.proxiedClientName conn + putStrLn $ "proxied clientver=" ++ H.proxiedClientVer conn + putStrLn $ "serverver=" ++ H.dbServerVer conn + let lenfn="len" -- mssql + --let lenfn="length" + a <- H.describeTable conn "persony" + print a + stmt <- 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 + putStrLn "\n3\n" + stmt <- H.prepare conn ("select \"id\","++lenfn++"(\"name\"),\"name\" from \"persony\"") + putStrLn "\n4\n" + vals <- H.execute stmt [] + results <- H.fetchAllRowsAL' stmt + mapM_ print results + H.commit conn + +main4::IO () +main4 = do + --let connectionString = "dsn=pg_test" + let connectionString = "dsn=mysql_test" + --let connectionString = "dsn=mssql_test; Trusted_Connection=True" + --let connectionString = "dsn=oracle_test" + --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 + + putStrLn "\nbefore insert\n" + stmt <- H.prepare conn "insert into fred values(?)" + a <- H.execute stmt [H.SqlString "hello"] + print a + + putStrLn "\nbefore select\n" + stmt <- H.prepare conn "select nm,length(nm) from fred" + vals <- H.execute stmt [] + results <- H.fetchAllRowsAL' stmt + putStrLn "select after insert" + print results + + putStrLn "\nbefore update\n" + stmt <- H.prepare conn "update fred set nm=?" + a <- H.execute stmt [H.SqlString "worldly"] + + putStrLn "\nbefore select #2\n" + stmt <- H.prepare conn "select nm,length(nm) from fred" + vals <- H.execute stmt [] + results <- H.fetchAllRowsAL' stmt + 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})] + +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
@@ -0,0 +1,66 @@+name: persistent-odbc +version: 0.1.2.0 +synopsis: Backend for the persistent library using ODBC +license: MIT +license-file: LICENSE +author: Grant Weyburne +maintainer: gbwey9@gmail.com +category: Database, Yesod +cabal-version: >= 1.8 +build-type: Simple +stability: Experimental +homepage: https://github.com/gbwey/persistent-odbc +bug-reports: https://github.com/gbwey/persistent-odbc/issues +description: + This package contains backends for persistent using ODBC. + It currently supports the following databases: MSSQL, MySql, Oracle, Sqlite, DB2, Postgres. + Uses HDBC-ODBC for accessing ODBC. + +Flag debug + Default: False + +Flag tester + Default: False + +library + if flag(debug) + cpp-options: -DDEBUG + + exposed-modules: Database.Persist.ODBC + , Database.Persist.ODBCTypes + , Database.Persist.MigrateOracle + , Database.Persist.MigratePostgres + , Database.Persist.MigrateSqlite + , Database.Persist.MigrateMSSQL + , Database.Persist.MigrateMySQL + , Database.Persist.MigrateDB2 + + ghc-options: -Wall + hs-source-dirs: src + + build-depends: base >= 4 && < 5 + , text >= 0.7 + , aeson >= 0.6 + , time >= 1.1 + , conduit >= 1.0 + , containers >= 0.4 + , transformers >= 0.3 + , convertible >= 1.0 + , HDBC >= 2.2 + , HDBC-odbc >= 2.2 + , monad-logger + , resourcet + , persistent-template >= 1.2 && < 1.4 + , persistent >= 1.2 && < 1.4 + , bytestring >= 0.9 + + if flag(tester) + hs-source-dirs: examples + exposed-modules: TestODBC + , FtypeEnum + build-depends: blaze-html + , esqueleto + +source-repository head + type: git + location: git://github.com/gbwey/persistent-odbc.git
+ src/Database/Persist/MigrateDB2.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +-- | A DB2 backend for @persistent@. +module Database.Persist.MigrateDB2 + ( getMigrationStrategy + ) where + +import Control.Arrow +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Error (ErrorT(..)) +import Data.ByteString (ByteString) +import Data.Either (partitionEithers) +import Data.Function (on) +import Data.List (find, intercalate, sort, groupBy) +import Data.Text (Text, pack) + +import Data.Conduit +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Database.Persist.Sql +import Database.Persist.ODBCTypes + +#if DEBUG +import Debug.Trace +tracex::String -> a -> a +tracex = trace +#else +tracex::String -> a -> a +tracex _ b = b +#endif + +getMigrationStrategy :: DBType -> MigrationStrategy +getMigrationStrategy dbtype@DB2 {} = + MigrationStrategy + { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT 99999999" + ,dbmsMigrate=migrate' + ,dbmsInsertSql=insertSql' + ,dbmsEscape=T.pack . escapeDBName + ,dbmsType=dbtype + } +getMigrationStrategy dbtype = error $ "DB2: calling with invalid dbtype " ++ show dbtype + +-- | Create the migration plan for the given 'PersistEntity' +-- @val@. +migrate' :: Show a + => [EntityDef a] + -> (Text -> IO Statement) + -> EntityDef SqlType + -> IO (Either [Text] [(Bool, Text)]) +migrate' allDefs getter val = do + let name = entityDB val + (idClmn, old) <- getColumns getter val + 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) $ + concat [" CONSTRAINT ", escapeDBName (pkeyName (entityDB val)), " PRIMARY KEY (", intercalate "," $ map (escapeDBName . snd) $ primaryFields pdef, ")"] + Nothing -> tracex ("not found val=" ++ show val) $ + concat [escapeDBName $ entityID val + , " BIGINT NOT NULL GENERATED ALWAYS AS IDENTITY (START WITH 1, INCREMENT BY 1) PRIMARY KEY "] + let addTable = AddTable $ concat + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " + , escapeDBName name + , "(" + , idtxt + , if null newcols then [] else "," + , intercalate "," $ map showColumn newcols + , ")" + ] + let uniques = flip concatMap udspair $ \(uname, ucols) -> + [ AlterTable name $ + AddUniqueConstraint uname $ + 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) $ + 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)) + 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) $ + 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' + -- Errors + (_, _, (errs, _)) -> return $ Left errs + +pkeyName :: DBName -> DBName +pkeyName (DBName table) = + DBName $ T.concat [table, "_pkey"] + +-- | Find out the type of a column. +findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn allDefs name col = + maybe (error $ "Could not find type of column " ++ + show col ++ " on table " ++ show name ++ + " (allDefs = " ++ show allDefs ++ ")") + ((,) col) $ do + entDef <- find ((== name) . entityDB) allDefs + fieldDef <- find ((== col) . fieldDB) (entityFields entDef) + return (fieldType fieldDef) + + +-- | Helper for 'AddRefence' that finds out the 'entityID'. +addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ + AddReference reftable fkeyname [cname] [id_] + where + id_ = maybe (error $ "Could not find ID of entity " ++ show reftable + ++ " (allDefs = " ++ show allDefs ++ ")") + id $ do + entDef <- find ((== reftable) . entityDB) allDefs + return (entityID entDef) + +data AlterColumn = Change Column + | IsNull + | NotNull + | Add' Column + | Drop + | Default String + | NoDefault + | Update' String + | AddReference DBName DBName [DBName] [DBName] + | DropReference DBName + +type AlterColumn' = (DBName, AlterColumn) + +data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType)] + | DropUniqueConstraint DBName + +data AlterDB = AddTable String + | AlterColumn DBName AlterColumn' + | AlterTable DBName AlterTable + + +udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) + +---------------------------------------------------------------------- + + +-- | Returns all of the 'Column'@s@ in the given table currently +-- in the database. +getColumns :: (Text -> IO Statement) + -> EntityDef a + -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column + , [Either Text (Either Column (DBName, [DBName]))] -- everything else + ) +getColumns getter def = do + -- Find out ID column. + stmtIdClmn <- getter $ T.concat + ["SELECT " + ,"colname column_name " + ,",nulls is_nullable " + ,",typename " + ,",default column_default " + ,",length " + ,",scale " + ,"FROM syscat.columns " + ,"WHERE tabschema=current_schema " + ,"AND tabname=? " + ,"AND colname <> ?"] + + inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + + -- Find out all columns. + stmtClmns <- getter $ T.concat + ["SELECT " + ,"colname column_name " + ,",nulls is_nullable " + ,",typename " + ,",default column_default " + ,",length " + ,",scale " + ,"FROM syscat.columns " + ,"WHERE tabschema=current_schema " + ,"AND tabname=? " + ,"AND colname <> ?"] + inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + + -- Find out the constraints. + stmtCntrs <- getter $ T.concat ["SELECT " + ,"a.constname constraint_name " + ,",a.colname column_name " + ,"FROM SYSCAT.KEYCOLUSE A, SYSCAT.TABCONST B " + ,"WHERE A.CONSTNAME=B.CONSTNAME " + ,"AND a.tabschema=current_schema " + ,"AND b.tabschema=a.tabschema " + ,"AND a.tabname=? " + ,"AND a.colname <> ? " + ,"AND b.type not in ('F','P') " + ,"UNION " + ,"SELECT " + ,"constname constraint_name " + ,",trim(pk_colnames) column_name " + ,"FROM syscat.references " + ,"WHERE tabschema=current_schema " + ,"AND tabname=? " + ,"AND trim(pk_colnames) <> ? " + ,"ORDER BY constraint_name, column_name"] + + us <- runResourceT $ stmtQuery stmtCntrs (vals++vals) $$ helperCntrs + liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us + -- Return both + return (ids, cs ++ us) + where + vals = [ PersistText $ unDBName $ entityDB def + , PersistText $ unDBName $ entityID def ] + + helperClmns = CL.mapM getIt =$ CL.consume + where + getIt = fmap (either Left (Right . Left)) . + liftIO . + getColumn getter (entityDB def) + + helperCntrs = do + let check [ PersistByteString cntrName + , PersistByteString clmnName] = return ( T.decodeUtf8 cntrName + , T.decodeUtf8 clmnName ) + check other = fail $ "helperCntrs: unexpected " ++ show other + rows <- mapM check =<< CL.consume + return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + $ groupBy ((==) `on` fst) rows + + +-- | Get the information about a column in a table. +getColumn :: (Text -> IO Statement) + -> DBName + -> [PersistValue] + -> IO (Either Text Column) +getColumn getter tname [ PersistByteString cname + , PersistByteString null_ + , PersistByteString type' + , default' + , npre + , nscl] = + fmap (either (Left . pack) Right) $ + runErrorT $ do + -- Default value + default_ <- case default' of + PersistNull -> return Nothing + PersistText t -> return (Just t) + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> fail $ "Invalid default column: " ++ + show default' ++ " (error: " ++ + show exc ++ ")" + Right t -> return (Just t) + _ -> fail $ "Invalid default column: " ++ show default' + + -- Column type + type_ <- parseType type' npre nscl + + -- Foreign key (if any) + stmt <- lift $ getter $ T.concat ["SELECT " + ,"tabname REFERENCED_TABLE_NAME, " + ,"constname, 1 " + ,"FROM syscat.references " + ,"WHERE tabschema=current_schema " + ,"AND tabname=? " + ,"AND trim(fk_colnames)=? " + ,"order by constname, fk_colnames " + ] + let vars = [ PersistText $ unDBName tname + , PersistByteString cname + ] + cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + ref <- case cntrs of + [] -> return Nothing + [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> + 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 ++ "]" + + -- Okay! + return Column + { cName = DBName $ T.decodeUtf8 cname + , cNull = null_ == "Y" + , cSqlType = type_ + , cDefault = default_ + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing -- FIXME: maxLen + , cReference = ref + } + +getColumn _ _ x = + return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x + + +-- | Parse the type of column as returned by MySQL's +-- @INFORMATION_SCHEMA@ tables. +parseType :: Monad m => ByteString -> PersistValue -> PersistValue -> m SqlType +parseType "SMALLINT" _ _ = return SqlInt32 +parseType "BIGINT" _ _ = return SqlInt64 +parseType "VARCHAR" _ _ = return SqlString +parseType "DATE" _ _ = return SqlDay +parseType "CHARACTER" _ _ = return SqlBool +parseType "TIMESTAMP" _ _ = return SqlDayTime +parseType "TIMESTAMP WITH TIMEZONE" _ _ = return SqlDayTimeZoned +parseType "FLOAT" _ _ = return SqlReal +parseType "DOUBLE" _ _ = return SqlReal +parseType "DECIMAL" _ _ = return SqlReal +parseType "BLOB" _ _ = return SqlBlob +parseType "TIME" _ _ = return SqlTime +parseType "NUMERIC" npre nscl = return $ getNumeric npre nscl +parseType a _ _ = error $ "what is this type a="++ show a -- Right $ SqlOther a + +getNumeric :: PersistValue -> PersistValue -> SqlType +getNumeric (PersistInt64 a) (PersistInt64 b) = SqlNumeric (fromIntegral a) (fromIntegral b) +getNumeric a b = error $ "Can not get numeric field precision, got: " ++ show a ++ " and " ++ show b ++ " as precision and scale" + + +---------------------------------------------------------------------- + + +-- | @getAlters allDefs tblName new old@ finds out what needs to +-- be changed from @old@ to become @new@. +getAlters :: Show a + => [EntityDef a] + -> DBName + -> ([Column], [(DBName, [DBName])]) + -> ([Column], [(DBName, [DBName])]) + -> ([AlterColumn'], [AlterTable]) +getAlters allDefs tblName (c1, u1) (c2, u2) = + (getAltersC c1 c2, getAltersU u1 u2) + where + getAltersC [] old = concatMap dropColumn old + getAltersC (new:news) old = + let (alters, old') = findAlters tblName allDefs new old + in alters ++ getAltersC news old' + + dropColumn col = + map ((,) (cName col)) $ + [DropReference n | Just (_, n) <- [cReference col]] ++ + [Drop] + + getAltersU [] old = map (DropUniqueConstraint . fst) old + getAltersU ((name, cols):news) old = + case lookup name old of + Nothing -> + AddUniqueConstraint name (map findType cols) : getAltersU news old + Just ocols -> + let old' = filter (\(x, _) -> x /= name) old + in if sort cols == ocols + then getAltersU news old' + else DropUniqueConstraint name + : AddUniqueConstraint name (map findType cols) + : getAltersU news old' + where + findType = findTypeOfColumn allDefs tblName + + +-- | @findAlters newColumn oldColumns@ finds out what needs to be +-- changed in the columns @oldColumns@ for @newColumn@ to be +-- supported. +findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName _maxLen ref) cols = + tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ + case filter ((name ==) . cName) cols of + [] -> 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 ++ "]") $ + [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 ++"]") $ + [(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' ++ "]") $ + [(tname, addReference allDefs (refName tblName name) tname name)] + _ -> [] + -- Type and nullability + modType | tpcheck type_ type_' && isNull == isNull' = [] + | otherwise = [(name, Change col)] + -- Default value + modDef | cmpdef def def' = [] + | otherwise = --tracex ("findAlters col=" ++ show col ++ " def=" ++ show def ++ " def'=" ++ show def') $ + case def of + Nothing -> [(name, NoDefault)] + Just s -> [(name, Default $ T.unpack s)] + in ( refDrop ++ modType ++ modDef ++ refAdd + , filter ((name /=) . cName) cols ) + + +cmpdef::Maybe Text -> Maybe Text -> Bool +cmpdef Nothing Nothing = True +cmpdef (Just def) (Just def') | def==def' = True + | otherwise = + let (a,_)=T.breakOnEnd ":" def' + in case T.stripSuffix "::" a of + Just xs -> def==xs + Nothing -> False +cmpdef _ _ = False + +tpcheck :: SqlType -> SqlType -> Bool +tpcheck (SqlNumeric _ _) SqlReal = True -- else will try to migrate rational columns +tpcheck SqlReal (SqlNumeric _ _) = True +tpcheck a b = a==b +---------------------------------------------------------------------- + + +-- | Prints the part of a @CREATE TABLE@ statement about a given +-- column. +showColumn :: Column -> String +showColumn (Column n nu t def _defConstraintName maxLen _ref) = concat + [ escapeDBName n + , " " + , showSqlType t maxLen + , " " + , if nu then "NULL" else "NOT NULL" + , case def of + Nothing -> "" + Just s -> " DEFAULT " ++ T.unpack s + ] + +-- | Renders an 'SqlType' in DB2's format. +showSqlType :: SqlType + -> Maybe Integer -- ^ @maxlen@ + -> String +showSqlType SqlString Nothing = "VARCHAR(1000)" +showSqlType SqlString (Just len) = "VARCHAR(" ++ show len ++ ")" +showSqlType SqlInt32 _ = "SMALLINT" +showSqlType SqlInt64 _ = "BIGINT" +showSqlType SqlReal _ = "DOUBLE PRECISION" +showSqlType (SqlNumeric _s prec) _ = "NUMERIC(" ++ show prec ++ ")" +showSqlType SqlDay _ = "DATE" +showSqlType SqlTime _ = "TIME" +showSqlType SqlDayTime _ = "TIMESTAMP" +showSqlType SqlDayTimeZoned _ = "TIMESTAMP WITH TIME ZONE" +showSqlType SqlBlob _ = "BLOB" +showSqlType SqlBool Nothing = "CHARACTER" +showSqlType SqlBool (Just 1) = "CHARACTER" +showSqlType SqlBool (Just n) = "CHARACTER(" ++ show n ++ ")" +showSqlType (SqlOther t) _ = T.unpack t + +-- | Render an action that must be done on the database. +showAlterDb :: AlterDB -> (Bool, Text) +showAlterDb (AddTable s) = (False, pack s) +showAlterDb (AlterColumn t (c, ac)) = + (isUnsafe ac, pack $ showAlter t (c, ac)) + where + isUnsafe Drop = True + isUnsafe _ = False +showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) + + +-- | Render an action that must be done on a table. +showAlterTable :: DBName -> AlterTable -> String +showAlterTable table (AddUniqueConstraint cname cols) = concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD CONSTRAINT " + , escapeDBName cname + , " UNIQUE(" + , intercalate "," $ map (escapeDBName . fst) cols + , ")" + ] + --where + -- escapeDBName' (name, FTTypeCon _ "Text" ) = escapeDBName name ++ "(200)" + -- escapeDBName' (name, FTTypeCon _ "String" ) = escapeDBName name ++ "(200)" + -- escapeDBName' (name, FTTypeCon _ "ByteString") = escapeDBName name ++ "(200)" + -- escapeDBName' (name, _ ) = escapeDBName name +showAlterTable table (DropUniqueConstraint cname) = concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP CONSTRAINT " + , escapeDBName cname + ] + + +-- | Render an action that must be done on a column. +showAlter :: DBName -> AlterColumn' -> String +showAlter table (oldName, Change (Column _n _nu t _def _defConstraintName _maxLen _ref)) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ALTER COLUMN " + , escapeDBName oldName + , " SET DATA TYPE " + , showSqlType t Nothing + ] +showAlter table (n, IsNull) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ALTER COLUMN " + , escapeDBName n + , " DROP NOT NULL" + ] +showAlter table (n, NotNull) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ALTER COLUMN " + , escapeDBName n + , " SET NOT NULL" + ] +showAlter table (_, Add' col) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD COLUMN " + , showColumn col + ] +showAlter table (n, Drop) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP COLUMN " + , escapeDBName n + ] +showAlter table (n, Default s) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ALTER COLUMN " + , escapeDBName n + , " SET DEFAULT " + , s + ] +showAlter table (n, NoDefault) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ALTER COLUMN " + , escapeDBName n + , " DROP DEFAULT" + ] +showAlter table (n, Update' s) = + concat + [ "UPDATE " + , escapeDBName table + , " SET " + , escapeDBName n + , "=" + , s + , " WHERE " + , escapeDBName n + , " IS NULL" + ] +showAlter table (_, AddReference reftable fkeyname t2 id2) = concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD CONSTRAINT " + , escapeDBName fkeyname + , " FOREIGN KEY(" + , intercalate "," $ map escapeDBName t2 + , ") REFERENCES " + , escapeDBName reftable + , "(" + , intercalate "," $ map escapeDBName id2 + , ")" + ] +showAlter table (_, DropReference cname) = concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP CONSTRAINT " + , escapeDBName cname + ] + +refName :: DBName -> DBName -> DBName +refName (DBName table) (DBName column) = + DBName $ T.concat [table, "_", column, "_fkey"] + +---------------------------------------------------------------------- + + +-- | Escape a database name to be included on a query. +escapeDBName :: DBName -> String +escapeDBName (DBName s) = '"' : go (T.unpack s) + where + go ('"':xs) = '"' : '"' : go xs + go ( x :xs) = x : go xs + go "" = "\"" +-- | SQL code to be executed when inserting an entity. +insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' ent vals = + case entityPrimary ent of + Just _pdef -> + ISRManyKeys sql vals + where sql = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + Nothing -> + ISRInsertGet doInsert "select IDENTITY_VAL_LOCAL() as last_cod from sysibm.sysdummy1" + where + doInsert = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," $ zipWith doValue (entityFields ent) vals + , ")" + ] + doValue f@FieldDef { fieldSqlType = SqlBlob } PersistNull = error $ "persistent-odbc db2 currently doesn't support inserting nulls in a blob field f=" ++ show f -- tracex "\n\nin blob with null\n\n" "iif(? is null, convert(varbinary(max), cast ('' as nvarchar(max))), convert(varbinary(max), cast ('' as nvarchar(max))))" + doValue FieldDef { fieldSqlType = SqlBlob } (PersistByteString _) = "blob(?)" -- tracex "\n\nin blob with a value\n\n" "blob(?)" + doValue _ _ = "?"
+ src/Database/Persist/MigrateMSSQL.hs view
@@ -0,0 +1,644 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +-- | A MSSQL backend for @persistent@. +module Database.Persist.MigrateMSSQL + ( getMigrationStrategy + ) where + +import Control.Arrow +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Error (ErrorT(..)) +import Data.ByteString (ByteString) +import Data.Either (partitionEithers) +import Data.Function (on) +import Data.List (find, intercalate, sort, groupBy) +import Data.Text (Text, pack) +import Data.Monoid ((<>), mconcat) + +import Data.Conduit +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Database.Persist.Sql +import Database.Persist.ODBCTypes + +#if DEBUG +import Debug.Trace +tracex::String -> a -> a +tracex = trace +#else +tracex::String -> a -> a +tracex _ b = b +#endif + +getMigrationStrategy :: DBType -> MigrationStrategy +getMigrationStrategy dbtype@MSSQL { mssql2012=ok } = + MigrationStrategy + { dbmsLimitOffset=limitOffset ok + ,dbmsMigrate=migrate' + ,dbmsInsertSql=insertSql' + ,dbmsEscape=T.pack . escapeDBName + ,dbmsType=dbtype + } +getMigrationStrategy dbtype = error $ "MSSQL: calling with invalid dbtype " ++ show dbtype + +-- | Create the migration plan for the given 'PersistEntity' +-- @val@. +migrate' :: Show a + => [EntityDef a] + -> (Text -> IO Statement) + -> EntityDef SqlType + -> IO (Either [Text] [(Bool, Text)]) +migrate' allDefs getter val = do + let name = entityDB val + (idClmn, old) <- getColumns getter val + 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 . snd) $ primaryFields pdef, ")"] + Nothing -> concat [escapeDBName $ entityID val, " BIGINT NOT NULL IDENTITY(1,1) PRIMARY KEY "] + let addTable = AddTable $ concat + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " + , escapeDBName name + , "(" + , idtxt + , if null newcols then [] else "," + , intercalate "," $ map showColumn newcols + , ")" + ] + let uniques = flip concatMap udspair $ \(uname, ucols) -> + [ AlterTable name $ + AddUniqueConstraint uname $ + 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) $ + 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)) + 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) $ + 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' + -- Errors + (_, _, (errs, _)) -> return $ Left errs + + +-- | Find out the type of a column. +findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn allDefs name col = + maybe (error $ "Could not find type of column " ++ + show col ++ " on table " ++ show name ++ + " (allDefs = " ++ show allDefs ++ ")") + ((,) col) $ do + entDef <- find ((== name) . entityDB) allDefs + fieldDef <- find ((== col) . fieldDB) (entityFields entDef) + return (fieldType fieldDef) + + +-- | Helper for 'AddRefence' that finds out the 'entityID'. +addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ + AddReference reftable fkeyname [cname] [id_] + where + id_ = maybe (error $ "Could not find ID of entity " ++ show reftable + ++ " (allDefs = " ++ show allDefs ++ ")") + id $ do + entDef <- find ((== reftable) . entityDB) allDefs + return (entityID entDef) + +data AlterColumn = Change Column + | Add' Column + | Drop + | Default String + | NoDefault DBName + | Update' String + | AddReference DBName DBName [DBName] [DBName] + | DropReference DBName + +type AlterColumn' = (DBName, AlterColumn) + +data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType)] + | DropUniqueConstraint DBName + +data AlterDB = AddTable String + | AlterColumn DBName AlterColumn' + | AlterTable DBName AlterTable + + +udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) + +---------------------------------------------------------------------- + + +-- | Returns all of the 'Column'@s@ in the given table currently +-- in the database. +getColumns :: (Text -> IO Statement) + -> EntityDef a + -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column + , [Either Text (Either Column (DBName, [DBName]))] -- everything else + ) +getColumns getter def = do + -- Find out ID column. + stmtIdClmn <- getter $ mconcat $ + ["SELECT COLUMN_NAME, " + ,"IS_NULLABLE, " + ,"DATA_TYPE, " + ,"COLUMN_DEFAULT " + ,"FROM INFORMATION_SCHEMA.COLUMNS " + ,"WHERE TABLE_NAME = ? " + ,"AND COLUMN_NAME = ?"] + inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + + -- Find out all columns. + let sql=mconcat [ + "select info.COLUMN_NAME" + ," ,info.IS_NULLABLE,info.DATA_TYPE" + ," ,info.COLUMN_DEFAULT" + ," ,OBJECT_NAME(con.constid) AS DEFAULT_CONSTRAINT_NAME " + ," FROM sys.columns col " + ," inner join sys.tables tab on col.object_id=tab.object_id " + ," join INFORMATION_SCHEMA.COLUMNS info on info.table_name=? " + ," and tab.name=info.table_name " + ," and col.name=info.COLUMN_NAME " + ," AND COLUMN_NAME <> ?" + ," LEFT OUTER JOIN sysconstraints con " + ," ON con.constid=col.default_object_id " + ] + --liftIO $ putStrLn $ "sql=" ++ show sql + stmtClmns <- getter sql + inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + + -- Find out the constraints. + stmtCntrs <- getter $ mconcat $ + ["SELECT CONSTRAINT_NAME, " + ,"COLUMN_NAME " + ,"FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE p " + ,"WHERE TABLE_NAME = ? " + ,"AND COLUMN_NAME <> ? " + ,"AND exists (select 1 from INFORMATION_SCHEMA.TABLE_CONSTRAINTs AS TC where tc.CONSTRAINT_NAME=p.CONSTRAINT_NAME and tc.constraint_type<>'PRIMARY KEY') " + ,"AND not exists (select 1 from INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC where rc.CONSTRAINT_NAME=p.CONSTRAINT_NAME) " + ,"ORDER BY CONSTRAINT_NAME, " + ,"COLUMN_NAME"] + us <- runResourceT $ stmtQuery stmtCntrs vals $$ helperCntrs + liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us + -- Return both + return (ids, cs ++ us) + where + vals = [ PersistText $ unDBName $ entityDB def + , PersistText $ unDBName $ entityID def ] + + helperClmns = CL.mapM getIt =$ CL.consume + where + getIt = fmap (either Left (Right . Left)) . + liftIO . + getColumn getter (entityDB def) + + helperCntrs = do + let check [ PersistByteString cntrName + , PersistByteString clmnName] = return ( T.decodeUtf8 cntrName + , T.decodeUtf8 clmnName ) + check other = fail $ "helperCntrs: unexpected " ++ show other + rows <- mapM check =<< CL.consume + return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + $ groupBy ((==) `on` fst) rows + + +-- | Get the information about a column in a table. +getColumn :: (Text -> IO Statement) + -> DBName + -> [PersistValue] + -> IO (Either Text Column) +getColumn getter tname [ PersistByteString cname + , PersistByteString null_ + , PersistByteString type' + , default' + , defaultConstraintName'] = + fmap (either (Left . pack) Right) $ + runErrorT $ do + -- Default value + default_ <- case default' of + PersistNull -> return Nothing + PersistText t -> return (Just t) + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> fail $ "Invalid default column: " ++ + show default' ++ " (error: " ++ + show exc ++ ")" + Right t -> return (Just t) + _ -> fail $ "Invalid default column: " ++ show default' + + -- Default Constraint name + defaultConstraintName_ <- case defaultConstraintName' of + PersistNull -> return Nothing + PersistText t -> return $ Just $ DBName t + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> fail $ "Invalid default constraintname: " ++ + show defaultConstraintName' ++ " (error: " ++ + show exc ++ ")" + Right t -> return $ Just $ DBName t + _ -> fail $ "Invalid default constraint name: " ++ show defaultConstraintName' + -- Column type + type_ <- parseType type' + + -- Foreign key (if any) + stmt <- lift $ getter $ mconcat $ + ["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 " + ,"AND KCU2.CONSTRAINT_SCHEMA = RC.UNIQUE_CONSTRAINT_SCHEMA " + ,"AND KCU2.CONSTRAINT_NAME = RC.UNIQUE_CONSTRAINT_NAME " + ,"AND KCU2.ORDINAL_POSITION = KCU1.ORDINAL_POSITION " + ,"where KCU1.TABLE_NAME = ? and KCU1.COLUMN_NAME = ? " + ,"order by CONSTRAINT_NAME, KCU1.COLUMN_NAME"] + + let vars = [ PersistText $ unDBName tname + , PersistByteString cname + ] + cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + ref <- case cntrs of + [] -> return Nothing + [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> + 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 ++ "]" + + -- Okay! + return Column + { cName = DBName $ T.decodeUtf8 cname + , cNull = null_ == "YES" + , cSqlType = type_ + , cDefault = default_ + , cDefaultConstraintName = defaultConstraintName_ + , cMaxLen = Nothing -- FIXME: maxLen + , cReference = ref + } + +getColumn _ _ x = + return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x + + +-- | Parse the type of column as returned by MSSQL's +-- @INFORMATION_SCHEMA@ tables. +parseType :: Monad m => ByteString -> m SqlType +parseType "tinyint" = return SqlBool +-- Ints +parseType "int" = return SqlInt32 +parseType "short" = return SqlInt32 +parseType "long" = return SqlInt64 +parseType "longlong" = return SqlInt64 +parseType "mediumint" = return SqlInt32 +parseType "bigint" = return SqlInt64 +-- Double +parseType "real" = return SqlReal +parseType "float" = return SqlReal +parseType "double" = return SqlReal +parseType "decimal" = return SqlReal +parseType "numeric" = return SqlReal +-- Text +parseType "varchar" = return SqlString +parseType "varstring" = return SqlString +parseType "string" = return SqlString +parseType "text" = return SqlString +parseType "tinytext" = return SqlString +parseType "mediumtext" = return SqlString +parseType "longtext" = return SqlString +-- ByteString +parseType "varbinary" = return SqlBlob +parseType "image" = return SqlBlob +-- Time-related +parseType "time" = return SqlTime +parseType "datetime" = return SqlDayTime +parseType "datetime2" = return SqlDayTime +parseType "timestamp" = return SqlDayTime +parseType "date" = return SqlDay +parseType "newdate" = return SqlDay +parseType "year" = return SqlDay +-- Other +parseType b = error $ "no idea how to handle this type b=" ++ show b -- return $ SqlOther $ T.decodeUtf8 b + + +---------------------------------------------------------------------- + + +-- | @getAlters allDefs tblName new old@ finds out what needs to +-- be changed from @old@ to become @new@. +getAlters :: Show a + => [EntityDef a] + -> DBName + -> ([Column], [(DBName, [DBName])]) + -> ([Column], [(DBName, [DBName])]) + -> ([AlterColumn'], [AlterTable]) +getAlters allDefs tblName (c1, u1) (c2, u2) = + (getAltersC c1 c2, getAltersU u1 u2) + where + getAltersC [] old = concatMap dropColumn old + getAltersC (new:news) old = + let (alters, old') = findAlters tblName allDefs new old + in alters ++ getAltersC news old' + + dropColumn col = + map ((,) (cName col)) $ + [DropReference n | Just (_, n) <- [cReference col]] ++ + [Drop] + + getAltersU [] old = map (DropUniqueConstraint . fst) old + getAltersU ((name, cols):news) old = + case lookup name old of + Nothing -> + AddUniqueConstraint name (map findType cols) : getAltersU news old + Just ocols -> + let old' = filter (\(x, _) -> x /= name) old + in if sort cols == ocols + then getAltersU news old' + else DropUniqueConstraint name + : AddUniqueConstraint name (map findType cols) + : getAltersU news old' + where + findType = findTypeOfColumn allDefs tblName + + +-- | @findAlters newColumn oldColumns@ finds out what needs to be +-- changed in the columns @oldColumns@ for @newColumn@ to be +-- supported. +findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName _maxLen ref) cols = + tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ + case filter ((name ==) . cName) cols of + [] -> 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 ++ "]") $ + [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 ++"]") $ + [(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' ++ "]") $ + [(tname, addReference allDefs (refName tblName name) tname name)] + _ -> [] + -- Type and nullability + modType | tpcheck type_ type_' && isNull == isNull' = [] + | 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") $ + 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 Nothing Nothing = True +cmpdef (Just def) (Just def') = "(" <> def <> ")" == def' +cmpdef _ _ = False + +tpcheck :: SqlType -> SqlType -> Bool +tpcheck (SqlNumeric _ _) SqlReal = True +tpcheck SqlReal (SqlNumeric _ _) = True +tpcheck a b = a==b + +---------------------------------------------------------------------- + + +-- | Prints the part of a @CREATE TABLE@ statement about a given +-- column. +showColumn :: Column -> String +showColumn (Column n nu t def _defConstraintName maxLen _ref) = concat + [ escapeDBName n + , " " + , showSqlType t maxLen + , " " + , if nu then "NULL" else "NOT NULL" + , case def of + Nothing -> "" + Just s -> " DEFAULT " ++ T.unpack s + ] + + +-- | Renders an 'SqlType' in MSSQL's format. +showSqlType :: SqlType + -> Maybe Integer -- ^ @maxlen@ + -> String +showSqlType SqlBlob Nothing = "VARBINARY(MAX)" +showSqlType SqlBlob (Just i) = "VARBINARY(" ++ show i ++ ")" +showSqlType SqlBool _ = "TINYINT" +showSqlType SqlDay _ = "DATE" +showSqlType SqlDayTime _ = "DATETIME2" +showSqlType SqlDayTimeZoned _ = "VARCHAR(50)" +showSqlType SqlInt32 _ = "INT" +showSqlType SqlInt64 _ = "BIGINT" +showSqlType SqlReal _ = "REAL" +showSqlType (SqlNumeric s prec) _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")" +showSqlType SqlString Nothing = "VARCHAR(1000)" +showSqlType SqlString (Just i) = "VARCHAR(" ++ show i ++ ")" +showSqlType SqlTime _ = "TIME" +showSqlType (SqlOther t) _ = error ("showSqlType unhandled type t="++show t) -- T.unpack t + +-- | Render an action that must be done on the database. +showAlterDb :: AlterDB -> (Bool, Text) +showAlterDb (AddTable s) = (False, pack s) +showAlterDb (AlterColumn t (c, ac)) = + (isUnsafe ac, pack $ showAlter t (c, ac)) + where + isUnsafe Drop = True + isUnsafe _ = False +showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) + + +-- | Render an action that must be done on a table. +showAlterTable :: DBName -> AlterTable -> String +showAlterTable table (AddUniqueConstraint cname cols) = concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD CONSTRAINT " + , escapeDBName cname + , " UNIQUE(" + , intercalate "," $ map (escapeDBName . fst) cols + , ")" + ] +showAlterTable table (DropUniqueConstraint cname) = concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP " + , escapeDBName cname + ] + + +-- | Render an action that must be done on a column. +showAlter :: DBName -> AlterColumn' -> String +showAlter table (_oldName, Change (Column n nu t def defConstraintName maxLen _ref)) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ALTER COLUMN " + , showColumn (Column n nu t def defConstraintName maxLen Nothing) + ] +showAlter table (_, Add' col) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD " + , showColumn col + ] +showAlter table (n, Drop) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP COLUMN " + , escapeDBName n + ] +showAlter table (n, Default s) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD DEFAULT " + , s + , " FOR " + , escapeDBName n + ] +showAlter table (_n, NoDefault defConstraintName) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP CONSTRAINT " + , escapeDBName defConstraintName + ] +showAlter table (n, Update' s) = + concat + [ "UPDATE " + , escapeDBName table + , " SET " + , escapeDBName n + , "=" + , s + , " WHERE " + , escapeDBName n + , " IS NULL" + ] +showAlter table (_, AddReference reftable fkeyname t2 id2) = concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD CONSTRAINT " + , escapeDBName fkeyname + , " FOREIGN KEY(" + , intercalate "," $ map escapeDBName t2 + , ") REFERENCES " + , escapeDBName reftable + , "(" + , intercalate "," $ map escapeDBName id2 + , ")" + ] +showAlter table (_, DropReference cname) = concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP CONSTRAINT " + , escapeDBName cname + ] + +refName :: DBName -> DBName -> DBName +refName (DBName table) (DBName column) = + DBName $ T.concat [table, "_", column, "_fkey"] + +---------------------------------------------------------------------- + + +-- | Escape a database name to be included on a query. +escapeDBName :: DBName -> String +escapeDBName (DBName s) = '[' : go (T.unpack s) + where + go (']':xs) = ']' : ']' : go xs + go ( x :xs) = x : go xs + go "" = "]" +-- | SQL code to be executed when inserting an entity. +insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' ent vals = + case entityPrimary ent of + Just _pdef -> + ISRManyKeys sql vals + where sql = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + Nothing -> +-- should use scope_identity() but doesnt work :gives null + ISRInsertGet doInsert "SELECT @@identity" + where + doInsert = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," $ zipWith doValue (entityFields ent) vals + , ")" + ] + --doValue (FieldDef { fieldSqlType = SqlBlob }, PersistByteString _) = tracex "\n\nin blob with a value\n\n" "convert(varbinary(max),convert(varbinary(max),?))" + --doValue (FieldDef { fieldSqlType = SqlBlob }, PersistByteString _) = tracex "\n\nin blob with a value\n\n" "convert(varbinary(max), cast (? as varchar(1000)))" + doValue f@FieldDef { fieldSqlType = SqlBlob } PersistNull = error $ "persistent-odbc mssql currently doesn't support inserting nulls in a blob field f=" ++ show f -- tracex "\n\nin blob with null\n\n" "iif(? is null, convert(varbinary(max), cast ('' as nvarchar(max))), convert(varbinary(max), cast ('' as nvarchar(max))))" + doValue FieldDef { fieldSqlType = SqlBlob } (PersistByteString _) = "convert(varbinary(max),?)" -- tracex "\n\nin blob with a value\n\n" "convert(varbinary(max),?)" + -- doValue (FieldDef { fieldSqlType = SqlBlob }, PersistNull) = tracex "\n\nin blob with null\n\n" "iif(? is null, convert(varbinary(max),''), convert(varbinary(max),''))" + -- doValue (FieldDef { fieldSqlType = SqlBlob }, PersistNull) = tracex "\n\nin blob with null\n\n" "isnull(?,'')" -- or 0x not in quotes + -- 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 + | 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 + 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" + else error $ "MSSQL: not 2012 so trying to add 'top n' but is not a select sql=" ++ T.unpack sql + | 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 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
@@ -0,0 +1,609 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +-- | A MySQL backend for @persistent@. +module Database.Persist.MigrateMySQL + ( getMigrationStrategy + ) where + +import Control.Arrow +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Error (ErrorT(..)) +import Data.ByteString (ByteString) +import Data.Either (partitionEithers) +import Data.Function (on) +import Data.List (find, intercalate, sort, groupBy) +import Data.Text (Text, pack) +import Data.Monoid ((<>)) + +import Data.Conduit +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Database.Persist.Sql +import Database.Persist.ODBCTypes + +#if DEBUG +import Debug.Trace +tracex::String -> a -> a +tracex = trace +#else +tracex::String -> a -> a +tracex _ b = b +#endif + + +getMigrationStrategy :: DBType -> MigrationStrategy +getMigrationStrategy dbtype@MySQL {} = + MigrationStrategy + { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT 18446744073709551615" + ,dbmsMigrate=migrate' + ,dbmsInsertSql=insertSql' + ,dbmsEscape=T.pack . escapeDBName + ,dbmsType=dbtype + } +getMigrationStrategy dbtype = error $ "MySQL: calling with invalid dbtype " ++ show dbtype + +-- | Create the migration plan for the given 'PersistEntity' +-- @val@. +migrate' :: Show a + => [EntityDef a] + -> (Text -> IO Statement) + -> EntityDef SqlType + -> IO (Either [Text] [(Bool, Text)]) +migrate' allDefs getter val = do + let name = entityDB val + (idClmn, old) <- getColumns getter val + 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 . snd) $ primaryFields pdef, ")"] + Nothing -> concat [escapeDBName $ entityID val, " BIGINT NOT NULL AUTO_INCREMENT PRIMARY KEY"] + + let addTable = AddTable $ concat + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " + , escapeDBName name + , "(" + , idtxt + , if null newcols then [] else "," + , intercalate "," $ map showColumn newcols + , ")" + ] + let uniques = flip concatMap udspair $ \(uname, ucols) -> + [ AlterTable name $ + AddUniqueConstraint uname $ + 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) $ + 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)) + 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) $ + 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' + -- Errors + (_, _, (errs, _)) -> return $ Left errs + + +-- | Find out the type of a column. +findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn allDefs name col = + maybe (error $ "Could not find type of column " ++ + show col ++ " on table " ++ show name ++ + " (allDefs = " ++ show allDefs ++ ")") + ((,) col) $ do + entDef <- find ((== name) . entityDB) allDefs + fieldDef <- find ((== col) . fieldDB) (entityFields entDef) + return (fieldType fieldDef) + + +-- | Helper for 'AddRefence' that finds out the 'entityID'. +addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ + AddReference reftable fkeyname [cname] [id_] + where + id_ = maybe (error $ "Could not find ID of entity " ++ show reftable + ++ " (allDefs = " ++ show allDefs ++ ")") + id $ do + entDef <- find ((== reftable) . entityDB) allDefs + return (entityID entDef) + +data AlterColumn = Change Column + | Add' Column + | Drop + | Default String + | NoDefault + | Update' String + | AddReference DBName DBName [DBName] [DBName] + | DropReference DBName + +type AlterColumn' = (DBName, AlterColumn) + +data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType)] + | DropUniqueConstraint DBName + +data AlterDB = AddTable String + | AlterColumn DBName AlterColumn' + | AlterTable DBName AlterTable + + +udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) + +---------------------------------------------------------------------- + + +-- | Returns all of the 'Column'@s@ in the given table currently +-- in the database. +getColumns :: (Text -> IO Statement) + -> EntityDef a + -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column + , [Either Text (Either Column (DBName, [DBName]))] -- everything else + ) +getColumns getter def = do + -- Find out ID column. + stmtIdClmn <- getter $ T.concat $ + ["SELECT COLUMN_NAME, " + ,"IS_NULLABLE, " + ,"DATA_TYPE, " + ,"COLUMN_DEFAULT " + ,"FROM INFORMATION_SCHEMA.COLUMNS " + ,"WHERE table_schema=schema() " + ,"AND TABLE_NAME = ? " + ,"AND COLUMN_NAME = ?"] + inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + + -- Find out all columns. + stmtClmns <- getter $ T.concat $ + ["SELECT COLUMN_NAME, " + ,"IS_NULLABLE, " + ,"DATA_TYPE, " + ,"COLUMN_DEFAULT " + ,"FROM INFORMATION_SCHEMA.COLUMNS " + ,"WHERE table_schema=schema() " + ,"AND TABLE_NAME = ? " + ,"AND COLUMN_NAME <> ?"] + inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + + -- Find out the constraints. + stmtCntrs <- getter $ T.concat $ + ["SELECT CONSTRAINT_NAME, " + ,"COLUMN_NAME " + ,"FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE " + ,"WHERE table_schema=schema() " + ,"AND TABLE_NAME = ? " + ,"AND COLUMN_NAME <> ? " + ,"AND CONSTRAINT_NAME <> 'PRIMARY' " + ,"AND REFERENCED_TABLE_SCHEMA IS NULL " + ,"ORDER BY CONSTRAINT_NAME, " + ,"COLUMN_NAME"] + us <- runResourceT $ stmtQuery stmtCntrs vals $$ helperCntrs + liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us + -- Return both + return (ids, cs ++ us) + where + vals = [ PersistText $ unDBName $ entityDB def + , PersistText $ unDBName $ entityID def ] + + helperClmns = CL.mapM getIt =$ CL.consume + where + getIt = fmap (either Left (Right . Left)) . + liftIO . + getColumn getter (entityDB def) + + helperCntrs = do + let check [ PersistByteString cntrName + , PersistByteString clmnName] = return ( T.decodeUtf8 cntrName + , T.decodeUtf8 clmnName ) + check other = fail $ "helperCntrs: unexpected " ++ show other + rows <- mapM check =<< CL.consume + return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + $ groupBy ((==) `on` fst) rows + + +-- | Get the information about a column in a table. +getColumn :: (Text -> IO Statement) + -> DBName + -> [PersistValue] + -> IO (Either Text Column) +getColumn getter tname [ PersistByteString cname + , PersistByteString null_ + , PersistByteString type' + , default'] = + fmap (either (Left . pack) Right) $ + runErrorT $ do + -- Default value + default_ <- case default' of + PersistNull -> return Nothing + PersistText t -> return (Just t) + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> fail $ "Invalid default column: " ++ + show default' ++ " (error: " ++ + show exc ++ ")" + Right t -> return (Just t) + _ -> fail $ "Invalid default column: " ++ show default' + + -- Column type + type_ <- parseType type' + + -- Foreign key (if any) + stmt <- lift $ getter $ T.concat $ + ["SELECT REFERENCED_TABLE_NAME, " + ,"CONSTRAINT_NAME, " + ,"ORDINAL_POSITION " + ,"FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE " + ,"WHERE table_schema=schema() " + ,"AND TABLE_NAME = ? " + ,"AND COLUMN_NAME = ? " + ,"and REFERENCED_TABLE_SCHEMA=schema() " + ,"and ordinal_position = 1 " + ,"ORDER BY CONSTRAINT_NAME, " + ,"COLUMN_NAME"] + let vars = [ PersistText $ unDBName tname + , PersistByteString cname + ] + cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + ref <- case cntrs of + [] -> return Nothing + [[PersistByteString tab, PersistByteString ref, PersistInt64 pos]] -> + 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 ++ "]" + + -- Okay! + return Column + { cName = DBName $ T.decodeUtf8 cname + , cNull = null_ == "YES" + , cSqlType = type_ + , cDefault = default_ + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing -- FIXME: maxLen + , cReference = ref + } + +getColumn _ _ x = + return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x + + +-- | Parse the type of column as returned by MySQL's +-- @INFORMATION_SCHEMA@ tables. +parseType :: Monad m => ByteString -> m SqlType +parseType "tinyint" = return SqlBool +-- Ints +parseType "int" = return SqlInt32 +parseType "short" = return SqlInt32 +parseType "long" = return SqlInt64 +parseType "longlong" = return SqlInt64 +parseType "mediumint" = return SqlInt32 +parseType "bigint" = return SqlInt64 +-- Double +parseType "float" = return SqlReal +parseType "double" = return SqlReal +parseType "decimal" = return SqlReal +parseType "newdecimal" = return SqlReal +-- Text +parseType "varchar" = return SqlString +parseType "varstring" = return SqlString +parseType "string" = return SqlString +parseType "text" = return SqlString +parseType "tinytext" = return SqlString +parseType "mediumtext" = return SqlString +parseType "longtext" = return SqlString +-- ByteString +parseType "varbinary" = return SqlBlob +parseType "blob" = return SqlBlob +parseType "tinyblob" = return SqlBlob +parseType "mediumblob" = return SqlBlob +parseType "longblob" = return SqlBlob +-- Time-related +parseType "time" = return SqlTime +parseType "datetime" = return SqlDayTime +parseType "timestamp" = return SqlDayTime +parseType "date" = return SqlDay +parseType "newdate" = return SqlDay +parseType "year" = return SqlDay +-- Other +parseType b = error $ "no idea how to handle this type b=" ++ show b -- return $ SqlOther $ T.decodeUtf8 b + + +---------------------------------------------------------------------- + + +-- | @getAlters allDefs tblName new old@ finds out what needs to +-- be changed from @old@ to become @new@. +getAlters :: Show a + => [EntityDef a] + -> DBName + -> ([Column], [(DBName, [DBName])]) + -> ([Column], [(DBName, [DBName])]) + -> ([AlterColumn'], [AlterTable]) +getAlters allDefs tblName (c1, u1) (c2, u2) = + (getAltersC c1 c2, getAltersU u1 u2) + where + getAltersC [] old = concatMap dropColumn old + getAltersC (new:news) old = + let (alters, old') = findAlters tblName allDefs new old + in alters ++ getAltersC news old' + + dropColumn col = + map ((,) (cName col)) $ + [DropReference n | Just (_, n) <- [cReference col]] ++ + [Drop] + + getAltersU [] old = map (DropUniqueConstraint . fst) old + getAltersU ((name, cols):news) old = + case lookup name old of + Nothing -> + AddUniqueConstraint name (map findType cols) : getAltersU news old + Just ocols -> + let old' = filter (\(x, _) -> x /= name) old + in if sort cols == ocols + then getAltersU news old' + else DropUniqueConstraint name + : AddUniqueConstraint name (map findType cols) + : getAltersU news old' + where + findType = findTypeOfColumn allDefs tblName + + +-- | @findAlters newColumn oldColumns@ finds out what needs to be +-- changed in the columns @oldColumns@ for @newColumn@ to be +-- supported. +findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def defConstraintName _maxLen ref) cols = + tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ + case filter ((name ==) . cName) cols of + [] -> 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 ++ "]") $ + [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 ++"]") $ + [(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' ++ "]") $ + [(tname, addReference allDefs (refName tblName name) tname name)] + _ -> [] + -- Type and nullability + modType | tpcheck type_ type_' && isNull == isNull' = [] + | 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") $ + case def of + Nothing -> [(name, NoDefault)] + Just s -> [(name, Default $ T.unpack s)] + in ( refDrop ++ modType ++ modDef ++ refAdd + , filter ((name /=) . cName) cols ) + + +cmpdef::Maybe Text -> Maybe Text -> Bool +cmpdef Nothing Nothing = True +cmpdef (Just def) (Just def') = def == "'" <> def' <> "'" +cmpdef _ _ = False + +tpcheck :: SqlType -> SqlType -> Bool +tpcheck SqlDayTime SqlString = True +tpcheck SqlString SqlDayTime = True +tpcheck (SqlNumeric _ _) SqlReal = True +tpcheck SqlReal (SqlNumeric _ _) = True +tpcheck a b = a==b +---------------------------------------------------------------------- + + +-- | Prints the part of a @CREATE TABLE@ statement about a given +-- column. +showColumn :: Column -> String +showColumn (Column n nu t def _defConstraintName maxLen ref) = concat + [ escapeDBName n + , " " + , showSqlType t maxLen + , " " + , if nu then "NULL" else "NOT NULL" + , case def of + Nothing -> "" + Just s -> " DEFAULT " ++ T.unpack s + , case ref of + Nothing -> "" + Just (s, _) -> " REFERENCES " ++ escapeDBName s + ] + + +-- | Renders an 'SqlType' in MySQL's format. +showSqlType :: SqlType + -> Maybe Integer -- ^ @maxlen@ + -> String +showSqlType SqlBlob Nothing = "BLOB" +showSqlType SqlBlob (Just i) = "VARBINARY(" ++ show i ++ ")" +showSqlType SqlBool _ = "TINYINT(1)" +showSqlType SqlDay _ = "DATE" +showSqlType SqlDayTime _ = "VARCHAR(50) CHARACTER SET utf8" -- "DATETIME" +showSqlType SqlDayTimeZoned _ = "VARCHAR(50) CHARACTER SET utf8" +showSqlType SqlInt32 _ = "INT" +showSqlType SqlInt64 _ = "BIGINT" +showSqlType SqlReal _ = "DOUBLE PRECISION" +showSqlType (SqlNumeric s prec) _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")" +showSqlType SqlString Nothing = "TEXT CHARACTER SET utf8" +showSqlType SqlString (Just i) = "VARCHAR(" ++ show i ++ ") CHARACTER SET utf8" +showSqlType SqlTime _ = "TIME" +showSqlType (SqlOther t) _ = T.unpack t + +-- | Render an action that must be done on the database. +showAlterDb :: AlterDB -> (Bool, Text) +showAlterDb (AddTable s) = (False, pack s) +showAlterDb (AlterColumn t (c, ac)) = + (isUnsafe ac, pack $ showAlter t (c, ac)) + where + isUnsafe Drop = True + isUnsafe _ = False +showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) + + +-- | Render an action that must be done on a table. +showAlterTable :: DBName -> AlterTable -> String +showAlterTable table (AddUniqueConstraint cname cols) = concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD CONSTRAINT " + , escapeDBName cname + , " UNIQUE(" + , intercalate "," $ map escapeDBName' cols + , ")" + ] + where + escapeDBName' (name, FTTypeCon _ "Text" ) = escapeDBName name ++ "(200)" + escapeDBName' (name, FTTypeCon _ "String" ) = escapeDBName name ++ "(200)" + escapeDBName' (name, FTTypeCon _ "ByteString") = escapeDBName name ++ "(200)" + escapeDBName' (name, _ ) = escapeDBName name +showAlterTable table (DropUniqueConstraint cname) = concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP INDEX " + , escapeDBName cname + ] + + +-- | Render an action that must be done on a column. +showAlter :: DBName -> AlterColumn' -> String +showAlter table (oldName, Change (Column n nu t def defConstraintName maxLen _ref)) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " CHANGE " + , escapeDBName oldName + , " " + , showColumn (Column n nu t def defConstraintName maxLen Nothing) + ] +showAlter table (_, Add' col) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD COLUMN " + , showColumn col + ] +showAlter table (n, Drop) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP COLUMN " + , escapeDBName n + ] +showAlter table (n, Default s) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ALTER COLUMN " + , escapeDBName n + , " SET DEFAULT " + , s + ] +showAlter table (n, NoDefault) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ALTER COLUMN " + , escapeDBName n + , " DROP DEFAULT" + ] +showAlter table (n, Update' s) = + concat + [ "UPDATE " + , escapeDBName table + , " SET " + , escapeDBName n + , "=" + , s + , " WHERE " + , escapeDBName n + , " IS NULL" + ] +showAlter table (_, AddReference reftable fkeyname t2 id2) = concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD CONSTRAINT " + , escapeDBName fkeyname + , " FOREIGN KEY(" + , intercalate "," $ map escapeDBName t2 + , ") REFERENCES " + , escapeDBName reftable + , "(" + , intercalate "," $ map escapeDBName id2 + , ")" + ] +showAlter table (_, DropReference cname) = concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP FOREIGN KEY " + , escapeDBName cname + ] + +refName :: DBName -> DBName -> DBName +refName (DBName table) (DBName column) = + DBName $ T.concat [table, "_", column, "_fkey"] + +---------------------------------------------------------------------- + + +-- | Escape a database name to be included on a query. +escapeDBName :: DBName -> String +escapeDBName (DBName s) = '`' : go (T.unpack s) + where + go ('`':xs) = '`' : '`' : go xs + go ( x :xs) = x : go xs + go "" = "`" +-- | SQL code to be executed when inserting an entity. +insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' ent vals = + case entityPrimary ent of + Just _pdef -> + ISRManyKeys sql vals + where sql = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + Nothing -> ISRInsertGet doInsert "SELECT LAST_INSERT_ID()" + where + doInsert = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ]
+ src/Database/Persist/MigrateOracle.hs view
@@ -0,0 +1,651 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +-- | A Oracle backend for @persistent@. +module Database.Persist.MigrateOracle + ( getMigrationStrategy + ) where + +import Control.Arrow +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Error (ErrorT(..)) +import Data.ByteString (ByteString) +import Data.Either (partitionEithers) +import Data.Function (on) +import Data.List (find, intercalate, sort, groupBy) +import Data.Text (Text, pack) + +import Data.Conduit +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Monoid ((<>)) +import Database.Persist.Sql +import Database.Persist.ODBCTypes + +#if DEBUG +import Debug.Trace +tracex::String -> a -> a +tracex = trace +#else +tracex::String -> a -> a +tracex _ b = b +#endif + +getMigrationStrategy :: DBType -> MigrationStrategy +getMigrationStrategy dbtype@Oracle { oracle12c=ok} = + MigrationStrategy + { dbmsLimitOffset=limitOffset ok + ,dbmsMigrate=migrate' + ,dbmsInsertSql=insertSql' + ,dbmsEscape=T.pack . escapeDBName + ,dbmsType=dbtype + } +getMigrationStrategy dbtype = error $ "Oracle: calling with invalid dbtype " ++ show dbtype +-- | Create the migration plan for the given 'PersistEntity' +-- @val@. +migrate' :: Show a + => [EntityDef a] + -> (Text -> IO Statement) + -> EntityDef SqlType + -> IO (Either [Text] [(Bool, Text)]) +migrate' allDefs getter val = do + let name = entityDB val + (idClmn, old, mseq) <- getColumns getter val + let (newcols, udefs, fdefs) = mkColumns allDefs val + let udspair = map udToPair udefs + let addSequence = AddSequence $ concat + [ "CREATE SEQUENCE " + ,getSeqNameEscaped name + , " START WITH 1 INCREMENT BY 1" + ] + case (idClmn, old, partitionEithers old, mseq) of + -- Nothing found, create everything + ([], [], _, _) -> do + let idtxt = case entityPrimary val of + Just pdef -> " CONSTRAINT " <> escapeDBName (pkeyName (entityDB val)) <> " PRIMARY KEY (" <> (intercalate "," $ map (escapeDBName . snd) $ primaryFields pdef) <> ")" + Nothing -> concat [escapeDBName $ entityID val, " NUMBER NOT NULL PRIMARY KEY "] + let addTable = AddTable $ concat + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " + , escapeDBName name + , "(" + , idtxt + , if null newcols then [] else "," + , intercalate "," $ map showColumn newcols + , ")" + ] + let uniques = flip concatMap udspair $ \(uname, ucols) -> + [ AlterTable name $ + AddUniqueConstraint uname $ + 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) $ + 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)) + in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + + return $ Right $ map showAlterDb $ addTable : addSequence : uniques ++ foreigns ++ foreignsAlt + -- No errors and something found, migrate + (_, _, ([], 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) $ + 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') + -- Errors + (_, _, (errs, _), _) -> return $ Left errs + + +-- | Find out the type of a column. +findTypeOfColumn :: Show a => [EntityDef a] -> DBName -> DBName -> (DBName, FieldType) +findTypeOfColumn allDefs name col = + maybe (error $ "Could not find type of column " ++ + show col ++ " on table " ++ show name ++ + " (allDefs = " ++ show allDefs ++ ")") + ((,) col) $ do + entDef <- find ((== name) . entityDB) allDefs + fieldDef <- find ((== col) . fieldDB) (entityFields entDef) + return (fieldType fieldDef) + + +-- | Helper for 'AddRefence' that finds out the 'entityID'. +addReference :: Show a => [EntityDef a] -> DBName -> DBName -> DBName -> AlterColumn +addReference allDefs fkeyname reftable cname = tracex ("\n\naddreference cname="++show cname++" fkeyname="++show fkeyname++" reftable="++show reftable++" id_="++show id_) $ + AddReference reftable fkeyname [cname] [id_] + where + id_ = maybe (error $ "Could not find ID of entity " ++ show reftable + ++ " (allDefs = " ++ show allDefs ++ ")") + id $ do + entDef <- find ((== reftable) . entityDB) allDefs + return (entityID entDef) + +data AlterColumn = Change Column + | Add' Column + | Drop + | Default String + | NoDefault + | Update' String + | AddReference DBName DBName [DBName] [DBName] + | DropReference DBName + +type AlterColumn' = (DBName, AlterColumn) + +data AlterTable = AddUniqueConstraint DBName [(DBName, FieldType)] + | DropUniqueConstraint DBName + +data AlterDB = AddTable String + | AlterColumn DBName AlterColumn' + | AlterTable DBName AlterTable + | AddSequence String + +udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) + +---------------------------------------------------------------------- + + +-- | Returns all of the 'Column'@s@ in the given table currently +-- in the database. +getColumns :: (Text -> IO Statement) + -> EntityDef a + -> IO ( [Either Text (Either Column (DBName, [DBName]))] -- ID column + , [Either Text (Either Column (DBName, [DBName]))] -- everything else + , Maybe PersistValue -- sequence name + ) +getColumns getter def = do + -- Find out ID column. + stmtIdClmn <- getter $ T.concat + ["SELECT COLUMN_NAME, " + ,"cast(NULLABLE as CHAR) as IS_NULLABLE, " + ,"DATA_TYPE, " + ,"DATA_DEFAULT as COLUMN_DEFAULT " + ,"FROM user_tab_cols " + ,"WHERE TABLE_NAME = ? " + ,"AND COLUMN_NAME = ?"] + inter1 <- runResourceT $ stmtQuery stmtIdClmn vals $$ CL.consume + ids <- runResourceT $ CL.sourceList inter1 $$ helperClmns -- avoid nested queries + + -- Find if sequence already exists. + stmtSeq <- getter $ T.concat ["SELECT sequence_name " + ,"FROM user_sequences " + ,"WHERE sequence_name = ?"] + seqlist <- runResourceT $ stmtQuery stmtSeq [PersistText $ getSeqNameUnescaped $ entityDB def] $$ CL.consume + --liftIO $ putStrLn $ "seqlist=" ++ show seqlist + + -- Find out all columns. + stmtClmns <- getter $ T.concat ["SELECT COLUMN_NAME, " + ,"cast(NULLABLE as CHAR) as IS_NULLABLE, " + ,"DATA_TYPE, " + ,"DATA_DEFAULT " + ,"FROM user_tab_cols " + ,"WHERE TABLE_NAME = ? " + ,"AND COLUMN_NAME <> ?"] + inter2 <- runResourceT $ stmtQuery stmtClmns vals $$ CL.consume + cs <- runResourceT $ CL.sourceList inter2 $$ helperClmns -- avoid nested queries + + -- Find out the constraints. + + stmtCntrs <- getter $ T.concat + ["SELECT a.CONSTRAINT_NAME, " + ,"a.COLUMN_NAME " + ,"FROM user_cons_columns a,user_constraints b " + ,"WHERE a.table_name = ? " + ,"and a.table_name=b.table_name " + ,"and a.constraint_name=b.constraint_name " + ,"and b.constraint_type in ('U') " + ,"AND a.COLUMN_NAME <> ? " + ,"ORDER BY b.CONSTRAINT_NAME, " + ,"a.COLUMN_NAME"] + us <- runResourceT $ stmtQuery stmtCntrs vals $$ helperCntrs + + -- Return both + return (ids, cs ++ us, listAsMaybe seqlist) + where + listAsMaybe [] = Nothing + listAsMaybe [[x]] = Just x + listAsMaybe xs = error $ "returned to many sequences xs=" ++ show xs + + vals = [ PersistText $ unDBName $ entityDB def + , PersistText $ unDBName $ entityID def ] + + helperClmns = CL.mapM getIt =$ CL.consume + where + getIt = fmap (either Left (Right . Left)) . + liftIO . + getColumn getter (entityDB def) + + helperCntrs = do + let check [ PersistByteString cntrName + , PersistByteString clmnName] = return ( T.decodeUtf8 cntrName + , T.decodeUtf8 clmnName ) + check other = fail $ "helperCntrs: unexpected " ++ show other + rows <- mapM check =<< CL.consume + return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) + $ groupBy ((==) `on` fst) rows + + +-- | Get the information about a column in a table. +getColumn :: (Text -> IO Statement) + -> DBName + -> [PersistValue] + -> IO (Either Text Column) +getColumn getter tname [ PersistByteString cname + , PersistByteString null_ + , PersistByteString type' + , default'] = + fmap (either (Left . pack) Right) $ + runErrorT $ do + -- Default value + default_ <- case default' of + PersistNull -> return Nothing + PersistText t -> return (Just t) + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> fail $ "Invalid default column: " ++ + show default' ++ " (error: " ++ + show exc ++ ")" + Right t -> return (Just t) + _ -> fail $ "Invalid default column: " ++ show default' + + -- Column type + type_ <- parseType type' + -- Foreign key (if any) + + stmt <- lift $ getter $ T.concat + ["SELECT " + ,"UCC.TABLE_NAME as REFERENCED_TABLE_NAME, " + ,"UC.CONSTRAINT_NAME as CONSTRAINT_NAME " + ,"FROM USER_CONSTRAINTS UC, " + ,"USER_CONS_COLUMNS UCC, " + ,"USER_CONS_COLUMNS CC " + ,"WHERE UC.R_CONSTRAINT_NAME = UCC.CONSTRAINT_NAME " + ,"AND uc.constraint_type = 'R' " + ,"and cc.constraint_name=uc.constraint_name " + ,"and ucc.position = 1 " + ,"and cc.position = 1 " + ,"and uc.table_name=? " + ,"and cc.column_name=? " + ,"ORDER BY UC.TABLE_NAME, " + ,"UC.R_CONSTRAINT_NAME, " + ,"UCC.TABLE_NAME, " + ,"UCC.COLUMN_NAME"] + + let vars = [ PersistText $ unDBName tname + , PersistByteString cname + ] + cntrs <- runResourceT $ stmtQuery stmt vars $$ CL.consume + ref <- case cntrs of + [] -> return Nothing + [[PersistByteString tab, PersistByteString ref]] -> + return $ Just (DBName $ T.decodeUtf8 tab, DBName $ T.decodeUtf8 ref) + a1 -> fail $ "Oracle.getColumn/getRef: never here error[" ++ show a1 ++ "]" + + -- Okay! + return Column + { cName = DBName $ T.decodeUtf8 cname + , cNull = null_ == "Y" + , cSqlType = type_ + , cDefault = default_ + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing -- FIXME: maxLen + , cReference = ref + } + +getColumn _ _ x = + return $ Left $ pack $ "Invalid result from INFORMATION_SCHEMA: " ++ show x + + +-- | Parse the type of column as returned by Oracle's +-- schema tables. +parseType :: Monad m => ByteString -> m SqlType +parseType "CHAR" = return SqlBool +-- Ints +--parseType "int" = return SqlInt32 +--parseType "short" = return SqlInt32 +--parseType "long" = return SqlInt64 +--parseType "longlong" = return SqlInt64 +--parseType "mediumint" = return SqlInt32 +parseType "NUMBER" = return SqlInt32 +-- **** todo parseType "number(a,b)" = return SqlReal + +-- Double +parseType "FLOAT" = return SqlReal +parseType "DOUBLE" = return SqlReal +--parseType "decimal" = return SqlReal +--parseType "newdecimal" = return SqlReal +parseType "VARCHAR2(100)" = return SqlString +-- Text +parseType "VARCHAR2" = return SqlString +parseType "TEXT" = return SqlString +--parseType "tinytext" = return SqlString +--parseType "mediumtext" = return SqlString +parseType "LONG" = return SqlString +-- ByteString +parseType "BLOB" = return SqlBlob +--parseType "tinyblob" = return SqlBlob +--parseType "mediumblob" = return SqlBlob +--parseType "longblob" = return SqlBlob +-- Time-related +--parseType "time" = return SqlTime +--parseType "datetime" = return SqlDayTime +parseType "TIMESTAMP" = return SqlDayTime +parseType "TIMESTAMP(6)" = return SqlDayTime +--parseType "date" = return SqlDay +--parseType "newdate" = return SqlDay +--parseType "year" = return SqlDay +-- Other +parseType b = error $ "oracle: parseType no idea how to parse this b="++show b + + +---------------------------------------------------------------------- + + +-- | @getAlters allDefs tblName new old@ finds out what needs to +-- be changed from @old@ to become @new@. +getAlters :: Show a + => [EntityDef a] + -> DBName + -> ([Column], [(DBName, [DBName])]) + -> ([Column], [(DBName, [DBName])]) + -> ([AlterColumn'], [AlterTable]) +getAlters allDefs tblName (c1, u1) (c2, u2) = + (getAltersC c1 c2, getAltersU u1 u2) + where + getAltersC [] old = concatMap dropColumn old + getAltersC (new:news) old = + let (alters, old') = findAlters tblName allDefs new old + in alters ++ getAltersC news old' + + dropColumn col = + map ((,) (cName col)) $ + [DropReference n | Just (_, n) <- [cReference col]] ++ + [Drop] + + getAltersU [] old = map (DropUniqueConstraint . fst) old + getAltersU ((name, cols):news) old = + case lookup name old of + Nothing -> + AddUniqueConstraint name (map findType cols) : getAltersU news old + Just ocols -> + let old' = filter (\(x, _) -> x /= name) old + in if sort cols == ocols + then getAltersU news old' + else DropUniqueConstraint name + : AddUniqueConstraint name (map findType cols) + : getAltersU news old' + where + findType = findTypeOfColumn allDefs tblName + + +-- | @findAlters newColumn oldColumns@ finds out what needs to be +-- changed in the columns @oldColumns@ for @newColumn@ to be +-- supported. +findAlters :: Show a => DBName -> [EntityDef a] -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters tblName allDefs col@(Column name isNull type_ def _defConstraintName _maxLen ref) cols = + tracex ("\n\n\nfindAlters tablename="++show tblName++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ + case filter ((name ==) . cName) cols of + [] -> 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 ++ "]") $ + [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 ++"]") $ + [(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' ++ "]") $ + [(tname, addReference allDefs (refName tblName name) tname name)] + _ -> [] + -- Type and nullability + modType | tpcheck type_ type_' && isNull == isNull' = [] + | otherwise = [(name, Change col)] + -- Default value + modDef | cmpdef def def' = [] + | otherwise = --tracex ("findAlters col=" ++ show col ++ " def=" ++ show def ++ " def'=" ++ show def') $ + case def of + Nothing -> [(name, NoDefault)] + Just s -> [(name, Default $ T.unpack s)] + in ( refDrop ++ modType ++ modDef ++ refAdd + , filter ((name /=) . cName) cols ) + + +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 _ _ = False + +tpcheck :: SqlType -> SqlType -> Bool +tpcheck SqlInt32 SqlInt64 = True +tpcheck SqlInt64 SqlInt32 = True +tpcheck (SqlNumeric _ _) SqlInt32 = True -- else will try to migrate rational columns +tpcheck SqlInt32 (SqlNumeric _ _) = True +tpcheck a b = a==b + +---------------------------------------------------------------------- + + +-- | Prints the part of a @CREATE TABLE@ statement about a given +-- column. +showColumn :: Column -> String +showColumn (Column n nu t def _defConstraintName maxLen _ref) = concat + [ escapeDBName n + , " " + , showSqlType t maxLen + , " " + , if nu then "NULL" else "NOT NULL" + , case def of + Nothing -> "" + Just s -> " DEFAULT " ++ T.unpack s +-- , case ref of +-- Nothing -> "" +-- Just (s, _) -> " REFERENCES " ++ escapeDBName s + ] + + +-- | Renders an 'SqlType' in Oracle's format. +showSqlType :: SqlType + -> Maybe Integer -- ^ @maxlen@ + -> String +showSqlType SqlBlob Nothing = "BLOB" +showSqlType SqlBlob (Just _i) = "BLOB" -- cannot specify the size +showSqlType SqlBool _ = "CHAR" +showSqlType SqlDay _ = "DATE" +showSqlType SqlDayTime _ = "TIMESTAMP(6)" +showSqlType SqlDayTimeZoned _ = "VARCHAR2(50)" +showSqlType SqlInt32 _ = "NUMBER" +showSqlType SqlInt64 _ = "NUMBER" +showSqlType SqlReal _ = "FLOAT" +showSqlType (SqlNumeric s prec) _ = "NUMBER(" ++ show s ++ "," ++ show prec ++ ")" +showSqlType SqlString Nothing = "VARCHAR2(1000)" +showSqlType SqlString (Just i) = "VARCHAR2(" ++ show i ++ ")" +showSqlType SqlTime _ = "TIME" +showSqlType (SqlOther t) _ = error ("oops in showSqlType " ++ show t) -- $ T.unpack t + +-- | Render an action that must be done on the database. +showAlterDb :: AlterDB -> (Bool, Text) +showAlterDb (AddTable s) = (False, pack s) +showAlterDb (AddSequence s) = (False, pack s) +showAlterDb (AlterColumn t (c, ac)) = + (isUnsafe ac, pack $ showAlter t (c, ac)) + where + isUnsafe Drop = True + isUnsafe _ = False +showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) + + +-- | Render an action that must be done on a table. +showAlterTable :: DBName -> AlterTable -> String +showAlterTable table (AddUniqueConstraint cname cols) = concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD CONSTRAINT " + , escapeDBName cname + , " UNIQUE(" + , intercalate "," $ map (escapeDBName . fst) cols + , ")" + ] +showAlterTable table (DropUniqueConstraint cname) = concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP CONSTRAINT " + , escapeDBName cname + ] + + +-- | Render an action that must be done on a column. +showAlter :: DBName -> AlterColumn' -> String +showAlter table (_oldName, Change (Column n nu t def defConstraintName maxLen _ref)) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " MODIFY (" + -- , escapeDBName oldName + , " " + , showColumn (Column n nu t def defConstraintName maxLen Nothing) + , ")" + ] +showAlter table (_, Add' col) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD " + , showColumn col + ] +showAlter table (n, Drop) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP COLUMN " + , escapeDBName n + ] +showAlter table (n, Default s) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " MODIFY (" + , escapeDBName n + , " DEFAULT " + , s + , ")" + ] +showAlter table (n, NoDefault) = + concat + [ "ALTER TABLE " + , escapeDBName table + , " MODIFY " + , escapeDBName n + , " DEFAULT NULL" + ] +showAlter table (n, Update' s) = + concat + [ "UPDATE " + , escapeDBName table + , " SET " + , escapeDBName n + , "=" + , s + , " WHERE " + , escapeDBName n + , " IS NULL" + ] +showAlter table (_, AddReference reftable fkeyname t2 id2) = concat + [ "ALTER TABLE " + , escapeDBName table + , " ADD CONSTRAINT " + , escapeDBName fkeyname + , " FOREIGN KEY(" + , intercalate "," $ map escapeDBName t2 + , ") REFERENCES " + , escapeDBName reftable + , "(" + , intercalate "," $ map escapeDBName id2 + , ")" + ] +showAlter table (_, DropReference cname) = concat + [ "ALTER TABLE " + , escapeDBName table + , " DROP CONSTRAINT " + , escapeDBName cname + ] + +-- ORA-00972: identifier is too long +refName :: DBName -> DBName -> DBName +refName (DBName table) (DBName column) = + DBName $ T.take 30 $ T.concat [table, "_", column, "_fkey"] + +--refNames :: DBName -> [DBName] -> DBName +--refNames (DBName table) dbnames = +-- let columns = T.intercalate "_" $ map unDBName dbnames +-- in DBName $ T.take 30 $ T.concat [table, "_", columns, "_fkey"] + +pkeyName :: DBName -> DBName +pkeyName (DBName table) = + DBName $ T.take 30 $ T.concat [table, "_pkey"] + +---------------------------------------------------------------------- + + +-- | Escape a database name to be included on a query. +escapeDBName :: DBName -> String +escapeDBName (DBName s) = '"' : go (T.unpack s) + where + go ('"':xs) = '"' : '"' : go xs + go ( x :xs) = x : go xs + go "" = "\"" +-- | SQL code to be executed when inserting an entity. +insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' ent vals = + case entityPrimary ent of + Just _pdef -> + ISRManyKeys sql vals + where sql = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + Nothing -> ISRInsertGet doInsert $ T.pack ("select cast(" ++ getSeqNameEscaped (entityDB ent) ++ ".currval as number) from dual") + where + doInsert = pack $ concat + [ "INSERT INTO " + , escapeDBName $ entityDB ent + , "(" + , escapeDBName $ entityID ent + , if null (entityFields ent) then "" else "," + , intercalate "," $ map (escapeDBName . fieldDB) $ entityFields ent + , ") VALUES(" + , getSeqNameEscaped (entityDB ent) ++ ".nextval" + , if null (entityFields ent) then "" else "," + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + +getSeqNameEscaped :: DBName -> String +getSeqNameEscaped d = escapeDBName $ DBName $ getSeqNameUnescaped d + +getSeqNameUnescaped::DBName -> Text +getSeqNameUnescaped (DBName s) = "seq_" <> s <> "_id" + +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" + | otherwise = error $ "Oracle does not support limit and offset until Oracle 12c sql=" ++ T.unpack sql
+ src/Database/Persist/MigratePostgres.hs view
@@ -0,0 +1,549 @@+{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} +-- | An ODBC backend for persistent. +module Database.Persist.MigratePostgres + ( getMigrationStrategy + ) where + +import Database.Persist.Sql +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Text as T +import Data.Text (pack,Text) + +import Data.Either (partitionEithers) +import Control.Arrow +import Data.List (find, intercalate, sort, groupBy) +import Data.Function (on) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Maybe (mapMaybe) + +import qualified Data.Text.Encoding as T + +import Database.Persist.ODBCTypes + +#if DEBUG +import Debug.Trace +tracex::String -> a -> a +tracex = trace +#else +tracex::String -> a -> a +tracex _ b = b +#endif + +getMigrationStrategy :: DBType -> MigrationStrategy +getMigrationStrategy dbtype@Postgres {} = + MigrationStrategy + { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT ALL" + ,dbmsMigrate=migrate' + ,dbmsInsertSql=insertSql' + ,dbmsEscape=escape + ,dbmsType=dbtype + } +getMigrationStrategy dbtype = error $ "Postgres: calling with invalid dbtype " ++ show dbtype + +migrate' :: [EntityDef a] + -> (Text -> IO Statement) + -> EntityDef SqlType + -> IO (Either [Text] [(Bool, Text)]) +migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do + let name = entityDB val + old <- getColumns getter val + case partitionEithers old of + ([], old'') -> do + let old' = partitionEithers old'' + let (newcols', udefs, fdefs) = mkColumns allDefs val + let newcols = filter (not . safeToRemove val . cName) newcols' + let udspair = map udToPair udefs + --let composite = isJust $ entityPrimary val + if null old + then do + let idtxt = case entityPrimary val of + Just pdef -> concat [" PRIMARY KEY (", intercalate "," $ map (T.unpack . escape . snd) $ primaryFields pdef, ")"] + Nothing -> concat [T.unpack $ escape $ entityID val + , " SERIAL PRIMARY KEY UNIQUE"] + let addTable = AddTable $ concat + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " + , T.unpack $ escape name + , "(" + , idtxt + , if null newcols then [] else "," + , intercalate "," $ map showColumn newcols + , ")" + ] + 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)) + in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + return $ Right $ addTable : uniques ++ references ++ foreignsAlt + else do + let (acs, ats) = getAlters allDefs val (newcols, udspair) old' + let acs' = map (AlterColumn name) acs + let ats' = map (AlterTable name) ats + return $ Right $ acs' ++ ats' + (errs, _) -> return $ Left errs + +type SafeToRemove = Bool + +data AlterColumn = Type SqlType | IsNull | NotNull | Add' Column | Drop SafeToRemove + | Default String | NoDefault | Update' String + | AddReference DBName [DBName] [DBName] | DropReference DBName +type AlterColumn' = (DBName, AlterColumn) + +data AlterTable = AddUniqueConstraint DBName [DBName] + | DropConstraint DBName + +data AlterDB = AddTable String + | AlterColumn DBName AlterColumn' + | AlterTable DBName AlterTable + +-- | Returns all of the columns in the given table currently in the database. +getColumns :: (Text -> IO Statement) + -> EntityDef a + -> IO [Either Text (Either Column (DBName, [DBName]))] +getColumns getter def = do + let sqlv=concat ["SELECT " + ,"column_name " + ,",is_nullable " + ,",udt_name " + ,",column_default " + ,",numeric_precision " + ,",numeric_scale " + ,"FROM information_schema.columns " + ,"WHERE table_catalog=current_database() " + ,"AND table_schema=current_schema() " + ,"AND table_name=? " + ,"AND column_name <> ?"] + + stmt <- getter $ pack sqlv + let vals = + [ PersistText $ unDBName $ entityDB def + , PersistText $ unDBName $ entityID def + ] + cs <- runResourceT $ stmtQuery stmt vals $$ helperClmns + let sqlc=concat ["SELECT " + ,"c.constraint_name, " + ,"c.column_name " + ,"FROM information_schema.key_column_usage c, " + ,"information_schema.table_constraints k " + ,"WHERE c.table_catalog=current_database() " + ,"AND c.table_catalog=k.table_catalog " + ,"AND c.table_schema=current_schema() " + ,"AND c.table_schema=k.table_schema " + ,"AND c.table_name=? " + ,"AND c.table_name=k.table_name " + ,"AND c.column_name <> ? " + ,"AND c.ordinal_position=1 " + ,"AND c.constraint_name=k.constraint_name " + ,"AND k.constraint_type not in ('PRIMARY KEY','FOREIGN KEY') " + ,"ORDER BY c.constraint_name, c.column_name"] + + stmt' <- getter $ pack sqlc + + us <- runResourceT $ stmtQuery stmt' vals $$ helperU + liftIO $ putStrLn $ "\n\ngetColumns cs="++show cs++"\n\nus="++show us + return $ cs ++ us + where + getAll front = do + x <- CL.head + 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 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 + where + getIt = fmap (either Left (Right . Left)) . + liftIO . + getColumn getter (entityDB def) +{- + helper = do + x <- CL.head + case x of + Nothing -> tracex "getColumns helper Nothing!!!" $ return [] + Just x' -> do + col <- liftIO $ getColumn getter (entityDB def) x' + let col' = tracex ("getColumns helper: col="++show col) $ case col of + Left e -> Left e + Right c -> Right $ Left c + cols <- helper + return $ col' : cols +-} +-- | Check if a column name is listed as the "safe to remove" in the entity +-- list. +safeToRemove :: EntityDef a -> DBName -> Bool +safeToRemove def (DBName colName) + = any (elem "SafeToRemove" . fieldAttrs) + $ filter ((== (DBName colName)) . fieldDB) + $ entityFields def + +getAlters :: [EntityDef a] + -> EntityDef SqlType + -> ([Column], [(DBName, [DBName])]) + -> ([Column], [(DBName, [DBName])]) + -> ([AlterColumn'], [AlterTable]) +getAlters allDefs def (c1, u1) (c2, u2) = + (getAltersC c1 c2, getAltersU u1 u2) + where + getAltersC [] old = map (\x -> (cName x, Drop $ safeToRemove def $ cName x)) old + getAltersC (new:news) old = + let (alters, old') = findAlters allDefs (entityDB def) new old + in alters ++ getAltersC news old' + + getAltersU :: [(DBName, [DBName])] + -> [(DBName, [DBName])] + -> [AlterTable] + getAltersU [] old = map DropConstraint $ filter (not . isManual) $ map fst old + getAltersU ((name, cols):news) old = + case lookup name old of + Nothing -> AddUniqueConstraint name cols : getAltersU news old + Just ocols -> + let old' = filter (\(x, _) -> x /= name) old + in if sort cols == sort ocols + then getAltersU news old' + else DropConstraint name + : AddUniqueConstraint name cols + : getAltersU news old' + + -- Don't drop constraints which were manually added. + isManual (DBName x) = "__manual_" `T.isPrefixOf` x + +getColumn :: (Text -> IO Statement) + -> DBName -> [PersistValue] + -> IO (Either Text Column) +getColumn getter tname [PersistByteString x, PersistByteString y, PersistByteString z, d, npre, nscl] = do + case d' of + Left s -> return $ Left s + Right d'' -> + case getType (T.decodeUtf8 z) of + Left s -> return $ Left s + Right t -> do + let cname = DBName $ T.decodeUtf8 x + ref <- getRef cname + return $ Right Column + { cName = cname + , cNull = y == "YES" + , cSqlType = t + , cDefault = d'' + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = ref + } + where + getRef cname = do + let sql = pack $ concat + [ "SELECT " + ,"tc.table_name, " + ,"kcu.column_name, " + ,"ccu.table_name AS foreign_table_name, " + ,"ccu.column_name AS foreign_column_name, " + ,"kcu.ordinal_position " + ,"FROM " + ,"information_schema.table_constraints AS tc " + ,"JOIN information_schema.key_column_usage " + ,"AS kcu ON tc.constraint_name = kcu.constraint_name " + ,"JOIN information_schema.constraint_column_usage " + ,"AS ccu ON ccu.constraint_name = tc.constraint_name " + ,"WHERE constraint_type = 'FOREIGN KEY' " + ,"and tc.table_name=? " + ,"and tc.constraint_name=? " + ,"and tc.table_catalog=current_database() " + ,"AND tc.table_catalog=kcu.table_catalog " + ,"AND tc.table_catalog=ccu.table_catalog " + ,"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 " + ] + + let ref = refName tname cname + stmt <- getter sql + runResourceT $ stmtQuery stmt + [ PersistText $ unDBName tname + , PersistText $ unDBName ref + ] $$ do + m <- CL.head + + return $ case m of + Just [PersistText _table, PersistText _col, PersistText reftable, PersistText _refcol, PersistInt64 _pos] -> Just (DBName reftable, ref) + Just [PersistByteString _table, PersistByteString _col, PersistByteString reftable, PersistByteString _refcol, PersistInt64 _pos] -> Just (DBName (T.decodeUtf8 reftable), ref) + Nothing -> Nothing + _ -> error $ "unexpected result found ["++ show m ++ "]" + d' = case d of + PersistNull -> Right Nothing + PersistText t -> Right $ Just t + PersistByteString bs -> Right $ Just $ T.decodeUtf8 bs + _ -> Left $ pack $ "Invalid default column: " ++ show d + getType "int4" = Right $ SqlInt32 + getType "int8" = Right $ SqlInt64 + getType "varchar" = Right $ SqlString + getType "date" = Right $ SqlDay + getType "bool" = Right $ SqlBool + getType "timestamp" = Right $ SqlDayTime + getType "timestamptz" = Right $ SqlDayTimeZoned + getType "float4" = Right $ SqlReal + getType "float8" = Right $ SqlReal + getType "bytea" = Right $ SqlBlob + getType "time" = Right $ SqlTime + getType "numeric" = getNumeric npre nscl + getType a = Right $ SqlOther a + + getNumeric (PersistInt64 a) (PersistInt64 b) = Right $ SqlNumeric (fromIntegral a) (fromIntegral b) + getNumeric a b = Left $ pack $ "Can not get numeric field precision, got: " ++ show a ++ " and " ++ show b ++ " as precision and scale" +getColumn _ a2 x = + return $ Left $ pack $ "Invalid result from information_schema: " ++ show x ++ " a2[" ++ show a2 ++ "]" + +findAlters :: [EntityDef a] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column]) +findAlters defs tablename col@(Column name isNull sqltype def _defConstraintName _maxLen ref) cols = + tracex ("\n\n\nfindAlters tablename="++show tablename++ " name="++ show name++" col="++show col++"\ncols="++show cols++"\n\n\n") $ case filter ((name ==) . cName) cols of + [] -> ([(name, Add' col)], cols) + 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") $ + [(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") $ + case find ((==tname) . entityDB) defs of + Just refdef -> [(tname, AddReference a [name] [entityID refdef])] + Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]" + modRef = tracex ("modType: sqltype[" ++ show sqltype ++ "] sqltype'[" ++ show sqltype' ++ "] name=" ++ show name) $ + if fmap snd ref == fmap snd ref' + 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") $ + refDrop ref' ++ refAdd ref + modNull = case (isNull, isNull') of + (True, False) -> [(name, IsNull)] + (False, True) -> + let up = case def of + Nothing -> id + Just s -> (:) (name, Update' $ T.unpack s) + in up [(name, NotNull)] + _ -> [] + 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' + then [] + else case def of + Nothing -> [(name, NoDefault)] + Just s -> [(name, Default $ T.unpack s)] + in (modRef ++ modDef ++ modNull ++ modType, + filter (\c -> cName c /= name) cols) + +cmpdef::Maybe Text -> Maybe Text -> Bool +cmpdef Nothing Nothing = True +cmpdef (Just def) (Just def') | def==def' = True + | otherwise = + let (a,_)=T.breakOnEnd ":" def' + in -- tracex ("cmpdef def[" ++ show def ++ "] def'[" ++ show def' ++ "] a["++show a++"]") $ + case T.stripSuffix "::" a of + Just xs -> def==xs + Nothing -> False +cmpdef _ _ = False + +-- | Get the references to be added to a table for the given column. +getAddReference :: [EntityDef a] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB +getAddReference 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 $ 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 (entityID entDef) + + +showColumn :: Column -> String +showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = concat + [ T.unpack $ escape n + , " " + , showSqlType sqlType' _maxLen + , " " + , if nu then "NULL" else "NOT NULL" + , case def of + Nothing -> "" + Just s -> " DEFAULT " ++ T.unpack s + ] + +showSqlType :: SqlType -> Maybe Integer -> String +showSqlType SqlString Nothing = "VARCHAR" +showSqlType SqlString (Just len) = "VARCHAR(" ++ show len ++ ")" +showSqlType SqlInt32 _ = "INT4" +showSqlType SqlInt64 _ = "INT8" +showSqlType SqlReal _ = "DOUBLE PRECISION" +showSqlType (SqlNumeric s prec) _ = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")" +showSqlType SqlDay _ = "DATE" +showSqlType SqlTime _ = "TIME" +showSqlType SqlDayTime _ = "TIMESTAMP" +showSqlType SqlDayTimeZoned _ = "TIMESTAMP WITH TIME ZONE" +showSqlType SqlBlob _ = "BYTEA" +showSqlType SqlBool _ = "BOOLEAN" +showSqlType (SqlOther t) _ = T.unpack t + +showAlterDb :: AlterDB -> (Bool, Text) +showAlterDb (AddTable s) = (False, pack s) +showAlterDb (AlterColumn t (c, ac)) = + (isUnsafe ac, pack $ showAlter t (c, ac)) + where + isUnsafe (Drop safeToRemove) = not safeToRemove + isUnsafe _ = False +showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) + +showAlterTable :: DBName -> AlterTable -> String +showAlterTable table (AddUniqueConstraint cname cols) = concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " ADD CONSTRAINT " + , T.unpack $ escape cname + , " UNIQUE(" + , intercalate "," $ map (T.unpack . escape) cols + , ")" + ] +showAlterTable table (DropConstraint cname) = concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " DROP CONSTRAINT " + , T.unpack $ escape cname + ] + +showAlter :: DBName -> AlterColumn' -> String +showAlter table (n, Type t) = + concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " ALTER COLUMN " + , T.unpack $ escape n + , " TYPE " + , showSqlType t Nothing + ] +showAlter table (n, IsNull) = + concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " ALTER COLUMN " + , T.unpack $ escape n + , " DROP NOT NULL" + ] +showAlter table (n, NotNull) = + concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " ALTER COLUMN " + , T.unpack $ escape n + , " SET NOT NULL" + ] +showAlter table (_, Add' col) = + concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " ADD COLUMN " + , showColumn col + ] +showAlter table (n, Drop _) = + concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " DROP COLUMN " + , T.unpack $ escape n + ] +showAlter table (n, Default s) = + concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " ALTER COLUMN " + , T.unpack $ escape n + , " SET DEFAULT " + , s + ] +showAlter table (n, NoDefault) = concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " ALTER COLUMN " + , T.unpack $ escape n + , " DROP DEFAULT" + ] +showAlter table (n, Update' s) = concat + [ "UPDATE " + , T.unpack $ escape table + , " SET " + , T.unpack $ escape n + , "=" + , s + , " WHERE " + , T.unpack $ escape n + , " IS NULL" + ] +showAlter table (reftable, AddReference fkeyname t2 id2) = concat + [ "ALTER TABLE " + , T.unpack $ escape table + , " ADD CONSTRAINT " + , T.unpack $ escape fkeyname + , " FOREIGN KEY(" + , T.unpack $ T.intercalate "," $ map escape t2 + , ") REFERENCES " + , T.unpack $ escape reftable + , "(" + , T.unpack $ T.intercalate "," $ map escape id2 + , ")" + ] +showAlter table (_, DropReference cname) = concat + [ "ALTER TABLE " + , T.unpack (escape table) + , " DROP CONSTRAINT " + , T.unpack $ escape cname + ] + +escape :: DBName -> Text +escape (DBName s) = + T.pack $ '"' : go (T.unpack s) ++ "\"" + where + go "" = "" + go ('"':xs) = "\"\"" ++ go xs + go (x:xs) = x : go xs + + +refName :: DBName -> DBName -> DBName +refName (DBName table) (DBName column) = + DBName $ T.concat [table, "_", column, "_fkey"] + +udToPair :: UniqueDef -> (DBName, [DBName]) +udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) + +insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' ent vals = tracex ("\n\n\nGBTEST " ++ show (entityFields ent) ++ "\n\n\n") $ + case entityPrimary ent of + Just _pdef -> + ISRManyKeys sql vals + where sql = pack $ concat + [ "INSERT INTO " + , T.unpack $ escape $ entityDB ent + , "(" + , intercalate "," $ map (T.unpack . escape . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + Nothing -> + ISRSingle $ pack $ concat + [ "INSERT INTO " + , T.unpack $ escape $ entityDB ent + , "(" + , intercalate "," $ map (T.unpack . escape . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ") RETURNING " + , T.unpack $ escape $ entityID ent + ]
+ src/Database/Persist/MigrateSqlite.hs view
@@ -0,0 +1,234 @@+-- add foreign key support?? +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +-- | A Sqlite backend for @persistent@. +module Database.Persist.MigrateSqlite + ( getMigrationStrategy + ) where + +import Data.List (intercalate) +import Data.Text (Text, pack) + +import Data.Conduit +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Database.Persist.Sql +import Database.Persist.ODBCTypes + +getMigrationStrategy :: DBType -> MigrationStrategy +getMigrationStrategy dbtype@Sqlite { sqlite3619 = _fksupport } = + MigrationStrategy + { dbmsLimitOffset=decorateSQLWithLimitOffset "LIMIT -1" + ,dbmsMigrate=migrate' + ,dbmsInsertSql=insertSql' + ,dbmsEscape=escape + ,dbmsType=dbtype + } +getMigrationStrategy dbtype = error $ "Sqlite: calling with invalid dbtype " ++ show dbtype + +insertSql' :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult +insertSql' ent vals = + case entityPrimary ent of + Just _ -> + ISRManyKeys sql vals + where sql = pack $ concat + [ "INSERT INTO " + , escape' $ entityDB ent + , "(" + , intercalate "," $ map (escape' . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + Nothing -> ISRInsertGet (pack ins) sel + where + sel = "SELECT last_insert_rowid()" + ins = concat + [ "INSERT INTO " + , escape' $ entityDB ent + , "(" + , intercalate "," $ map (escape' . fieldDB) $ entityFields ent + , ") VALUES(" + , intercalate "," (map (const "?") $ entityFields ent) + , ")" + ] + +showSqlType :: SqlType -> Text +showSqlType SqlString = "VARCHAR" +showSqlType SqlInt32 = "INTEGER" +showSqlType SqlInt64 = "INTEGER" +showSqlType SqlReal = "REAL" +showSqlType (SqlNumeric precision scale) = pack $ "NUMERIC(" ++ show precision ++ "," ++ show scale ++ ")" +showSqlType SqlDay = "DATE" +showSqlType SqlTime = "TIME" +showSqlType SqlDayTimeZoned = "TIMESTAMP" +showSqlType SqlDayTime = "TIMESTAMP" +showSqlType SqlBlob = "BLOB" +showSqlType SqlBool = "BOOLEAN" +showSqlType (SqlOther t) = t + +migrate' :: [EntityDef a] + -> (Text -> IO Statement) + -> EntityDef SqlType + -> IO (Either [Text] [(Bool, Text)]) +migrate' allDefs getter val = do + let (cols, uniqs, _fdefs) = mkColumns allDefs val + let newSql = mkCreateTable False def (filter (not . safeToRemove val . cName) cols, uniqs) + stmt <- getter "SELECT sql FROM sqlite_master WHERE type='table' AND name=?" + oldSql' <- runResourceT + $ stmtQuery stmt [PersistText $ unDBName table] $$ go + case oldSql' of + Nothing -> return $ Right [(False, newSql)] + Just oldSql -> do + if oldSql == newSql + then return $ Right [] + else do + sql <- getCopyTable allDefs getter val + return $ Right sql + where + def = val + table = entityDB def + go = do + x <- CL.head + case x of + Nothing -> return Nothing + Just [PersistText y] -> return $ Just y + Just [PersistByteString y] -> return $ Just $ T.decodeUtf8 y + Just y -> error $ "Unexpected result from sqlite_master: " ++ show y + +-- | Check if a column name is listed as the "safe to remove" in the entity +-- list. +safeToRemove :: EntityDef a -> DBName -> Bool +safeToRemove def (DBName colName) + = any (elem "SafeToRemove" . fieldAttrs) + $ filter ((== (DBName colName)) . fieldDB) + $ entityFields def + +getCopyTable :: [EntityDef a] + -> (Text -> IO Statement) + -> EntityDef SqlType + -> IO [(Bool, Text)] +getCopyTable allDefs getter val = do + stmt <- getter $ pack $ "PRAGMA table_info(" ++ escape' table ++ ")" + oldCols' <- runResourceT $ stmtQuery stmt [] $$ getCols + let oldCols = map DBName $ filter (/= "id") oldCols' -- need to update for table id attribute ? + let newCols = filter (not . safeToRemove def) $ map cName cols + let common = filter (`elem` oldCols) newCols + let id_ = entityID val + let ret = case entityPrimary val of + Just _ -> [ (False, tmpSql) + , (False, copyToTemp common) + , (common /= filter (not . safeToRemove def) oldCols, pack dropOld) + , (False, newSql) + , (False, copyToFinal newCols) + , (False, pack dropTmp) + ] + Nothing -> [ (False, tmpSql) + , (False, copyToTemp $ id_ : common) + , (common /= filter (not . safeToRemove def) oldCols, pack dropOld) + , (False, newSql) + , (False, copyToFinal $ id_ : newCols) + , (False, pack dropTmp) + ] + return ret + where + + def = val + getCols = do + x <- CL.head + case x of + Nothing -> return [] + Just (_:PersistText name:_) -> do + names <- getCols + return $ name : names + Just (_:PersistByteString name:_) -> do + names <- getCols + return $ T.decodeUtf8 name : names + Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y + table = entityDB def + tableTmp = DBName $ unDBName table `T.append` "_backup" + (cols, uniqs, _fdefs) = mkColumns allDefs val + cols' = filter (not . safeToRemove def . cName) cols + newSql = mkCreateTable False def (cols', uniqs) + tmpSql = mkCreateTable True def { entityDB = tableTmp } (cols', uniqs) + dropTmp = "DROP TABLE " ++ escape' tableTmp + dropOld = "DROP TABLE " ++ escape' table + copyToTemp common = pack $ concat + [ "INSERT INTO " + , escape' tableTmp + , "(" + , intercalate "," $ map escape' common + , ") SELECT " + , intercalate "," $ map escape' common + , " FROM " + , escape' table + ] + copyToFinal newCols = pack $ concat + [ "INSERT INTO " + , T.unpack $ escape table + , " SELECT " + , intercalate "," $ map escape' newCols + , " FROM " + , escape' tableTmp + ] + +escape' :: DBName -> String +escape' = T.unpack . escape + +mkCreateTable :: Bool -> EntityDef a -> ([Column], [UniqueDef]) -> Text +mkCreateTable isTemp entity (cols, uniqs) = T.concat + [ "CREATE" + , if isTemp then " TEMP" else "" + , " TABLE " + , escape $ entityDB entity + , "(" + , T.drop 1 $ T.concat $ map sqlColumn cols + , "," + , idx + , T.concat $ map sqlUnique uniqs + , ")" + ] + -- gb convert to use text directly + where idx=case entityPrimary entity of + Just pdef -> T.pack $ concat [" PRIMARY KEY (", intercalate "," $ map (T.unpack . escape . snd) $ primaryFields pdef, ")"] + Nothing -> T.pack $ concat [T.unpack $ escape $ entityID entity + ," INTEGER PRIMARY KEY "] + --cols' = case entityPrimary entity of + -- Just _ -> drop 1 cols + -- Nothing -> cols + +sqlColumn :: Column -> Text +sqlColumn (Column name isNull typ def _cn _maxLen ref) = T.concat + [ "," + , escape name + , " " + , showSqlType typ + , if isNull then " NULL" else " NOT NULL" + , case def of + Nothing -> "" + Just d -> " DEFAULT " `T.append` d + , case ref of + Nothing -> "" + Just (table, _) -> " REFERENCES " `T.append` escape table + ] + +sqlUnique :: UniqueDef -> Text +sqlUnique (UniqueDef _ cname cols _) = T.concat + [ ",CONSTRAINT " + , escape cname + , " UNIQUE (" + , T.intercalate "," $ map (escape . snd) cols + , ")" + ] + +escape :: DBName -> Text +escape (DBName s) = + T.concat [q, T.concatMap go s, q] + where + q = T.singleton '"' + go '"' = "\"\"" + go c = T.singleton c
+ src/Database/Persist/ODBC.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} +-- | An ODBC backend for persistent. +module Database.Persist.ODBC + ( withODBCPool + , withODBCConn + , createODBCPool + , module Database.Persist.Sql + , ConnectionString + , OdbcConf (..) + , openSimpleConn + , DBType (..) + , mysql,postgres,mssqlMin2012,mssql,oracleMin12c,oracle,db2,sqlite + ) where + +import qualified Control.Exception as E -- (catch, SomeException) +import Database.Persist.Sql +import qualified Database.Persist.MigratePostgres as PG +import qualified Database.Persist.MigrateMySQL as MYSQL +import qualified Database.Persist.MigrateMSSQL as MSSQL +import qualified Database.Persist.MigrateOracle as ORACLE +import qualified Database.Persist.MigrateDB2 as DB2 +import qualified Database.Persist.MigrateSqlite as SQLITE + +import Data.Time(ZonedTime(..), LocalTime(..), Day(..)) + +import qualified Database.HDBC.ODBC as O +import qualified Database.HDBC as O +import qualified Database.HDBC.SqlValue as HSV +import qualified Data.Convertible as DC + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.IORef(newIORef) +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Time.LocalTime (localTimeToUTC, utc) +import Data.Text (Text) +import Data.Aeson -- (Object(..), (.:)) +import Control.Monad (mzero) +import Data.Int (Int64) +import Data.Conduit +import Database.Persist.ODBCTypes +import qualified Data.List as L +-- | An @HDBC-odbc@ connection string. A simple example of connection +-- string would be @DSN=hdbctest1@. +type ConnectionString = String + +-- | Create an ODBC connection pool and run the given +-- action. The pool is properly released after the action +-- finishes using it. Note that you should not use the given +-- 'ConnectionPool' outside the action since it may be already +-- been released. +withODBCPool :: MonadIO m + => Maybe DBType + -> ConnectionString + -- ^ Connection string to the database. + -> Int + -- ^ Number of connections to be kept open in + -- the pool. + -> (ConnectionPool -> m a) + -- ^ Action to be executed that uses the + -- connection pool. + -> m a +withODBCPool dbt ci = withSqlPool $ open' dbt ci + + +-- | Create an ODBC connection pool. Note that it's your +-- responsibility to properly close the connection pool when +-- unneeded. Use 'withODBCPool' for an automatic resource +-- control. +createODBCPool :: MonadIO m + => Maybe DBType + -> ConnectionString + -- ^ Connection string to the database. + -> Int + -- ^ Number of connections to be kept open + -- in the pool. + -> m ConnectionPool +createODBCPool dbt ci = createSqlPool $ open' dbt ci + +-- | Same as 'withODBCPool', but instead of opening a pool +-- of connections, only one connection is opened. +withODBCConn :: (MonadIO m, MonadBaseControl IO m) + => Maybe DBType -> ConnectionString -> (Connection -> m a) -> m a +withODBCConn dbt cs = withSqlConn (open' dbt cs) + +-- | helper function that returns a connection based on the database type +open' :: Maybe DBType -> ConnectionString -> IO Connection +open' mdbtype cstr = + O.connectODBC cstr >>= openSimpleConn mdbtype + +-- | 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) + | driver=="Oracle" = Oracle $ getServerVersionNumber dvs>=12 + | "DB2" `L.isPrefixOf` driver = DB2 + | driver=="Microsoft SQL Server" = MSSQL $ getServerVersionNumber dvs>=11 + | 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 +getServerVersionNumber::(String, String, String) -> Integer +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 ++ "]" + + +-- | Generate a persistent 'Connection' from an odbc 'O.Connection' +openSimpleConn :: Maybe DBType -> O.Connection -> IO Connection +openSimpleConn mdbtype conn = do + let mig=case mdbtype of + Nothing -> getMigrationStrategy $ findDBMS (O.proxiedClientName conn, O.proxiedClientVer conn, O.dbServerVer conn) + Just dbtype -> getMigrationStrategy dbtype + + smap <- newIORef Map.empty + return Connection + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = dbmsInsertSql mig + , connClose = O.disconnect conn + , connMigrateSql = dbmsMigrate mig + , connBegin = 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 + , connRollback = const $ O.rollback conn + , connEscapeName = dbmsEscape mig + , connNoLimit = "" -- esqueleto uses this but needs to use connLimitOffset then we can dump this field + , connRDBMS = T.pack $ show (dbmsType mig) + , connLimitOffset = dbmsLimitOffset mig + } +-- | Choose the migration strategy based on the user provided database type +getMigrationStrategy::DBType -> MigrationStrategy +getMigrationStrategy dbtype = + case dbtype of + Postgres -> PG.getMigrationStrategy dbtype + MySQL -> MYSQL.getMigrationStrategy dbtype + MSSQL {} -> MSSQL.getMigrationStrategy dbtype + Oracle {} -> ORACLE.getMigrationStrategy dbtype + DB2 {} -> DB2.getMigrationStrategy dbtype + Sqlite {} -> SQLITE.getMigrationStrategy dbtype + +prepare' :: O.Connection -> Text -> IO Statement +prepare' conn sql = do +#if DEBUG + 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 ? + , stmtExecute = execute' stmt + , stmtQuery = withStmt' stmt + } + +execute' :: O.Statement -> [PersistValue] -> IO Int64 +execute' query vals = fmap fromInteger $ O.execute query $ map (HSV.toSql . P) vals + +withStmt' :: MonadResource m + => O.Statement + -> [PersistValue] + -> Source m [PersistValue] +withStmt' stmt vals = do +#if DEBUG + liftIO $ putStrLn $ "withStmt': vals: " ++ show vals +#endif + bracketP openS closeS pull + where + openS = execute' stmt vals >> return () + closeS _ = O.finish stmt + pull x = do + mr <- liftIO $ O.fetchRow stmt + maybe (return ()) + (\r -> do +#if DEBUG + liftIO $ putStrLn $ "withStmt': yield: " ++ show r + liftIO $ putStrLn $ "withStmt': yield2: " ++ show (map (unP . HSV.fromSql) r) +#endif + yield (map (unP . HSV.fromSql) r) + pull x + ) + mr + +-- | Information required to connect to a PostgreSQL database +-- using @persistent@'s generic facilities. These values are the +-- same that are given to 'withODBCPool'. +data OdbcConf = OdbcConf + { odbcConnStr :: ConnectionString + -- ^ The connection string. + , odbcPoolSize :: Int + -- ^ How many connections should be held on the connection pool. + , odbcDbtype :: String + } + +instance PersistConfig OdbcConf where + type PersistConfigBackend OdbcConf = SqlPersistT + type PersistConfigPool OdbcConf = ConnectionPool + createPoolConfig (OdbcConf cs size dbtype) = createODBCPool (read dbtype) cs size + runPool _ = runSqlPool + loadConfig (Object o) = do + cstr <- o .: "connStr" + pool <- o .: "poolsize" + dbtype <- o .: "dbtype" + return $ OdbcConf cstr pool dbtype + loadConfig _ = mzero + + applyEnv c0 = return c0 + + +-- | Avoid orphan instances. +newtype P = P { unP :: PersistValue } deriving Show + +instance DC.Convertible P HSV.SqlValue where + 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 (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 + safeConvert (P (PersistTimeOfDay t)) = Right $ HSV.toSql t + safeConvert (P (PersistUTCTime t)) = Right $ HSV.toSql t + safeConvert (P (PersistZonedTime (ZT t))) = Right $ HSV.toSql t + safeConvert (P 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 + { DC.convSourceValue = show p + , 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 + 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 + { DC.convSourceValue = show v + , DC.convSourceType = "SqlValue" + , DC.convDestType = "P (PersistValue)" + , DC.convErrorMessage = "There is no conversion from SqlWord32 to PersistValue" } + safeConvert v@(HSV.SqlWord64 _) = Left DC.ConvertError + { DC.convSourceValue = show v + , DC.convSourceType = "SqlValue" + , DC.convDestType = "P (PersistValue)" + , DC.convErrorMessage = "There is no conversion from SqlWord64 to PersistValue" } + safeConvert (HSV.SqlInt32 i) = Right $ P $ PersistInt64 $ fromIntegral i + safeConvert (HSV.SqlInt64 i) = Right $ P $ PersistInt64 i + safeConvert (HSV.SqlInteger i) = Right $ P $ PersistInt64 $ fromIntegral i + safeConvert (HSV.SqlChar c) = Right $ P $ charChk c + safeConvert (HSV.SqlBool b) = Right $ P $ PersistBool b + safeConvert (HSV.SqlDouble d) = Right $ P $ PersistDouble d + safeConvert (HSV.SqlRational r) = Right $ P $ PersistRational r + safeConvert (HSV.SqlLocalDate d) = Right $ P $ PersistDay d + safeConvert (HSV.SqlLocalTimeOfDay t)= Right $ P $ PersistTimeOfDay t + safeConvert (HSV.SqlZonedLocalTimeOfDay td tz) + = Right $ P $ PersistZonedTime $ ZT $ ZonedTime (LocalTime (ModifiedJulianDay 0) td) tz + safeConvert (HSV.SqlLocalTime t) = Right $ P $ PersistUTCTime $ localTimeToUTC utc t + safeConvert (HSV.SqlZonedTime zt) = Right $ P $ PersistZonedTime $ ZT zt + safeConvert (HSV.SqlUTCTime t) = Right $ P $ PersistUTCTime t + safeConvert (HSV.SqlDiffTime ndt) = Right $ P $ PersistDouble $ fromRational $ toRational ndt + safeConvert (HSV.SqlPOSIXTime pt) = Right $ P $ PersistDouble $ fromRational $ toRational pt + safeConvert (HSV.SqlEpochTime e) = Right $ P $ PersistInt64 $ fromIntegral e + safeConvert (HSV.SqlTimeDiff i) = Right $ P $ PersistInt64 $ fromIntegral i + safeConvert (HSV.SqlNull) = Right $ P PersistNull + +charChk :: Char -> PersistValue +charChk '\0' = PersistBool True +charChk '\1' = PersistBool False +charChk c = PersistText $ T.singleton c
+ src/Database/Persist/ODBCTypes.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +module Database.Persist.ODBCTypes where +import Data.Text (Text) +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) + +mysql,postgres,mssqlMin2012,mssql,oracleMin12c,oracle,db2,sqlite,sqliteMin3619::DBType +mysql = MySQL +postgres = Postgres +mssqlMin2012 = MSSQL True +mssql = MSSQL False +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 + ,dbmsMigrate :: Show a => [EntityDef a] -> (Text -> IO Statement) -> EntityDef SqlType -> IO (Either [Text] [(Bool, Text)]) + ,dbmsInsertSql :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult + ,dbmsEscape :: DBName -> Text + ,dbmsType :: DBType + }