Feature/debugging logs

db-migration.cabal

@@ -70,6 +70,7 @@ library
     , postgresql-simple
     , scientific
     , text
+    , time
     , unliftio
     , unordered-containers
     , vector

package.yaml

@@ -53,6 +53,7 @@ library:
     - free
     - extra
     - unliftio
+    - time
 
 executables:
   generate-dll:

src/Database/Migration.hs

@@ -56,7 +56,7 @@ schemaDiffIteration conn options actualPredicates haskellConstraints = do
         DF.foldl'
           (\preds dP ->
              maybe preds (snoc preds)
-               $ lenientPredicateCheck options dP groupedDBChecks)
+               $ lenientlyCheckPredicate options dP groupedDBChecks)
           []
           dbPredicates
   if null lenientPredicates

src/Database/Migration/Backend/Postgres/Queries.hs

@@ -4,50 +4,52 @@ import Data.String (fromString)
 import qualified Data.Text as T
 import qualified Database.Beam.Postgres as BP
 import qualified Database.PostgreSQL.Simple as Pg
-
-import Control.Monad (void)
-import Data.Maybe (fromMaybe)
+import Data.Maybe(fromMaybe)
 import qualified Data.Vector as V
-import Database.Migration.Utils.Common
+import Control.Monad (void)
+import qualified Database.Beam.Postgres.Migrate as BPM
+import Database.Migration.Utils.Common(headMaybe)
 
 getSequencesFromPg ::
      BP.Connection
   -> T.Text
   -> IO [(String, String, String, String, String, String, String, String)]
 getSequencesFromPg conn mSchema =
-  Pg.query_ conn
-    $ fromString
-    $ unlines
-        [ "select sequence_schema, sequence_name, minimum_value,"
-        , "maximum_value, start_value, increment, cycle_option, data_type"
-        , "from information_schema.sequences"
-        , "where sequence_schema = '" ++ T.unpack mSchema ++ "';"
-        ]
+    BPM.executePgQueryAndWrap conn
+      (fromString
+        $ unlines
+            [ "select sequence_schema, sequence_name, minimum_value,"
+            , "maximum_value, start_value, increment, cycle_option, data_type"
+            , "from information_schema.sequences"
+            , "where sequence_schema = '" ++ T.unpack mSchema ++ "';"
+            ])
+      BPM.mkToRowInstanceMaybe
 
 getSchemasFromPg :: BP.Connection -> IO [T.Text]
 getSchemasFromPg conn =
-  fmap Pg.fromOnly
-    <$> Pg.query_
-          conn
-          (fromString
-             "select schema_name from information_schema.schemata where catalog_name = current_database();")
+  map Pg.fromOnly <$> BPM.executePgQueryAndWrap conn 
+    (fromString
+        "select schema_name from information_schema.schemata where catalog_name = current_database();")
+    BPM.mkToRowInstanceMaybe
 
 getColumnDefaultsFromPg ::
      BP.Connection -> T.Text -> IO [(T.Text, T.Text, T.Text, T.Text)]
 getColumnDefaultsFromPg conn mSchema =
-  Pg.query_ conn
-    $ fromString
-    $ unlines
-        [ "select table_schema, table_name, column_name, column_default"
-        , "from information_schema.columns where"
-        , "column_default is not null and"
-        , "table_schema = '" ++ T.unpack mSchema ++ "';"
-        ]
+    BPM.executePgQueryAndWrap 
+      conn
+      (fromString
+          $ unlines
+              [ "select table_schema, table_name, column_name, column_default"
+              , "from information_schema.columns where"
+              , "column_default is not null and"
+              , "table_schema = '" ++ T.unpack mSchema ++ "';"
+              ])
+      BPM.mkToRowInstanceMaybe
 
 getSearchPath :: BP.Connection -> IO [T.Text]
-getSearchPath conn =
+getSearchPath conn = 
   fromMaybe [] . headMaybe . fmap (V.toList . Pg.fromOnly)
-    <$> Pg.query_ conn (fromString "select current_schemas(false)")
+    <$> BPM.executePgQueryAndWrap conn (fromString "select current_schemas(false)") BPM.mkToRowInstanceMaybe
 
 setSearchPath :: BP.Connection -> [T.Text] -> IO ()
 setSearchPath conn schemas =

src/Database/Migration/Types.hs

@@ -28,9 +28,22 @@ class RenderPredicate be p where
 
 type ColumnTypeCheck = T.Text -> T.Text -> ColumnType -> ColumnType -> Bool
 
