packages feed

traction (empty) → 0.0.1

raw patch · 8 files changed

+616/−0 lines, 8 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, exceptions, hedgehog, mmorph, postgresql-simple, resource-pool, syb, template-haskell, text, time, traction, transformers, transformers-either

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Traction/Control.hs view
@@ -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+    ]
+ src/Traction/Migration.hs view
@@ -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
+ src/Traction/Prelude.hs view
@@ -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
+ src/Traction/QQ.hs view
@@ -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
+ src/Traction/Sql.hs view
@@ -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
+ test/test.hs view
@@ -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
+ traction.cabal view
@@ -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