psql-utils (empty) → 0.1.0.0
raw patch · 4 files changed
+488/−0 lines, 4 filesdep +aesondep +basedep +hashable
Dependencies added: aeson, base, hashable, postgresql-simple, resource-pool, time
Files
- LICENSE +30/−0
- psql-utils.cabal +31/−0
- src/Database/PSQL/Config.hs +65/−0
- src/Database/PSQL/Types.hs +362/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Li Meng Jun (c) 2017++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 Li Meng Jun 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.
+ psql-utils.cabal view
@@ -0,0 +1,31 @@+name: psql-utils+version: 0.1.0.0+synopsis: PostgreSQL Simple util tools.+description: An easy way to use postgresql-simple library.+homepage: https://github.com/Lupino/yuntan-common/tree/master/psql-utils#readme+license: BSD3+license-file: LICENSE+author: Li Meng Jun+maintainer: lmjubuntu@gmail.com+copyright: MIT+category: Data,PostgreSQL+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10+++library+ hs-source-dirs: src+ exposed-modules: Database.PSQL.Config+ , Database.PSQL.Types+ build-depends: base >= 4.7 && < 5+ , resource-pool+ , time+ , aeson+ , postgresql-simple+ , hashable+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/Lupino/yuntan-common
+ src/Database/PSQL/Config.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.PSQL.Config+ ( PSQL (..)+ , genPSQLPool+ ) where++import Data.Aeson (FromJSON, parseJSON, withObject,+ (.!=), (.:), (.:?))+import Data.Pool (Pool, createPool)+import Data.Time (NominalDiffTime)+import Database.PostgreSQL.Simple (ConnectInfo (..), Connection,+ close, connect, defaultConnectInfo)+import GHC.Word (Word16)++data PSQL = PSQL+ { psqlDBName :: String+ , psqlHost :: String+ , psqlPort :: Word16+ , psqlUser :: String+ , psqlPass :: String+ , psqlPoolNumStrips :: Int+ -- ^ The number of stripes (distinct sub-pools) to maintain.+ , psqlPoolIdleTime :: NominalDiffTime+ -- ^ Amount of time for which an unused resource is kept alive.+ , psqlPoolMaxResources :: Int+ -- ^ Maximum number of resources to maintain per stripe. The+ , psqlHaxlNumThreads :: Int+ -- numThreads of fetch async for haxl+ }+ deriving (Show)++instance FromJSON PSQL where+ parseJSON = withObject "PSQL" $ \o -> do+ psqlDBName <- o .: "db"+ psqlHost <- o .:? "host" .!= "127.0.0.1"+ psqlPort <- o .:? "port" .!= 5432+ psqlUser <- o .:? "user" .!= "postgre"+ psqlPass <- o .:? "pass" .!= ""+ psqlPoolNumStrips <- o .:? "numStripes" .!= 1+ psqlPoolIdleTime <- o .:? "idleTime" .!= 0.5+ psqlPoolMaxResources <- o .:? "maxResources" .!= 1+ psqlHaxlNumThreads <- o .:? "numThreads" .!= 1+ return PSQL{..}++genPSQLPool :: PSQL -> IO (Pool Connection)+genPSQLPool conf = createPool conn close numStripes idleTime maxResources+ where conn = connect defaultConnectInfo+ { connectDatabase = dbName+ , connectHost = dbHost+ , connectPort = dbPort+ , connectUser = dbUser+ , connectPassword = dbPass+ }++ dbName = psqlDBName conf+ dbHost = psqlHost conf+ dbPort = psqlPort conf+ dbUser = psqlUser conf+ dbPass = psqlPass conf++ numStripes = psqlPoolNumStrips conf+ idleTime = psqlPoolIdleTime conf+ maxResources = psqlPoolMaxResources conf
+ src/Database/PSQL/Types.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.PSQL.Types+ ( TablePrefix++ , PSQLPool+ , PSQL+ , HasPSQL+ , psqlPool+ , tablePrefix+ , SimpleEnv+ , simpleEnv++ , HasOtherEnv+ , otherEnv++ , TableName+ , getTableName+ , Columns+ , createTable+ , constraintPrimaryKey+ , getIndexName+ , IndexName+ , createIndex++ , getOnly+ , getOnlyDefault++ , insert+ , insertRet+ , insertOrUpdate+ , update+ , delete+ , delete_+ , count+ , count_+ , select+ , selectOnly+ , select_+ , selectOnly_+ , selectOne+ , selectOneOnly++ , VersionList+ , mergeDatabase+++ -- re-exports+ , FromRow (..)+ , field+ , Only (..)+ , SqlError (..)++ , OrderBy+ , asc+ , desc+ , none+ ) where+++import Control.Monad (void)+import Data.Hashable (Hashable (..))+import Data.Int (Int64)+import Data.List (intercalate)+import Data.Maybe (listToMaybe)+import Data.Pool (Pool)+import Data.String (IsString (..))+import Database.PostgreSQL.Simple (Connection, Only (..),+ SqlError (..), ToRow,+ execute, execute_, query,+ query_)+import Database.PostgreSQL.Simple.FromRow (FromRow (..), field)+import GHC.Generics (Generic)++type From = Int64+type Size = Int64+++newtype TablePrefix = TablePrefix String+ deriving (Show)++instance IsString TablePrefix where+ fromString = TablePrefix++type PSQL a = TablePrefix -> Connection -> IO a+type PSQLPool = Pool Connection++class HasPSQL u where+ psqlPool :: u -> PSQLPool+ tablePrefix :: u -> TablePrefix++class HasOtherEnv u a where+ otherEnv :: a -> u++data SimpleEnv u = SimpleEnv+ { pc :: Pool Connection+ , pf :: TablePrefix+ , pu :: u+ }++instance HasPSQL (SimpleEnv u) where+ psqlPool = pc+ tablePrefix = pf++instance HasOtherEnv u (SimpleEnv u) where+ otherEnv = pu++simpleEnv :: Pool Connection -> TablePrefix -> u -> SimpleEnv u+simpleEnv pool prefix env0 = SimpleEnv{pc=pool, pf = prefix, pu = env0}++newtype TableName = TableName String+ deriving (Show)++instance IsString TableName where+ fromString = TableName++getTableName :: TablePrefix -> TableName -> String+getTableName (TablePrefix "") (TableName name) =+ concat ["\"", name, "\"" ]+getTableName (TablePrefix prefix) (TableName name) =+ concat ["\"", prefix, "_", name, "\"" ]++newtype Column = Column { unColumn :: String }+ deriving (Show)++instance IsString Column where+ fromString = Column++type Columns = [Column]++columnsToString :: Columns -> String+columnsToString = intercalate ", " . map unColumn++constraintPrimaryKey :: TablePrefix -> TableName -> Columns -> Column+constraintPrimaryKey prefix tn columns = Column . concat $+ [ "CONSTRAINT "+ , getIndexName prefix tn "pkey"+ , " PRIMARY KEY (", columnsToString columns, ")"+ ]++createTable :: TableName -> Columns -> PSQL Int64+createTable tn cols prefix conn = execute_ conn sql+ where sql = fromString $ concat+ [ "CREATE TABLE IF NOT EXISTS ", getTableName prefix tn, " ("+ , columnsToString cols+ , ")"+ ]++newtype IndexName = IndexName String+ deriving (Show)++instance IsString IndexName where+ fromString = IndexName++getIndexName :: TablePrefix -> TableName -> IndexName -> String+getIndexName (TablePrefix "") (TableName tn) (IndexName name) =+ concat [ "\"", tn, "_", name, "\"" ]+getIndexName (TablePrefix prefix) (TableName tn) (IndexName name) =+ concat [ "\"", prefix, "_", tn , "_", name, "\"" ]+++createIndex :: Bool -> TableName -> IndexName -> Columns -> PSQL Int64+createIndex uniq tn idxN cols prefix conn = execute_ conn sql+ where sql = fromString $ concat+ [ "CREATE ", uniqWord, "INDEX IF NOT EXISTS ", getIndexName prefix tn idxN+ , " ON " , getTableName prefix tn, "(", columnsToString cols, ")"+ ]++ uniqWord = if uniq then "UNIQUE " else ""++getOnly :: FromRow (Only a) => [Only a] -> Maybe a+getOnly = fmap fromOnly . listToMaybe++getOnlyDefault :: FromRow (Only a) => a -> [Only a] -> a+getOnlyDefault a = maybe a fromOnly . listToMaybe++insert :: ToRow a => TableName -> Columns -> a -> PSQL Int64+insert tn cols a prefix conn = execute conn sql a+ where v = take (length cols) $ cycle ["?"]+ sql = fromString $ concat+ [ "INSERT INTO ", getTableName prefix tn+ , " (", columnsToString cols, ")"+ , " VALUES"+ , " (", columnsToString v, ")"+ ]++insertRet :: (ToRow a, FromRow (Only b)) => TableName -> Columns -> Column -> a -> b -> PSQL b+insertRet tn cols col a def prefix conn = getOnlyDefault def <$> query conn sql a+ where v = take (length cols) $ cycle ["?"]+ sql = fromString $ concat+ [ "INSERT INTO ", getTableName prefix tn+ , " (", columnsToString cols, ")"+ , " VALUES"+ , " (", columnsToString v, ")"+ , " returning ", unColumn col+ ]++insertOrUpdate :: ToRow a => TableName -> Columns -> Columns -> Columns -> a -> PSQL Int64+insertOrUpdate tn uniqCols valCols otherCols a prefix conn = execute conn sql a+ where cols = uniqCols ++ valCols ++ otherCols+ v = replicate (length cols) "?"++ setSql = intercalate ", " $ map appendSet valCols++ appendSet :: Column -> String+ appendSet (Column col) | '=' `elem` col = col+ | otherwise = col ++ " = excluded." ++ col++ doSql = if null valCols then " DO NOTHING" else " DO UPDATE SET " ++ setSql++ sql = fromString $ concat+ [ "INSERT INTO ", getTableName prefix tn+ , " (", columnsToString cols, ")"+ , " VALUES"+ , " (", columnsToString v, ")"+ , " ON CONFLICT (", columnsToString uniqCols, ")"+ , doSql+ ]++update :: ToRow a => TableName -> Columns -> String -> a -> PSQL Int64+update tn cols partSql a prefix conn = execute conn sql a+ where setSql = intercalate ", " $ map appendSet cols+ whereSql = if null partSql then "" else " WHERE " ++ partSql+ sql = fromString $ concat+ [ "UPDATE ", getTableName prefix tn+ , " SET ", setSql+ , whereSql+ ]++ appendSet :: Column -> String+ appendSet (Column col) | '=' `elem` col = col+ | otherwise = col ++ " = ?"++delete :: ToRow a => TableName -> String -> a -> PSQL Int64+delete tn partSql a prefix conn = execute conn sql a+ where whereSql = " WHERE " ++ partSql+ sql = fromString $ concat+ [ "DELETE FROM ", getTableName prefix tn, whereSql+ ]++delete_ :: TableName -> PSQL Int64+delete_ tn prefix conn = execute_ conn sql+ where sql = fromString $ concat+ [ "DELETE FROM ", getTableName prefix tn+ ]++count :: ToRow a => TableName -> String -> a -> PSQL Int64+count tn partSql a prefix conn =+ getOnlyDefault 0 <$> query conn sql a+ where whereSql = " WHERE " ++ partSql+ sql = fromString $ concat+ [ "SELECT count(*) FROM ", getTableName prefix tn, whereSql+ ]++count_ :: TableName -> PSQL Int64+count_ tn prefix conn =+ getOnlyDefault 0 <$> query_ conn sql+ where sql = fromString $ concat+ [ "SELECT count(*) FROM ", getTableName prefix tn+ ]++select :: (ToRow a, FromRow b) => TableName -> Columns -> String -> a -> From -> Size -> OrderBy -> PSQL [b]+select tn cols partSql a from size o prefix conn = query conn sql a+ where whereSql = " WHERE " ++ partSql+ sql = fromString $ concat+ [ "SELECT ", columnsToString cols, " FROM ", getTableName prefix tn+ , whereSql+ , " ", show o+ , " LIMIT ", show size+ , " OFFSET ", show from+ ]++selectOnly :: (ToRow a, FromRow (Only b)) => TableName -> Column -> String -> a -> From -> Size -> OrderBy -> PSQL [b]+selectOnly tn col partSql a from size o prefix conn =+ map fromOnly <$> select tn [col] partSql a from size o prefix conn++select_ :: FromRow b => TableName -> Columns -> From -> Size -> OrderBy -> PSQL [b]+select_ tn cols from size o prefix conn = query_ conn sql+ where sql = fromString $ concat+ [ "SELECT ", columnsToString cols, " FROM ", getTableName prefix tn+ , " ", show o+ , " LIMIT ", show size+ , " OFFSET ", show from+ ]++selectOnly_ :: FromRow (Only b) => TableName -> Column -> From -> Size -> OrderBy -> PSQL [b]+selectOnly_ tn col from size o prefix conn =+ map fromOnly <$> select_ tn [col] from size o prefix conn++selectOne :: (ToRow a, FromRow b) => TableName -> Columns -> String -> a -> PSQL (Maybe b)+selectOne tn cols partSql a prefix conn = listToMaybe <$> query conn sql a+ where whereSql = " WHERE " ++ partSql+ sql = fromString $ concat+ [ "SELECT ", columnsToString cols, " FROM ", getTableName prefix tn+ , whereSql+ ]++selectOneOnly :: (ToRow a, FromRow (Only b)) => TableName -> Column -> String -> a -> PSQL (Maybe b)+selectOneOnly tn col partSql a prefix conn =+ fmap fromOnly <$> selectOne tn [col] partSql a prefix conn++createVersionTable :: PSQL Int64+createVersionTable prefix conn =+ createTable "version"+ [ "name VARCHAR(10) NOT NULL"+ , "version INT DEFAULT '0'"+ , "PRIMARY KEY (name)"+ ] prefix conn++getCurrentVersion :: PSQL Int64+getCurrentVersion prefix conn = do+ void $ createVersionTable prefix conn+ ts <- selectOneOnly "version" "version" "name = ?" (Only ("version" :: String)) prefix conn+ case ts of+ Just v -> pure v+ Nothing ->+ insertRet "version" ["name", "version"] "version" ("version" :: String, 0 :: Int) 0 prefix conn+++updateVersion :: Int64 -> PSQL ()+updateVersion ts prefix conn =+ void $ update "version" ["version"] "name = ?" (ts, "version" :: String) prefix conn++type Version a = (Int64, [PSQL a])+type VersionList a = [Version a]++mergeDatabase :: VersionList a -> PSQL ()+mergeDatabase versionList prefix conn = do+ version <- getCurrentVersion prefix conn+ mapM_ (\v -> processAction version v prefix conn) versionList++processAction :: Int64 -> Version a -> PSQL ()+processAction version (ts, actions) prefix conn =+ if ts > version then do+ updateVersion ts prefix conn+ mapM_ (\o -> void $ o prefix conn) actions+ else pure ()++data OrderBy = Desc String | Asc String | None+ deriving (Generic, Eq)++instance Hashable OrderBy++desc :: String -> OrderBy+desc = Desc++asc :: String -> OrderBy+asc = Asc++none :: OrderBy+none = None++instance Show OrderBy where+ show (Desc f) = "ORDER BY " ++ f ++ " DESC"+ show (Asc f) = "ORDER BY " ++ f ++ " ASC"+ show None = ""