+data LoopbackLimitValue = NoLimit | Limit Int
+
+data LoopbackLimit = LoopbackLimit
+  {   defaultLimit :: LoopbackLimitValue
+    , partitionedTableMapLimit :: !(HM.HashMap T.Text LoopbackLimitValue)
+    , logPreloopbackPartionedErr :: Bool
+  }
+
+data PartitonFormat = YYYYMM | MMYYYY -- TODO add support weekly paritions or Daily Partitons
+
 data PartitionOption = PartitionOption
   { includeParentTable :: !Bool
   , partitionMap :: !(HM.HashMap T.Text [T.Text])
+  , loopBackLimit :: LoopbackLimit
+  , partitionDelimiter :: T.Text -- TODO make this Table Specific HashMap
+  , partitionFormat :: PartitonFormat
   }
 
 data Options = Options
@@ -42,8 +55,11 @@ data Options = Options
   , listDifference :: !Bool 
   }
 
+defaultLoopbackLimit :: LoopbackLimit
+defaultLoopbackLimit = LoopbackLimit NoLimit HM.empty False
+
 defaultPartitionOption :: PartitionOption
-defaultPartitionOption = PartitionOption True HM.empty
+defaultPartitionOption = PartitionOption True HM.empty defaultLoopbackLimit "_M_" YYYYMM
 
 defaultOptions :: Options
 defaultOptions = Options [] Nothing defaultPartitionOption False False True

src/Database/Migration/Utils/Beam.hs

@@ -670,4 +670,4 @@ findIndexInDBPredicates pd groupedDBPredicates =
           $ LHM.elems groupedDBPredicates
    in case mPred of
         Just (DBTableHasIndex p) -> Just p
-        _ignore -> Nothing
+        _ignore -> Nothing

src/Database/Migration/Utils/Check.hs

@@ -5,9 +5,109 @@ import qualified Data.List as DL
 import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import qualified Database.Beam.Migrate as BM
-import Database.Migration.Types
+import Database.Migration.Types hiding (mod)
 import qualified Database.Migration.Types.LinkedHashMap as LHM
 import Database.Migration.Utils.Beam
