mirror of
https://github.com/flipstone/orville.git
synced 2024-09-11 03:55:29 +03:00
Initial commit
This commit is contained in:
commit
a68f7c482a
3
.gitignore
vendored
Normal file
3
.gitignore
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
dist
|
||||
.cabal-sandbox
|
||||
cabal.sandbox.config
|
6
Dockerfile
Normal file
6
Dockerfile
Normal file
@ -0,0 +1,6 @@
|
||||
FROM haskell:7.10.3
|
||||
|
||||
RUN apt-get update &&\
|
||||
apt-get install -y --no-install-recommends libpq5 libpq-dev &&\
|
||||
apt-get clean
|
||||
|
20
LICENSE
Normal file
20
LICENSE
Normal file
@ -0,0 +1,20 @@
|
||||
Copyright (c) 2016 Flipstone Technology Partners
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this software and associated documentation files (the
|
||||
"Software"), to deal in the Software without restriction, including
|
||||
without limitation the rights to use, copy, modify, merge, publish,
|
||||
distribute, sublicense, and/or sell copies of the Software, and to
|
||||
permit persons to whom the Software is furnished to do so, subject to
|
||||
the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included
|
||||
in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
||||
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
||||
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
||||
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
5
docker-compose.yml
Normal file
5
docker-compose.yml
Normal file
@ -0,0 +1,5 @@
|
||||
dev:
|
||||
build: .
|
||||
volumes:
|
||||
- .:/orville
|
||||
working_dir: /orville
|
70
orville.cabal
Normal file
70
orville.cabal
Normal file
@ -0,0 +1,70 @@
|
||||
-- Initial orville.cabal generated by cabal init. For further
|
||||
-- documentation, see http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: orville
|
||||
version: 0.2.1.0
|
||||
synopsis: ORM
|
||||
-- description:
|
||||
license: AllRightsReserved
|
||||
license-file: LICENSE
|
||||
author: Flipstone Technology Partners
|
||||
maintainer: development@flipstone.com
|
||||
-- copyright:
|
||||
category: Database
|
||||
build-type: Simple
|
||||
-- extra-source-files:
|
||||
cabal-version: >=1.10
|
||||
|
||||
library
|
||||
ghc-options: -Wall -fno-warn-orphans
|
||||
exposed-modules: Database.Orville,
|
||||
Database.Orville.Core,
|
||||
Database.Orville.Popper,
|
||||
Database.Orville.PostgresSQL,
|
||||
Database.Orville.Raw,
|
||||
Database.Orville.Tracked
|
||||
|
||||
other-modules: Database.Orville.Internal.ConstraintDefinition,
|
||||
Database.Orville.Internal.FieldDefinition,
|
||||
Database.Orville.Internal.FieldUpdate,
|
||||
Database.Orville.Internal.FromSql,
|
||||
Database.Orville.Internal.IndexDefinition,
|
||||
Database.Orville.Internal.MigrateConstraint,
|
||||
Database.Orville.Internal.MigrateIndex,
|
||||
Database.Orville.Internal.MigrateSchema,
|
||||
Database.Orville.Internal.MigrateTable,
|
||||
Database.Orville.Internal.Monad,
|
||||
Database.Orville.Internal.OrderBy,
|
||||
Database.Orville.Internal.QueryCache,
|
||||
Database.Orville.Internal.QueryKey,
|
||||
Database.Orville.Internal.SelectOptions,
|
||||
Database.Orville.Internal.TableDefinition,
|
||||
Database.Orville.Internal.Types,
|
||||
Database.Orville.Internal.Where,
|
||||
|
||||
Data.Map.Helpers
|
||||
|
||||
default-extensions: GeneralizedNewtypeDeriving,
|
||||
MultiParamTypeClasses
|
||||
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.8 && <4.9,
|
||||
bytestring,
|
||||
containers >= 0.5,
|
||||
convertible >= 1.1,
|
||||
dlist >= 0.7,
|
||||
exceptions >= 0.8,
|
||||
lifted-base >= 0.2,
|
||||
monad-control >= 1.0,
|
||||
HDBC >= 2.4,
|
||||
HDBC-postgresql >= 2.3,
|
||||
mtl >= 2.2,
|
||||
resource-pool >= 0.2,
|
||||
text,
|
||||
time >= 1.5,
|
||||
transformers >= 0.4,
|
||||
transformers-base >= 0.4
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
16
src/Data/Map/Helpers.hs
Normal file
16
src/Data/Map/Helpers.hs
Normal file
@ -0,0 +1,16 @@
|
||||
module Data.Map.Helpers
|
||||
( groupBy
|
||||
, groupBy'
|
||||
) where
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
groupBy :: Ord k => (a -> k) -> [a] -> Map.Map k [a]
|
||||
groupBy keyFunc = groupBy' mkEntry
|
||||
where mkEntry a = (keyFunc a, a)
|
||||
|
||||
groupBy' :: Ord k => (a -> (k,v)) -> [a] -> Map.Map k [v]
|
||||
groupBy' mkEntry as = Map.fromListWith (++) (map mkListEntry as)
|
||||
where mkListEntry a = let (k,v) = mkEntry a
|
||||
in (k, [v])
|
||||
|
10
src/Database/Orville.hs
Normal file
10
src/Database/Orville.hs
Normal file
@ -0,0 +1,10 @@
|
||||
module Database.Orville
|
||||
( module Database.Orville.Core
|
||||
, module Database.Orville.Popper
|
||||
, module Database.Orville.Tracked
|
||||
) where
|
||||
|
||||
import Database.Orville.Core
|
||||
import Database.Orville.Popper
|
||||
import Database.Orville.Tracked
|
||||
|
258
src/Database/Orville/Core.hs
Normal file
258
src/Database/Orville/Core.hs
Normal file
@ -0,0 +1,258 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Database.Orville.Core
|
||||
( SqlValue
|
||||
, Orville
|
||||
, OrvilleT, unOrvilleT, OrvilleEnv, newOrvilleEnv, ormEnvPool
|
||||
, MonadOrville(..), runOrville, mapOrvilleT
|
||||
, withTransaction
|
||||
|
||||
, ColumnFlag (..)
|
||||
, Now(..)
|
||||
, ColumnType (..)
|
||||
, FieldDefinition
|
||||
, TableDefinition (..)
|
||||
, tablePrimaryKey
|
||||
|
||||
, IndexDefinition (..)
|
||||
, uniqueIndex, simpleIndex
|
||||
|
||||
, ConstraintDefinition (..)
|
||||
, uniqueConstraint, dropConstraint
|
||||
|
||||
, FromSql
|
||||
, FromSqlError(..)
|
||||
, ColumnSpecifier(..)
|
||||
, col
|
||||
, nullableCol
|
||||
, nextColumn
|
||||
, prefixed
|
||||
|
||||
, ToSql
|
||||
, getField
|
||||
, getComponent
|
||||
, withFlag
|
||||
, withName
|
||||
|
||||
, SchemaItem(..)
|
||||
, SchemaDefinition
|
||||
, Record
|
||||
, CreatedAt
|
||||
|
||||
, TableComments
|
||||
, noComments, say
|
||||
|
||||
, WhereCondition
|
||||
, whereAnd, whereOr, isNull, isNotNull
|
||||
, (.==), (.<-), (%==), (.>), (.>=), (.<), (.<=)
|
||||
|
||||
, SelectOptions(..)
|
||||
, where_, order, limit, offset
|
||||
, (<>)
|
||||
|
||||
, FieldUpdate(..)
|
||||
, fieldUpdate, (.:=)
|
||||
|
||||
, OrderByClause (..)
|
||||
, SortDirection (..)
|
||||
, migrateSchema
|
||||
, selectAll
|
||||
, selectFirst
|
||||
, deleteRecord
|
||||
, deleteWhere
|
||||
, findRecord
|
||||
, findRecords
|
||||
, findRecordsBy
|
||||
, insertRecord
|
||||
, insertRecordMany
|
||||
, updateFields
|
||||
, updateRecord
|
||||
) where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Convertible
|
||||
import qualified Data.List as List
|
||||
import Data.Maybe (listToMaybe)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Monoid
|
||||
import Database.HDBC hiding (withTransaction)
|
||||
|
||||
import qualified Data.Map.Helpers as Map
|
||||
import Database.Orville.Internal.ConstraintDefinition
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.FieldUpdate
|
||||
import Database.Orville.Internal.FromSql
|
||||
import Database.Orville.Internal.IndexDefinition
|
||||
import Database.Orville.Internal.Monad
|
||||
import Database.Orville.Internal.MigrateSchema
|
||||
import Database.Orville.Internal.OrderBy
|
||||
import Database.Orville.Internal.SelectOptions
|
||||
import Database.Orville.Internal.TableDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
import Database.Orville.Internal.Where
|
||||
import Database.Orville.Raw
|
||||
|
||||
getField :: Convertible a SqlValue
|
||||
=> (entity -> a) -> ToSql entity ()
|
||||
getField f = do
|
||||
value <- asks f
|
||||
sqlValues <- get
|
||||
put (convert value : sqlValues)
|
||||
|
||||
selectWhereBuild :: TableDefinition entity
|
||||
-> FromSql result
|
||||
-> SelectOptions
|
||||
-> Orville [result]
|
||||
selectWhereBuild tableDef builder opts =
|
||||
selectSql querySql (selectOptValues opts) builder
|
||||
where
|
||||
selectClause = mkSelectClause tableDef
|
||||
querySql = List.intercalate " " [
|
||||
selectClause
|
||||
, selectOptClause opts
|
||||
]
|
||||
|
||||
selectAll :: TableDefinition entity
|
||||
-> SelectOptions
|
||||
-> Orville [entity Record]
|
||||
selectAll tableDef = selectWhereBuild tableDef (tableFromSql tableDef)
|
||||
|
||||
selectFirst :: TableDefinition entity
|
||||
-> SelectOptions
|
||||
-> Orville (Maybe (entity Record))
|
||||
selectFirst tableDef opts = listToMaybe <$> selectAll tableDef (limit 1 <> opts)
|
||||
|
||||
deleteWhereBuild :: TableDefinition entity
|
||||
-> [WhereCondition]
|
||||
-> Orville Integer
|
||||
deleteWhereBuild tableDef conds = do
|
||||
let deleteSql = mkDeleteClause tableDef
|
||||
let whereSql = whereClause conds
|
||||
let values = whereValues conds
|
||||
let querySql = deleteSql ++ " " ++ whereSql
|
||||
|
||||
withConnection $ \conn -> liftIO $ do
|
||||
deletedCount <- run conn querySql values
|
||||
return deletedCount
|
||||
|
||||
deleteWhere :: TableDefinition entity
|
||||
-> [WhereCondition]
|
||||
-> Orville Integer
|
||||
deleteWhere tableDef = deleteWhereBuild tableDef
|
||||
|
||||
findRecords :: TableDefinition entity
|
||||
-> [Record]
|
||||
-> Orville (Map.Map Record (entity Record))
|
||||
findRecords _ [] = return Map.empty
|
||||
findRecords tableDef keys = do
|
||||
let keyField = tablePrimaryKey tableDef
|
||||
mkEntry record = (tableGetKey tableDef record, record)
|
||||
|
||||
recordList <- selectAll tableDef (where_ $ keyField .<- keys)
|
||||
pure $ Map.fromList (map mkEntry recordList)
|
||||
|
||||
findRecordsBy :: (Convertible SqlValue fieldValue, Ord fieldValue)
|
||||
=> TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SelectOptions
|
||||
-> Orville (Map.Map fieldValue [entity Record])
|
||||
findRecordsBy tableDef field opts = do
|
||||
let builder = (,) <$> col field <*> tableFromSql tableDef
|
||||
Map.groupBy' id <$> selectWhereBuild tableDef builder opts
|
||||
|
||||
findRecord :: TableDefinition entity
|
||||
-> Record
|
||||
-> Orville (Maybe (entity Record))
|
||||
findRecord tableDef key = do
|
||||
let keyField = tablePrimaryKey tableDef
|
||||
selectFirst tableDef (where_ $ keyField .== key)
|
||||
|
||||
updateFields :: TableDefinition entity
|
||||
-> [FieldUpdate]
|
||||
-> [WhereCondition]
|
||||
-> Orville Integer
|
||||
updateFields tableDef updates conds =
|
||||
updateSql (updateClause ++ " " ++ condClause)
|
||||
(updateValues ++ condValues)
|
||||
where
|
||||
condClause = whereClause conds
|
||||
condValues = whereValues conds
|
||||
|
||||
updateValues = map fieldUpdateValue updates
|
||||
updateClause = mkUpdateClause tableDef updates
|
||||
|
||||
updateRecord :: TableDefinition entity
|
||||
-> Record
|
||||
-> entity key
|
||||
-> Orville (entity Record)
|
||||
updateRecord tableDef recordId record = do
|
||||
let keyField = tablePrimaryKey tableDef
|
||||
conds = [keyField .== recordId]
|
||||
|
||||
fields = filter (not . isUninsertedField)
|
||||
(tableFields tableDef)
|
||||
|
||||
builder = tableToSql tableDef
|
||||
|
||||
updates = zipWith FieldUpdate
|
||||
fields
|
||||
(runToSql builder record)
|
||||
|
||||
void $ updateFields tableDef updates conds
|
||||
|
||||
pure $ tableSetKey tableDef recordId record
|
||||
|
||||
|
||||
insertRecord :: TableDefinition entity
|
||||
-> entity ()
|
||||
-> Orville (entity Record)
|
||||
insertRecord tableDef newRecord = do
|
||||
let insertSql = mkInsertClause tableDef ++ " RETURNING id"
|
||||
let builder = tableToSql tableDef
|
||||
|
||||
rows <- withConnection $ \conn -> liftIO $ do
|
||||
putStrLn insertSql
|
||||
let vals = (runToSql builder newRecord)
|
||||
print vals
|
||||
|
||||
insert <- prepare conn insertSql
|
||||
void $ execute insert vals
|
||||
rows <- fetchAllRows' insert
|
||||
return rows
|
||||
|
||||
case rows of
|
||||
[[key]] -> case safeConvert key of
|
||||
Right int -> return $ tableSetKey tableDef int newRecord
|
||||
_ -> error "Got a non-integer key back from the db!"
|
||||
|
||||
[] -> error "Didn't get a key back from the database!"
|
||||
_ -> error "Got more than one key back from the database!"
|
||||
|
||||
insertRecordMany :: TableDefinition entity
|
||||
-> [entity ()]
|
||||
-> Orville ()
|
||||
insertRecordMany tableDef newRecords = do
|
||||
let insertSql = mkInsertClause tableDef
|
||||
let builder = tableToSql tableDef
|
||||
|
||||
withConnection $ \conn -> liftIO $ do
|
||||
insert <- prepare conn insertSql
|
||||
executeMany insert (map (runToSql builder) newRecords)
|
||||
|
||||
deleteRecord :: TableDefinition entity
|
||||
-> entity Record
|
||||
-> Orville ()
|
||||
deleteRecord tableDef record = do
|
||||
let keyField = tablePrimaryKey tableDef
|
||||
|
||||
n <- deleteWhere tableDef
|
||||
[keyField .== tableGetKey tableDef record]
|
||||
|
||||
if n /= 1
|
||||
then error $ "Expected to delete exactly 1 row for deleteRecord\
|
||||
\but actually deleted" ++ show n
|
||||
else pure ()
|
||||
|
||||
|
21
src/Database/Orville/Internal/ConstraintDefinition.hs
Normal file
21
src/Database/Orville/Internal/ConstraintDefinition.hs
Normal file
@ -0,0 +1,21 @@
|
||||
module Database.Orville.Internal.ConstraintDefinition
|
||||
( uniqueConstraint
|
||||
, dropConstraint
|
||||
) where
|
||||
|
||||
import Data.List (intercalate)
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
uniqueConstraint :: String -> TableDefinition entity -> [FieldDefinition] -> ConstraintDefinition
|
||||
uniqueConstraint name tableDef fields =
|
||||
ConstraintDefinition {
|
||||
constraintName = name
|
||||
, constraintTable = tableName tableDef
|
||||
, constraintBody = "UNIQUE (" ++ intercalate "," (map escapedFieldName fields) ++ ")"
|
||||
}
|
||||
|
||||
dropConstraint :: TableDefinition entity -> String -> SchemaItem
|
||||
dropConstraint tableDef = DropConstraint (tableName tableDef)
|
||||
|
39
src/Database/Orville/Internal/FieldDefinition.hs
Normal file
39
src/Database/Orville/Internal/FieldDefinition.hs
Normal file
@ -0,0 +1,39 @@
|
||||
module Database.Orville.Internal.FieldDefinition where
|
||||
|
||||
import Database.Orville.Internal.Types
|
||||
import Database.Orville.Internal.QueryKey
|
||||
|
||||
isPrimaryKey :: ColumnFlag -> Bool
|
||||
isPrimaryKey PrimaryKey = True
|
||||
isPrimaryKey _ = False
|
||||
|
||||
isNullFlag :: ColumnFlag -> Bool
|
||||
isNullFlag Null = True
|
||||
isNullFlag _ = False
|
||||
|
||||
isUninserted :: ColumnFlag -> Bool
|
||||
isUninserted PrimaryKey = True
|
||||
isUninserted (InsertDefault _) = True
|
||||
isUninserted _ = False
|
||||
|
||||
fieldName :: FieldDefinition -> String
|
||||
fieldName (name, _, _) = name
|
||||
|
||||
escapedFieldName :: FieldDefinition -> String
|
||||
escapedFieldName field = "\"" ++ fieldName field ++ "\""
|
||||
|
||||
fieldType :: FieldDefinition -> ColumnType
|
||||
fieldType (_,typ,_) = typ
|
||||
|
||||
isPrimaryKeyField :: FieldDefinition -> Bool
|
||||
isPrimaryKeyField (_, _, flags) = any isPrimaryKey flags
|
||||
|
||||
withFlag :: FieldDefinition -> ColumnFlag -> FieldDefinition
|
||||
withFlag (name, typ, flags) newFlag = (name, typ, newFlag : flags)
|
||||
|
||||
withName :: FieldDefinition -> String -> FieldDefinition
|
||||
withName (_, typ, flags) newName = (newName, typ, flags)
|
||||
|
||||
isUninsertedField :: FieldDefinition -> Bool
|
||||
isUninsertedField (_, _, flags) = any isUninserted flags
|
||||
|
20
src/Database/Orville/Internal/FieldUpdate.hs
Normal file
20
src/Database/Orville/Internal/FieldUpdate.hs
Normal file
@ -0,0 +1,20 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Database.Orville.Internal.FieldUpdate where
|
||||
|
||||
import Data.Convertible
|
||||
import Database.HDBC
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
fieldUpdate :: Convertible a SqlValue
|
||||
=> FieldDefinition -> a -> FieldUpdate
|
||||
fieldUpdate def = FieldUpdate def . convert
|
||||
|
||||
(.:=) :: Convertible a SqlValue => FieldDefinition -> a -> FieldUpdate
|
||||
(.:=) = fieldUpdate
|
||||
|
||||
fieldUpdateSql :: FieldUpdate -> String
|
||||
fieldUpdateSql u =
|
||||
fieldName (fieldUpdateField u) ++ " = ?"
|
||||
|
88
src/Database/Orville/Internal/FromSql.hs
Normal file
88
src/Database/Orville/Internal/FromSql.hs
Normal file
@ -0,0 +1,88 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Database.Orville.Internal.FromSql where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy.Char8 as LBS
|
||||
import Data.Convertible
|
||||
import Data.List
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import Database.HDBC
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
convertFromSql :: Convertible SqlValue a => SqlValue -> FromSql a
|
||||
convertFromSql sqlValue =
|
||||
case safeConvert sqlValue of
|
||||
Right value -> return value
|
||||
Left conversionError -> throwError $ RowDataError $ prettyConvertError conversionError
|
||||
|
||||
nextColumn :: Convertible SqlValue a => FromSql a
|
||||
nextColumn = do
|
||||
columns <- get
|
||||
|
||||
case columns of
|
||||
[] -> throwError $ QueryError $ "Insufficient column values to build type"
|
||||
(_,sqlValue) : rest -> do
|
||||
put rest
|
||||
convertFromSql sqlValue
|
||||
|
||||
columnPrefix :: FromSql String
|
||||
columnPrefix = ask
|
||||
|
||||
prefixed :: String -> FromSql a -> FromSql a
|
||||
prefixed str = local (++str)
|
||||
|
||||
fullColumnName :: ColumnSpecifier col => col -> FromSql String
|
||||
fullColumnName colSpec = do
|
||||
prefix <- columnPrefix
|
||||
pure $ prefix ++ columnName colSpec
|
||||
|
||||
col :: (ColumnSpecifier col, Convertible SqlValue a)
|
||||
=> col -> FromSql a
|
||||
col colSpec = do
|
||||
columns <- get
|
||||
name <- fullColumnName colSpec
|
||||
|
||||
case lookup name columns of
|
||||
Just sqlValue -> convertFromSql sqlValue
|
||||
Nothing ->
|
||||
throwError $ QueryError $ concat [ "Column "
|
||||
, name
|
||||
, " not found in result set, "
|
||||
, " actual columns: "
|
||||
, intercalate "," $ map fst columns
|
||||
]
|
||||
|
||||
-- allows a Nothing to be returned for a (Maybe field) within a (Maybe data_type)
|
||||
nullableCol :: (ColumnSpecifier col, Convertible SqlValue a)
|
||||
=> col
|
||||
-> FromSql (Maybe (Maybe a))
|
||||
nullableCol colSpec = (col colSpec) >>= pure . Just
|
||||
|
||||
class ColumnSpecifier col where
|
||||
columnName :: col -> String
|
||||
|
||||
instance ColumnSpecifier FieldDefinition where
|
||||
columnName = fieldName
|
||||
|
||||
instance ColumnSpecifier [Char] where
|
||||
columnName = id
|
||||
|
||||
instance ColumnSpecifier T.Text where
|
||||
columnName = T.unpack
|
||||
|
||||
instance ColumnSpecifier LT.Text where
|
||||
columnName = LT.unpack
|
||||
|
||||
instance ColumnSpecifier BS.ByteString where
|
||||
columnName = BS.unpack
|
||||
|
||||
instance ColumnSpecifier LBS.ByteString where
|
||||
columnName = LBS.unpack
|
||||
|
29
src/Database/Orville/Internal/IndexDefinition.hs
Normal file
29
src/Database/Orville/Internal/IndexDefinition.hs
Normal file
@ -0,0 +1,29 @@
|
||||
module Database.Orville.Internal.IndexDefinition
|
||||
( uniqueIndex, simpleIndex
|
||||
) where
|
||||
|
||||
import Data.List (intercalate)
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
uniqueIndex :: String -> TableDefinition entity -> [FieldDefinition] -> IndexDefinition
|
||||
uniqueIndex name tableDef fields =
|
||||
IndexDefinition {
|
||||
indexName = name
|
||||
, indexUnique = True
|
||||
, indexTable = tableName tableDef
|
||||
, indexBody = indexFieldsBody fields
|
||||
}
|
||||
|
||||
simpleIndex :: String -> TableDefinition entity -> [FieldDefinition] -> IndexDefinition
|
||||
simpleIndex name tableDef fields =
|
||||
IndexDefinition {
|
||||
indexName = name
|
||||
, indexUnique = False
|
||||
, indexTable = tableName tableDef
|
||||
, indexBody = indexFieldsBody fields
|
||||
}
|
||||
|
||||
indexFieldsBody :: [FieldDefinition] -> String
|
||||
indexFieldsBody fields = "(" ++ intercalate "," (map escapedFieldName fields) ++ ")"
|
42
src/Database/Orville/Internal/MigrateConstraint.hs
Normal file
42
src/Database/Orville/Internal/MigrateConstraint.hs
Normal file
@ -0,0 +1,42 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Database.Orville.Internal.MigrateConstraint
|
||||
( createConstraint
|
||||
, dropConstraint
|
||||
, getConstraints
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Convertible
|
||||
import Data.List
|
||||
import Database.HDBC
|
||||
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
createConstraint :: IConnection conn => conn -> ConstraintDefinition -> IO ()
|
||||
createConstraint conn (ConstraintDefinition {..}) = do
|
||||
let ddl = intercalate " " [ "ALTER TABLE"
|
||||
, "\"" ++ constraintTable ++ "\""
|
||||
, "ADD CONSTRAINT"
|
||||
, "\"" ++ constraintName ++ "\""
|
||||
, constraintBody
|
||||
]
|
||||
|
||||
putStrLn ddl
|
||||
void $ run conn ddl []
|
||||
|
||||
dropConstraint :: IConnection conn => conn -> String -> String -> IO ()
|
||||
dropConstraint conn tableName constraintName = do
|
||||
let ddl = "ALTER TABLE " ++ tableName ++ " DROP CONSTRAINT " ++ constraintName
|
||||
putStrLn ddl
|
||||
void $ run conn ddl []
|
||||
|
||||
getConstraints :: IConnection conn => conn -> IO [String]
|
||||
getConstraints conn = do
|
||||
query <- prepare conn "SELECT conname \
|
||||
\FROM pg_constraint \
|
||||
\JOIN pg_namespace ON pg_namespace.oid = pg_constraint.connamespace \
|
||||
\WHERE nspname = 'public'"
|
||||
|
||||
void $ execute query []
|
||||
map (convert . head) <$> fetchAllRows' query
|
||||
|
40
src/Database/Orville/Internal/MigrateIndex.hs
Normal file
40
src/Database/Orville/Internal/MigrateIndex.hs
Normal file
@ -0,0 +1,40 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Database.Orville.Internal.MigrateIndex
|
||||
( createIndex
|
||||
, dropIndex
|
||||
, getIndexes
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Convertible
|
||||
import Data.List
|
||||
import Database.HDBC
|
||||
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
createIndex :: IConnection conn => conn -> IndexDefinition -> IO ()
|
||||
createIndex conn (IndexDefinition {..}) = do
|
||||
let ddl = intercalate " " [ "CREATE"
|
||||
, if indexUnique then "UNIQUE" else ""
|
||||
, "INDEX"
|
||||
, indexName
|
||||
, "ON"
|
||||
, "\"" ++ indexTable ++ "\""
|
||||
, indexBody
|
||||
]
|
||||
|
||||
putStrLn ddl
|
||||
void $ run conn ddl []
|
||||
|
||||
dropIndex :: IConnection conn => conn -> String -> IO ()
|
||||
dropIndex conn name = do
|
||||
let ddl = "DROP INDEX " ++ name
|
||||
putStrLn ddl
|
||||
void $ run conn ddl []
|
||||
|
||||
getIndexes :: IConnection conn => conn -> IO [String]
|
||||
getIndexes conn = do
|
||||
query <- prepare conn "SELECT indexname FROM pg_indexes WHERE schemaname = 'public';"
|
||||
void $ execute query []
|
||||
map (convert . head) <$> fetchAllRows' query
|
||||
|
62
src/Database/Orville/Internal/MigrateSchema.hs
Normal file
62
src/Database/Orville/Internal/MigrateSchema.hs
Normal file
@ -0,0 +1,62 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Database.Orville.Internal.MigrateSchema
|
||||
( migrateSchema
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Convertible
|
||||
import Data.Int
|
||||
import Database.HDBC hiding (withTransaction)
|
||||
|
||||
import Database.Orville.Internal.MigrateConstraint
|
||||
import Database.Orville.Internal.MigrateIndex
|
||||
import Database.Orville.Internal.MigrateTable
|
||||
import Database.Orville.Internal.Monad
|
||||
import Database.Orville.Internal.Types
|
||||
import Database.Orville.Raw
|
||||
|
||||
orvilleLockScope :: Int32
|
||||
orvilleLockScope = 17772
|
||||
|
||||
migrationLockId :: Int32
|
||||
migrationLockId = 7995632
|
||||
|
||||
migrateSchema :: SchemaDefinition -> Orville ()
|
||||
migrateSchema schemaDef = withConnection $ \conn -> do
|
||||
withTransaction $ liftIO $ do
|
||||
void $ run conn
|
||||
"SELECT pg_advisory_xact_lock(?,?)"
|
||||
[convert orvilleLockScope, convert migrationLockId]
|
||||
|
||||
tables <- getTables conn
|
||||
indexes <- getIndexes conn
|
||||
constraints <- getConstraints conn
|
||||
|
||||
forM_ schemaDef $ \table ->
|
||||
case table of
|
||||
Table tableDef ->
|
||||
if tableName tableDef `elem` tables
|
||||
then migrateTable conn tableDef
|
||||
else createTable conn tableDef
|
||||
|
||||
DropTable name ->
|
||||
when (name `elem` tables)
|
||||
(dropTable conn name)
|
||||
|
||||
Index indexDef ->
|
||||
when (not $ indexName indexDef `elem` indexes)
|
||||
(createIndex conn indexDef)
|
||||
|
||||
DropIndex name ->
|
||||
when (name `elem` indexes)
|
||||
(dropIndex conn name)
|
||||
|
||||
Constraint constraintDef ->
|
||||
when (not $ constraintName constraintDef `elem` constraints)
|
||||
(createConstraint conn constraintDef)
|
||||
|
||||
DropConstraint tableName name ->
|
||||
when (name `elem` constraints)
|
||||
(dropConstraint conn tableName name)
|
||||
|
208
src/Database/Orville/Internal/MigrateTable.hs
Normal file
208
src/Database/Orville/Internal/MigrateTable.hs
Normal file
@ -0,0 +1,208 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
module Database.Orville.Internal.MigrateTable
|
||||
( createTable
|
||||
, dropTable
|
||||
, migrateTable
|
||||
, MigrateTableException(..)
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import qualified Control.Exception as Exc
|
||||
import qualified Data.List as List
|
||||
import Data.Maybe
|
||||
import Data.Typeable
|
||||
import Database.HDBC
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
|
||||
createTable :: IConnection conn => conn -> TableDefinition entity -> IO ()
|
||||
createTable conn tableDef = do
|
||||
let ddl = mkCreateTableDDL tableDef
|
||||
putStrLn ddl
|
||||
void $ run conn ddl []
|
||||
|
||||
|
||||
dropTable :: IConnection conn => conn -> String -> IO ()
|
||||
dropTable conn name = do
|
||||
let ddl = "DROP TABLE \"" ++ name ++ "\""
|
||||
putStrLn ddl
|
||||
void $ run conn ddl []
|
||||
|
||||
|
||||
migrateTable :: IConnection conn => conn -> TableDefinition entity -> IO ()
|
||||
migrateTable conn tableDef = do
|
||||
columns <- describeTable conn (tableName tableDef)
|
||||
|
||||
case mkMigrateTableDDL columns tableDef of
|
||||
Nothing -> return ()
|
||||
Just ddl -> do
|
||||
putStrLn ddl
|
||||
stmt <- prepare conn ddl
|
||||
|
||||
executeRaw stmt
|
||||
`Exc.catch` (Exc.throw . MTE tableDef)
|
||||
|
||||
mkMigrateTableDDL :: [(String, SqlColDesc)] -> TableDefinition entity -> Maybe String
|
||||
mkMigrateTableDDL columns tableDef =
|
||||
if null stmts then
|
||||
Nothing
|
||||
else
|
||||
Just $ "ALTER TABLE \"" ++ tableName tableDef ++ "\" " ++ cols
|
||||
|
||||
where fields = tableFields tableDef
|
||||
fieldColumn fieldDef = lookup (fieldName fieldDef) columns
|
||||
colStmt = mkMigrateColumnDDL <$> id <*> fieldColumn
|
||||
dropStmt = mkDropColumnDDL <$> id <*> flip lookup columns
|
||||
stmts = List.concatMap colStmt fields ++
|
||||
List.concatMap dropStmt (tableSafeToDelete tableDef)
|
||||
cols = List.intercalate ", " $ stmts
|
||||
|
||||
|
||||
mkMigrateColumnTypeDDL :: FieldDefinition -> SqlColDesc -> Maybe String
|
||||
mkMigrateColumnTypeDDL fieldDef colDesc =
|
||||
let fieldDesc = sqlFieldDesc fieldDef
|
||||
in if colType fieldDesc /= colType colDesc ||
|
||||
colSize fieldDesc /= colSize colDesc then
|
||||
Just $ "ALTER COLUMN " ++ fieldName fieldDef ++ " SET DATA TYPE " ++
|
||||
mkTypeDDL (fieldType fieldDef)
|
||||
else
|
||||
Nothing
|
||||
|
||||
|
||||
mkMigrateColumnNullDDL :: FieldDefinition -> SqlColDesc -> Maybe String
|
||||
mkMigrateColumnNullDDL fieldDef colDesc =
|
||||
let fieldDesc = sqlFieldDesc fieldDef
|
||||
fieldNull = fromMaybe True (colNullable fieldDesc)
|
||||
colNull = fromMaybe True (colNullable colDesc)
|
||||
in if fieldNull && not colNull then
|
||||
Just $ "ALTER COLUMN " ++ fieldName fieldDef ++ " DROP NOT NULL"
|
||||
else if not fieldNull && colNull then
|
||||
Just $ "ALTER COLUMN " ++ fieldName fieldDef ++ " SET NOT NULL"
|
||||
else
|
||||
Nothing
|
||||
|
||||
|
||||
mkMigrateColumnDDL :: FieldDefinition -> Maybe SqlColDesc -> [String]
|
||||
mkMigrateColumnDDL fieldDef Nothing = ["ADD COLUMN " ++ mkFieldDDL fieldDef]
|
||||
mkMigrateColumnDDL fieldDef (Just desc) = catMaybes [
|
||||
mkMigrateColumnTypeDDL fieldDef desc
|
||||
, mkMigrateColumnNullDDL fieldDef desc
|
||||
]
|
||||
|
||||
|
||||
mkDropColumnDDL :: ColumnName -> Maybe SqlColDesc -> [String]
|
||||
mkDropColumnDDL _ Nothing = []
|
||||
mkDropColumnDDL name (Just _) = ["DROP COLUMN " ++ name]
|
||||
|
||||
mkFlagDDL :: ColumnFlag -> String
|
||||
mkFlagDDL PrimaryKey = "PRIMARY KEY"
|
||||
mkFlagDDL Unique = "UNIQUE"
|
||||
mkFlagDDL Null = "NULL"
|
||||
mkFlagDDL (Default def) = "DEFAULT " ++ toColumnDefaultSql def
|
||||
mkFlagDDL (InsertDefault def) = "DEFAULT " ++ toColumnDefaultSql def
|
||||
mkFlagDDL (References table field) =
|
||||
"REFERENCES \"" ++ tableName table ++ "\" (" ++ fieldName field ++ ")"
|
||||
|
||||
mkTypeDDL :: ColumnType -> String
|
||||
mkTypeDDL AutomaticId = "SERIAL"
|
||||
mkTypeDDL ForeignId = "INTEGER"
|
||||
mkTypeDDL Integer = "INTEGER"
|
||||
mkTypeDDL BigInteger = "BIGINT"
|
||||
mkTypeDDL Double = "DOUBLE PRECISION"
|
||||
mkTypeDDL Boolean = "BOOLEAN"
|
||||
mkTypeDDL (Text len) = "CHAR(" ++ show len ++ ")"
|
||||
mkTypeDDL (VarText len) = "VARCHAR(" ++ show len ++ ")"
|
||||
mkTypeDDL (Date) = "DATE"
|
||||
mkTypeDDL (Timestamp) = "TIMESTAMP with time zone"
|
||||
mkTypeDDL TextSearchVector = "TSVECTOR"
|
||||
|
||||
mkFieldDDL :: FieldDefinition -> String
|
||||
mkFieldDDL (name, columnType, flags) =
|
||||
name ++ " " ++ sqlType ++ " " ++ flagSql
|
||||
where sqlType = mkTypeDDL columnType
|
||||
flagSql = List.intercalate " " (notNull : map mkFlagDDL flags)
|
||||
notNull = if any isNullFlag flags then
|
||||
""
|
||||
else
|
||||
"NOT NULL"
|
||||
|
||||
mkCreateTableDDL :: TableDefinition entity -> String
|
||||
mkCreateTableDDL tableDef =
|
||||
"CREATE TABLE \"" ++ tableName tableDef ++ "\" (" ++ fields ++ ")"
|
||||
where fields = List.intercalate ", " $ map mkFieldDDL (tableFields tableDef)
|
||||
|
||||
columnTypeSqlId :: ColumnType -> SqlTypeId
|
||||
columnTypeSqlId AutomaticId = SqlBigIntT
|
||||
columnTypeSqlId ForeignId = SqlBigIntT
|
||||
columnTypeSqlId Integer = SqlBigIntT
|
||||
columnTypeSqlId Boolean = SqlBitT
|
||||
columnTypeSqlId BigInteger = SqlBigIntT
|
||||
columnTypeSqlId Double = SqlFloatT
|
||||
columnTypeSqlId (VarText _) = SqlVarCharT
|
||||
columnTypeSqlId (Text _) = SqlCharT
|
||||
columnTypeSqlId Date = SqlDateT
|
||||
columnTypeSqlId Timestamp = SqlTimestampWithZoneT
|
||||
columnTypeSqlId TextSearchVector = SqlUnknownT "3614"
|
||||
|
||||
columnTypeSqlSize :: ColumnType -> Maybe Int
|
||||
columnTypeSqlSize AutomaticId = Just 4
|
||||
columnTypeSqlSize ForeignId = Just 4
|
||||
columnTypeSqlSize Integer = Just 4
|
||||
columnTypeSqlSize BigInteger = Just 8
|
||||
columnTypeSqlSize Double = Just 8
|
||||
columnTypeSqlSize Boolean = Just 1
|
||||
columnTypeSqlSize (VarText n) = Just n
|
||||
columnTypeSqlSize (Text n) = Just n
|
||||
columnTypeSqlSize Date = Just 4
|
||||
columnTypeSqlSize Timestamp = Just 8
|
||||
columnTypeSqlSize TextSearchVector = Nothing
|
||||
|
||||
sqlFieldDesc :: FieldDefinition -> SqlColDesc
|
||||
sqlFieldDesc (_, columnType, flags) = SqlColDesc {
|
||||
colType = columnTypeSqlId columnType
|
||||
, colSize = columnTypeSqlSize columnType
|
||||
, colNullable = Just (any isNullFlag flags)
|
||||
, colOctetLength = Nothing
|
||||
, colDecDigits = Nothing
|
||||
}
|
||||
|
||||
data MigrateTableException = forall entity. MTE (TableDefinition entity) Exc.SomeException
|
||||
deriving Typeable
|
||||
|
||||
instance Show MigrateTableException where
|
||||
show = formatMigrationException
|
||||
|
||||
instance Exc.Exception MigrateTableException
|
||||
|
||||
formatMigrationException :: MigrateTableException -> String
|
||||
formatMigrationException (MTE tableDef exception) = message
|
||||
where message = "There was an error migrating table " ++ name ++ ".\n\
|
||||
\The error is:\n\
|
||||
\\n\
|
||||
\ " ++ Exc.displayException exception ++ "\\n\
|
||||
\\n\
|
||||
\\n\
|
||||
\Here are the developer comments regarding the table:\n\
|
||||
\\n\
|
||||
\ " ++ comments ++ "\
|
||||
\\n"
|
||||
|
||||
name = tableName tableDef
|
||||
comments = formatTableComments " " tableDef
|
||||
|
||||
formatTableComments :: String -> TableDefinition entity -> String
|
||||
formatTableComments indent tableDef =
|
||||
List.intercalate ("\n" ++ indent) commentLines
|
||||
where
|
||||
commentLines = map formatTableComment comments
|
||||
comments = runComments (tableComments tableDef)
|
||||
|
||||
formatTableComment :: TableComment -> String
|
||||
formatTableComment c = List.intercalate " - " [
|
||||
tcWhat c
|
||||
, show (tcWhen c)
|
||||
, tcWho c
|
||||
]
|
||||
|
122
src/Database/Orville/Internal/Monad.hs
Normal file
122
src/Database/Orville/Internal/Monad.hs
Normal file
@ -0,0 +1,122 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Database.Orville.Internal.Monad where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Base
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask(..))
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Trans.Control
|
||||
import Data.Pool
|
||||
import Database.HDBC hiding (withTransaction)
|
||||
|
||||
type Orville a = forall m conn.
|
||||
(MonadOrville conn m, MonadThrow m)
|
||||
=> m a
|
||||
|
||||
data ConnectionEnv conn = ConnectionEnv {
|
||||
ormTransactionOpen :: Bool
|
||||
, ormConnection :: conn
|
||||
}
|
||||
|
||||
data OrvilleEnv conn = OrvilleEnv {
|
||||
ormEnvPool :: Pool conn
|
||||
, ormEnvConnectionEnv :: Maybe (ConnectionEnv conn)
|
||||
}
|
||||
|
||||
newOrvilleEnv :: Pool conn -> OrvilleEnv conn
|
||||
newOrvilleEnv pool = OrvilleEnv pool Nothing
|
||||
|
||||
setConnectionEnv :: ConnectionEnv conn -> OrvilleEnv conn -> OrvilleEnv conn
|
||||
setConnectionEnv c ormEnv = ormEnv { ormEnvConnectionEnv = Just c }
|
||||
|
||||
newtype OrvilleT conn m a = OrvilleT
|
||||
{ unOrvilleT :: ReaderT (OrvilleEnv conn) m a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MonadIO
|
||||
, MonadThrow
|
||||
, MonadCatch
|
||||
, MonadMask
|
||||
)
|
||||
|
||||
mapOrvilleT :: Monad n => (m a -> n b) -> OrvilleT conn m a -> OrvilleT conn n b
|
||||
mapOrvilleT f (OrvilleT action) = OrvilleT $ do
|
||||
ma <- runReaderT action <$> ask
|
||||
lift (f ma)
|
||||
|
||||
runOrville :: OrvilleT conn m a -> Pool conn -> m a
|
||||
runOrville ormt = runReaderT (unOrvilleT ormt) . newOrvilleEnv
|
||||
|
||||
newConnectionEnv :: conn -> ConnectionEnv conn
|
||||
newConnectionEnv = ConnectionEnv False
|
||||
|
||||
withConnectionEnv :: MonadOrville conn m => (ConnectionEnv conn -> m a) -> m a
|
||||
withConnectionEnv action = do
|
||||
ormEnv <- getOrvilleEnv
|
||||
|
||||
case ormEnvConnectionEnv ormEnv of
|
||||
Just connected -> action connected
|
||||
Nothing ->
|
||||
withResource (ormEnvPool ormEnv) $ \conn -> do
|
||||
let connected = newConnectionEnv conn
|
||||
localOrvilleEnv (const $ ormEnv { ormEnvConnectionEnv = Just connected }) $
|
||||
action connected
|
||||
|
||||
withConnection :: MonadOrville conn m => (conn -> m a) -> m a
|
||||
withConnection action = withConnectionEnv (action . ormConnection)
|
||||
|
||||
instance MonadTrans (OrvilleT conn) where
|
||||
lift = OrvilleT . lift
|
||||
|
||||
instance (MonadError e m) => MonadError e (OrvilleT conn m) where
|
||||
throwError = lift . throwError
|
||||
catchError action handler =
|
||||
OrvilleT ((unOrvilleT action) `catchError` (unOrvilleT . handler))
|
||||
|
||||
instance MonadBase b m => MonadBase b (OrvilleT conn m) where
|
||||
liftBase = lift . liftBase
|
||||
|
||||
class (Monad m, MonadIO m, IConnection conn, MonadBaseControl IO m)
|
||||
=> MonadOrville conn m | m -> conn where
|
||||
getOrvilleEnv :: m (OrvilleEnv conn)
|
||||
localOrvilleEnv :: (OrvilleEnv conn -> OrvilleEnv conn) -> m a -> m a
|
||||
|
||||
startTransactionSQL :: m String
|
||||
startTransactionSQL = pure "START TRANSACTION"
|
||||
|
||||
instance (Monad m, MonadIO m, IConnection conn, MonadBaseControl IO m)
|
||||
=> MonadOrville conn (OrvilleT conn m) where
|
||||
getOrvilleEnv = OrvilleT ask
|
||||
localOrvilleEnv modEnv (OrvilleT a) = OrvilleT (local modEnv a)
|
||||
|
||||
instance MonadOrville conn m => MonadOrville conn (ReaderT a m) where
|
||||
getOrvilleEnv = lift getOrvilleEnv
|
||||
localOrvilleEnv modEnv action =
|
||||
ReaderT $ \val -> localOrvilleEnv modEnv (runReaderT action val)
|
||||
|
||||
instance MonadOrville conn m => MonadOrville conn (StateT a m) where
|
||||
getOrvilleEnv = lift getOrvilleEnv
|
||||
localOrvilleEnv modEnv action =
|
||||
StateT $ \val -> localOrvilleEnv modEnv (runStateT action val)
|
||||
|
||||
instance MonadTransControl (OrvilleT conn) where
|
||||
type StT (OrvilleT conn) a = StT (ReaderT (OrvilleEnv conn)) a
|
||||
|
||||
liftWith = defaultLiftWith OrvilleT unOrvilleT
|
||||
restoreT = defaultRestoreT OrvilleT
|
||||
|
||||
instance MonadBaseControl b m => MonadBaseControl b (OrvilleT conn m) where
|
||||
type StM (OrvilleT conn m) a = ComposeSt (OrvilleT conn) m a
|
||||
liftBaseWith = defaultLiftBaseWith
|
||||
restoreM = defaultRestoreM
|
||||
|
46
src/Database/Orville/Internal/OrderBy.hs
Normal file
46
src/Database/Orville/Internal/OrderBy.hs
Normal file
@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Database.Orville.Internal.OrderBy where
|
||||
|
||||
import Database.HDBC
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
import Database.Orville.Internal.QueryKey
|
||||
|
||||
data SortDirection =
|
||||
Ascending
|
||||
| Descending
|
||||
deriving Show
|
||||
|
||||
instance QueryKeyable SortDirection where
|
||||
queryKey dir = QKOp (sqlDirection dir) QKEmpty
|
||||
|
||||
sqlDirection :: SortDirection -> String
|
||||
sqlDirection Ascending = "ASC"
|
||||
sqlDirection Descending = "DESC"
|
||||
|
||||
data OrderByClause = OrderByClause String
|
||||
[SqlValue]
|
||||
SortDirection
|
||||
|
||||
instance QueryKeyable OrderByClause where
|
||||
queryKey (OrderByClause sql vals dir) =
|
||||
QKList [QKField sql, queryKey vals, queryKey dir]
|
||||
|
||||
sortingSql :: OrderByClause -> String
|
||||
sortingSql (OrderByClause sql _ sortDir) =
|
||||
sql ++ " " ++ sqlDirection sortDir
|
||||
|
||||
sortingValues :: OrderByClause -> [SqlValue]
|
||||
sortingValues (OrderByClause _ values _) =
|
||||
values
|
||||
|
||||
class ToOrderBy a where
|
||||
toOrderBy :: a -> SortDirection -> OrderByClause
|
||||
|
||||
instance ToOrderBy FieldDefinition where
|
||||
toOrderBy fieldDef = OrderByClause (fieldName fieldDef) []
|
||||
|
||||
instance ToOrderBy (String, [SqlValue]) where
|
||||
toOrderBy (sql, values) = OrderByClause sql values
|
||||
|
128
src/Database/Orville/Internal/QueryCache.hs
Normal file
128
src/Database/Orville/Internal/QueryCache.hs
Normal file
@ -0,0 +1,128 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Database.Orville.Internal.QueryCache
|
||||
( QueryCached
|
||||
, runQueryCached
|
||||
, selectCached
|
||||
, selectFirstCached
|
||||
, findRecordCached
|
||||
, findRecordsCached
|
||||
, findRecordsByCached
|
||||
, unsafeLift
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Catch (MonadThrow)
|
||||
import Control.Monad.Trans
|
||||
import Control.Monad.Trans.State
|
||||
import Data.Convertible
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Map.Helpers as Map
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Database.HDBC hiding (withTransaction)
|
||||
|
||||
import Database.Orville.Internal.FromSql
|
||||
import Database.Orville.Internal.Monad
|
||||
import Database.Orville.Internal.QueryKey
|
||||
import Database.Orville.Internal.SelectOptions
|
||||
import Database.Orville.Internal.TableDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
import Database.Orville.Internal.Where
|
||||
import Database.Orville.Raw
|
||||
|
||||
type QueryCache = Map.Map QueryKey ResultSet
|
||||
|
||||
newtype QueryCached m a =
|
||||
QueryCached (StateT QueryCache m a)
|
||||
deriving
|
||||
(Functor, Applicative, Monad)
|
||||
|
||||
runQueryCached :: Monad m => QueryCached m a -> m a
|
||||
runQueryCached (QueryCached statet) = evalStateT statet Map.empty
|
||||
|
||||
cached :: Monad m => QueryKey -> QueryCached m ResultSet -> QueryCached m ResultSet
|
||||
cached key action = do
|
||||
cache <- QueryCached get
|
||||
|
||||
case Map.lookup key cache of
|
||||
Just result -> do
|
||||
pure result
|
||||
Nothing -> do
|
||||
result <- action
|
||||
QueryCached $ put (Map.insert key result cache)
|
||||
pure result
|
||||
|
||||
selectCachedRows :: (MonadThrow m, MonadOrville conn m)
|
||||
=> TableDefinition entity
|
||||
-> SelectOptions
|
||||
-> QueryCached m ResultSet
|
||||
selectCachedRows tableDef opts =
|
||||
cached key $ unsafeLift $ selectSqlRows querySql (selectOptValues opts)
|
||||
where
|
||||
selectClause = mkSelectClause tableDef
|
||||
key = mconcat [queryKey tableDef, queryKey opts]
|
||||
|
||||
querySql = List.intercalate " " [
|
||||
selectClause
|
||||
, selectOptClause opts
|
||||
]
|
||||
|
||||
selectCached :: (MonadThrow m, MonadOrville conn m)
|
||||
=> TableDefinition entity
|
||||
-> SelectOptions
|
||||
-> QueryCached m [entity Record]
|
||||
selectCached tableDef opts = do
|
||||
rows <- selectCachedRows tableDef opts
|
||||
unsafeLift $ decodeSqlRows (tableFromSql tableDef) rows
|
||||
|
||||
selectFirstCached :: (MonadThrow m, MonadOrville conn m)
|
||||
=> TableDefinition entity
|
||||
-> SelectOptions
|
||||
-> QueryCached m (Maybe (entity Record))
|
||||
selectFirstCached tableDef opts =
|
||||
listToMaybe <$> selectCached tableDef (limit 1 <> opts)
|
||||
|
||||
findRecordsCached :: (MonadThrow m, MonadOrville conn m)
|
||||
=> TableDefinition entity
|
||||
-> [Record]
|
||||
-> QueryCached m (Map.Map Record (entity Record))
|
||||
findRecordsCached tableDef recordIds = do
|
||||
let keyField = tablePrimaryKey tableDef
|
||||
mkEntry record = (tableGetKey tableDef record, record)
|
||||
|
||||
recordList <- selectCached tableDef (where_ $ keyField .<- recordIds)
|
||||
pure $ Map.fromList (map mkEntry recordList)
|
||||
|
||||
findRecordCached :: (MonadThrow m, MonadOrville conn m)
|
||||
=> TableDefinition entity
|
||||
-> Record
|
||||
-> QueryCached m (Maybe (entity Record))
|
||||
findRecordCached tableDef recordId = do
|
||||
let keyField = tablePrimaryKey tableDef
|
||||
selectFirstCached tableDef (where_ $ keyField .== recordId)
|
||||
|
||||
findRecordsByCached :: ( Convertible SqlValue fieldValue
|
||||
, Ord fieldValue
|
||||
, MonadThrow m
|
||||
, MonadOrville conn m)
|
||||
=> TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SelectOptions
|
||||
-> QueryCached m (Map.Map fieldValue [entity Record])
|
||||
findRecordsByCached tableDef field opts = do
|
||||
let builder = (,) <$> col field <*> tableFromSql tableDef
|
||||
rows <- selectCachedRows tableDef opts
|
||||
Map.groupBy' id <$> unsafeLift (decodeSqlRows builder rows)
|
||||
|
||||
-- this is unsafe in the sense that it does not provide
|
||||
-- any guarantees that the action won't chance values in
|
||||
-- the database, rendering the cache incorrect. It is not
|
||||
-- exposed publically, but all usages of it here need to
|
||||
-- be examined for correctness manually.
|
||||
--
|
||||
unsafeLift :: Monad m => m a -> QueryCached m a
|
||||
unsafeLift = QueryCached . lift
|
||||
|
||||
|
149
src/Database/Orville/Internal/QueryKey.hs
Normal file
149
src/Database/Orville/Internal/QueryKey.hs
Normal file
@ -0,0 +1,149 @@
|
||||
module Database.Orville.Internal.QueryKey where
|
||||
|
||||
import Data.Monoid
|
||||
import Data.Time.LocalTime
|
||||
import Database.HDBC
|
||||
|
||||
data QueryKey =
|
||||
QKValue OrdSqlValue
|
||||
| QKField String
|
||||
| QKTable String
|
||||
| QKOp String QueryKey
|
||||
| QKList [QueryKey]
|
||||
| QKEmpty
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Monoid QueryKey where
|
||||
mempty = QKEmpty
|
||||
mappend a b = QKList [a, b]
|
||||
mconcat = QKList
|
||||
|
||||
class QueryKeyable a where
|
||||
queryKey :: a -> QueryKey
|
||||
|
||||
instance QueryKeyable QueryKey where
|
||||
queryKey = id
|
||||
|
||||
instance QueryKeyable a => QueryKeyable [a] where
|
||||
queryKey = foldMap queryKey
|
||||
|
||||
instance QueryKeyable a => QueryKeyable (Maybe a) where
|
||||
queryKey = foldMap queryKey
|
||||
|
||||
instance QueryKeyable SqlValue where
|
||||
queryKey = QKValue . OrdSqlValue
|
||||
|
||||
qkOp :: (QueryKeyable a)
|
||||
=> String -> a -> QueryKey
|
||||
qkOp op a = QKOp op $ queryKey a
|
||||
|
||||
qkOp2 :: (QueryKeyable a, QueryKeyable b)
|
||||
=> String -> a -> b -> QueryKey
|
||||
qkOp2 op a b = QKOp op $ QKList [queryKey a, queryKey b]
|
||||
|
||||
newtype OrdSqlValue = OrdSqlValue SqlValue
|
||||
|
||||
instance Ord OrdSqlValue where
|
||||
compare (OrdSqlValue s) (OrdSqlValue s') = compareSqlValue s s'
|
||||
|
||||
instance Eq OrdSqlValue where
|
||||
a == b = compare a b == EQ
|
||||
|
||||
compareSqlValue :: SqlValue -> SqlValue -> Ordering
|
||||
|
||||
compareSqlValue (SqlString v) (SqlString v') = compare v v'
|
||||
compareSqlValue (SqlString _) _ = LT
|
||||
compareSqlValue _ (SqlString _) = GT
|
||||
|
||||
compareSqlValue (SqlByteString v) (SqlByteString v') = compare v v'
|
||||
compareSqlValue (SqlByteString _) _ = LT
|
||||
compareSqlValue _ (SqlByteString _) = GT
|
||||
|
||||
compareSqlValue (SqlWord32 v) (SqlWord32 v') = compare v v'
|
||||
compareSqlValue (SqlWord32 _) _ = LT
|
||||
compareSqlValue _ (SqlWord32 _) = GT
|
||||
|
||||
compareSqlValue (SqlWord64 v) (SqlWord64 v') = compare v v'
|
||||
compareSqlValue (SqlWord64 _) _ = LT
|
||||
compareSqlValue _ (SqlWord64 _) = GT
|
||||
|
||||
compareSqlValue (SqlInt32 v) (SqlInt32 v') = compare v v'
|
||||
compareSqlValue (SqlInt32 _) _ = LT
|
||||
compareSqlValue _ (SqlInt32 _) = GT
|
||||
|
||||
compareSqlValue (SqlInt64 v) (SqlInt64 v') = compare v v'
|
||||
compareSqlValue (SqlInt64 _) _ = LT
|
||||
compareSqlValue _ (SqlInt64 _) = GT
|
||||
|
||||
compareSqlValue (SqlInt32 v) (SqlInt32 v') = compare v v'
|
||||
compareSqlValue (SqlInt32 _) _ = LT
|
||||
compareSqlValue _ (SqlInt32 _) = GT
|
||||
|
||||
compareSqlValue (SqlInteger v) (SqlInteger v') = compare v v'
|
||||
compareSqlValue (SqlInteger _) _ = LT
|
||||
compareSqlValue _ (SqlInteger _) = GT
|
||||
|
||||
compareSqlValue (SqlChar v) (SqlChar v') = compare v v'
|
||||
compareSqlValue (SqlChar _) _ = LT
|
||||
compareSqlValue _ (SqlChar _) = GT
|
||||
|
||||
compareSqlValue (SqlBool v) (SqlBool v') = compare v v'
|
||||
compareSqlValue (SqlBool _) _ = LT
|
||||
compareSqlValue _ (SqlBool _) = GT
|
||||
|
||||
compareSqlValue (SqlDouble v) (SqlDouble v') = compare v v'
|
||||
compareSqlValue (SqlDouble _) _ = LT
|
||||
compareSqlValue _ (SqlDouble _) = GT
|
||||
|
||||
compareSqlValue (SqlRational v) (SqlRational v') = compare v v'
|
||||
compareSqlValue (SqlRational _) _ = LT
|
||||
compareSqlValue _ (SqlRational _) = GT
|
||||
|
||||
compareSqlValue (SqlLocalDate v) (SqlLocalDate v') = compare v v'
|
||||
compareSqlValue (SqlLocalDate _) _ = LT
|
||||
compareSqlValue _ (SqlLocalDate _) = GT
|
||||
|
||||
compareSqlValue (SqlLocalTimeOfDay v) (SqlLocalTimeOfDay v') = compare v v'
|
||||
compareSqlValue (SqlLocalTimeOfDay _) _ = LT
|
||||
compareSqlValue _ (SqlLocalTimeOfDay _) = GT
|
||||
|
||||
compareSqlValue (SqlZonedLocalTimeOfDay v z) (SqlZonedLocalTimeOfDay v' z') =
|
||||
compare v v' <> compare z z'
|
||||
|
||||
compareSqlValue (SqlZonedLocalTimeOfDay _ _) _ = LT
|
||||
compareSqlValue _ (SqlZonedLocalTimeOfDay _ _) = GT
|
||||
|
||||
compareSqlValue (SqlLocalTime v) (SqlLocalTime v') = compare v v'
|
||||
compareSqlValue (SqlLocalTime _) _ = LT
|
||||
compareSqlValue _ (SqlLocalTime _) = GT
|
||||
|
||||
compareSqlValue (SqlZonedTime (ZonedTime v z)) (SqlZonedTime (ZonedTime v' z')) =
|
||||
compare v v' <> compare z z'
|
||||
|
||||
compareSqlValue (SqlZonedTime _) _ = LT
|
||||
compareSqlValue _ (SqlZonedTime _) = GT
|
||||
|
||||
compareSqlValue (SqlUTCTime v) (SqlUTCTime v') = compare v v'
|
||||
compareSqlValue (SqlUTCTime _) _ = LT
|
||||
compareSqlValue _ (SqlUTCTime _) = GT
|
||||
|
||||
compareSqlValue (SqlDiffTime v) (SqlDiffTime v') = compare v v'
|
||||
compareSqlValue (SqlDiffTime _) _ = LT
|
||||
compareSqlValue _ (SqlDiffTime _) = GT
|
||||
|
||||
compareSqlValue (SqlPOSIXTime v) (SqlPOSIXTime v') = compare v v'
|
||||
compareSqlValue (SqlPOSIXTime _) _ = LT
|
||||
compareSqlValue _ (SqlPOSIXTime _) = GT
|
||||
|
||||
compareSqlValue (SqlEpochTime v) (SqlEpochTime v') = compare v v'
|
||||
compareSqlValue (SqlEpochTime _) _ = LT
|
||||
compareSqlValue _ (SqlEpochTime _) = GT
|
||||
|
||||
compareSqlValue (SqlTimeDiff v) (SqlTimeDiff v') = compare v v'
|
||||
compareSqlValue (SqlTimeDiff _) _ = LT
|
||||
compareSqlValue _ (SqlTimeDiff _) = GT
|
||||
|
||||
compareSqlValue SqlNull SqlNull = EQ
|
||||
compareSqlValue SqlNull _ = LT
|
||||
compareSqlValue _ SqlNull = GT
|
||||
|
106
src/Database/Orville/Internal/SelectOptions.hs
Normal file
106
src/Database/Orville/Internal/SelectOptions.hs
Normal file
@ -0,0 +1,106 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Database.Orville.Internal.SelectOptions where
|
||||
|
||||
import Data.Convertible
|
||||
import qualified Data.List as List
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Database.HDBC
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition ()
|
||||
import Database.Orville.Internal.OrderBy
|
||||
import Database.Orville.Internal.Types ()
|
||||
import Database.Orville.Internal.Where
|
||||
import Database.Orville.Internal.QueryKey
|
||||
|
||||
data SelectOptions = SelectOptions {
|
||||
selectOptWhere :: [WhereCondition]
|
||||
, selectOptOrder :: [OrderByClause]
|
||||
, selectOptLimit :: First Int
|
||||
, selectOptOffset :: First Int
|
||||
}
|
||||
|
||||
selectOptLimitSql :: SelectOptions -> Maybe SqlValue
|
||||
selectOptLimitSql = fmap convert . getFirst . selectOptLimit
|
||||
|
||||
selectOptOffsetSql :: SelectOptions -> Maybe SqlValue
|
||||
selectOptOffsetSql = fmap convert . getFirst . selectOptOffset
|
||||
|
||||
instance Monoid SelectOptions where
|
||||
mempty = SelectOptions mempty mempty mempty mempty
|
||||
mappend opt opt' =
|
||||
SelectOptions (selectOptWhere opt <> selectOptWhere opt')
|
||||
(selectOptOrder opt <> selectOptOrder opt')
|
||||
(selectOptLimit opt <> selectOptLimit opt')
|
||||
(selectOptOffset opt <> selectOptOffset opt')
|
||||
|
||||
instance QueryKeyable SelectOptions where
|
||||
queryKey opt =
|
||||
mconcat [ qkOp "WHERE" $ selectOptWhere opt
|
||||
, qkOp "ORDER" $ selectOptOrder opt
|
||||
, qkOp "LIMIT" $ selectOptLimitSql opt
|
||||
, qkOp "OFFSET" $ selectOptOffsetSql opt
|
||||
]
|
||||
|
||||
selectOptClause :: SelectOptions -> String
|
||||
selectOptClause opts = List.intercalate " "
|
||||
[ selectWhereClause opts
|
||||
, selectOrderByClause opts
|
||||
, selectLimitClause opts
|
||||
, selectOffsetClause opts
|
||||
]
|
||||
|
||||
selectWhereClause :: SelectOptions -> String
|
||||
selectWhereClause = whereClause . selectOptWhere
|
||||
|
||||
selectOrderByClause :: SelectOptions -> String
|
||||
selectOrderByClause = clause . selectOptOrder
|
||||
where
|
||||
clause [] = ""
|
||||
clause sortClauses =
|
||||
"ORDER BY " ++ List.intercalate ", " (map sortingSql sortClauses)
|
||||
|
||||
selectOptValues :: SelectOptions -> [SqlValue]
|
||||
selectOptValues opts = concat [
|
||||
whereValues $ selectOptWhere opts
|
||||
, concatMap sortingValues $ selectOptOrder opts
|
||||
, maybeToList $ selectOptLimitSql opts
|
||||
, maybeToList $ selectOptOffsetSql opts
|
||||
]
|
||||
|
||||
selectLimitClause :: SelectOptions -> String
|
||||
selectLimitClause opts =
|
||||
case getFirst $ selectOptLimit opts of
|
||||
Nothing -> ""
|
||||
Just _ -> "LIMIT ?"
|
||||
|
||||
selectOffsetClause :: SelectOptions -> String
|
||||
selectOffsetClause opts =
|
||||
case getFirst $ selectOptOffset opts of
|
||||
Nothing -> ""
|
||||
Just _ -> "OFFSET ?"
|
||||
|
||||
where_ :: WhereCondition -> SelectOptions
|
||||
where_ clause = SelectOptions [clause]
|
||||
mempty
|
||||
mempty
|
||||
mempty
|
||||
|
||||
order :: ToOrderBy a => a -> SortDirection -> SelectOptions
|
||||
order orderable dir = SelectOptions mempty
|
||||
[toOrderBy orderable dir]
|
||||
mempty
|
||||
mempty
|
||||
|
||||
limit :: Int -> SelectOptions
|
||||
limit n = SelectOptions mempty
|
||||
mempty
|
||||
(First $ Just n)
|
||||
mempty
|
||||
|
||||
offset :: Int -> SelectOptions
|
||||
offset n = SelectOptions mempty
|
||||
mempty
|
||||
mempty
|
||||
(First $ Just n)
|
||||
|
43
src/Database/Orville/Internal/TableDefinition.hs
Normal file
43
src/Database/Orville/Internal/TableDefinition.hs
Normal file
@ -0,0 +1,43 @@
|
||||
module Database.Orville.Internal.TableDefinition where
|
||||
|
||||
import qualified Data.List as List
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.FieldUpdate
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
tableColumnNames :: TableDefinition entity -> [String]
|
||||
tableColumnNames = map fieldName . tableFields
|
||||
|
||||
tablePrimaryKey :: TableDefinition entity -> FieldDefinition
|
||||
tablePrimaryKey tableDef =
|
||||
case List.find isPrimaryKeyField (tableFields tableDef) of
|
||||
Just field -> field
|
||||
Nothing -> error $ "No primary key defined for " ++ tableName tableDef
|
||||
|
||||
mkInsertClause :: TableDefinition entity -> String
|
||||
mkInsertClause tableDef =
|
||||
"INSERT INTO \"" ++ tableName tableDef ++
|
||||
"\" (" ++ columns ++ ") VALUES (" ++ placeholders ++ ")"
|
||||
|
||||
where insertFields = filter (not . isUninsertedField)
|
||||
(tableFields tableDef)
|
||||
|
||||
columns = List.intercalate "," $ map fieldName insertFields
|
||||
placeholders = List.intercalate "," $ map (const "?") insertFields
|
||||
|
||||
mkUpdateClause :: TableDefinition entity -> [FieldUpdate] -> String
|
||||
mkUpdateClause tableDef updates =
|
||||
"UPDATE \"" ++ tableName tableDef ++
|
||||
"\" SET " ++ placeholders
|
||||
where placeholders = List.intercalate "," $ map fieldUpdateSql updates
|
||||
|
||||
mkSelectClause :: TableDefinition entity -> String
|
||||
mkSelectClause tableDef =
|
||||
"SELECT " ++ columns ++ " FROM \"" ++ tableName tableDef ++ "\""
|
||||
where columns = List.intercalate ", " $ tableColumnNames tableDef
|
||||
|
||||
mkDeleteClause :: TableDefinition entity -> String
|
||||
mkDeleteClause tableDef =
|
||||
"DELETE FROM \"" ++ tableName tableDef ++ "\""
|
||||
|
178
src/Database/Orville/Internal/Types.hs
Normal file
178
src/Database/Orville/Internal/Types.hs
Normal file
@ -0,0 +1,178 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Database.Orville.Internal.Types where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Writer
|
||||
import Data.Typeable
|
||||
import Database.HDBC
|
||||
|
||||
import qualified Data.Time as Time
|
||||
|
||||
import Database.Orville.Internal.QueryKey
|
||||
|
||||
type Record = Int
|
||||
type CreatedAt = Time.UTCTime
|
||||
|
||||
data ColumnType =
|
||||
AutomaticId
|
||||
| ForeignId
|
||||
| Text Int
|
||||
| VarText Int
|
||||
| Date
|
||||
| Timestamp
|
||||
| Integer
|
||||
| BigInteger
|
||||
| TextSearchVector
|
||||
| Double
|
||||
| Boolean
|
||||
|
||||
data ColumnFlag =
|
||||
PrimaryKey
|
||||
| forall a. ColumnDefault a => InsertDefault a
|
||||
| forall a. ColumnDefault a => Default a
|
||||
| Null
|
||||
| Unique
|
||||
| forall entity. References (TableDefinition entity) FieldDefinition
|
||||
|
||||
class ColumnDefault a where
|
||||
toColumnDefaultSql :: a -> String
|
||||
|
||||
data Now = Now
|
||||
|
||||
instance ColumnDefault [Char] where
|
||||
toColumnDefaultSql s = "'" ++ s ++ "'"
|
||||
|
||||
instance ColumnDefault Now where
|
||||
toColumnDefaultSql _ = "(now() at time zone 'utc')"
|
||||
|
||||
instance ColumnDefault Integer where
|
||||
toColumnDefaultSql val = show val
|
||||
|
||||
instance ColumnDefault Bool where
|
||||
toColumnDefaultSql True = "true"
|
||||
toColumnDefaultSql False = "false"
|
||||
|
||||
|
||||
type FieldDefinition = (String, ColumnType, [ColumnFlag])
|
||||
|
||||
instance QueryKeyable (String, ColumnType, [ColumnFlag]) where
|
||||
queryKey (name, _, _) = QKField name
|
||||
|
||||
data FieldUpdate = FieldUpdate {
|
||||
fieldUpdateField :: FieldDefinition
|
||||
, fieldUpdateValue :: SqlValue
|
||||
}
|
||||
|
||||
type ColumnName = String
|
||||
|
||||
data TableComment = TableComment {
|
||||
tcWhat :: String
|
||||
, tcWhen :: (Int, Int, Int)
|
||||
, tcWho :: String
|
||||
}
|
||||
|
||||
newtype TableComments a = TableComments (Writer [TableComment] a)
|
||||
deriving (Functor, Applicative, Monad)
|
||||
|
||||
runComments :: TableComments a -> [TableComment]
|
||||
runComments (TableComments commenter) = snd (runWriter commenter)
|
||||
|
||||
noComments :: TableComments ()
|
||||
noComments = return ()
|
||||
|
||||
say :: String -> (Int, Int, Int) -> String -> TableComments ()
|
||||
say msg date commenter = TableComments $
|
||||
writer ((), [TableComment msg date commenter])
|
||||
|
||||
data FromSqlError =
|
||||
RowDataError String
|
||||
| QueryError String
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Exception FromSqlError
|
||||
|
||||
newtype FromSql a = FromSql { unFromSql :: ReaderT String
|
||||
(StateT [(String, SqlValue)]
|
||||
(Either FromSqlError))
|
||||
a
|
||||
}
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadError FromSqlError
|
||||
, MonadReader String
|
||||
, MonadState [(String, SqlValue)]
|
||||
)
|
||||
|
||||
runFromSql :: FromSql a -> [(String,SqlValue)] -> Either FromSqlError a
|
||||
runFromSql = evalStateT . flip runReaderT "" . unFromSql
|
||||
|
||||
newtype ToSql a b = ToSql { unToSql :: ReaderT a
|
||||
(State [SqlValue])
|
||||
b
|
||||
}
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadState [SqlValue]
|
||||
, MonadReader a
|
||||
)
|
||||
|
||||
runToSql :: ToSql a b -> a -> [SqlValue]
|
||||
runToSql tosql a = reverse $ execState (runReaderT (unToSql tosql) a) []
|
||||
|
||||
getComponent :: (entity -> a) -> ToSql a () -> ToSql entity ()
|
||||
getComponent getComp (ToSql serializer) =
|
||||
ToSql (withReaderT getComp serializer)
|
||||
|
||||
data TableDefinition entity = TableDefinition {
|
||||
tableName :: String
|
||||
, tableFields :: [FieldDefinition]
|
||||
, tableSafeToDelete :: [ColumnName]
|
||||
, tableFromSql :: FromSql (entity Record)
|
||||
, tableToSql :: forall key. ToSql (entity key) ()
|
||||
, tableSetKey :: forall key1 key2. key2 -> entity key1 -> entity key2
|
||||
, tableGetKey :: forall key. entity key -> key
|
||||
, tableComments :: TableComments ()
|
||||
}
|
||||
|
||||
instance QueryKeyable (TableDefinition entity) where
|
||||
queryKey = QKTable . tableName
|
||||
|
||||
data SchemaItem =
|
||||
forall entity. Table (TableDefinition entity)
|
||||
| DropTable String
|
||||
|
||||
| Index IndexDefinition
|
||||
| DropIndex String
|
||||
|
||||
| Constraint ConstraintDefinition
|
||||
| DropConstraint String String
|
||||
|
||||
instance Show SchemaItem where
|
||||
show (Table tableDef) = "Table <" ++ tableName tableDef ++ " definition>"
|
||||
show (DropTable name) = "DropTable " ++ show name
|
||||
show (Index indexDef) = "Index (" ++ show indexDef ++ ")"
|
||||
show (DropIndex name) = "DropIndex " ++ show name
|
||||
|
||||
type SchemaDefinition = [SchemaItem]
|
||||
|
||||
data IndexDefinition = IndexDefinition {
|
||||
indexName :: String
|
||||
, indexUnique :: Bool
|
||||
, indexTable :: String
|
||||
, indexBody :: String
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data ConstraintDefinition = ConstraintDefinition {
|
||||
constraintName :: String
|
||||
, constraintTable :: String
|
||||
, constraintBody :: String
|
||||
} deriving (Eq, Show)
|
||||
|
111
src/Database/Orville/Internal/Where.hs
Normal file
111
src/Database/Orville/Internal/Where.hs
Normal file
@ -0,0 +1,111 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Database.Orville.Internal.Where where
|
||||
|
||||
import Data.Convertible
|
||||
import qualified Data.List as List
|
||||
import Database.HDBC
|
||||
|
||||
import Database.Orville.Internal.FieldDefinition
|
||||
import Database.Orville.Internal.Types
|
||||
import Database.Orville.Internal.QueryKey
|
||||
|
||||
data WhereCondition =
|
||||
BinOp String FieldDefinition SqlValue
|
||||
| IsNull FieldDefinition
|
||||
| IsNotNull FieldDefinition
|
||||
| In FieldDefinition [SqlValue]
|
||||
| Or [WhereCondition]
|
||||
| And [WhereCondition]
|
||||
| AlwaysFalse
|
||||
|
||||
instance QueryKeyable WhereCondition where
|
||||
queryKey (BinOp op field value) = qkOp2 op field value
|
||||
queryKey (IsNull field) = qkOp "IS NULL" field
|
||||
queryKey (IsNotNull field) = qkOp "NOT IS NULL" field
|
||||
queryKey (In field values) = qkOp2 "IN" field values
|
||||
queryKey (Or conds) = qkOp "OR" conds
|
||||
queryKey (And conds) = qkOp "And" conds
|
||||
queryKey AlwaysFalse = qkOp "FALSE" QKEmpty
|
||||
|
||||
(.==) :: Convertible a SqlValue
|
||||
=> FieldDefinition -> a -> WhereCondition
|
||||
fieldDef .== a = BinOp "=" fieldDef (convert a)
|
||||
|
||||
(.>) :: Convertible a SqlValue
|
||||
=> FieldDefinition -> a -> WhereCondition
|
||||
fieldDef .> a = BinOp ">" fieldDef (convert a)
|
||||
|
||||
(.>=) :: Convertible a SqlValue
|
||||
=> FieldDefinition -> a -> WhereCondition
|
||||
fieldDef .>= a = BinOp ">=" fieldDef (convert a)
|
||||
|
||||
(.<) :: Convertible a SqlValue
|
||||
=> FieldDefinition -> a -> WhereCondition
|
||||
fieldDef .< a = BinOp "<" fieldDef (convert a)
|
||||
|
||||
(.<=) :: Convertible a SqlValue
|
||||
=> FieldDefinition -> a -> WhereCondition
|
||||
fieldDef .<= a = BinOp "<=" fieldDef (convert a)
|
||||
|
||||
(.<-) :: Convertible a SqlValue
|
||||
=> FieldDefinition -> [a] -> WhereCondition
|
||||
_ .<- [] = AlwaysFalse
|
||||
fieldDef .<- as = In fieldDef (List.nub $ map convert as)
|
||||
|
||||
(%==) :: Convertible a SqlValue
|
||||
=> FieldDefinition -> a -> WhereCondition
|
||||
fieldDef %== a = BinOp "@@" fieldDef (convert a)
|
||||
|
||||
whereConditionSql :: WhereCondition -> String
|
||||
whereConditionSql (BinOp op fieldDef _) =
|
||||
fieldName fieldDef ++ " " ++ op ++ " ?"
|
||||
|
||||
whereConditionSql (IsNull fieldDef) =
|
||||
fieldName fieldDef ++ " IS NULL"
|
||||
|
||||
whereConditionSql (IsNotNull fieldDef) =
|
||||
fieldName fieldDef ++ " IS NOT NULL"
|
||||
|
||||
whereConditionSql (In fieldDef values) =
|
||||
fieldName fieldDef ++ " IN (" ++ quesses ++ ")"
|
||||
where
|
||||
quesses = List.intercalate "," (map (const "?") values)
|
||||
|
||||
whereConditionSql AlwaysFalse = "TRUE = FALSE"
|
||||
|
||||
whereConditionSql (Or conds) = List.intercalate " OR " condsSql
|
||||
where condsSql = map condSql conds
|
||||
condSql c = "(" ++ whereConditionSql c ++ ")"
|
||||
|
||||
whereConditionSql (And conds) = List.intercalate " AND " condsSql
|
||||
where condsSql = map condSql conds
|
||||
condSql c = "(" ++ whereConditionSql c ++ ")"
|
||||
|
||||
whereConditionValues :: WhereCondition -> [SqlValue]
|
||||
whereConditionValues (BinOp _ _ value) = [value]
|
||||
whereConditionValues (IsNull _) = []
|
||||
whereConditionValues (IsNotNull _) = []
|
||||
whereConditionValues (In _ values) = values
|
||||
whereConditionValues AlwaysFalse = []
|
||||
whereConditionValues (Or conds) = concatMap whereConditionValues conds
|
||||
whereConditionValues (And conds) = concatMap whereConditionValues conds
|
||||
|
||||
whereAnd :: [WhereCondition] -> WhereCondition
|
||||
whereAnd = And
|
||||
|
||||
whereOr :: [WhereCondition] -> WhereCondition
|
||||
whereOr = Or
|
||||
|
||||
isNull :: FieldDefinition -> WhereCondition
|
||||
isNull fieldDef = IsNull fieldDef
|
||||
|
||||
isNotNull :: FieldDefinition -> WhereCondition
|
||||
isNotNull fieldDef = IsNotNull fieldDef
|
||||
|
||||
whereClause :: [WhereCondition] -> String
|
||||
whereClause [] = ""
|
||||
whereClause conds = "WHERE " ++ whereConditionSql (whereAnd conds)
|
||||
|
||||
whereValues :: [WhereCondition] -> [SqlValue]
|
||||
whereValues = List.concatMap whereConditionValues
|
||||
|
483
src/Database/Orville/Popper.hs
Normal file
483
src/Database/Orville/Popper.hs
Normal file
@ -0,0 +1,483 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Database.Orville.Popper
|
||||
( PopError(..)
|
||||
, Popper
|
||||
, Popped(..)
|
||||
, (>>>), (<<<)
|
||||
, abortPop
|
||||
, certainly
|
||||
, certainly'
|
||||
, fromKern
|
||||
, hasMany
|
||||
, hasManyIn
|
||||
, hasManyWhere
|
||||
, hasOne
|
||||
, hasOne'
|
||||
, hasOneWhere
|
||||
, kern
|
||||
, missingRecordMessage
|
||||
, popMissingRecord
|
||||
, onKern
|
||||
, pop, popThrow
|
||||
, popFirst
|
||||
, popMany
|
||||
, popMaybe
|
||||
, popQuery
|
||||
, popRecord
|
||||
, popRecord'
|
||||
, popTable
|
||||
) where
|
||||
|
||||
import Prelude hiding ((.))
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Control.Category
|
||||
import Control.Monad.Catch
|
||||
import Data.Convertible
|
||||
import Data.Either
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
|
||||
import Database.Orville.Core
|
||||
import Database.Orville.Internal.FieldDefinition (fieldName)
|
||||
import Database.Orville.Internal.QueryCache
|
||||
|
||||
-- Simple helpers and such that make the public API
|
||||
|
||||
kern :: Popper a a
|
||||
kern = PopId
|
||||
|
||||
fromKern :: (a -> b) -> Popper a b
|
||||
fromKern f = f <$> kern
|
||||
|
||||
onKern :: (a -> b -> c) -> Popper b a -> Popper b c
|
||||
onKern mkPuff popper = mkPuff <$> popper <*> kern
|
||||
|
||||
liftPop :: (a -> Popped b) -> Popper a b
|
||||
liftPop = PopLift
|
||||
|
||||
abortPop :: PopError -> Popper a b
|
||||
abortPop = PopAbort
|
||||
|
||||
popQuery :: Orville b -> Popper a b
|
||||
popQuery = PopQuery
|
||||
|
||||
certainly :: PopError-> Popper (Maybe b) b
|
||||
certainly err = liftPop $ maybe (PoppedError err) PoppedValue
|
||||
|
||||
certainly' :: Popper a PopError
|
||||
-> Popper a (Maybe b)
|
||||
-> Popper a b
|
||||
certainly' msgPopper bPopper =
|
||||
(msgPopper &&& bPopper) >>>
|
||||
liftPop (\(err, maybeB) -> maybe (PoppedError err) PoppedValue maybeB)
|
||||
|
||||
popRecord :: TableDefinition entity
|
||||
-> Record
|
||||
-> Popper a (Maybe (entity Record))
|
||||
popRecord tableDef recordId = popQuery (findRecord tableDef recordId)
|
||||
|
||||
popRecord' :: TableDefinition entity
|
||||
-> Record
|
||||
-> Popper a (entity Record)
|
||||
popRecord' td ri =
|
||||
popRecord td ri >>> certainly err
|
||||
where
|
||||
err = MissingRecord td (tablePrimaryKey td) (convert ri)
|
||||
|
||||
popFirst :: TableDefinition entity
|
||||
-> SelectOptions
|
||||
-> Popper a (Maybe (entity Record))
|
||||
popFirst tableDef opts = popQuery (selectFirst tableDef opts)
|
||||
|
||||
popTable :: TableDefinition entity
|
||||
-> SelectOptions
|
||||
-> Popper a ([entity Record])
|
||||
popTable tableDef opts = popQuery (selectAll tableDef opts)
|
||||
|
||||
popMaybe :: Popper a b -> Popper (Maybe a) (Maybe b)
|
||||
popMaybe = PopMaybe
|
||||
|
||||
hasMany :: TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> Popper Record [entity Record]
|
||||
hasMany tableDef fieldDef = PopRecordManyBy tableDef fieldDef mempty
|
||||
|
||||
hasManyIn :: TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> Popper [Record] (Map.Map Record (entity Record))
|
||||
hasManyIn tableDef fieldDef = PopRecordsBy tableDef fieldDef mempty
|
||||
|
||||
hasManyWhere :: TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SelectOptions
|
||||
-> Popper Record [entity Record]
|
||||
hasManyWhere = PopRecordManyBy
|
||||
|
||||
hasOne :: ( Convertible a SqlValue
|
||||
, Convertible SqlValue a
|
||||
, Ord a
|
||||
)
|
||||
=> TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> Popper a (Maybe (entity Record))
|
||||
hasOne tableDef fieldDef =
|
||||
hasOneWhere tableDef fieldDef mempty
|
||||
|
||||
hasOneWhere :: ( Convertible a SqlValue
|
||||
, Convertible SqlValue a
|
||||
, Ord a
|
||||
)
|
||||
=> TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SelectOptions
|
||||
-> Popper a (Maybe (entity Record))
|
||||
hasOneWhere = PopRecordBy
|
||||
|
||||
hasOne' :: ( Convertible a SqlValue
|
||||
, Convertible SqlValue a
|
||||
, Ord a
|
||||
)
|
||||
=> TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> Popper a (entity Record)
|
||||
hasOne' tableDef fieldDef =
|
||||
certainly' (popMissingRecord tableDef fieldDef) (hasOne tableDef fieldDef)
|
||||
|
||||
popMissingRecord :: Convertible a SqlValue
|
||||
=> TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> Popper a PopError
|
||||
popMissingRecord tableDef fieldDef =
|
||||
fromKern (MissingRecord tableDef fieldDef . convert)
|
||||
|
||||
|
||||
-- popMany is the most involved helper. It recursively
|
||||
-- rewrites the entire Popper expression to avoid
|
||||
-- running the popper's queries individually for each
|
||||
-- item in the list.
|
||||
--
|
||||
-- This is where the magic happens.
|
||||
--
|
||||
|
||||
popMany :: Popper a b -> Popper [a] [b]
|
||||
popMany (PopRecord tableDef) =
|
||||
zipWith Map.lookup <$> kern
|
||||
<*> (repeat <$> PopRecords tableDef)
|
||||
|
||||
popMany (PopRecordBy tableDef fieldDef selectOptions) =
|
||||
zipWith Map.lookup <$> kern
|
||||
<*> (repeat <$> PopRecordsBy tableDef fieldDef selectOptions)
|
||||
|
||||
popMany (PopRecordManyBy tableDef fieldDef opts) =
|
||||
zipWith getRecords <$> kern
|
||||
<*> (repeat <$> PopRecordsManyBy tableDef fieldDef opts)
|
||||
where
|
||||
|
||||
getRecords key = fromMaybe [] . Map.lookup key
|
||||
|
||||
popMany (PopRecords tableDef) =
|
||||
(zipWith restrictMap)
|
||||
<$> kern
|
||||
<*> (fromKern concat >>>
|
||||
PopRecords tableDef >>>
|
||||
fromKern repeat)
|
||||
|
||||
where restrictMap keys = Map.filterWithKey (isKey keys)
|
||||
isKey keys key _ = key `elem` keys
|
||||
|
||||
popMany (PopRecordsManyBy tableDef fieldDef opts) =
|
||||
(zipWith restrictMap)
|
||||
<$> kern
|
||||
<*> (fromKern concat >>>
|
||||
PopRecordsManyBy tableDef fieldDef opts >>>
|
||||
fromKern repeat)
|
||||
|
||||
where restrictMap keys = Map.filterWithKey (isKey keys)
|
||||
isKey keys key _ = key `elem` keys
|
||||
|
||||
popMany (PopRecordsBy tableDef fieldDef opts) =
|
||||
(zipWith restrictMap)
|
||||
<$> kern
|
||||
<*> (fromKern concat >>>
|
||||
PopRecordsBy tableDef fieldDef opts >>>
|
||||
fromKern repeat)
|
||||
|
||||
where restrictMap keys = Map.filterWithKey (isKey keys)
|
||||
isKey keys key _ = key `elem` keys
|
||||
|
||||
popMany PopId = PopId
|
||||
popMany (PopAbort err) = (PopAbort err)
|
||||
popMany (PopPure a) =
|
||||
PopPure (repeat a) -- lists here should be treated as
|
||||
-- ZipLists, so 'repeat' is 'pure'
|
||||
|
||||
popMany (PopLift f) = PopLift $ \inputs ->
|
||||
let poppeds = map f inputs
|
||||
|
||||
extract (PoppedValue b) (PoppedValue bs) = PoppedValue (b : bs)
|
||||
extract _ (PoppedError err) = PoppedError err
|
||||
extract (PoppedError err) _ = PoppedError err
|
||||
|
||||
in foldr extract (PoppedValue []) poppeds
|
||||
|
||||
popMany (PopMap f popper) = PopMap (fmap f) (popMany popper)
|
||||
popMany (PopApply fPopper aPopper) =
|
||||
getZipList <$>
|
||||
PopApply (fmap (<*>) (ZipList <$> popMany fPopper))
|
||||
(ZipList <$> popMany aPopper)
|
||||
|
||||
popMany (PopChain bPopper aPopper) =
|
||||
PopChain (popMany bPopper) (popMany aPopper)
|
||||
|
||||
popMany (PopArrowFirst popper) =
|
||||
fromKern unzip >>>
|
||||
first (popMany popper) >>>
|
||||
fromKern (uncurry zip)
|
||||
|
||||
popMany (PopArrowLeft popper) =
|
||||
rebuildList <$> kern
|
||||
<*> (fromKern lefts >>> popMany popper)
|
||||
where
|
||||
rebuildList [] _ = []
|
||||
rebuildList (Left _ : _) [] = [] -- shouldn't happen?
|
||||
|
||||
rebuildList (Right c : eacs) bs = Right c : rebuildList eacs bs
|
||||
rebuildList (Left _ : eacs) (b : bs) = Left b : rebuildList eacs bs
|
||||
|
||||
popMany (PopMaybe singlePopper) =
|
||||
rebuildList <$> kern
|
||||
<*> (fromKern catMaybes >>> popMany singlePopper)
|
||||
where
|
||||
rebuildList [] _ = []
|
||||
rebuildList (Just _ : _) [] = [] -- shouldn't happen?
|
||||
|
||||
rebuildList (Nothing : as) bs = Nothing : rebuildList as bs
|
||||
rebuildList (Just _ : as) (b : bs) = Just b : rebuildList as bs
|
||||
|
||||
popMany (PopQuery orm) =
|
||||
-- the orm query here doesn't depend on the Popper input,
|
||||
-- so we can run it once and then construct an infinite
|
||||
-- list of the results to be lined up as the outputs for
|
||||
-- each input in the list
|
||||
--
|
||||
-- ('repeat' is 'pure' since lists here are zipped)
|
||||
--
|
||||
PopQuery (repeat <$> orm)
|
||||
|
||||
-- The Popper guts
|
||||
|
||||
data PopError =
|
||||
forall ent. MissingRecord (TableDefinition ent) FieldDefinition SqlValue
|
||||
| Unpoppable String
|
||||
|
||||
instance Show PopError where
|
||||
show (MissingRecord tableDef fieldDef fieldValue) =
|
||||
"MissingRecord: " ++ missingRecordMessage tableDef fieldDef fieldValue
|
||||
|
||||
show (Unpoppable msg) =
|
||||
"Unpoppable: " ++ msg
|
||||
|
||||
missingRecordMessage :: TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SqlValue
|
||||
-> String
|
||||
missingRecordMessage tableDef fieldDef fieldValue =
|
||||
concat [ "Unable to find "
|
||||
, tableName tableDef
|
||||
, " with "
|
||||
, fieldName fieldDef
|
||||
, " = "
|
||||
, show fieldValue
|
||||
]
|
||||
|
||||
instance Exception PopError
|
||||
|
||||
data Popped a =
|
||||
PoppedValue a
|
||||
| PoppedError PopError
|
||||
|
||||
instance Functor Popped where
|
||||
fmap f (PoppedValue a) = PoppedValue (f a)
|
||||
fmap _ (PoppedError err) = PoppedError err
|
||||
|
||||
instance Applicative Popped where
|
||||
pure = PoppedValue
|
||||
(PoppedValue f) <*> (PoppedValue a) = PoppedValue (f a)
|
||||
(PoppedError err) <*> _ = PoppedError err
|
||||
_ <*> (PoppedError err) = PoppedError err
|
||||
|
||||
|
||||
-- Popper GADT. This defines the popper expression dsl
|
||||
-- that is used internally to represent poppers. These
|
||||
-- constructors are not exposed, so they can be changed
|
||||
-- freely as long as the exported API is stable.
|
||||
--
|
||||
data Popper a b where
|
||||
PopQuery :: Orville b -> Popper a b
|
||||
|
||||
PopRecord :: TableDefinition entity
|
||||
-> Popper Record (Maybe (entity Record))
|
||||
|
||||
PopRecords :: TableDefinition entity
|
||||
-> Popper [Record] (Map.Map Record (entity Record))
|
||||
|
||||
PopRecordBy :: ( Convertible c SqlValue
|
||||
, Convertible SqlValue c
|
||||
, Ord c
|
||||
)
|
||||
=> TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SelectOptions
|
||||
-> Popper c (Maybe (entity Record))
|
||||
|
||||
PopRecordManyBy :: TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SelectOptions
|
||||
-> Popper Record [entity Record]
|
||||
|
||||
PopRecordsBy :: ( Convertible c SqlValue
|
||||
, Convertible SqlValue c
|
||||
, Ord c
|
||||
)
|
||||
=> TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SelectOptions
|
||||
-> Popper [c] (Map.Map c (entity Record))
|
||||
|
||||
PopRecordsManyBy :: TableDefinition entity
|
||||
-> FieldDefinition
|
||||
-> SelectOptions
|
||||
-> Popper [Record] (Map.Map Record [entity Record])
|
||||
|
||||
PopId :: Popper a a
|
||||
PopPure :: b -> Popper a b
|
||||
PopLift :: (a -> Popped b) -> Popper a b
|
||||
PopAbort :: PopError -> Popper a b
|
||||
|
||||
PopMap :: (b -> c) -> Popper a b -> Popper a c
|
||||
PopApply :: Popper a (b -> c)
|
||||
-> Popper a b
|
||||
-> Popper a c
|
||||
|
||||
PopChain :: Popper b c -> Popper a b -> Popper a c
|
||||
PopArrowFirst :: Popper a b -> Popper (a, c) (b, c)
|
||||
PopArrowLeft :: Popper a b -> Popper (Either a c) (Either b c)
|
||||
|
||||
PopMaybe :: Popper a b -> Popper (Maybe a) (Maybe b)
|
||||
|
||||
instance Functor (Popper a) where
|
||||
fmap = PopMap
|
||||
|
||||
instance Applicative (Popper a) where
|
||||
pure = PopPure
|
||||
(<*>) = PopApply
|
||||
|
||||
instance Category Popper where
|
||||
id = PopId
|
||||
(.) = PopChain
|
||||
|
||||
instance Arrow Popper where
|
||||
arr = fromKern
|
||||
first = PopArrowFirst
|
||||
|
||||
instance ArrowChoice Popper where
|
||||
left = PopArrowLeft
|
||||
|
||||
popThrow :: Popper a b -> a -> Orville b
|
||||
popThrow popper a = do
|
||||
popped <- pop popper a
|
||||
|
||||
case popped of
|
||||
PoppedValue b -> return b
|
||||
PoppedError e -> throwM e
|
||||
|
||||
-- This is where the action happens. pop converts the
|
||||
-- Popper DSL into Orville calls with the provided input
|
||||
--
|
||||
pop :: Popper a b -> a -> Orville (Popped b)
|
||||
pop popper a = runQueryCached $ popCached popper a
|
||||
|
||||
popCached :: (MonadThrow m, MonadOrville conn m)
|
||||
=> Popper a b -> a -> QueryCached m (Popped b)
|
||||
popCached (PopQuery query) _ =
|
||||
PoppedValue <$> unsafeLift query
|
||||
|
||||
popCached (PopRecordBy tableDef fieldDef opts) recordId =
|
||||
PoppedValue <$> selectFirstCached tableDef
|
||||
( where_ (fieldDef .== recordId)
|
||||
<> opts
|
||||
)
|
||||
|
||||
popCached (PopRecordManyBy tableDef fieldDef opts) recordId =
|
||||
PoppedValue <$> selectCached tableDef
|
||||
( where_ (fieldDef .== recordId)
|
||||
<> opts
|
||||
)
|
||||
|
||||
popCached (PopRecordsBy tableDef fieldDef opts) recordIds =
|
||||
PoppedValue <$> Map.map head
|
||||
<$> findRecordsByCached tableDef
|
||||
fieldDef
|
||||
( where_ (fieldDef .<- recordIds)
|
||||
<> opts
|
||||
)
|
||||
|
||||
popCached (PopRecordsManyBy tableDef fieldDef opts) recordIds =
|
||||
PoppedValue <$> findRecordsByCached tableDef
|
||||
fieldDef
|
||||
( where_ (fieldDef .<- recordIds)
|
||||
<> opts
|
||||
)
|
||||
|
||||
popCached (PopRecord tableDef) recordId =
|
||||
PoppedValue <$> findRecordCached tableDef recordId
|
||||
|
||||
popCached (PopRecords tableDef) recordIds =
|
||||
PoppedValue <$> findRecordsCached tableDef recordIds
|
||||
|
||||
popCached (PopAbort err) _ =
|
||||
pure (PoppedError err)
|
||||
|
||||
popCached PopId a =
|
||||
pure (PoppedValue a)
|
||||
|
||||
popCached (PopPure a) _ =
|
||||
pure (PoppedValue a)
|
||||
|
||||
popCached (PopLift f) a =
|
||||
pure (f a)
|
||||
|
||||
popCached (PopMap f popper) a =
|
||||
fmap f <$> popCached popper a
|
||||
|
||||
popCached (PopApply fPopper bPopper) a =
|
||||
(fmap (<*>) (popCached fPopper a)) <*> popCached bPopper a
|
||||
|
||||
popCached (PopChain popperB popperA) a = do
|
||||
value <- popCached popperA a
|
||||
|
||||
case value of
|
||||
PoppedError err -> pure (PoppedError err)
|
||||
PoppedValue b -> popCached popperB b
|
||||
|
||||
popCached (PopArrowFirst popper) (a,c) = do
|
||||
poppedB <- popCached popper a
|
||||
|
||||
case poppedB of
|
||||
PoppedValue b -> return (PoppedValue (b, c))
|
||||
PoppedError err -> return (PoppedError err)
|
||||
|
||||
popCached (PopArrowLeft popper) ac = do
|
||||
case ac of
|
||||
Left a -> fmap Left <$> popCached popper a
|
||||
Right c -> pure (PoppedValue (Right c))
|
||||
|
||||
popCached (PopMaybe popper) a =
|
||||
case a of
|
||||
Nothing -> pure (PoppedValue Nothing)
|
||||
Just val -> fmap Just <$> popCached popper val
|
||||
|
23
src/Database/Orville/PostgresSQL.hs
Normal file
23
src/Database/Orville/PostgresSQL.hs
Normal file
@ -0,0 +1,23 @@
|
||||
module Database.Orville.PostgresSQL
|
||||
( createConnectionPool
|
||||
, Pool
|
||||
, Connection
|
||||
) where
|
||||
|
||||
import Data.Pool
|
||||
import Data.Time
|
||||
import Database.HDBC as HDBC
|
||||
import Database.HDBC.PostgreSQL
|
||||
|
||||
createConnectionPool :: Int -- Stripe Count
|
||||
-> NominalDiffTime -- Linger time
|
||||
-> Int -- Max resources per stripe
|
||||
-> String
|
||||
-> IO (Pool Connection)
|
||||
createConnectionPool stripes linger maxRes connString =
|
||||
createPool (connectPostgreSQL' connString)
|
||||
disconnect
|
||||
stripes
|
||||
linger
|
||||
maxRes
|
||||
|
89
src/Database/Orville/Raw.hs
Normal file
89
src/Database/Orville/Raw.hs
Normal file
@ -0,0 +1,89 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Database.Orville.Raw
|
||||
( selectSql
|
||||
, selectSqlRows
|
||||
, decodeSqlRows
|
||||
, ResultSet
|
||||
, updateSql
|
||||
, withConnection, withTransaction
|
||||
) where
|
||||
|
||||
import Control.Exception.Lifted (finally, throw)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.IORef
|
||||
import Database.HDBC hiding (withTransaction)
|
||||
|
||||
import Database.Orville.Internal.Monad
|
||||
import Database.Orville.Internal.Types
|
||||
|
||||
type ResultSet = [[(String, SqlValue)]]
|
||||
|
||||
selectSqlRows :: String -> [SqlValue] -> Orville ResultSet
|
||||
selectSqlRows sql values = do
|
||||
withConnection $ \conn -> liftIO $ do
|
||||
putStrLn sql
|
||||
|
||||
query <- prepare conn sql
|
||||
void $ execute query values
|
||||
fetchAllRowsAL' query
|
||||
|
||||
decodeSqlRows :: FromSql result -> ResultSet -> Orville [result]
|
||||
decodeSqlRows builder rows =
|
||||
fmap catMaybes $ forM rows $ \row -> do
|
||||
case runFromSql builder row of
|
||||
Right result -> pure $ Just result
|
||||
|
||||
(Left (RowDataError msg)) -> do
|
||||
liftIO $ putStrLn $ "** Warning ** Error converting row from sql. " ++
|
||||
show msg
|
||||
pure Nothing
|
||||
|
||||
Left err -> throw err
|
||||
|
||||
selectSql :: String
|
||||
-> [SqlValue]
|
||||
-> FromSql result
|
||||
-> Orville [result]
|
||||
selectSql sql values builder =
|
||||
selectSqlRows sql values >>= decodeSqlRows builder
|
||||
|
||||
updateSql :: String
|
||||
-> [SqlValue]
|
||||
-> Orville Integer
|
||||
updateSql sql values =
|
||||
withConnection $ \conn -> liftIO $ do
|
||||
putStrLn sql
|
||||
run conn sql values
|
||||
|
||||
startTransaction :: ConnectionEnv conn -> ConnectionEnv conn
|
||||
startTransaction c = c { ormTransactionOpen = True }
|
||||
|
||||
withTransaction :: MonadOrville conn m => m a -> m a
|
||||
withTransaction action =
|
||||
withConnectionEnv $ \connected ->
|
||||
if ormTransactionOpen connected then
|
||||
action
|
||||
else
|
||||
localOrvilleEnv (setConnectionEnv $ startTransaction connected)
|
||||
doTransaction
|
||||
|
||||
where
|
||||
doTransaction =
|
||||
withConnection $ \conn -> do
|
||||
committed <- liftIO $ newIORef False
|
||||
startTran <- startTransactionSQL
|
||||
|
||||
let doAction = do liftIO $ (executeRaw =<< prepare conn startTran)
|
||||
value <- action
|
||||
liftIO $ commit conn >> (writeIORef committed True)
|
||||
return value
|
||||
|
||||
let rollbackUncommitted = liftIO $ do
|
||||
finished <- readIORef committed
|
||||
when (not finished) (rollback conn)
|
||||
|
||||
doAction `finally` rollbackUncommitted
|
||||
|
152
src/Database/Orville/Tracked.hs
Normal file
152
src/Database/Orville/Tracked.hs
Normal file
@ -0,0 +1,152 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Database.Orville.Tracked
|
||||
( Sign(..)
|
||||
, SignType(..)
|
||||
, signTableAs
|
||||
, signEntityFrom
|
||||
|
||||
, TrackedOrville
|
||||
, Trail(..)
|
||||
, MonadTrackedOrville (..)
|
||||
|
||||
, insertRecordTracked
|
||||
, updateRecordTracked
|
||||
|
||||
, mapTrackedOrville
|
||||
, runTrackedOrville
|
||||
, trackedMapper
|
||||
, trailToList
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Base
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.Writer
|
||||
import qualified Data.DList as D
|
||||
import Data.Typeable
|
||||
|
||||
import Database.Orville.Core
|
||||
|
||||
data SignType = Inserted | Updated
|
||||
deriving (Eq, Show, Enum)
|
||||
|
||||
data Sign = forall entity. (Typeable entity) =>
|
||||
Sign {
|
||||
signType :: SignType
|
||||
, signTable :: TableDefinition entity
|
||||
, signEntity :: entity Record
|
||||
}
|
||||
|
||||
signTableAs :: Typeable entity
|
||||
=> TableDefinition entity
|
||||
-> Sign
|
||||
-> Maybe (TableDefinition entity)
|
||||
signTableAs _ (Sign _ tableDef _) = cast tableDef
|
||||
|
||||
signEntityFrom :: Typeable entity
|
||||
=> TableDefinition entity
|
||||
-> Sign
|
||||
-> Maybe (entity Record)
|
||||
signEntityFrom _ (Sign _ _ entity) = cast entity
|
||||
|
||||
instance Show Sign where
|
||||
show (Sign sType tableDef entity) =
|
||||
"Sign " <>
|
||||
show sType <> " " <>
|
||||
tableName tableDef <> " " <>
|
||||
show (tableGetKey tableDef entity)
|
||||
|
||||
newtype Trail = Trail (D.DList Sign)
|
||||
deriving (Monoid)
|
||||
|
||||
newtype TrackedOrville m a = TrackedOrville {
|
||||
unTrackedOrville :: WriterT Trail
|
||||
m
|
||||
a
|
||||
} deriving ( Functor
|
||||
, Alternative
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
, MonadIO
|
||||
, MonadThrow
|
||||
, MonadCatch
|
||||
, MonadMask
|
||||
, MonadError e
|
||||
)
|
||||
|
||||
runTrackedOrville :: TrackedOrville m a -> m (a, Trail)
|
||||
runTrackedOrville = runWriterT . unTrackedOrville
|
||||
|
||||
trailToList :: Trail -> [Sign]
|
||||
trailToList (Trail dList) = D.toList dList
|
||||
|
||||
class (MonadOrville conn m, MonadThrow m)
|
||||
=> MonadTrackedOrville conn m where
|
||||
track :: Sign -> m ()
|
||||
|
||||
mapTrackedOrville :: (m (a,Trail) -> n (b,Trail)) -> TrackedOrville m a -> TrackedOrville n b
|
||||
mapTrackedOrville f = TrackedOrville . mapWriterT f . unTrackedOrville
|
||||
|
||||
trackedMapper :: Monad m => (m a -> m b) -> m (a, Trail) -> m (b, Trail)
|
||||
trackedMapper f trackedM = do
|
||||
(a, trail) <- trackedM
|
||||
b <- f (pure a)
|
||||
pure (b, trail)
|
||||
|
||||
untracked :: Monad m => m a -> TrackedOrville m a
|
||||
untracked = TrackedOrville . lift
|
||||
|
||||
insertRecordTracked :: (MonadTrackedOrville conn m, Typeable entity)
|
||||
=> TableDefinition entity
|
||||
-> entity ()
|
||||
-> m (entity Record)
|
||||
insertRecordTracked tableDef entity = do
|
||||
record <- insertRecord tableDef entity
|
||||
|
||||
track $ Sign Inserted tableDef record
|
||||
|
||||
pure record
|
||||
|
||||
updateRecordTracked :: (MonadTrackedOrville conn m, Typeable entity)
|
||||
=> TableDefinition entity
|
||||
-> Record
|
||||
-> entity key
|
||||
-> m (entity Record)
|
||||
updateRecordTracked tableDef recordId record = do
|
||||
updated <- updateRecord tableDef recordId record
|
||||
|
||||
track $ Sign Updated tableDef updated
|
||||
|
||||
pure updated
|
||||
|
||||
instance (MonadOrville conn m, MonadThrow m) => MonadTrackedOrville conn (TrackedOrville m) where
|
||||
track = TrackedOrville . tell . Trail . D.singleton
|
||||
|
||||
instance MonadTrans TrackedOrville where
|
||||
lift = untracked
|
||||
|
||||
instance MonadBase IO m => MonadBase IO (TrackedOrville m) where
|
||||
liftBase = lift . liftBase
|
||||
|
||||
instance MonadTransControl TrackedOrville where
|
||||
type StT TrackedOrville a = StT (WriterT Trail) a
|
||||
liftWith = defaultLiftWith TrackedOrville unTrackedOrville
|
||||
restoreT = defaultRestoreT TrackedOrville
|
||||
|
||||
instance MonadBaseControl IO m =>
|
||||
MonadBaseControl IO (TrackedOrville m) where
|
||||
type StM (TrackedOrville m) a = ComposeSt TrackedOrville m a
|
||||
liftBaseWith = defaultLiftBaseWith
|
||||
restoreM = defaultRestoreM
|
||||
|
||||
instance MonadOrville conn m => MonadOrville conn (TrackedOrville m) where
|
||||
getOrvilleEnv = lift getOrvilleEnv
|
||||
localOrvilleEnv f = mapTrackedOrville (localOrvilleEnv f)
|
||||
startTransactionSQL = lift startTransactionSQL
|
||||
|
Loading…
Reference in New Issue
Block a user