diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## 0.0.1.0 (April 24th, 2017) + +- Initial release diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- This script is used to build and install your package. Typically you don't +-- need to change it. The Cabal documentation has more information about this +-- file: . +import qualified Distribution.Simple + +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/genesis.cabal b/genesis.cabal new file mode 100644 --- /dev/null +++ b/genesis.cabal @@ -0,0 +1,73 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: genesis +version: 0.0.1.0 +synopsis: Opinionated bootstrapping for Haskell web services. +description: Opinionated bootstrapping for Haskell web services. +category: Other +homepage: https://github.com/cjdev/genesis#readme +bug-reports: https://github.com/cjdev/genesis/issues +maintainer: Alexis King +copyright: 2017 CJ Affiliate by Conversant +license: ISC +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGELOG.md + package.yaml + stack.yaml + +source-repository head + type: git + location: https://github.com/cjdev/genesis + +library + hs-source-dirs: + library + default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.9.0.0 && < 5 + , directory >= 1.2.7.0 + , envparse >= 0.3.0 && < 1 + , file-embed >= 0.0.10 && < 1 + , filepath + , monad-control >= 1.0.0.0 && < 2 + , monad-logger >= 0.3.10 + , monad-persist >= 0.0.1.0 && < 1 + , persistent >= 2.5 && < 3 + , persistent-postgresql >= 2.5 && < 3 + , persistent-template >= 2.5 && < 3 + , resource-pool + , template-haskell >= 2.11.0.0 && < 2.12 + , text + , text-conversions >= 0.2.0 && < 1 + exposed-modules: + Genesis.Persist + Genesis.Persist.Base + Genesis.Persist.Migrate + default-language: Haskell2010 + +test-suite genesis-test-suite + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test-suite + default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeOperators + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , genesis + , hspec + , monad-control + , monad-logger + , monad-persist + , persistent-sqlite + , persistent-template + , text + other-modules: + Genesis.MigrateSpec + default-language: Haskell2010 diff --git a/library/Genesis/Persist.hs b/library/Genesis/Persist.hs new file mode 100644 --- /dev/null +++ b/library/Genesis/Persist.hs @@ -0,0 +1,16 @@ +module Genesis.Persist + ( -- * Connecting to PostgreSQL + -- | The bindings in this section are re-exported from + -- "Genesis.Persist.Base". + PostgresOptions(..) + , postgresOptions + , withPostgresqlPool + , withPostgresqlConn + -- * Compiling and running SQL migrations + -- | The bindings in this section are re-exported from + -- "Genesis.Persist.Migrate". + , runMigrations + ) where + +import Genesis.Persist.Base +import Genesis.Persist.Migrate diff --git a/library/Genesis/Persist/Base.hs b/library/Genesis/Persist/Base.hs new file mode 100644 --- /dev/null +++ b/library/Genesis/Persist/Base.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE NoDuplicateRecordFields #-} + +{-| + This module provides utilities for using PostgreSQL with + "Control.Monad.Persist" and @persistent@. +-} +module Genesis.Persist.Base + ( PostgresOptions(..) + , postgresOptions + , withPostgresqlPool + , withPostgresqlConn + ) where + +import qualified Database.Persist.Postgresql as PG +import qualified Env + +import Control.Monad ((<=<)) +import Control.Monad.Logger (MonadLogger) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Persist (SqlBackend) +import Data.Monoid ((<>)) +import Data.Pool (Pool) +import Data.Text (Text) +import Data.Text.Conversions (fromText, toText, unUTF8) +import GHC.Generics (Generic) + +{-| + Connection options needed to connect to PostgreSQL. You can use + 'postgresOptions' to parse these options from the environment. +-} +data PostgresOptions = PostgresOptions + { host :: Text + , port :: Int + , user :: Text + , dbName :: Text + , password :: Text + } deriving (Eq, Show, Generic) + +{-| + An @envparse@ 'Env.Parser' that parses 'PostgresOptions' from the environment, + looking for the environment variables @PG_HOST@, @PG_PORT@, @PG_USER@, + @PG_USER@, @PG_DB_NAME@, and @PG_PASSWORD@. All of them are optional except + for @PG_DB_NAME@. +-} +postgresOptions :: (Env.AsEmpty e, Env.AsUnread e, Env.AsUnset e) => Env.Parser e PostgresOptions +postgresOptions = PostgresOptions + <$> Env.var (Env.str <=< Env.nonempty) "PG_HOST" (helpDef "localhost" "host of postgres database") + <*> Env.var (Env.auto <=< Env.nonempty) "PG_PORT" (helpDef 5432 "port of postgres database") + <*> Env.var (Env.str <=< Env.nonempty) "PG_USER" (helpDef "postgres" "user to connect to postgres as") + <*> Env.var (Env.str <=< Env.nonempty) "PG_DB_NAME" (Env.help "postgres database name to connect to") + <*> Env.var Env.str "PG_PASSWORD" (helpDef "" "password to connect to postgres with") + where helpDef def msg = Env.def def <> Env.help (msg ++ " (default: " ++ show def ++ ")") + +{-| + Like 'PG.withPostgresqlPool' from "Database.Persist.Postgresql", except using + 'PostgresOptions'. +-} +withPostgresqlPool :: (MonadBaseControl IO m, MonadLogger m, MonadIO m) + => PostgresOptions -- ^ Options to connect to the database. + -> Int -- ^ Number of connections to be kept open in the pool. + -> (Pool SqlBackend -> m a) -- ^ Action to be executed that uses the connection pool. + -> m a +withPostgresqlPool opts = PG.withPostgresqlPool (pgConnString opts) + +{-| +Like 'PG.withPostgresqlConn' from "Database.Persist.Postgresql", except using +'PostgresOptions'. +-} +withPostgresqlConn :: (MonadBaseControl IO m, MonadLogger m, MonadIO m) => PostgresOptions -> (SqlBackend -> m a) -> m a +withPostgresqlConn opts = PG.withPostgresqlConn (pgConnString opts) + +pgConnString :: PostgresOptions -> PG.ConnectionString +pgConnString PostgresOptions { host, port, user, dbName, password } = + unUTF8 . fromText $ "host=" <> host <> " port=" <> toText (show port) <> " user=" <> user + <> " dbname=" <> dbName <> " password=" <> password diff --git a/library/Genesis/Persist/Migrate.hs b/library/Genesis/Persist/Migrate.hs new file mode 100644 --- /dev/null +++ b/library/Genesis/Persist/Migrate.hs @@ -0,0 +1,102 @@ +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{-| + This module provides functions for creating and running migrations written as + plain SQL files. By using 'runMigrations', the migrations will be compiled + directly into your Haskell application using Template Haskell, so the files + will not need to be present in the eventual runtime environment. + + For more information, see the documentation for 'runMigrations'. +-} +module Genesis.Persist.Migrate (runMigrations, runMigrations') where + +import qualified Data.Text.IO as T + +import Control.Monad (filterM, forM, forM_, unless, when) +import Control.Monad.Logger (MonadLogger, logDebugNS, logInfoNS) +import Control.Monad.Persist (MonadSqlPersist, insert_, rawExecute, runMigrationSilent, selectList, transactionSave) +import System.Directory (doesDirectoryExist, doesFileExist, doesPathExist, listDirectory) +import System.FilePath (()) +import Data.FileEmbed (makeRelativeToProject) +import Data.List (isSuffixOf, sort) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Conversions (toText) +import Database.Persist.Sql (Entity(..)) +import Database.Persist.TH (share, mkPersist, sqlSettings, mkMigrate, persistLowerCase) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +share [mkPersist sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase| +SchemaMigration + name FilePath + deriving Eq Show +|] + +{-| + Compiles a set of .sql files in a particular directory into your application, + then runs them against a database at runtime. This function is implemented + with Template Haskell so that it can read the migration files at compile-time, + but it semantically has the type + @('MonadLogger' m, 'MonadSqlPersist' m) => 'FilePath' -> m ()@. Migrations + will be executed in order based on their filename, according to 'sort'. + + The 'FilePath' provided should be relative to your /project root/, and it will + detect all files within the immediate directory (that is, /not/ in + subdirectories) with the suffix @.sql@. + + Example: + + @ + main :: IO () + main = 'Control.Monad.Logger.runStderrLoggingT' $ withSqliteConn ":memory:" ('Control.Monad.Persist.runSqlPersistT' $('runMigrations' "db/migrations")) + @ +-} +runMigrations :: FilePath -> Q Exp +runMigrations dir = do + migrationsDir <- makeRelativeToProject dir + migrationsDirExists <- runIO $ doesPathExist migrationsDir + unless migrationsDirExists $ + fail $ "No such directory ‘" ++ dir ++ "’ exists at root of project.\n (Looking at ‘" ++ migrationsDir ++ "’)." + + migrationsDirIsDir <- runIO $ doesDirectoryExist migrationsDir + unless migrationsDirIsDir $ + fail $ "The file at ‘" ++ dir ++ "’ in root of project is not a directory.\n (Looking at ‘" ++ migrationsDir ++ "’)." + + allFiles <- runIO $ listDirectory migrationsDir + nonDirectoryFiles <- runIO $ filterM (doesFileExist . (migrationsDir )) allFiles + let migrationFiles = sort $ filter (isSuffixOf ".sql") nonDirectoryFiles + forM_ migrationFiles (addDependentFile . (migrationsDir )) + when (null migrationFiles) $ + reportWarning $ "No migrations (files ending in .sql) in ‘" ++ dir ++ "’ at root of project.\n (Looking in ‘" ++ migrationsDir ++ "’.)\n" + + migrations <- runIO $ forM migrationFiles $ \path -> (path,) <$> T.readFile (migrationsDir path) + [| runMigrations' migrations |] + +{-| + The low-level API that underlies 'runMigrations'. It is unlikely that you will + need to use this. + + Unlike 'runMigrations', this function does not use Template Haskell. + Migrations are passed as a list of tuples, where the first element is the name + of the migration (which must be unique) and the second element is the SQL to + be run. The migrations will be run in the order they are provided, from left + to right. +-} +runMigrations' :: (MonadLogger m, MonadSqlPersist m) => [(FilePath, Text)] -> m () +runMigrations' allMigrations = do + messages <- runMigrationSilent migrateSchema + forM_ messages (logDebugNS "SQL") + transactionSave + existingMigrations <- map (schemaMigrationName . entityVal) <$> selectList [] [] + let newMigrations = filter (\(path, _) -> path `notElem` existingMigrations) allMigrations + forM_ newMigrations $ \(path, sql) -> do + logInfoNS "migrate" $ "migrating ‘" <> toText path <> "’" + rawExecute sql [] + insert_ (SchemaMigration path) + transactionSave diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,71 @@ +name: genesis +version: 0.0.1.0 +category: Other +synopsis: Opinionated bootstrapping for Haskell web services. +description: Opinionated bootstrapping for Haskell web services. +maintainer: Alexis King +copyright: 2017 CJ Affiliate by Conversant +license: ISC +github: cjdev/genesis + +extra-source-files: +- CHANGELOG.md +- package.yaml +- stack.yaml + +ghc-options: -Wall +default-extensions: +- ConstraintKinds +- DeriveGeneric +- DuplicateRecordFields +- FlexibleContexts +- FlexibleInstances +- GADTs +- GeneralizedNewtypeDeriving +- KindSignatures +- LambdaCase +- MultiParamTypeClasses +- NamedFieldPuns +- OverloadedStrings +- RankNTypes +- ScopedTypeVariables +- TypeApplications +- TypeOperators + +library: + dependencies: + - base >= 4.9.0.0 && < 5 + - directory >= 1.2.7.0 + - envparse >= 0.3.0 && < 1 + - file-embed >= 0.0.10 && < 1 + - filepath + - monad-control >= 1.0.0.0 && < 2 + - monad-logger >= 0.3.10 + - monad-persist >= 0.0.1.0 && < 1 + - persistent >= 2.5 && < 3 + - persistent-postgresql >= 2.5 && < 3 + - persistent-template >= 2.5 && < 3 + - resource-pool + - template-haskell >= 2.11.0.0 && < 2.12 + - text + - text-conversions >= 0.2.0 && < 1 + source-dirs: library + +tests: + genesis-test-suite: + dependencies: + - base + - genesis + - hspec + - monad-control + - monad-logger + - monad-persist + - persistent-sqlite + - persistent-template + - text + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + main: Main.hs + source-dirs: test-suite diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,9 @@ +resolver: lts-8.11 + +packages: +- '.' +extra-deps: [monad-persist-0.0.1.0] + +flags: {} + +extra-package-dbs: [] diff --git a/test-suite/Genesis/MigrateSpec.hs b/test-suite/Genesis/MigrateSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Genesis/MigrateSpec.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Genesis.MigrateSpec (spec) where + +import qualified Test.Hspec as Hspec + +import Control.Monad.Logger (NoLoggingT, runNoLoggingT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Persist (Entity(..), SqlPersistT, insert, runSqlPersistT, selectList) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Text (Text) +import Database.Persist.Sqlite (withSqliteConn) +import Database.Persist.TH (mkPersist, persistLowerCase, sqlSettings) +import Test.Hspec hiding (shouldBe) + +import Genesis.Persist (runMigrations) + +mkPersist sqlSettings [persistLowerCase| +Blog + name Text + deriving Eq Show + +Post + title Text + body Text + blogId BlogId + deriving Eq Show +|] + +runSqlite :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT (NoLoggingT m) a -> m a +runSqlite x = runNoLoggingT $ withSqliteConn ":memory:" (runSqlPersistT ($(runMigrations "test-suite/migrations") >> x)) + +shouldBe :: (Eq a, Show a, MonadIO m) => a -> a -> m () +shouldBe x y = liftIO $ Hspec.shouldBe x y + +spec :: Spec +spec = describe "runMigrations" $ + it "executes all SQL migrations in the specified directory" $ example $ runSqlite $ do + blogId <- insert $ Blog "Alyssa’s Blog" + let post = Post { postTitle = "First Post", postBody = "world changing post", postBlogId = blogId } + postId <- insert post + posts <- selectList [] [] + posts `shouldBe` [Entity postId post] diff --git a/test-suite/Main.hs b/test-suite/Main.hs new file mode 100644 --- /dev/null +++ b/test-suite/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}