+import qualified Database.Migration.Types as DMT
+import qualified Data.HashMap.Strict as HM
+import Control.Monad (when,void)
+import qualified Debug.Trace as DT
+import qualified Database.Beam.Migrate.Types as BMT
+import qualified Data.Time as DT
+import qualified System.IO.Unsafe as SIU 
+import qualified Text.Read as TR
+
+-- type Year = Integer
+-- type Month = Int
+
+getCurrentMonthAndYear :: IO (Integer,Int)
+getCurrentMonthAndYear = do
+  (year,month,_) <- DT.getCurrentTime >>= return . DT.toGregorian . DT.utctDay
+  return (year,month)
+
+lenientlyCheckPredicate ::
+     Options
+  -> DBPredicate
+  -> LHM.LinkedHashMap T.Text DBPredicate
+  -> Maybe DBPredicate
+lenientlyCheckPredicate options@Options{partitionOptions} predicate groupedDBPredicates = do
+  case extractQualifiedTableNameFromPredicate predicate of
+    Nothing -> lenientPredicateCheck options predicate groupedDBPredicates
+    Just qualifiedTblName -> do
+      let (tblName,paritionParam) = extractOrigTblNameAndPartitionParam options qualifiedTblName
+      case HM.lookup tblName $ DMT.partitionMap partitionOptions of -- check parition options
+        Nothing -> lenientPredicateCheck options predicate groupedDBPredicates
+        Just _ -> do
+          let loopbackLimit = DMT.loopBackLimit partitionOptions
+          case HM.lookup tblName $ DMT.partitionedTableMapLimit loopbackLimit of
+            Nothing -> handleLoopbackLimit (DMT.defaultLimit loopbackLimit) (tblName,paritionParam) qualifiedTblName options predicate groupedDBPredicates
+            Just lbl -> handleLoopbackLimit lbl (tblName,paritionParam) qualifiedTblName options predicate groupedDBPredicates
+  where 
+    handleLoopbackLimit :: LoopbackLimitValue -> (T.Text,T.Text) -> BMT.QualifiedName -> Options -> DBPredicate -> LHM.LinkedHashMap T.Text DBPredicate -> Maybe DBPredicate
+    handleLoopbackLimit NoLimit _  _ opt preds gdb = lenientPredicateCheck opt preds gdb
+    handleLoopbackLimit (Limit lmt) (tblName,paritionParam) qualifiedTblName opt preds gdb = do
+      let isPartitionedTableBeyondLimit = checkParitionedTableLimit options paritionParam lmt
+      if isPartitionedTableBeyondLimit
+        then do
+          let maybeLenientCheckResp = lenientPredicateCheck opt preds gdb
+          case maybeLenientCheckResp of
+            Nothing -> Nothing
+            Just dbPredicate -> do
+              when (DMT.logPreloopbackPartionedErr $ DMT.loopBackLimit $ DMT.partitionOptions opt) $ 
+                (return $ DT.traceShow "DB NOT_IN_SYNC " (show (preds,qualifiedTblName))) *> return ()
+              Nothing
+        else lenientlyCheckPredicate opt preds gdb
+
+    checkParitionedTableLimit :: Options -> T.Text -> Int -> Bool 
+    checkParitionedTableLimit opts@Options{partitionOptions} paritionParam lmt = do
+      case DMT.partitionFormat partitionOptions  of
+        YYYYMM -> do
+          let (currYear,currMonth) = SIU.unsafePerformIO getCurrentMonthAndYear
+              maybeYear  = TR.readMaybe (T.unpack (T.take 4 paritionParam)) :: Maybe Integer
+              maybeMonth = TR.readMaybe (T.unpack (T.drop 4 paritionParam)) :: Maybe Int
+              year       = case maybeYear of
+                              Just val -> val
+                              Nothing -> error "Invalid year"
+              month      = case maybeMonth of
+                            Just val -> val
+                            Nothing -> error "Invalid month"
+          checkIfTableIsInRange currYear currMonth year month lmt
+        MMYYYY -> do
+          let (currYear,currMonth) = SIU.unsafePerformIO getCurrentMonthAndYear
+              maybeYear  = TR.readMaybe (T.unpack (T.drop 4 paritionParam)) :: Maybe Integer
+              maybeMonth = TR.readMaybe (T.unpack (T.take 2 paritionParam)) :: Maybe Int
+              year       = case maybeYear of
+                              Just val -> val
+                              Nothing -> error "Invalid year"
+              month      = case maybeMonth of
+                            Just val -> val
+                            Nothing -> error "Invalid month"
+          checkIfTableIsInRange currYear currMonth year month lmt
+
+    checkIfTableIsInRange  :: Integer -> Int -> Integer -> Int -> Int -> Bool
+    checkIfTableIsInRange currYear currMonth year month lmt = do
+        let prevYear   = currYear - toInteger (lmt `div` 12) - (if (lmt `mod` 12 >= currMonth) then 1 else 0)
+        let  prevMonth 
+                | lmt `mod` 12 < currMonth = currMonth - (lmt `mod` 12) :: Int
+                | otherwise = 12 - (lmt `mod` 12 - currMonth)
+        prevYear > year || (prevYear == year && prevMonth >= month)
+
+    extractOrigTblNameAndPartitionParam :: Options -> BMT.QualifiedName -> (T.Text,T.Text)
+    extractOrigTblNameAndPartitionParam options@Options{partitionOptions} qualifiedTableName = do
+      let tblName = BMT.qnameAsText qualifiedTableName
+      let partitonTblList = T.splitOn (DMT.partitionDelimiter partitionOptions) tblName
+      let tableName = partitonTblList DL.!! 0
+      let partition = partitonTblList DL.!! 1
+      (tableName, partition)
+
+
+extractQualifiedTableNameFromPredicate :: DBPredicate -> Maybe BMT.QualifiedName
+extractQualifiedTableNameFromPredicate (DBHasEnum _) = Nothing
+extractQualifiedTableNameFromPredicate (DBHasSequence _) = Nothing
+extractQualifiedTableNameFromPredicate (DBHasTable (TablePredicate (TableInfo tblName) _ _)) = Just tblName
+extractQualifiedTableNameFromPredicate (DBTableHasColumns _) = Nothing
+extractQualifiedTableNameFromPredicate (DBHasSchema _) = Nothing
+extractQualifiedTableNameFromPredicate (DBTableHasIndex tblIndexPredicate@TableHasIndexPredicate{tableName}) = Just tableName
 
 lenientPredicateCheck ::
      Options

stack.yaml

@@ -6,7 +6,7 @@ packages:
 
 extra-deps:
   - github: adiR28/beam
-    commit: 0791544548652731bd70c788b0b22c45b396999d
+    commit: 2f9a4b45bc43caab717eff94c0974ca4fd71445e
     subdirs:
       - beam-core
       - beam-migrate

stack.yaml.lock

@@ -1,61 +1,61 @@
 # This file was autogenerated by Stack.
 # You should not edit this file by hand.
 # For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
+#   https://docs.haskellstack.org/en/stable/topics/lock_files
 
 packages:
 - completed:
     name: beam-core
     pantry-tree:
       sha256: f2f156de6ab2c8e2dfe9df2333ceb570ee168dae709ef7139002fee5f1a1ab7f
       size: 2623
