dbm 0.1.0.0 → 0.1.0.1

raw patch · 4 files changed

+74/−12 lines, 4 filesdep ~optparse-applicative

Dependency ranges changed: optparse-applicative

Files

• dbm.cabal +3/−2
• src/Main.hs +9/−10
• src/SQLite.hs +48/−0
• src/Utility.hs +14/−0

@@ -1,5 +1,5 @@ name:                dbm-version:             0.1.0.0+version:             0.1.0.1 synopsis:            A *simple* database migration tool. homepage:            https://github.com/relrod/dbm license:             BSD3@@ -13,7 +13,8 @@  executable dbm   main-is:             Main.hs-  -- other-modules:+  other-modules:       Utility+                     , SQLite   -- other-extensions:   build-depends:       base >= 4 && < 5                      , directory

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import Control.Monad import Data.Ini import Data.List (elem, isSuffixOf) import Data.Maybe (fromMaybe)@@ -119,20 +120,18 @@     Just mid -> putStrLn $ "Last migration id: " ++ show mid     Nothing -> putStrLn "No migrations have been performed. :-(" -getNecessaryMigrations :: Config -> IO [(Maybe Integer, FilePath)]+getNecessaryMigrations :: Config -> IO [(Integer, FilePath)] getNecessaryMigrations cfg = do   mid <- fromMaybe 0 <$> getLastMigration cfg   migrations <- filter (\x -> ".sql" `isSuffixOf` x) <$> listDirectory "sql"   let migrationList = fmap (\x -> (parseMigrationId x, "sql/" ++ x)) migrations-      migrationFiltered = filter (getNecessaryMigrations mid) migrationList-  return migrationFiltered+  migrationFiltered <- filterM (getNecessaryMigrations' mid) migrationList+  return [(x, y) | (Just x, y) <- migrationFiltered]   where-    getNecessaryMigrations _ (Nothing, fn) =-      error $ "Invalid migration filename: " ++ fn-    getNecessaryMigrations current (Just mid, fn) =-      if mid > current-      then True-      else False+    getNecessaryMigrations' _ (Nothing, fn) = do+      putStrLn $ "Invalid migration filename: " ++ fn+      exitFailure >> return False+    getNecessaryMigrations' current (Just mid, fn) = return (mid > current)  showMigrationStatus :: Config -> IO () showMigrationStatus cfg = do@@ -149,7 +148,7 @@   migrations <- getNecessaryMigrations cfg   -- This pattern match is "safe" because we `error` in getNecessaryMigrations   -- if it were never a `Nothing`.-  mapM_ (\(Just mid, x) -> doMigration' x mid) migrations+  mapM_ (\(mid, x) -> doMigration' x mid) migrations   where     doMigration' sql mid = do       putStr $ "Migrating " ++ sql ++ "... "

@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+module SQLite where++import Data.Maybe (listToMaybe)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Database.SQLite.Simple++import Utility++instance FromRow Migration where+  fromRow = Migration <$> field <*> field <*> field++instance ToRow Migration where+  toRow (Migration id_ timestamp mid) = toRow (id_, timestamp, mid)++-- These are slightly inefficient right now in that they open and close a+-- connection each time. This is probably worth optimizing later, but especially+-- moreso for the other backends where network overhead is a legitimate concern.++initialize :: FilePath -> IO ()+initialize path = do+  conn <- open path+  execute_ conn $+    "create table if not exists dbm_migrations (\+    \  id integer primary key autoincrement\+    \, applied_at datetime not null default current_timestamp\+    \, migration_id integer not null\+    \);"+  close conn++logMigration :: Connection -> Integer -> IO ()+logMigration conn mid =+  execute conn "insert into dbm_migrations (migration_id) values (?);" (Only mid)++performMigration :: FilePath -> FilePath -> Integer -> IO ()+performMigration dbPath sql mid = do+  conn <- open dbPath+  withTransaction conn $ do+    migrationQuery <- T.readFile sql+    execute_ conn (Query migrationQuery)+    logMigration conn mid++getLastMigration :: FilePath -> IO (Maybe Integer)+getLastMigration dbPath = do+  conn <- open dbPath+  lastMigration <- query_ conn "select * from dbm_migrations order by id desc limit 1;" :: IO [Migration]+  return (listToMaybe (mid <$> lastMigration))

@@ -0,0 +1,14 @@+-- | Global types and functions.+module Utility where++import Data.Time.Clock (UTCTime)+import Text.Read++data Migration =+  Migration { id_ :: Integer+            , timestamp :: UTCTime+            , mid :: Integer+            } deriving (Show)++parseMigrationId :: String -> Maybe Integer+parseMigrationId = readMaybe . takeWhile (/= '-')