Initial commit

.gitignore

@@ -0,0 +1,3 @@
+dist
+.cabal-sandbox
+cabal.sandbox.config

Dockerfile

@@ -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
+

LICENSE

@@ -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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

docker-compose.yml

@@ -0,0 +1,5 @@
+dev:
+  build: .
+  volumes:
+    - .:/orville
+  working_dir: /orville

orville.cabal

@@ -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
+

src/Data/Map/Helpers.hs

@@ -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])
+

src/Database/Orville.hs

@@ -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
+

src/Database/Orville/Core.hs

@@ -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 ()
+
+

src/Database/Orville/Internal/ConstraintDefinition.hs

@@ -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)
+

src/Database/Orville/Internal/FieldDefinition.hs

@@ -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
+

src/Database/Orville/Internal/FieldUpdate.hs

@@ -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) ++ " = ?"
+

src/Database/Orville/Internal/FromSql.hs

@@ -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
+

src/Database/Orville/Internal/IndexDefinition.hs

@@ -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) ++ ")"

src/Database/Orville/Internal/MigrateConstraint.hs

@@ -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
+

src/Database/Orville/Internal/MigrateIndex.hs

@@ -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
+

src/Database/Orville/Internal/MigrateSchema.hs

@@ -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)
+

src/Database/Orville/Internal/MigrateTable.hs

@@ -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
+                       ]
+

src/Database/Orville/Internal/Monad.hs

@@ -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
+

src/Database/Orville/Internal/OrderBy.hs

@@ -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
+

src/Database/Orville/Internal/QueryCache.hs

@@ -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
+
+

src/Database/Orville/Internal/QueryKey.hs

@@ -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
+

src/Database/Orville/Internal/SelectOptions.hs

@@ -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)
+

src/Database/Orville/Internal/TableDefinition.hs

@@ -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 ++ "\""
+

src/Database/Orville/Internal/Types.hs

@@ -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)
+

src/Database/Orville/Internal/Where.hs

@@ -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
+

src/Database/Orville/Popper.hs

@@ -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
+

src/Database/Orville/PostgresSQL.hs

@@ -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
+

src/Database/Orville/Raw.hs

@@ -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
+

src/Database/Orville/Tracked.hs

@@ -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
+