drifter-sqlite (empty) → 0.1.0.0

raw patch · 7 files changed

+397/−0 lines, 7 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, drifter, drifter-sqlite, mtl, sqlite-simple, tasty, tasty-hunit, text, time, transformers

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +3/−0
Setup.hs +2/−0
drifter-sqlite.cabal +82/−0
src/Drifter/SQLite.hs +192/−0
test/Main.hs +85/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for drifter-sqlite++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Michael Xavier (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,3 @@+# drifter-sqlite++SQLite bindings to the drifter migration tool.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ drifter-sqlite.cabal view

@@ -0,0 +1,82 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1c812093b91becb632c3972bb1823dedd068a8d7435c734b27fb9aaf1095e484++name:           drifter-sqlite+version:        0.1.0.0+synopsis:       SQLite support for the drifter schema migraiton tool+description:    Please see the README on GitHub at <https://github.com/MichaelXavier/drifter-sqlite#readme>+category:       Database+homepage:       https://github.com/MichaelXavier/drifter-sqlite#readme+bug-reports:    https://github.com/MichaelXavier/drifter-sqlite/issues+author:         Michael Xavier+maintainer:     michael@michaelxavier.net+copyright:      2018 Michael Xavier+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/MichaelXavier/drifter-sqlite++flag lib-Werror+  description: Treat warnings as errors+  manual: True+  default: False++library+  exposed-modules:+      Drifter.SQLite+  other-modules:+      Paths_drifter_sqlite+  hs-source-dirs:+      src+  default-extensions: ScopedTypeVariables TypeFamilies GeneralizedNewtypeDeriving OverloadedStrings+  build-depends:+      base >=4.7 && <5+    , containers+    , drifter >=0.2.1+    , mtl+    , sqlite-simple+    , time+    , transformers+  if flag(lib-Werror)+    ghc-options: -Werror -Wall+  else+    ghc-options: -Wall+  default-language: Haskell2010++test-suite drifter-sqlite-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_drifter_sqlite+  hs-source-dirs:+      test+  default-extensions: ScopedTypeVariables TypeFamilies GeneralizedNewtypeDeriving OverloadedStrings+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers+    , directory+    , drifter >=0.2.1+    , drifter-sqlite+    , mtl+    , sqlite-simple+    , tasty+    , tasty-hunit+    , text+    , time+    , transformers+  if flag(lib-Werror)+    ghc-options: -Werror -Wall+  else+    ghc-options: -Wall+  default-language: Haskell2010

+ src/Drifter/SQLite.hs view

@@ -0,0 +1,192 @@+module Drifter.SQLite+    ( SQLiteMigration+    , Method(..)+    , DBConnection(..)+    , ChangeHistory(..)+    , runMigrations+    , getChangeHistory+    , getChangeNameHistory+    ) where+++-------------------------------------------------------------------------------+import           Control.Applicative              as A+import           Control.Exception+import           Control.Monad+import           Control.Monad.Trans+import           Control.Monad.Trans.Except+import           Data.Set                         (Set)+import qualified Data.Set                         as Set+import           Data.Time+import           Database.SQLite.Simple+import           Database.SQLite.Simple.FromField+import           Drifter+-------------------------------------------------------------------------------++++data SQLiteMigration+++data instance Method SQLiteMigration =+    MigrationQuery Query+    -- ^ Run a query against the database+  | MigrationCode (Connection -> IO (Either String ()))+                                  -- ^ Run any arbitrary IO code+++data instance DBConnection SQLiteMigration = DBConnection SQLiteMigrationConnection+++data SQLiteMigrationConnection = SQLiteMigrationConnection (Set ChangeName) Connection+++instance Drifter SQLiteMigration where+  migrateSingle (DBConnection migrationConn) change = do+    runExceptT (migrateChange migrationConn change)+++-------------------------------------------------------------------------------+-- Change History Tracking+-------------------------------------------------------------------------------+newtype ChangeId = ChangeId Int deriving (Eq, Ord, Show, FromField)+++data ChangeHistory = ChangeHistory {+      histId          :: ChangeId+    , histName        :: ChangeName+    , histDescription :: Maybe Description+    , histTime        :: UTCTime+    } deriving (Show)+++instance Eq ChangeHistory where+    a == b = (histName a) == (histName b)+++instance Ord ChangeHistory where+    compare a b = compare (histId a) (histId b)+++instance FromRow ChangeHistory where+    fromRow = ChangeHistory+      <$> field+      <*> (ChangeName <$> field)+      <*> field+      <*> field+++-------------------------------------------------------------------------------+-- Queries+-------------------------------------------------------------------------------+bootstrapQ :: Query+bootstrapQ = "\+\  CREATE TABLE IF NOT EXISTS schema_migrations ( \+\    id              INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,\+\    name            TEXT        NOT NULL UNIQUE ON CONFLICT ROLLBACK,\+\    description     TEXT,\+\    time            DATETIME NOT NULL DEFAULT CURRENT_TIMESTAMP\+\  );"+++-------------------------------------------------------------------------------+changeHistoryQ :: Query+changeHistoryQ =+  "SELECT id, name, description, time FROM schema_migrations ORDER BY id;"+++-------------------------------------------------------------------------------+changeNameHistoryQ :: Query+changeNameHistoryQ =+  "SELECT name FROM schema_migrations ORDER BY id;"+++-------------------------------------------------------------------------------+insertLogQ :: Query+insertLogQ =+  "INSERT INTO schema_migrations (name, description, time) VALUES (?, ?, ?);"+++-------------------------------------------------------------------------------+migrateChange :: SQLiteMigrationConnection -> Change SQLiteMigration -> ExceptT String IO ()+migrateChange (SQLiteMigrationConnection hist c) change = do+  if Set.member cn hist+    then lift (putStrLn ("Skipping: " ++ show (changeNameText cn)))+    else do+      runMethod c (changeMethod change)+      logChange c change+      lift (putStrLn ("Committed: " ++ show cn))+  where+    cn = changeName change+++-------------------------------------------------------------------------------+runMethod :: Connection -> Method SQLiteMigration -> ExceptT String IO ()+runMethod c (MigrationQuery q) =+  void (ExceptT ((Right <$> execute_ c q) `catches` errorHandlers))+runMethod c (MigrationCode f) =+  ExceptT (f c `catches` errorHandlers)+++  -------------------------------------------------------------------------------+logChange :: Connection -> Change SQLiteMigration -> ExceptT String IO ()+logChange c change = do+    now <- lift getCurrentTime+    void (ExceptT ((Right <$> go now) `catches` errorHandlers))+  where+    go now = execute c insertLogQ (changeNameText (changeName change), changeDescription change, now)+++-------------------------------------------------------------------------------+errorHandlers :: [Handler (Either String b)]+errorHandlers =+  [ Handler (\(ex::SQLError) -> return (Left (show ex)))+  , Handler (\(ex::FormatError) -> return (Left (show ex)))+  , Handler (\(ex::ResultError) -> return (Left (show ex)))+  ]+++-------------------------------------------------------------------------------+-- | Takes a connection and builds the state to thread throughout the migration.+-- This includes bootstrapping the migration tables and collecting all the+-- migrations that have already been committed.+makePGMigrationConnection :: Connection -> IO SQLiteMigrationConnection+makePGMigrationConnection conn = do+  void (execute_ conn bootstrapQ)+  hist <- getChangeNameHistory conn+  return (SQLiteMigrationConnection (Set.fromList hist) conn)+++-------------------------------------------------------------------------------+-- | Takes the list of all migrations, removes the ones that have+-- already run and runs them. Use this instead of 'migrate'.+runMigrations :: Connection -> [Change SQLiteMigration] -> IO (Either String ())+runMigrations conn changesList = handle (\(RolledBack e) -> pure (Left e)) $ fmap Right $ do+  withTransaction conn $ do+    migrationConn <- makePGMigrationConnection conn+    res <- migrate (DBConnection migrationConn) changesList+    case res of+      Right _ -> pure ()+      Left e -> throw (RolledBack e)+++-------------------------------------------------------------------------------+data RolledBack = RolledBack String+  deriving (Show)++instance Exception RolledBack+++-------------------------------------------------------------------------------+-- | Get all changes from schema_migrations table for all the migrations that+-- have previously run.+getChangeHistory :: Connection -> IO [ChangeHistory]+getChangeHistory conn = query_ conn changeHistoryQ+++-------------------------------------------------------------------------------+-- | Get just the names of all changes from schema_migrations for migrations+-- that have previously run.+getChangeNameHistory :: Connection -> IO [ChangeName]+getChangeNameHistory conn = fmap (\(Only nm) -> ChangeName nm)+  A.<$> query_ conn changeNameHistoryQ

+ test/Main.hs view

@@ -0,0 +1,85 @@+module Main+    ( main+    ) where+++-------------------------------------------------------------------------------+import           Control.Applicative       as A+import           Control.Exception+import           Data.IORef+import           Data.Text                 (Text)+import           Database.SQLite.Simple+import           Drifter+import           System.Directory+import           System.IO.Error+import           Test.Tasty+import           Test.Tasty.HUnit+-------------------------------------------------------------------------------+import           Drifter.SQLite+-------------------------------------------------------------------------------++main :: IO ()+main = defaultMain $ testGroup "drifter-postgresql"+  [+    withResource setup teardown $ \getConn -> testCase "migrations" $ do+       c <- getConn+       c3Calls <- newIORef 0+       let migrate' = runMigrations c . changeSequence+       res <- migrate' [c1, c2]+       res @?= Right ()++       rows <- query_ c "SELECT x FROM c1;"+       rows @?= ([Only "val"] :: [Only Text])++       res' <- migrate' [c1, c2, c3 c3Calls]+       res' @?= Right ()+       calls <- readIORef c3Calls+       calls @?= 1++       res'' <- migrate' [c1, c2, c3 c3Calls]+       res'' @?= Right ()++       calls' <- readIORef c3Calls+       calls' @?= 1+  ]+++-------------------------------------------------------------------------------+c1 :: Change SQLiteMigration+c1 = Change (ChangeName "c1") (Just "create table") [] meth+  where+    meth = MigrationQuery q+    q = "CREATE TABLE c1 (id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, x text NOT NULL);"+++c2 :: Change SQLiteMigration+c2 = Change (ChangeName "c2") (Just "insert value") [] meth+  where+    meth = MigrationQuery q+    q = "INSERT INTO c1 (x) VALUES ('val');"++-------------------------------------------------------------------------------+c3 :: IORef Int -> Change SQLiteMigration+c3 ref = Change (ChangeName "c3") (Just "bump an IORef") [changeName c1] meth+  where+    meth = MigrationCode (\_ -> Right A.<$> modifyIORef' ref succ)+++-------------------------------------------------------------------------------+setup :: IO Connection+setup = open testFile+++-------------------------------------------------------------------------------+teardown :: Connection -> IO ()+teardown conn = close conn `finally` dropFile+  where+    dropFile = catchJust+      (\e -> if isDoesNotExistError e then Just () else Nothing)+      (removeFile testFile)+      pure+++-------------------------------------------------------------------------------+testFile :: FilePath+testFile = "test.db"