diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/src/Traction/Control.hs b/src/Traction/Control.hs
new file mode 100644
--- /dev/null
+++ b/src/Traction/Control.hs
@@ -0,0 +1,183 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+module Traction.Control (
+    Db (..)
+  , DbError (..)
+  , renderDbError
+  , DbPool (..)
+  , DbPoolConfiguration (..)
+  , defaultDbPoolConfiguration
+  , MonadDb (..)
+  , runDb
+  , runDbT
+  , newPool
+  , newPoolWith
+  , newRollbackPool
+  , newRollbackPoolWith
+  , withRollbackSingletonPool
+  , withConnection
+  , failWith
+  ) where
+
+import           Control.Monad.Catch (Exception, MonadMask (..), Handler (..), handle, catches, bracket_, throwM)
+import           Control.Monad.IO.Class (MonadIO (..))
+import           Control.Monad.Morph (squash)
+import           Control.Monad.Trans.Class (MonadTrans (..))
+import           Control.Monad.Trans.Except (ExceptT(..))
+import           Control.Monad.Trans.Reader (ReaderT (..), ask)
+
+import           Data.ByteString (ByteString)
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Time as Time
+import           Data.Typeable (Typeable)
+import qualified Data.Pool as Pool
+
+import qualified Database.PostgreSQL.Simple as Postgresql
+
+import           System.IO (IO)
+
+import           Traction.Prelude
+
+
+newtype DbPool =
+  DbPool {
+      runDbPool :: forall a. Db a -> EitherT DbError IO a
+    }
+
+data DbError =
+    DbSqlError Postgresql.Query Postgresql.SqlError
+  | DbQueryError Postgresql.Query Postgresql.QueryError
+  | DbFormatError Postgresql.Query Postgresql.FormatError
+  | DbResultError Postgresql.Query Postgresql.ResultError
+  | DbTooManyResults Postgresql.Query Int
+  | DbNoResults Postgresql.Query
+  | DbEncodingInvariant Postgresql.Query Text Text
+    deriving (Show, Eq, Typeable)
+
+renderDbError :: DbError -> Text
+renderDbError e =
+  Text.pack $ case e of
+    DbSqlError q err ->
+      mconcat ["SQL Error [", show err, "], for query: ", show q]
+    DbQueryError q err ->
+      mconcat ["Query Error [", show err, "], for query: ", show q]
+    DbFormatError q err ->
+      mconcat ["Format Error [", show err, "], for query: ", show q]
+    DbResultError q err ->
+      mconcat ["Result Error [", show err, "], for query: ", show q]
+    DbTooManyResults q n ->
+      mconcat ["Too many results [", show n , "], for query: ", show q]
+    DbNoResults q ->
+      mconcat ["Query generated no results, for query: ", show q]
+    DbEncodingInvariant q field encoding ->
+      mconcat ["Query could not decode results, expected to be able to decode [", Text.unpack field, "], to type, [", Text.unpack encoding, "], for query: ", show q]
+
+newtype Db a =
+  Db {
+      _runDb :: ReaderT Postgresql.Connection (EitherT DbError IO) a
+    }  deriving (Functor, Applicative, Monad, MonadIO)
+
+class MonadIO m => MonadDb m where
+  liftDb :: Db a -> m a
+
+instance MonadDb Db where
+  liftDb = id
+
+instance MonadDb m => MonadDb (ExceptT e m) where
+  liftDb = lift . liftDb
+
+failWith :: DbError -> Db a
+failWith =
+  Db . lift . left
+
+runDb :: DbPool -> Db a -> EitherT DbError IO a
+runDb pool db =
+  runDbPool pool db
+
+runDbT :: DbPool -> (DbError -> e) -> EitherT e Db a -> EitherT e IO a
+runDbT pool handler db =
+  squash $ mapEitherT (firstEitherT handler . runDb pool) db
+
+data DbPoolConfiguration =
+  DbPoolConfiguration {
+      dbPoolStripes :: Int
+    , dbPoolKeepAliveSeconds :: Time.NominalDiffTime
+    , dbPoolSize :: Int
+    } deriving (Eq, Ord, Show)
+
+defaultDbPoolConfiguration :: DbPoolConfiguration
+defaultDbPoolConfiguration =
+  DbPoolConfiguration {
+      dbPoolStripes = 4
+    , dbPoolKeepAliveSeconds = 20
+    , dbPoolSize = 20
+    }
+
+data RollbackException =
+    RollbackException DbError
+    deriving (Eq, Show, Typeable)
+
+instance Exception RollbackException
+
+newPool :: ByteString -> IO DbPool
+newPool connection =
+  newPoolWith connection defaultDbPoolConfiguration (pure ())
+
+newPoolWith :: ByteString -> DbPoolConfiguration -> Db () -> IO DbPool
+newPoolWith connection configuration initializer = do
+  pool <- Pool.createPool
+    (Postgresql.connectPostgreSQL connection)
+    Postgresql.close
+    (dbPoolStripes configuration)
+    (dbPoolKeepAliveSeconds configuration)
+    (dbPoolSize configuration)
+  pure $ DbPool $ \db ->
+    newEitherT $ Pool.withResource pool $ \c ->
+      handle (\(RollbackException e) -> pure $ Left e) $ Postgresql.withTransaction c $ do
+        r <- runEitherT $ flip runReaderT c $ _runDb (initializer >> db)
+        case r of
+          Left e -> do
+            throwM $ RollbackException e
+          Right _ ->
+            pure r
+
+newRollbackPool :: ByteString -> IO DbPool
+newRollbackPool connection =
+  newRollbackPoolWith connection defaultDbPoolConfiguration (pure ())
+
+newRollbackPoolWith :: ByteString -> DbPoolConfiguration -> Db () -> IO DbPool
+newRollbackPoolWith connection configuration initializer = do
+  pool <- Pool.createPool
+    (Postgresql.connectPostgreSQL connection)
+    Postgresql.close
+    (dbPoolStripes configuration)
+    (dbPoolKeepAliveSeconds configuration)
+    (dbPoolSize configuration)
+  pure $ DbPool $ \db ->
+    newEitherT $ Pool.withResource pool $ \c ->
+      bracket_ (Postgresql.begin c) (Postgresql.rollback c)  $ do
+        runEitherT $ flip runReaderT c $ _runDb (initializer >> db)
+
+withRollbackSingletonPool :: (MonadMask m, MonadIO m) => ByteString -> (DbPool -> m a) -> m a
+withRollbackSingletonPool connection action = do
+  c <- liftIO . Postgresql.connectPostgreSQL $ connection
+  bracket_ (liftIO $ Postgresql.begin c) (liftIO $ Postgresql.rollback c) $
+    action $ DbPool $ \db ->
+      newEitherT $
+        runEitherT $ flip runReaderT c $ _runDb db
+
+withConnection :: Postgresql.Query -> (Postgresql.Connection -> IO a) -> Db a
+withConnection query f =
+  Db $ ask >>= lift . safely query . f
+
+safely :: Postgresql.Query -> IO a -> EitherT DbError IO a
+safely query action =
+  newEitherT $ catches (Right <$> action) [
+      Handler $ pure . Left . DbSqlError query
+    , Handler $ pure . Left . DbQueryError query
+    , Handler $ pure . Left . DbFormatError query
+    , Handler $ pure . Left . DbResultError query
+    ]
diff --git a/src/Traction/Migration.hs b/src/Traction/Migration.hs
new file mode 100644
--- /dev/null
+++ b/src/Traction/Migration.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Traction.Migration (
+    Migration (..)
+  , migrate
+  ) where
+
+import qualified Data.List as List
+import           Data.Text (Text)
+import qualified Data.Set as Set
+
+import           Database.PostgreSQL.Simple.SqlQQ (sql)
+import qualified Database.PostgreSQL.Simple as Postgresql
+
+import           Traction.Prelude
+import           Traction.Control
+import qualified Traction.Sql as Sql
+
+
+data Migration =
+   Migration {
+       migrationName :: Text
+     , migrationQuery :: Postgresql.Query
+     } deriving (Eq, Show)
+
+migrate :: [Migration] -> Db [Migration]
+migrate migrations = do
+  void $ Sql.execute_ "SET client_min_messages TO WARNING"
+  void $ Sql.execute_ [sql| CREATE TABLE IF NOT EXISTS migrations (migration TEXT PRIMARY KEY) |]
+  installed <- (fmap . fmap) Postgresql.fromOnly $ Sql.query_ [sql| SELECT migration FROM migrations |]
+  forM (diff migrations installed) $ \migration -> do
+    void $ Sql.execute_ $ migrationQuery migration
+    void $ Sql.execute [sql| INSERT INTO migrations (migration) VALUES (?) |] (Postgresql.Only $ migrationName migration)
+    pure migration
+
+diff :: [Migration] -> [Text] -> [Migration]
+diff migrations installed =
+  let
+    installed' = Set.fromList installed
+    missing = List.filter (\x -> not . Set.member (migrationName x) $ installed') migrations
+  in
+    missing
diff --git a/src/Traction/Prelude.hs b/src/Traction/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/src/Traction/Prelude.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Traction.Prelude (
+    module X
+  , fromMaybeM
+  , whenM
+  , unlessM
+  , with
+  ) where
+
+import           Control.Applicative as X
+import           Control.Monad as X
+import           Data.Bool as X (Bool (..), (||), (&&), not, bool, otherwise)
+import           Data.Char as X (Char)
+import           Data.Bifunctor as X (Bifunctor (..))
+import           Data.Either as X (Either (..), either)
+import           Data.Foldable as X
+import           Data.Function as X ((.), ($), (&), flip, id, const)
+import           Data.Functor as X (($>))
+import           Data.Int as X
+import           Data.Maybe as X (Maybe (..), maybe, fromMaybe)
+import           Data.Monoid as X (Monoid (..), (<>))
+import           Data.Traversable as X
+import           Prelude as X (Eq (..), Show (..), Ord (..), Num (..), Enum, Bounded (..), Integral (..), Double, error, seq, fromIntegral, (/), (^), fst, snd)
+import           Text.Read as X (Read (..), readMaybe)
+import           Control.Monad.Trans.Either as X
+
+
+fromMaybeM :: Applicative f => f a -> Maybe a -> f a
+fromMaybeM =
+  flip maybe pure
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM p m =
+  p >>= flip when m
+
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM p m =
+  p >>= flip unless m
+
+with :: Functor f => f a -> (a -> b) -> f b
+with =
+  flip fmap
diff --git a/src/Traction/QQ.hs b/src/Traction/QQ.hs
new file mode 100644
--- /dev/null
+++ b/src/Traction/QQ.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Traction.QQ (
+    savepoint
+  , schema
+  , sql
+  ) where
+
+import           Data.Data (Data)
+import           Data.Generics (extQ)
+import           Data.Text (Text)
+import qualified Data.Text as Text
+
+import           Database.PostgreSQL.Simple.SqlQQ (sql)
+
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Quote
+
+import qualified Prelude
+
+import           Traction.Sql (newSchema, newSavepoint)
+import           Traction.Prelude
+
+schema :: QuasiQuoter
+schema =
+  QuasiQuoter {
+    quoteExp = \s -> case newSchema (Text.pack s) of
+      Nothing ->
+        Prelude.error "Failed to parse savepoint"
+      Just v ->
+        dataExp v
+  , quotePat = Prelude.error "not able to qq pats"
+  , quoteType = Prelude.error "not able to qq types"
+  , quoteDec = Prelude.error "not able to qq decs"
+  }
+
+savepoint :: QuasiQuoter
+savepoint =
+  QuasiQuoter {
+    quoteExp = \s -> case newSavepoint (Text.pack s) of
+      Nothing ->
+        Prelude.error "Failed to parse savepoint"
+      Just v ->
+        dataExp v
+  , quotePat = Prelude.error "not able to qq pats"
+  , quoteType = Prelude.error "not able to qq types"
+  , quoteDec = Prelude.error "not able to qq decs"
+  }
+
+dataExp :: Data a => a -> Q Exp
+dataExp a =
+  dataToExpQ (const Nothing `extQ` textExp) a
+
+textExp :: Text -> Maybe ExpQ
+textExp =
+  pure . appE (varE 'Text.pack) . litE . StringL . Text.unpack
diff --git a/src/Traction/Sql.hs b/src/Traction/Sql.hs
new file mode 100644
--- /dev/null
+++ b/src/Traction/Sql.hs
@@ -0,0 +1,210 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Traction.Sql (
+    Only (..)
+  , Binary (..)
+  , mandatory
+  , mandatory_
+  , unique
+  , unique_
+  , query
+  , query_
+  , execute
+  , execute_
+  , value
+  , valueWith
+  , values
+  , valuesWith
+  , Schema (..)
+  , newSchema
+  , Savepoint (..)
+  , newSavepoint
+  , createSavepoint
+  , releaseSavepoint
+  , rollbackSavepoint
+  , Unique (..)
+  , isUnique
+  , isDuplicate
+  , withUniqueCheck
+  , withUniqueCheckSavepoint
+  ) where
+
+import           Control.Monad.Trans.Class (MonadTrans (..))
+import           Control.Monad.Trans.Reader (ask, runReaderT)
+import           Control.Monad.IO.Class (MonadIO (..))
+
+import qualified Data.ByteString.Builder as ByteStringBuilder
+import qualified Data.Char as Char
+import           Data.Data (Data)
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import           Data.Typeable (Typeable)
+
+import           Database.PostgreSQL.Simple.SqlQQ (sql)
+import           Database.PostgreSQL.Simple (ToRow, FromRow, Only (..), Binary (..))
+import qualified Database.PostgreSQL.Simple as Postgresql
+import qualified Database.PostgreSQL.Simple.ToField as Postgresql
+
+import           Traction.Control
+import           Traction.Prelude
+
+
+mandatory :: (MonadDb m, ToRow a, FromRow b) => Postgresql.Query -> a -> m b
+mandatory q =
+  liftDb . definitely q . unique q
+
+mandatory_ :: (MonadDb m, FromRow a) => Postgresql.Query -> m a
+mandatory_ q =
+  liftDb . definitely q $ unique_ q
+
+unique :: (MonadDb m, ToRow a, FromRow b) => Postgresql.Query -> a -> m (Maybe b)
+unique q parameters =
+  liftDb . possibly q . withConnection q $ \c ->
+    Postgresql.query c q parameters
+
+unique_ :: (MonadDb m, FromRow a) => Postgresql.Query -> m (Maybe a)
+unique_ q =
+  liftDb . possibly q . withConnection q $ \c ->
+    Postgresql.query_ c q
+
+query :: (MonadDb m, ToRow a, FromRow  b) => Postgresql.Query -> a -> m [b]
+query q parameters =
+  liftDb . withConnection q $ \c ->
+    Postgresql.query c q parameters
+
+query_ :: (MonadDb m, FromRow a) => Postgresql.Query -> m [a]
+query_ q =
+  liftDb . withConnection q $ \c ->
+    Postgresql.query_ c q
+
+execute :: (MonadDb m, ToRow a) => Postgresql.Query -> a -> m Int64
+execute q parameters =
+  liftDb . withConnection q $ \c ->
+    Postgresql.execute c q parameters
+
+execute_ :: MonadDb m => Postgresql.Query -> m Int64
+execute_ q =
+  liftDb . withConnection q $ \c ->
+    Postgresql.execute_  c q
+
+possibly :: Postgresql.Query -> Db [a] -> Db (Maybe a)
+possibly q db =
+  db >>= \as ->
+    case as of
+      [] ->
+        pure Nothing
+      [x] ->
+        pure . Just $ x
+      (_x:_xs) ->
+        failWith $ DbTooManyResults q (length as)
+
+definitely :: Postgresql.Query -> Db (Maybe a) -> Db a
+definitely q db =
+  db >>=
+    fromMaybeM (failWith $ DbNoResults q)
+
+value :: Functor f => f (Only a) -> f a
+value =
+  fmap fromOnly
+
+valueWith :: Functor f => (a -> b) -> f (Only a) -> f b
+valueWith f =
+  fmap (f . fromOnly)
+
+values :: (Functor f, Functor g) => g (f (Only a)) -> g (f a)
+values =
+  (fmap . fmap) fromOnly
+
+valuesWith :: (Functor f, Functor g) => (a -> b) -> g (f (Only a)) -> g (f b)
+valuesWith f =
+  (fmap . fmap) (f . fromOnly)
+
+newtype Schema =
+  Schema {
+      renderSchema :: Text
+    } deriving (Eq, Show, Data, Typeable)
+
+instance Postgresql.ToField Schema where
+  toField = Postgresql.EscapeIdentifier . Text.encodeUtf8 . renderSchema
+
+newSchema :: Text -> Maybe Schema
+newSchema t =
+  if Text.all (\c -> Char.isAlpha c || c == '_') t
+    then Just (Schema t)
+    else Nothing
+
+newtype Savepoint =
+  Savepoint {
+      renderSavepoint :: Text
+    } deriving (Eq, Show, Data, Typeable)
+
+instance Postgresql.ToField Savepoint where
+  toField = Postgresql.Plain . ByteStringBuilder.byteString . Text.encodeUtf8 . renderSavepoint
+
+newSavepoint :: Text -> Maybe Savepoint
+newSavepoint t =
+  if Text.all (\c -> Char.isAlpha c || c == '_') t
+    then Just (Savepoint t)
+    else Nothing
+
+createSavepoint :: Savepoint -> Db ()
+createSavepoint s =
+  void $ execute [sql| SAVEPOINT ? |] (Only s)
+
+releaseSavepoint :: Savepoint -> Db ()
+releaseSavepoint s =
+  void $ execute [sql| RELEASE SAVEPOINT ? |] (Only s)
+
+rollbackSavepoint :: Savepoint -> Db ()
+rollbackSavepoint s =
+  void $ execute [sql| ROLLBACK TO SAVEPOINT ? |] (Only s)
+
+bracketSavepoint :: Savepoint -> Db a -> Db a
+bracketSavepoint savepoint db =
+  Db $ ask >>= \c -> lift $ do
+    r <- liftIO . runEitherT $ flip runReaderT c $ _runDb (createSavepoint savepoint >> db)
+    case r of
+      Left _ -> do
+        flip runReaderT c $ _runDb (rollbackSavepoint savepoint)
+        newEitherT $ pure r
+      Right _ -> do
+        flip runReaderT c $ _runDb (releaseSavepoint savepoint)
+        newEitherT $ pure r
+
+data Unique a =
+    Unique a
+  | Duplicate Postgresql.Query Postgresql.SqlError
+    deriving (Show, Functor)
+
+isUnique :: Unique a -> Bool
+isUnique u =
+  case u of
+    Unique _ ->
+      True
+    Duplicate _ _ ->
+      False
+
+isDuplicate :: Unique a -> Bool
+isDuplicate =
+  not . isUnique
+
+withUniqueCheck :: MonadDb m => Db a -> m (Unique a)
+withUniqueCheck =
+  withUniqueCheckSavepoint (Savepoint "duplicate_key_savepoint")
+
+withUniqueCheckSavepoint :: MonadDb m => Savepoint -> Db a -> m (Unique a)
+withUniqueCheckSavepoint savepoint db =
+  liftDb . Db $ ask >>= \c -> lift $ do
+    r <- liftIO . runEitherT $ flip runReaderT c $ _runDb (bracketSavepoint savepoint db)
+    case r of
+      Left (DbSqlError q e) -> do
+        if Postgresql.sqlState e == "23505" then
+          pure (Duplicate q e)
+        else
+          fmap Unique $ newEitherT $ pure r
+      _ ->
+        fmap Unique $ newEitherT $ pure r
diff --git a/test/test.hs b/test/test.hs
new file mode 100644
--- /dev/null
+++ b/test/test.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+import           Traction.Prelude
+
+import           System.Exit (exitFailure)
+import           System.IO (IO)
+import qualified System.IO as IO
+
+import qualified Test.Traction
+
+
+main :: IO ()
+main =
+  IO.hSetBuffering IO.stdout IO.LineBuffering >> mapM id [
+      Test.Traction.tests
+    ] >>= \rs -> when (not . all id $ rs) exitFailure
diff --git a/traction.cabal b/traction.cabal
new file mode 100644
--- /dev/null
+++ b/traction.cabal
@@ -0,0 +1,60 @@
+name: traction
+version: 0.0.1
+license: BSD3
+author: Mark Hibberd <mark@hibberd.id.au>
+maintainer: Mark Hibberd <mark@hibberd.id.au>
+copyright: (c) 2017 Mark Hibberd
+cabal-version: >= 1.24
+build-type: Simple
+description:
+  A few tools for using postgresql-simple.
+
+library
+  default-language: Haskell2010
+
+  build-depends:
+      base >= 3 && < 5
+    , bytestring == 0.10.*
+    , containers >= 0.5.8 && < 0.7
+    , exceptions >= 0.9 && < 0.11
+    , mmorph == 1.*
+    , postgresql-simple == 0.5.*
+    , resource-pool == 0.2.*
+    , syb >= 0.4 && < 0.8
+    , template-haskell
+    , text == 1.2.*
+    , time >= 1.5 && < 1.10
+    , transformers == 0.5.*
+    , transformers-either == 0.0.*
+
+  ghc-options:
+    -Wall
+
+  hs-source-dirs:
+    src
+
+  exposed-modules:
+    Traction.Control
+    Traction.Migration
+    Traction.Prelude
+    Traction.Sql
+    Traction.QQ
+
+test-suite test
+  default-language: Haskell2010
+  type: exitcode-stdio-1.0
+  main-is: test.hs
+  hs-source-dirs: test
+  build-depends:
+      base >= 3 && < 5
+    , hedgehog == 0.5.*
+    , mmorph == 1.*
+    , postgresql-simple == 0.5.*
+    , resource-pool == 0.2.*
+    , text == 1.2.*
+    , traction
+
+  ghc-options:
+    -Wall
+    -threaded
+    -O2