-    sha256: 0fac30be8f83d35c4c06840591130df7a0d917437d46e97ec94f77be46d18056
-    size: 1205592
+    sha256: 7c5e75657eb1df87b66de701ce4050f9fbc1ebe9c2b80c574f18f29ed7cd2985
+    size: 1206197
     subdir: beam-core
-    url: https://github.com/adiR28/beam/archive/0791544548652731bd70c788b0b22c45b396999d.tar.gz
+    url: https://github.com/adiR28/beam/archive/2f9a4b45bc43caab717eff94c0974ca4fd71445e.tar.gz
     version: 0.9.0.0
   original:
     subdir: beam-core
-    url: https://github.com/adiR28/beam/archive/0791544548652731bd70c788b0b22c45b396999d.tar.gz
+    url: https://github.com/adiR28/beam/archive/2f9a4b45bc43caab717eff94c0974ca4fd71445e.tar.gz
 - completed:
     name: beam-migrate
     pantry-tree:
-      sha256: e8a6c428770a1b9db684f7433169c2b36c92c96c990ee362236f59b8718c417c
+      sha256: ff540837092a94be6c9573133be0fd0c1bbfc25117ba1f6894e5c79c957986ec
       size: 1826
-    sha256: 0fac30be8f83d35c4c06840591130df7a0d917437d46e97ec94f77be46d18056
-    size: 1205592
+    sha256: 7c5e75657eb1df87b66de701ce4050f9fbc1ebe9c2b80c574f18f29ed7cd2985
+    size: 1206197
     subdir: beam-migrate
-    url: https://github.com/adiR28/beam/archive/0791544548652731bd70c788b0b22c45b396999d.tar.gz
+    url: https://github.com/adiR28/beam/archive/2f9a4b45bc43caab717eff94c0974ca4fd71445e.tar.gz
     version: 0.5.0.0
   original:
     subdir: beam-migrate
-    url: https://github.com/adiR28/beam/archive/0791544548652731bd70c788b0b22c45b396999d.tar.gz
+    url: https://github.com/adiR28/beam/archive/2f9a4b45bc43caab717eff94c0974ca4fd71445e.tar.gz
 - completed:
     name: beam-postgres
     pantry-tree:
-      sha256: f8768b46136bc5500c5ee88700ece0f16780bdec1c683f0be338d74d5ab2ea63
+      sha256: 03e7be3f8099015d43cc8f4f1d126b7d27bb3c8e426d05d253fe208c8a2390f1
       size: 2594
-    sha256: 0fac30be8f83d35c4c06840591130df7a0d917437d46e97ec94f77be46d18056
-    size: 1205592
+    sha256: 7c5e75657eb1df87b66de701ce4050f9fbc1ebe9c2b80c574f18f29ed7cd2985
+    size: 1206197
     subdir: beam-postgres
-    url: https://github.com/adiR28/beam/archive/0791544548652731bd70c788b0b22c45b396999d.tar.gz
+    url: https://github.com/adiR28/beam/archive/2f9a4b45bc43caab717eff94c0974ca4fd71445e.tar.gz
     version: 0.5.0.0
   original:
     subdir: beam-postgres
-    url: https://github.com/adiR28/beam/archive/0791544548652731bd70c788b0b22c45b396999d.tar.gz
+    url: https://github.com/adiR28/beam/archive/2f9a4b45bc43caab717eff94c0974ca4fd71445e.tar.gz
 - completed:
     name: beam-sqlite
     pantry-tree:
       sha256: 3de1879fca8bcacf4a55f97b27d6525946820cbadd3f2d2f5c83e083a562a319
       size: 859
-    sha256: 0fac30be8f83d35c4c06840591130df7a0d917437d46e97ec94f77be46d18056
-    size: 1205592
+    sha256: 7c5e75657eb1df87b66de701ce4050f9fbc1ebe9c2b80c574f18f29ed7cd2985
+    size: 1206197
     subdir: beam-sqlite
-    url: https://github.com/adiR28/beam/archive/0791544548652731bd70c788b0b22c45b396999d.tar.gz
+    url: https://github.com/adiR28/beam/archive/2f9a4b45bc43caab717eff94c0974ca4fd71445e.tar.gz
     version: 0.5.0.0
   original:
     subdir: beam-sqlite
-    url: https://github.com/adiR28/beam/archive/0791544548652731bd70c788b0b22c45b396999d.tar.gz
+    url: https://github.com/adiR28/beam/archive/2f9a4b45bc43caab717eff94c0974ca4fd71445e.tar.gz
 - completed:
     hackage: flatparse-0.5.1.0@sha256:6f5bc2d750061eac198dae1ca700d8c5c9d69dc8a536d53fdccd21a115ccb9aa,4537
     pantry-tree: