trek-app (empty) → 0.1.0.0

raw patch · 12 files changed

+451/−0 lines, 12 filesdep +aesondep +aeson-prettydep +async

Dependencies added: aeson, aeson-pretty, async, base, base64-bytestring, bytestring, cryptohash-sha256, directory, filepath, hspec, hspec-discover, optparse-applicative, optparse-generic, pg-transact, postgres-options, postgresql-simple, postgresql-simple-opts, process, resource-pool, semigroups, split, temporary, time, time-qq, tmp-postgres, trek-app, trek-db

Files

LICENSE +30/−0
app/Main.hs +5/−0
data/2020-07-12T06-21-21_foo.sql +1/−0
data/2020-07-12T06-21-27_bar.sql +1/−0
data/2020-07-12T06-21-32_quux.sql +1/−0
data/dummy.txt +0/−0
src/Database/Trek/Parser.hs +24/−0
src/Database/Trek/Run.hs +130/−0
test/Spec.hs +1/−0
test/Tests/Database/Trek/ParserSpec.hs +19/−0
test/Tests/Database/Trek/RunSpec.hs +122/−0
trek-app.cabal +117/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Jonathan Fischoff (c) 2019, 2020++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.

+ app/Main.hs view

@@ -0,0 +1,5 @@+import Database.Trek.Run+import Options.Generic++main :: IO ()+main = getRecord "trek" >>= eval

+ data/2020-07-12T06-21-21_foo.sql view

@@ -0,0 +1,1 @@+CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.foo (id SERIAL PRIMARY KEY)

+ data/2020-07-12T06-21-27_bar.sql view

@@ -0,0 +1,1 @@+CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.bar (id SERIAL PRIMARY KEY)

+ data/2020-07-12T06-21-32_quux.sql view

@@ -0,0 +1,1 @@+CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.quux (id SERIAL PRIMARY KEY)

+ data/dummy.txt view

+ src/Database/Trek/Parser.hs view

@@ -0,0 +1,24 @@+module Database.Trek.Parser where+import Options.Generic+import Database.PostgreSQL.Simple.PartialOptions+import qualified Options.Applicative.Builder as B++data Command = Apply PartialOptions FilePath | Create String+  deriving (Show, Eq, Generic)++instance ParseRecord Command where+  parseRecord = do+    let applyParser+           =  Apply+          <$> parseRecord+          <*> B.strArgument (B.metavar "FILEPATH")++        createParser+          = Create <$> B.strArgument (B.metavar "NAME")++    B.subparser+     (  B.command "apply"+          (B.info applyParser (B.progDesc "Apply migrations"))+     <> B.command "create"+          (B.info createParser (B.progDesc "Create migrations"))+     )

+ src/Database/Trek/Run.hs view

@@ -0,0 +1,130 @@+module Database.Trek.Run where+import qualified Database.Trek.Db as Db+import qualified Database.PostgreSQL.Simple.Options as P+import qualified Database.PostgreSQL.Simple.PartialOptions as Partial+import Data.Time.Format+import Data.Time+import System.IO+import Database.Trek.Parser+import System.FilePath.Posix+import Data.String+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.ByteString.Char8 as BSC+import Crypto.Hash.SHA256+import Control.Exception+import Data.Typeable+import Database.PostgreSQL.Simple+import Data.Aeson+import System.Exit+import System.IO.Error+import Control.Monad+import Data.List.NonEmpty (nonEmpty)+import System.Directory+import Data.Foldable+import qualified Database.PostgreSQL.Transact as T+import Database.PostgreSQL.Simple.Transaction+import qualified Data.ByteString.Base64 as Base64+import qualified Database.PostgreSQL.Simple as Psql+import Data.List.Split+import Data.Maybe+import Data.Aeson.Encode.Pretty++data Errors = CouldNotParseMigration FilePath+            | DirectoryDoesNotExist FilePath+  deriving (Show, Eq, Typeable)++instance Exception Errors++eval :: Command -> IO ()+eval cmd = do+  let e = case cmd of+        Create name -> putStrLn =<< create name+        Apply partialOptions filePath -> do+          let options = either (const $ error "Partial db options. Not possible") id+                      $ Partial.completeOptions partialOptions++          traverse_ (BSL.putStrLn . encodePretty) =<< apply options filePath++  let action = try e >>= \case+        Left err -> case err of+          CouldNotParseMigration filePath -> do+            hPutStrLn stderr $ "Could not parse migration: " <> filePath+            exitWith $ ExitFailure 2+          DirectoryDoesNotExist filePath -> do+            hPutStrLn stderr $ "Directory does not exist: " <> filePath+            exitWith $ ExitFailure 4+        Right () -> pure ()++  try action >>= \case+    Left (finalErr :: SomeException) -> do+      hPutStrLn stderr $ "Unknown error: " <> show finalErr+      exitWith $ ExitFailure 1+    Right () -> pure ()++create :: String -> IO String+create name = do+  now <- getCurrentTime+  let (dir, theFileName) = splitFileName name+      outputFile = formatTime defaultTimeLocale "%Y-%m-%dT%H-%M-%S" now <> "_" <> theFileName+      outputFilePath = dir </> outputFile+  try (withFile outputFilePath WriteMode (const $ pure ())) >>= \case+    Left i+      | isDoesNotExistError i -> throwIO $ DirectoryDoesNotExist outputFilePath+      | otherwise             -> throwIO i+    Right () -> pure ()++  pure outputFilePath++withOptions :: P.Options -> (Connection -> IO a) -> IO a+withOptions options f =+  bracket (Psql.connectPostgreSQL $ P.toConnectionString options) Psql.close f++parseVersion :: FilePath -> Maybe UTCTime+parseVersion filePath = do+  date <- listToMaybe $ splitOn "_" $ takeFileName filePath+  parseTimeM True defaultTimeLocale "%Y-%m-%dT%H-%M-%S" date++computeHash :: String -> Binary Db.Hash+computeHash = Binary . hash . BSC.pack++makeInputMigration :: FilePath -> IO Db.InputMigration+makeInputMigration filePath = do+  inputVersion <- maybe (throwIO $ CouldNotParseMigration filePath) pure $ parseVersion filePath++  theQuery <- readFile filePath+  let inputAction  = void $ T.execute_ $ fromString theQuery+      inputHash    = computeHash theQuery++  pure Db.InputMigration {..}++newtype OutputMigration = OutputMigration Db.OutputMigration++instance ToJSON OutputMigration where+  toJSON (OutputMigration (Db.OutputMigration {..})) = object+    [ "version" .= omVersion+    , "hash"    .= binaryToJSON omHash+    ]++newtype OutputGroup = OutputGroup Db.OutputGroup+  deriving (Show, Eq)++instance ToJSON OutputGroup where+  toJSON (OutputGroup (Db.OutputGroup {..})) = do+    object+      [ "id"         .= groupIdToJSON ogId+      , "created_at" .= ogCreatedAt+      , "migrations" .= fmap OutputMigration ogMigrations+      ]++binaryToJSON :: Binary BSC.ByteString -> Value+binaryToJSON (Binary x) = toJSON $ BSC.unpack $ Base64.encode x++groupIdToJSON :: Db.GroupId -> Value+groupIdToJSON (Db.GroupId x) = binaryToJSON x++apply :: P.Options -> FilePath -> IO (Maybe OutputGroup)+apply options dirPath = do+  xs <- mapM (makeInputMigration . (dirPath </>)) . filter ((==".sql") . takeExtension)+    =<< listDirectory dirPath+  withOptions options $ \conn -> fmap (fmap OutputGroup . join) $ forM (nonEmpty xs) $ \theNonEmpty ->+    T.runDBT (Db.apply =<< Db.inputGroup theNonEmpty) ReadCommitted conn

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

+ test/Tests/Database/Trek/ParserSpec.hs view

@@ -0,0 +1,19 @@+module Tests.Database.Trek.ParserSpec where+import Database.Trek.Parser+import Test.Hspec+import System.Environment+import Options.Generic+import Database.PostgreSQL.Simple.PartialOptions+++spec :: Spec+spec = describe "Database.Trek.Parser" $ do+  it "parses create" $+    withArgs ["create", "foo"] $+     getRecord "trek" `shouldReturn` Create "foo"+  it "parses apply" $+    withArgs ["apply", "/path/to/migrations"] $+      getRecord "trek" `shouldReturn` Apply mempty "/path/to/migrations"+  it "parses apply" $+    withArgs ["apply", "/path/to/migrations", "--dbname=db"] $+      getRecord "trek" `shouldReturn` Apply (mempty { dbname = pure "db"}) "/path/to/migrations"

+ test/Tests/Database/Trek/RunSpec.hs view

@@ -0,0 +1,122 @@+module Tests.Database.Trek.RunSpec where+import Database.Trek.Run+import Test.Hspec+import Data.Maybe+import Data.List.Split+import Data.Time.Format+import System.IO.Temp+import System.Directory+import Control.Exception+import Data.Time+import System.FilePath.Posix+import Data.List.NonEmpty (NonEmpty(..))+import qualified Database.Postgres.Temp as Temp+import Control.Concurrent+import Control.Concurrent.Async+import Data.IORef+import Data.Foldable+import qualified Database.PostgreSQL.Simple.Options as P+import qualified Database.Trek.Db as Db+import Database.PostgreSQL.Simple.Types+import Data.Time.QQ+import qualified Database.PostgreSQL.Simple as Psql+import Paths_trek_app (getDataDir)++aroundAll :: forall a. ((a -> IO ()) -> IO ()) -> SpecWith a -> Spec+aroundAll withFunc specWith = do+  (var, stopper, asyncer) <- runIO $+    (,,) <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Nothing+  let theStart :: IO a+      theStart = do++        thread <- async $ do+          withFunc $ \x -> do+            putMVar var x+            takeMVar stopper+          pure $ error "Don't evaluate this"++        writeIORef asyncer $ Just thread++        either pure pure =<< (wait thread `race` takeMVar var)++      theStop :: a -> IO ()+      theStop _ = do+        putMVar stopper ()+        traverse_ cancel =<< readIORef asyncer++  beforeAll theStart $ afterAll theStop $ specWith++foo :: String+foo = "CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.foo (id SERIAL PRIMARY KEY)"++bar :: String+bar = "CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.bar (id SERIAL PRIMARY KEY)"++quux :: String+quux = "CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.quux (id SERIAL PRIMARY KEY)"++inputGroup :: NonEmpty FilePath -> IO FilePath+inputGroup = error "inputGroup"++withSetup :: (P.Options -> IO a) -> IO a+withSetup f = do+  -- Helper to throw exceptions+  let throwE x = either throwIO pure =<< x++  throwE $ Temp.withDbCache $ \dbCache -> do+    let combinedConfig = Temp.defaultConfig <> Temp.cacheConfig dbCache+    Temp.withConfig combinedConfig $ \db -> f $ Temp.toConnectionOptions db+++spec :: Spec+spec = do+  describe "Database.Trek.Run" $ do+    it "creates a file" $ do+      withSystemTempDirectory "trek-test" $ \tmp -> do+        old <- getCurrentDirectory+        bracket_ (setCurrentDirectory tmp) (setCurrentDirectory old) $ do+          createDirectory "path"+          let name = "path/migration.sql"+          output <- create name+          let (dir, theFileName) = splitFileName output+              [date, actualName] = splitOn "_" theFileName+          dir `shouldBe` "path/"+          actualName `shouldBe` "migration.sql"+          isJust (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H-%M-%S" date :: Maybe UTCTime) `shouldBe` True+          doesFileExist output `shouldReturn` True++  aroundAll withSetup $ describe "Database.Trek.Run.apply" $ do+    it "empty directory does nothing" $ \options -> withSystemTempDirectory "trek-test" $ \tmp -> do+      apply options tmp `shouldReturn` Nothing+      -- Doing it twice should be the same+      apply options tmp `shouldReturn` Nothing++    it "standard migrations succeed" $ \options -> do+      dataDir <- fmap (</> "data") getDataDir++      Just (OutputGroup (Db.OutputGroup {ogMigrations})) <- apply options dataDir+      let fooM :| [barM, quuxM] = ogMigrations+      fooM  `shouldBe` Db.OutputMigration+        { Db.omVersion = [utcIso8601ms|2020-07-12T06:21:21.00000|]+        , Db.omHash = Binary+          { fromBinary = "L\DLE\137\195\169\&0\163o!I\189\253`\250\203\147\215\200\224\137S\160m{\179\227\240\ESC\194P-I" }+          }+      barM  `shouldBe` Db.OutputMigration+        { Db.omVersion = [utcIso8601ms| 2020-07-12T06:21:27.00000 |]+        , Db.omHash = Binary+          { fromBinary = "\ETX\225\155\215\184\144\147\DLEn\SO\195\175\&4\167\208~-\244S\146\&9\215K\223i\173\EOT\209A'Z7" }+          }+      quuxM `shouldBe` Db.OutputMigration+        { Db.omVersion = [utcIso8601ms| 2020-07-12T06:21:32.00000 |]+        , Db.omHash = Binary+          { fromBinary = "\DLE*\221\")\SO\204\207\EMdmn\b\197\233a\212-NA\133;\255\167/\t\133\139\163\222Tz" }+          }++      let action :: Psql.Connection -> IO [String]+          action conn = fmap Psql.fromOnly <$> Psql.query_ conn+            "SELECT CAST(table_name AS varchar) FROM information_schema.tables where table_schema = 'test' ORDER BY table_name"++      withOptions options action `shouldReturn` ["bar", "foo", "quux"]++    it "reapplying does nothing" $ \options -> do+      (apply options . (</> "data") =<< getDataDir) `shouldReturn` Nothing

+ trek-app.cabal view

@@ -0,0 +1,117 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: ab7f58e2ba372fd8cc72dcb41598085a170ea1109e6522551fd9f2b2d1fd5bde++name:           trek-app+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/jfischoff/trek#readme>+homepage:       https://github.com/jfischoff/trek#readme+bug-reports:    https://github.com/jfischoff/trek/issues+author:         Author name here+maintainer:     jonathangfischoff at gmail.com+copyright:      2019 Jonathan Fischoff+license:        BSD3+license-file:   LICENSE+build-type:     Simple+tested-with: GHC==8.8.1+category: Database+synopsis: A PostgreSQL Database Migrator+data-files: data/*.sql+          , data/*.txt+++source-repository head+  type: git+  location: https://github.com/jfischoff/trek+++executable trek+  main-is: Main.hs+  hs-source-dirs: app+  build-depends:+      base >=4.7 && <5+    , optparse-generic+    , trek-app+  default-language: Haskell2010+  default-extensions: OverloadedStrings++library+  exposed-modules:+      Database.Trek.Run+    , Database.Trek.Parser+  other-modules: Paths_trek_app+  autogen-modules: Paths_trek_app+  hs-source-dirs:+      src+  default-extensions: DataKinds GADTs KindSignatures QuasiQuotes RecordWildCards LambdaCase RankNTypes ScopedTypeVariables OverloadedStrings GeneralizedNewtypeDeriving DerivingVia DeriveGeneric DeriveAnyClass TupleSections+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , bytestring+    , process+    , aeson+    , time+    , optparse-generic+    , postgresql-simple-opts >= 0.6.0.1+    , optparse-applicative+    , trek-db+    , postgres-options >= 0.2.0.0+    , filepath+    , aeson+    , cryptohash-sha256+    , postgresql-simple+    , semigroups+    , directory+    , pg-transact+    , base64-bytestring+    , split+    , aeson-pretty+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules: Tests.Database.Trek.ParserSpec+               , Tests.Database.Trek.RunSpec+               , Paths_trek_app+  autogen-modules: Paths_trek_app+  hs-source-dirs: test+  default-extensions:+      NamedFieldPuns+    , QuasiQuotes+    , RecordWildCards+    , LambdaCase+    , RankNTypes+    , ScopedTypeVariables+    , OverloadedStrings+    , GeneralizedNewtypeDeriving+    , DerivingVia+    , DeriveGeneric+    , DeriveAnyClass+    , TupleSections+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      base >=4.7 && <5+    , hspec+    , hspec-discover+    , time+    , trek-app+    , optparse-generic+    , postgresql-simple-opts >= 0.6.0.1+    , split+    , temporary+    , directory+    , filepath+    , tmp-postgres+    , resource-pool+    , async+    , time-qq+    , trek-db+    , postgresql-simple+    , postgres-options+  default-language: Haskell2010+  build-tool-depends: hspec-discover:hspec-discover