diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,8 @@ +The MIT License (MIT) +Copyright (c) 2015, 2016 Travis Athougies + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/beam.cabal b/beam.cabal new file mode 100644 --- /dev/null +++ b/beam.cabal @@ -0,0 +1,38 @@ +-- Initial beam.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: beam +version: 0.3.0.0 +synopsis: A type-safe SQL mapper for Haskell that doesn't use Template Haskell +description: See the documentation on [my blog](http://travis.athougies.net/tags/beam.html) and on [GitHub](https://github.com/tathougies/beam/tree/master/Doc). +homepage: http://travis.athougies.net/projects/beam +license: MIT +license-file: LICENSE +author: Travis Athougies +maintainer: travis@athougies.net +-- copyright: +category: Database +build-type: Simple +-- extra-source-files: +cabal-version: >=1.18 + +library + exposed-modules: Database.Beam Database.Beam.Backend + Database.Beam.SQL Database.Beam.Query + Database.Beam.Schema Database.Beam.Backend.Sqlite3 + Database.Beam.Internal Database.Beam.Query.Internal + other-modules: Database.Beam.SQL.Types + + Database.Beam.Query.Types + Database.Beam.Query.Combinators + + Database.Beam.Schema.Lenses + Database.Beam.Schema.Tables + Database.Beam.Schema.Fields + build-depends: base >=4.7 && <4.9, text, time, tagged, pretty, HDBC, HDBC-sqlite3, mtl, semigroups, containers, + conduit, convertible, microlens, uniplate + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: ScopedTypeVariables, OverloadedStrings, GADTs, RecursiveDo, FlexibleInstances, FlexibleContexts, TypeFamilies, + GeneralizedNewtypeDeriving, RankNTypes, TupleSections, ConstraintKinds, StandaloneDeriving, TypeOperators, + DefaultSignatures, KindSignatures, MultiParamTypeClasses, DeriveGeneric, DeriveFunctor, DeriveDataTypeable diff --git a/src/Database/Beam.hs b/src/Database/Beam.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE GADTs #-} +-- | Top-level Beam module. This module re-exports all the symbols +-- necessary for most common user operations. +-- +-- The most interesting modules are 'Database.Beam.Schema' and 'Database.Beam.Query'. +-- +-- 'Database.Beam.SQL' contains an internal representation of SQL +-- that can be easily converted to textual +-- SQL. 'Database.Beam.Backend' offers functions to run Beam queries +-- and data manipulation commands within specific SQL backends. +-- +-- For a series of tutorials, see my series of blog posts at +-- +-- * [Beam tutorial (part 1)](http://travis.athougies.net/posts/2016-01-21-beam-tutorial-1.html) +-- * [Beam tutorial (part 2)](http://travis.athougies.net/posts/2016-01-22-beam-tutorial-part-2.html) +module Database.Beam + ( module Database.Beam.SQL + , module Database.Beam.Query + , module Database.Beam.Schema + , module Database.Beam.Backend + + , Typeable, Generic, Identity + + , liftIO + + , Beam, BeamBackend, BeamT, BeamResult(..), BeamRollbackReason(..) ) where + +import Database.Beam.Internal +import Database.Beam.SQL +import Database.Beam.Query +import Database.Beam.Schema +import Database.Beam.Backend + +import Control.Monad.Trans +import Control.Monad.Identity + +import Data.Typeable +import Data.Conduit + +import GHC.Generics diff --git a/src/Database/Beam/Backend.hs b/src/Database/Beam/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Backend.hs @@ -0,0 +1,122 @@ +module Database.Beam.Backend where + +import Database.Beam.Internal +import Database.Beam.Schema +import Database.Beam.SQL.Types +import Database.Beam.SQL + +import Control.Arrow +import Control.Applicative +import Control.Monad.Trans +import Control.Monad.Writer +import Control.Monad.Identity +import Control.Monad + +import Data.String +import Data.Maybe +import Data.List +import Data.Proxy +import Data.Text (Text) +import qualified Data.Set as S +import qualified Data.Map as M + +import Database.HDBC + +instance Monoid DBSchemaComparison where + mappend (Migration a) (Migration b) = Migration (a <> b) + mappend _ Unknown = Unknown + mappend Unknown _ = Unknown + + mempty = Migration [] + +reifyDBSchema :: Database db => DatabaseSettings db -> ReifiedDatabaseSchema +reifyDBSchema dbSettings = + let tables = allTableSettings dbSettings + in map (\(GenDatabaseTable (DatabaseTable table name)) -> (name, reifyTableSchema table)) tables + +defaultBeamCompareSchemas :: Database db => ReifiedDatabaseSchema -> DatabaseSettings db -> DBSchemaComparison +defaultBeamCompareSchemas actual db = execWriter compare + where dbTables = allTableSettings db + + expected = S.fromList (map (\(GenDatabaseTable (DatabaseTable _ name)) -> name) dbTables) + actualTables = S.fromList (map fst actual) + + tablesToBeMadeNames = expected S.\\ actualTables + tablesToBeMade = mapMaybe (\(GenDatabaseTable (DatabaseTable table name)) -> + if name `S.member` tablesToBeMadeNames + then Just (MACreateTable name table) + else Nothing) dbTables + + compare = tell (Migration tablesToBeMade) + +hdbcSchema :: (IConnection conn, MonadIO m) => conn -> m ReifiedDatabaseSchema +hdbcSchema conn = + liftIO $ + do tables <- getTables conn + forM tables $ \tbl -> + do descs <- describeTable conn tbl + return (fromString tbl, map (fromString *** noConstraints) descs) + +createStmtFor :: Table t => Beam db m -> Text -> Proxy t -> SQLCreateTable +createStmtFor beam name (table :: Proxy t) = + let tblSchema = reifyTableSchema table + tblSchema' = map addPrimaryKeyConstraint tblSchema + tblSchemaInDb' = map (second (adjustColDescForBackend beam)) tblSchema' + + addPrimaryKeyConstraint (name, sch) + | elem name primaryKeyFields = (name, sch { csConstraints = SQLPrimaryKey:csConstraints sch }) + | otherwise = (name, sch) + + _fieldName' :: Columnar' (TableField t) x -> Text + _fieldName' (Columnar' x) = _fieldName x + + primaryKeyFields = pkAllValues _fieldName' (primaryKey (tblFieldSettings :: TableSettings t)) + in SQLCreateTable name tblSchemaInDb' + +migrateDB :: MonadIO m => DatabaseSettings db -> Beam db m -> [MigrationAction] -> m () +migrateDB db beam actions = + forM_ actions $ \action -> + do when (beamDebug beam) (liftIO (putStrLn ("Performing " ++ show action))) + + case action of + MACreateTable name t -> do let stmt = createStmtFor beam name t + (sql, vals) = ppSQL (CreateTable stmt) + when (beamDebug beam) (liftIO (putStrLn ("Will run SQL:\n" ++sql))) + withHDBCConnection beam (\conn -> liftIO $ do runRaw conn sql + commit conn) + when (beamDebug beam) (liftIO (putStrLn "Done...")) + +autoMigrateDB db beam = + do actDBSchema <- withHDBCConnection beam hdbcSchema + let comparison = compareSchemas beam actDBSchema db + + case comparison of + Migration actions -> do when (beamDebug beam) (liftIO $ putStrLn ("Comparison result: " ++ show actions)) + migrateDB db beam actions + Unknown -> when (beamDebug beam) (liftIO $ putStrLn "Unknown comparison") + +openDatabaseDebug, openDatabase :: (BeamBackend dbSettings, MonadIO m, Database db) => DatabaseSettings db -> dbSettings -> m (Beam db m) +openDatabase = openDatabase' False +openDatabaseDebug = openDatabase' True + +openDatabase' :: (BeamBackend dbSettings, MonadIO m, Database db) => Bool -> DatabaseSettings db -> dbSettings -> m (Beam db m) +openDatabase' isDebug db dbSettings = + do beam <- openBeam db dbSettings + let beam' = beam { beamDebug = isDebug } + autoMigrateDB db beam' + + return beam' + +dumpSchema :: Database db => DatabaseSettings db -> IO () +dumpSchema (db :: DatabaseSettings db) = + do let createTableStmts = allTables (\(DatabaseTable tbl name) -> createStmtFor debugBeam name tbl) db + putStrLn "Dumping database schema ..." + mapM_ (putStrLn . fst . ppSQL . CreateTable) createTableStmts + where debugBeam ::Beam db Identity + debugBeam = Beam { beamDbSettings = db + , beamDebug = False + , closeBeam = return () + , compareSchemas = \_ _ -> Unknown + , adjustColDescForBackend = id + , getLastInsertedRow = \_ -> return [] + , withHDBCConnection = \_ -> error "trying to run in debug mode" } diff --git a/src/Database/Beam/Backend/Sqlite3.hs b/src/Database/Beam/Backend/Sqlite3.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Backend/Sqlite3.hs @@ -0,0 +1,39 @@ +module Database.Beam.Backend.Sqlite3 where + +import Database.Beam.Internal +import Database.Beam.Query.Internal +import Database.Beam.Backend +import Database.Beam.SQL.Types + +import Control.Monad.Trans + +import Database.HDBC.Sqlite3 +import Database.HDBC + +import Data.Text (Text, unpack) + +-- * Sqlite3 support + +data Sqlite3Settings = Sqlite3Settings FilePath + deriving Show + +instance BeamBackend Sqlite3Settings where + openBeam dbSettings (Sqlite3Settings fp) = + do conn <- liftIO (connectSqlite3 fp) + + return Beam { beamDbSettings = dbSettings + , beamDebug = False + , closeBeam = liftIO (disconnect conn) + , compareSchemas = defaultBeamCompareSchemas + , adjustColDescForBackend = + \cs -> cs { csConstraints = filter (/=SQLAutoIncrement) (csConstraints cs) } + , getLastInsertedRow = getLastInsertedRow' conn + , withHDBCConnection = \f -> f conn } + +getLastInsertedRow' :: MonadIO m => Connection -> Text -> m [SqlValue] +getLastInsertedRow' conn tblName = do + [res] <- liftIO (quickQuery conn (concat ["SELECT * FROM ", unpack tblName, " WHERE ROWID=(SELECT last_insert_rowid()) limit 1"]) []) + return res + +(++.) :: QExpr Text -> QExpr Text -> QExpr Text +QExpr a ++. QExpr b = QExpr (SQLBinOpE "||" a b) diff --git a/src/Database/Beam/Internal.hs b/src/Database/Beam/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Internal.hs @@ -0,0 +1,86 @@ +module Database.Beam.Internal where + + +import Database.Beam.Schema.Tables +import Database.Beam.SQL.Types + +import Control.Applicative +import Control.Monad +import Control.Arrow +import Control.Monad.Error +import Control.Monad.Reader + +import Data.Text (Text, unpack) +import Data.Proxy +import Data.String +import Data.Typeable + +import Database.HDBC + +data DBSchemaComparison = Migration [MigrationAction] + | Unknown + deriving Show + +data MigrationAction where + MACreateTable :: Table table => Text -> Proxy table -> MigrationAction + +instance Show MigrationAction where + show (MACreateTable name t) = concat ["MACreateTable ", unpack name , " ", "(Proxy :: ", show (typeOf t), ")"] + +class BeamBackend backendSettings where + openBeam :: (MonadIO m, Database d) => DatabaseSettings d -> backendSettings -> m (Beam d m) + +data Beam d m = Beam + { beamDbSettings :: DatabaseSettings d + , beamDebug :: Bool + + , closeBeam :: m () + + , compareSchemas :: ReifiedDatabaseSchema -> DatabaseSettings d -> DBSchemaComparison + , adjustColDescForBackend :: SQLColumnSchema -> SQLColumnSchema + + , getLastInsertedRow :: Text -> m [SqlValue] + + , withHDBCConnection :: forall a. (forall conn. IConnection conn => conn -> m a) -> m a } + +newtype BeamT e d m a = BeamT { runBeamT :: Beam d m -> m (BeamResult e a) } + +data BeamResult e a = Success a + | Rollback (BeamRollbackReason e) + deriving Show + +data BeamRollbackReason e = InternalError String + | UserError e + deriving Show +instance Error (BeamRollbackReason e) where + strMsg = InternalError + + +transBeam :: Functor m => (forall a. (s -> m (a, Maybe b)) -> n a) -> (forall a. n a -> s -> m (a, b)) -> Beam d m -> Beam d n +transBeam lift lower beam = beam + { closeBeam = lift (const ((,Nothing) <$> closeBeam beam)) + , getLastInsertedRow = \s -> lift (const ((, Nothing) <$> getLastInsertedRow beam s)) + , withHDBCConnection = \f -> lift (\s -> second Just <$> withHDBCConnection beam (flip lower s . f)) } + +instance Monad m => Monad (BeamT e d m) where + a >>= mkB = BeamT $ \beam -> + do x <- runBeamT a beam + case x of + Success x -> runBeamT (mkB x) beam + Rollback e -> return (Rollback e) + return = BeamT . const . return . Success + +instance Monad m => Functor (BeamT e d m) where + fmap = liftM + +instance Monad m => Applicative (BeamT e d m) where + pure = return + (<*>) = ap + +instance MonadIO m => MonadIO (BeamT e d m) where + liftIO = lift . liftIO + +instance MonadTrans (BeamT e d) where + lift x = BeamT $ \_ -> + do res <- x + return (Success res) diff --git a/src/Database/Beam/Query.hs b/src/Database/Beam/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Query.hs @@ -0,0 +1,237 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +module Database.Beam.Query + ( module Database.Beam.Query.Types + , module Database.Beam.Query.Combinators + + , beamTxn, insertInto, query, queryList, getOne + , updateWhere, saveTo + , deleteWhere, deleteFrom ) + where + +import Database.Beam.Query.Types +import Database.Beam.Query.Combinators +import Database.Beam.Query.Internal + +import Database.Beam.Schema.Tables +import Database.Beam.Schema.Fields +import Database.Beam.Internal +import Database.Beam.SQL +import Database.Beam.SQL.Types + +import Control.Applicative +import Control.Arrow +import Control.Monad.Trans +import Control.Monad.Writer (tell, execWriter, Writer) +import Control.Monad.State +import Control.Monad.Error +import Control.Monad.Identity + +import Data.Monoid hiding (All) +import Data.Proxy +import Data.Data +import Data.List (find) +import Data.Maybe +import Data.Convertible +import Data.String (fromString) +import Data.Conduit +import qualified Data.Conduit.List as C +import qualified Data.Set as S +import qualified Data.Text as T + +import Database.HDBC + +import Unsafe.Coerce + +-- * Query + +runSQL' :: IConnection conn => Bool -> conn -> SQLCommand -> IO (Either String (IO (Maybe [SqlValue]))) +runSQL' debug conn cmd = do + let (sql, vals) = ppSQL cmd + when debug (putStrLn ("Will execute " ++ sql ++ " with " ++ show vals)) + stmt <- prepare conn sql + execute stmt vals + return (Right (fetchRow stmt)) + +-- * Data insertion, updating, and deletion + +insertToSQL :: Table table => T.Text -> table Identity -> SQLInsert +insertToSQL name (table :: table Identity) = SQLInsert name + (fieldAllValues (\(Columnar' (SqlValue' x)) -> x) (makeSqlValues table)) + +runInsert :: (MonadIO m, Table table, FromSqlValues (table Identity)) => T.Text -> table Identity -> Beam d m -> m (Either String (table Identity)) +runInsert tableName (table :: table Identity) beam = + do let insertCmd = Insert sqlInsert + sqlInsert@(SQLInsert tblName sqlValues) = insertToSQL tableName table + withHDBCConnection beam (\conn -> liftIO (runSQL' (beamDebug beam) conn insertCmd)) + + -- There are three possibilities here: + -- + -- * we have no autoincrement keys, and so we simply have to return the + -- newly created QueryTable, or + -- * we have autoincrement keys, but all the fields marked autoincrement + -- were non-null. In this case, we have all the information needed to + -- construct the QueryTable, or + -- * we have autoincrement keys, and some of the fields were marked null. + -- In this case, we need to ask the backend for the last inserted row. + let tableSchema = reifyTableSchema (Proxy :: Proxy table) + + autoIncrementsAreNull = zipWith (\(_, columnSchema) value -> hasAutoIncrementConstraint columnSchema && value == SqlNull) tableSchema sqlValues + hasNullAutoIncrements = or autoIncrementsAreNull + + hasAutoIncrementConstraint SQLColumnSchema { csConstraints = cs } = isJust (find (== SQLAutoIncrement) cs) + + insertedValues <- if hasNullAutoIncrements + then getLastInsertedRow beam tblName + else return sqlValues + return (fromSqlValues insertedValues) + +insertInto :: (MonadIO m, Functor m, Table table, FromSqlValues (table Identity)) => + DatabaseTable db table -> table Identity -> BeamT e db m (table Identity) +insertInto (DatabaseTable _ name) data_ = + BeamT (\beam -> toBeamResult <$> runInsert name data_ beam) + +updateToSQL :: Table table => T.Text -> table QExpr -> QExpr Bool -> Maybe SQLUpdate +updateToSQL tblName (setTo :: table QExpr) where_ = + let setExprs = fieldAllValues (\(Columnar' x) -> optimizeExpr x) setTo + setColumns = fieldAllValues (\(Columnar' fieldS) -> _fieldName fieldS) (tblFieldSettings :: TableSettings table) + + isInteresting columnName (SQLFieldE (SQLFieldName fName)) + | fName == columnName = Nothing + isInteresting columnName newE = Just (SQLFieldName columnName, newE) + + assignments = catMaybes (zipWith isInteresting setColumns setExprs) + + where_' = case optimizeExpr where_ of + SQLValE (SqlBool True) -> Nothing + where_' -> Just where_' + + in case assignments of + [] -> Nothing + _ -> Just SQLUpdate + { uTableNames = [tblName] + , uAssignments = assignments + , uWhere = where_' } + +updateWhere :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> (tbl QExpr -> tbl QExpr) -> (tbl QExpr -> QExpr Bool) -> BeamT e db m () +updateWhere tbl@(DatabaseTable _ name :: DatabaseTable db tbl) mkAssignments mkWhere = + do let assignments = mkAssignments tblExprs + where_ = mkWhere tblExprs + + tblExprs = changeRep (\(Columnar' fieldS) -> Columnar' (QExpr (SQLFieldE (QField name Nothing (_fieldName fieldS))))) (tblFieldSettings :: TableSettings tbl) + + case updateToSQL name assignments where_ of + Nothing -> pure () -- Assignments were empty, so do nothing + Just upd -> + let updateCmd = Update upd + in BeamT $ \beam -> + withHDBCConnection beam $ \conn -> + do liftIO (runSQL' (beamDebug beam) conn updateCmd) + pure (Success ()) + +saveTo :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> tbl Identity -> BeamT e db m () +saveTo tbl (newValues :: tbl Identity) = + updateWhere tbl (\_ -> tableVal newValues) (val_ (primaryKey newValues) `references_`) + + +deleteWhere :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> (tbl QExpr -> QExpr Bool) -> BeamT e db m () +deleteWhere (DatabaseTable _ name :: DatabaseTable db tbl) mkWhere = + let tblExprs = changeRep (\(Columnar' fieldS) -> Columnar' (QExpr (SQLFieldE (QField name Nothing (_fieldName fieldS))))) (tblFieldSettings :: TableSettings tbl) + + cmd = Delete SQLDelete + { dTableName = name + , dWhere = case optimizeExpr (mkWhere tblExprs) of + SQLValE (SqlBool True) -> Nothing + where_ -> Just where_ } + in BeamT $ \beam -> + withHDBCConnection beam $ \conn -> + do liftIO (runSQL' (beamDebug beam) conn cmd) + pure (Success ()) + +deleteFrom :: (MonadIO m, Table tbl) => DatabaseTable db tbl -> PrimaryKey tbl Identity -> BeamT e db m () +deleteFrom tbl pkToDelete = deleteWhere tbl (\tbl -> primaryKey tbl ==. val_ pkToDelete) + +-- * BeamT actions + +beamTxn :: MonadIO m => Beam db m -> (DatabaseSettings db -> BeamT e db m a) -> m (BeamResult e a) +beamTxn beam action = do res <- runBeamT (action (beamDbSettings beam)) beam + withHDBCConnection beam $ + case res of + Success x -> liftIO . commit + Rollback e -> liftIO . rollback + return res + +toBeamResult :: Either String a -> BeamResult e a +toBeamResult = (Rollback . InternalError) ||| Success + +runQuery :: ( MonadIO m + , FromSqlValues (QExprToIdentity a) + , Projectible a + , IsQuery q ) => + (forall s. q db s a) -> Beam db m -> m (Either String (Source m (QExprToIdentity a))) +runQuery q beam = + do let selectCmd = Select (snd (queryToSQL' (toQ q))) + + res <- withHDBCConnection beam $ \conn -> + liftIO $ runSQL' (beamDebug beam) conn selectCmd + + case res of + Left err -> return (Left err) + Right fetchRow -> do let source = do row <- liftIO fetchRow + case row of + Just row -> + case fromSqlValues row of + Left err -> fail err + Right q -> do yield q + source + Nothing -> return () + return (Right source) + +query :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => (forall s. q db s a) -> BeamT e db m (Source (BeamT e db m) (QExprToIdentity a)) +query q = BeamT $ \beam -> + do res <- runQuery q beam + case res of + Right x -> return (Success (transPipe (BeamT . const . fmap Success) x)) + Left err -> return (Rollback (InternalError err)) + +queryList :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => (forall s. q db s a) -> BeamT e db m [QExprToIdentity a] +queryList q = do src <- query q + src $$ C.consume + +getOne :: (IsQuery q, MonadIO m, Functor m, FromSqlValues (QExprToIdentity a), Projectible a) => (forall s. q db s a) -> BeamT e db m (Maybe (QExprToIdentity a)) +getOne q = + do let justOneSink = await >>= \x -> + case x of + Nothing -> return Nothing + Just x -> noMoreSink x + noMoreSink x = await >>= \nothing -> + case nothing of + Nothing -> return (Just x) + Just _ -> return Nothing + src <- query q + src $$ justOneSink + +fromSqlValues :: FromSqlValues a => [SqlValue] -> Either String a +fromSqlValues vals = + case runState (runErrorT fromSqlValues') vals of + (Right a, []) -> Right a + (Right _, _) -> Left "fromSqlValues: Not all values were consumed" + (Left err, _) -> Left err + +-- * Generic combinators + +-- ref :: Table t => t c -> ForeignKey t c +-- ref = ForeignKey . primaryKey +-- justRef :: Table related => +-- related Identity -> ForeignKey related (Nullable Identity) +-- justRef (e :: related Identity) = ForeignKey (pkChangeRep (Proxy :: Proxy related) just (primaryKey e)) +-- where just :: Columnar' Identity a -> Columnar' (Nullable Identity) a +-- just (Columnar' x) = Columnar' (Just (unsafeCoerce x)) -- TODO : Why is unsafecoerce necessary here? + +-- nothingRef :: Table related => +-- Query db (related Identity) -> ForeignKey related (Nullable Identity) +-- nothingRef (_ :: Query db (related Identity)) = ForeignKey (pkChangeRep (Proxy :: Proxy related) nothing (primaryKey fieldSettings)) +-- where nothing :: Columnar' (TableField related) a -> Columnar' (Nullable Identity) a +-- nothing x = Columnar' Nothing + +-- fieldSettings :: TableSettings related +-- fieldSettings = tblFieldSettings diff --git a/src/Database/Beam/Query/Combinators.hs b/src/Database/Beam/Query/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Query/Combinators.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE UndecidableInstances #-} +module Database.Beam.Query.Combinators + ( all_, join_, guard_, related_, lookup_ + , references_ + + , limit_, offset_ + + , (<.), (>.), (<=.), (>=.), (==.), (&&.), (||.), not_, div_, mod_ + , HaskellLiteralForQExpr(..), SqlValable(..) + , enum_ + + , aggregate + , group_, sum_, count_ + + , orderBy, asc_, desc_ + + , subquery_ ) where + +import Database.Beam.Query.Internal +import Database.Beam.Query.Types + +import Database.Beam.Schema.Tables +import Database.Beam.Schema.Fields +import Database.Beam.SQL +import Database.HDBC + +import Control.Monad.State +import Control.Monad.RWS +import Control.Monad.Identity + +import Data.Monoid +import Data.String +import Data.Maybe +import Data.Convertible +import Data.Text (Text) +import Data.Coerce + +instance IsString (QExpr Text) where + fromString = QExpr . SQLValE . SqlString +instance (Num a, Convertible a SqlValue) => Num (QExpr a) where + fromInteger x = let res :: QExpr a + res = val_ (fromInteger x) + in res + QExpr a + QExpr b = QExpr (SQLBinOpE "+" a b) + QExpr a - QExpr b = QExpr (SQLBinOpE "-" a b) + QExpr a * QExpr b = QExpr (SQLBinOpE "*" a b) + negate (QExpr a) = QExpr (SQLUnOpE "-" a) + abs (QExpr x) = QExpr (SQLFuncE "ABS" [x]) + signum x = error "signum: not defined for QExpr. Use CASE...WHEN" + +-- | Introduce all entries of a table into the 'Q' monad +all_ :: Database db => DatabaseTable db table -> Q db s (table QExpr) +all_ tbl = join_ tbl (val_ True) + +-- | Introduce all entries of a table into the 'Q' monad based on the given SQLExpr +join_ :: Database db => DatabaseTable db table -> QExpr Bool -> Q db s (table QExpr) +join_ (DatabaseTable table name :: DatabaseTable db table) on = + do curTbl <- gets qbNextTblRef + modify $ \qb@QueryBuilder { qbNextTblRef = curTbl + , qbFrom = from + , qbWhere = where_ } -> + let (from', where') = case from of + Nothing -> (Just newSource, where_ &&. on) + Just from -> ( Just (SQLJoin SQLInnerJoin from newSource (optimizeExpr on)), + where_ ) + newSource = SQLFromSource (SQLAliased (SQLSourceTable name) (Just (fromString ("t" <> show curTbl)))) + in qb { qbNextTblRef = curTbl + 1 + , qbFrom = from' + , qbWhere = where' } + + let tableSettings :: TableSettings table + tableSettings = tblFieldSettings + + mkScopedField :: Columnar' (TableField table) a -> Columnar' QExpr a + mkScopedField (Columnar' f) = Columnar' (QExpr (SQLFieldE (QField name (Just curTbl) (_fieldName f)))) + pure (changeRep mkScopedField tableSettings) + +-- | Only allow results for which the 'QExpr' yields 'True' +guard_ :: QExpr Bool -> Q db s () +guard_ guardE' = modify $ \qb@QueryBuilder { qbWhere = guardE } -> qb { qbWhere = guardE &&. guardE' } + +-- | Introduce all entries of the given table which are referenced by the given 'ForeignKey' +related_ :: (Database db, Table rel) => DatabaseTable db rel -> PrimaryKey rel QExpr -> Q db s (rel QExpr) +related_ (relTbl :: DatabaseTable db rel) pk = + mdo rel <- join_ relTbl (pk ==. primaryKey rel) + pure rel + +lookup_ :: (Database db, Table rel) => DatabaseTable db rel -> PrimaryKey rel QExpr -> Q db s (rel QExpr) +lookup_ = related_ + +references_ :: Table tbl => PrimaryKey tbl QExpr -> tbl QExpr -> QExpr Bool +references_ pk (tbl :: tbl QExpr) = pk ==. primaryKey tbl + +-- | Limit the number of results returned by a query. +-- +-- The resulting query is a top-level one that must be passed to 'query', 'queryList', or 'subquery_'. See 'TopLevelQ' for details. +limit_ :: IsQuery q => Integer -> q db s a -> TopLevelQ db s a +limit_ limit' q = + TopLevelQ $ + do res <- toQ q + modify $ \qb -> + let qbLimit' = case qbLimit qb of + Nothing -> Just limit' + Just limit -> Just (min limit limit') + in qb { qbLimit = qbLimit' } + pure res + +-- | Drop the first `offset'` results. +-- +-- The resulting query is a top-level one that must be passed to 'query', 'queryList', or 'subquery_'. See 'TopLevelQ' for details. +offset_ :: IsQuery q => Integer -> q db s a -> TopLevelQ db s a +offset_ offset' q = + TopLevelQ $ + do res <- toQ q + modify $ \qb -> + let qbOffset' = case qbOffset qb of + Nothing -> Just offset' + Just offset -> Just (offset + offset') + in qb { qbOffset = qbOffset' } + pure res + +-- ** Combinators for boolean expressions + +class SqlOrd a where + decomposeToGenQExprs :: a -> [SQLExpr' QField] + (==.), (/=.) :: a -> a -> QExpr Bool + a ==. b = let aExprs = decomposeToGenQExprs a + bExprs = decomposeToGenQExprs b + + combine :: SQLExpr' QField -> SQLExpr' QField -> QExpr Bool + combine a b = QExpr a ==. QExpr b + in foldr (&&.) (val_ True) (zipWith combine aExprs bExprs) + a /=. b = not_ (a ==. b) + +instance SqlOrd (QExpr a) where + decomposeToGenQExprs (QExpr e) = [e] + (==.) = binOpE "==" + (/=.) = binOpE "<>" + +instance {-# OVERLAPPING #-} Table tbl => SqlOrd (PrimaryKey tbl QExpr) where + decomposeToGenQExprs = pkAllValues (\(Columnar' (QExpr e)) -> e) +instance {-# OVERLAPPING #-} Table tbl => SqlOrd (tbl QExpr) where + decomposeToGenQExprs = fieldAllValues (\(Columnar' (QExpr e)) -> e) + +binOpE op (QExpr a) (QExpr b) = QExpr (SQLBinOpE op a b) + +(<.), (>.), (<=.), (>=.) :: QExpr a -> QExpr a -> QExpr Bool +(<.) = binOpE "<" +(>.) = binOpE ">" +(<=.) = binOpE "<=" +(>=.) = binOpE ">=" + +(&&.), (||.) :: QExpr Bool -> QExpr Bool -> QExpr Bool +(&&.) = binOpE "AND" +(||.) = binOpE "OR" + +infixr 3 &&. +infixr 2 ||. +infix 4 ==., /=. + +not_ :: QExpr Bool -> QExpr Bool +not_ (QExpr a) = QExpr (SQLUnOpE "NOT" a) + +mod_, div_ :: Integral a => QExpr a -> QExpr a -> QExpr a +div_ = binOpE "/" +mod_ = binOpE "%" + +enum_ :: Show a => a -> QExpr (BeamEnum a) +enum_ = QExpr . SQLValE . SqlString . show + +-- * Marshalling between Haskell literals and QExprs + +type family HaskellLiteralForQExpr x +type instance HaskellLiteralForQExpr (QExpr a) = a +type instance HaskellLiteralForQExpr (table QExpr) = table Identity + +class SqlValable a where + val_ :: HaskellLiteralForQExpr a -> a +instance Convertible a SqlValue => SqlValable (QExpr a) where + val_ = QExpr . SQLValE . convert + +-- NOTE: This shouldn't cause problems because both overlapping instances are in the same module. +-- GHC should prefer the PrimaryKey one for primary keys and the table one for everything else. +-- AFAICT, PrimaryKey tbl QExpr ~ tbl QExpr is impossible +instance {-# OVERLAPPING #-} Table tbl => SqlValable (PrimaryKey tbl QExpr) where + val_ = pkChangeRep valToQExpr . pkMakeSqlValues + where valToQExpr :: Columnar' SqlValue' a -> Columnar' QExpr a + valToQExpr (Columnar' (SqlValue' v)) = Columnar' (QExpr (SQLValE v)) +instance {-# OVERLAPPING #-} Table tbl => SqlValable (tbl QExpr) where + val_ = changeRep valToQExpr . makeSqlValues + where valToQExpr :: Columnar' SqlValue' a -> Columnar' QExpr a + valToQExpr (Columnar' (SqlValue' v)) = Columnar' (QExpr (SQLValE v)) + +-- * Aggregators + +class Aggregating agg where + type LiftAggregationsToQExpr agg + + aggToSql :: agg -> SQLGrouping + liftAggToQExpr :: agg -> LiftAggregationsToQExpr agg +instance Table t => Aggregating (t Aggregation) where + type LiftAggregationsToQExpr (t Aggregation) = t QExpr + aggToSql table = mconcat (fieldAllValues (\(Columnar' x) -> aggToSql x) table) + liftAggToQExpr = changeRep (\(Columnar' x) -> Columnar' (liftAggToQExpr x)) +instance Aggregating (Aggregation a) where + type LiftAggregationsToQExpr (Aggregation a) = QExpr a + aggToSql (GroupAgg e) = let eSql = optimizeExpr' e + in mempty { sqlGroupBy = [eSql] } + aggToSql (GenericAgg f qExprs) = mempty + + liftAggToQExpr (GroupAgg e) = QExpr e + liftAggToQExpr (GenericAgg f qExprs) = QExpr (SQLFuncE f qExprs) +instance (Aggregating a, Aggregating b) => Aggregating (a, b) where + type LiftAggregationsToQExpr (a, b) = ( LiftAggregationsToQExpr a + , LiftAggregationsToQExpr b ) + aggToSql (a, b) = aggToSql a <> aggToSql b + liftAggToQExpr (a, b) = (liftAggToQExpr a, liftAggToQExpr b) +instance (Aggregating a, Aggregating b, Aggregating c) => Aggregating (a, b, c) where + type LiftAggregationsToQExpr (a, b, c) = ( LiftAggregationsToQExpr a + , LiftAggregationsToQExpr b + , LiftAggregationsToQExpr c ) + aggToSql (a, b, c) = aggToSql a <> aggToSql b <> aggToSql c + liftAggToQExpr (a, b, c) = (liftAggToQExpr a, liftAggToQExpr b, liftAggToQExpr c) +instance (Aggregating a, Aggregating b, Aggregating c, Aggregating d) => Aggregating (a, b, c, d) where + type LiftAggregationsToQExpr (a, b, c, d) = ( LiftAggregationsToQExpr a + , LiftAggregationsToQExpr b + , LiftAggregationsToQExpr c + , LiftAggregationsToQExpr d ) + aggToSql (a, b, c, d) = aggToSql a <> aggToSql b <> aggToSql c <> aggToSql d + liftAggToQExpr (a, b, c, d) = (liftAggToQExpr a, liftAggToQExpr b, liftAggToQExpr c, liftAggToQExpr d) +instance (Aggregating a, Aggregating b, Aggregating c, Aggregating d, Aggregating e) => Aggregating (a, b, c, d, e) where + type LiftAggregationsToQExpr (a, b, c, d, e) = ( LiftAggregationsToQExpr a + , LiftAggregationsToQExpr b + , LiftAggregationsToQExpr c + , LiftAggregationsToQExpr d + , LiftAggregationsToQExpr e ) + aggToSql (a, b, c, d, e) = aggToSql a <> aggToSql b <> aggToSql c <> aggToSql d <> aggToSql e + liftAggToQExpr (a, b, c, d, e) = (liftAggToQExpr a, liftAggToQExpr b, liftAggToQExpr c, liftAggToQExpr d, liftAggToQExpr e) + +group_ :: QExpr a -> Aggregation a +group_ (QExpr a) = GroupAgg a + +sum_ :: Num a => QExpr a -> Aggregation a +sum_ (QExpr over) = GenericAgg "SUM" [over] + +count_ :: QExpr a -> Aggregation Int +count_ (QExpr over) = GenericAgg "COUNT" [over] + +aggregate :: (Projectible a, Aggregating agg) => (a -> agg) -> (forall s. Q db s a) -> Q db s (LiftAggregationsToQExpr agg) +aggregate aggregator q = + do res <- q + + curTbl <- gets qbNextTblRef + let aggregation = aggregator res + grouping' = aggToSql aggregation + modify $ \qb -> case sqlGroupBy grouping' of + [] -> qb + _ -> case qbGrouping qb of + Nothing -> qb { qbGrouping = Just grouping' } + Just grouping -> qb { qbGrouping = Just (grouping <> grouping') } + pure (liftAggToQExpr aggregation) + +-- * Order bys + +class SqlOrderable a where + makeSQLOrdering :: a -> [SQLOrdering] +instance SqlOrderable SQLOrdering where + makeSQLOrdering x = [x] +instance SqlOrderable a => SqlOrderable [a] where + makeSQLOrdering = concatMap makeSQLOrdering +instance ( SqlOrderable a + , SqlOrderable b ) => SqlOrderable (a, b) where + makeSQLOrdering (a, b) = makeSQLOrdering a <> makeSQLOrdering b +instance ( SqlOrderable a + , SqlOrderable b + , SqlOrderable c ) => SqlOrderable (a, b, c) where + makeSQLOrdering (a, b, c) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c +instance ( SqlOrderable a + , SqlOrderable b + , SqlOrderable c + , SqlOrderable d ) => SqlOrderable (a, b, c, d) where + makeSQLOrdering (a, b, c, d) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d +instance ( SqlOrderable a + , SqlOrderable b + , SqlOrderable c + , SqlOrderable d + , SqlOrderable e ) => SqlOrderable (a, b, c, d, e) where + makeSQLOrdering (a, b, c, d, e) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> makeSQLOrdering e + +orderBy :: (SqlOrderable ordering, IsQuery q) => (a -> ordering) -> q db s a -> TopLevelQ db s a +orderBy orderer q = + TopLevelQ $ + do res <- toQ q + let ordering = makeSQLOrdering (orderer res) + modify $ \qb -> qb { qbOrdering = qbOrdering qb <> ordering } + pure res + +desc_, asc_ :: QExpr a -> SQLOrdering +asc_ e = Asc (optimizeExpr e) +desc_ e = Desc (optimizeExpr e) + +-- * Subqueries + +class Subqueryable a where + subqueryProjections :: a -> RWS (Text, Int) [SQLAliased SQLExpr] Int a +instance Subqueryable (QExpr a) where + subqueryProjections e = + do i <- state (\i -> (i, i+1)) + (tblName, tblOrd) <- ask + let fieldName = fromString ("e" <> show i) + tell [SQLAliased (optimizeExpr e) (Just fieldName)] + pure (QExpr (SQLFieldE (QField tblName (Just tblOrd) fieldName))) +instance ( Subqueryable a + , Subqueryable b ) => + Subqueryable (a, b) where + subqueryProjections (a, b) = + (,) <$> subqueryProjections a + <*> subqueryProjections b +instance ( Subqueryable a + , Subqueryable b + , Subqueryable c ) => + Subqueryable (a, b, c) where + subqueryProjections (a, b, c) = + (,,) <$> subqueryProjections a + <*> subqueryProjections b + <*> subqueryProjections c +instance ( Subqueryable a + , Subqueryable b + , Subqueryable c + , Subqueryable d ) => + Subqueryable (a, b, c, d) where + subqueryProjections (a, b, c, d) = + (,,,) <$> subqueryProjections a + <*> subqueryProjections b + <*> subqueryProjections c + <*> subqueryProjections d +instance ( Subqueryable a + , Subqueryable b + , Subqueryable c + , Subqueryable d + , Subqueryable e ) => + Subqueryable (a, b, c, d, e) where + subqueryProjections (a, b, c, d, e) = + (,,,,) <$> subqueryProjections a + <*> subqueryProjections b + <*> subqueryProjections c + <*> subqueryProjections d + <*> subqueryProjections e + +subquery_ :: (IsQuery q, Projectible a, Subqueryable a) => (forall s. q db s a) -> Q db s a +subquery_ q = do curTbl <- gets qbNextTblRef + + let (res, select') = queryToSQL' (toQ q) + + subTblName = fromString ("t" <> show curTbl) + (res', projection') = evalRWS (subqueryProjections res) (subTblName, curTbl) 0 + + select'' = select' { selProjection = SQLProj projection' } + + modify $ \qb@QueryBuilder { qbNextTblRef = curTbl + , qbFrom = from } -> + let from' = case from of + Nothing -> Just newSource + Just from -> Just (SQLJoin SQLInnerJoin from newSource (SQLValE (SqlBool True))) + newSource = SQLFromSource (SQLAliased (SQLSourceSelect select'') (Just (fromString ("t" <> show curTbl)))) + in qb { qbNextTblRef = curTbl + 1 + , qbFrom = from' } + + pure res' diff --git a/src/Database/Beam/Query/Internal.hs b/src/Database/Beam/Query/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Query/Internal.hs @@ -0,0 +1,84 @@ +module Database.Beam.Query.Internal where + +import Database.Beam.SQL.Types +import Database.Beam.Schema + +import qualified Data.Text as T +import Data.Typeable +import Data.Coerce + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Writer hiding (All) +import Control.Monad.Identity + +import Database.HDBC + +class IsQuery q where + toQ :: q db s a -> Q db s a + +newtype Q (db :: (((* -> *) -> *) -> *) -> *) s a = Q { runQ :: State QueryBuilder a} + deriving (Monad, Applicative, Functor, MonadFix, MonadState QueryBuilder) + +-- | Wrapper for 'Q's that have been modified in such a way that they can no longer be joined against +-- without the use of 'subquery'. 'TopLevelQ' is also an instance of 'IsQuery', and so can be passed +-- directly to 'query' or 'queryList' +newtype TopLevelQ db s a = TopLevelQ (Q db s a) + +data QueryBuilder = QueryBuilder + { qbNextTblRef :: Int + , qbFrom :: Maybe SQLFrom + , qbWhere :: QExpr Bool + + , qbLimit :: Maybe Integer + , qbOffset :: Maybe Integer + , qbOrdering :: [SQLOrdering] + , qbGrouping :: Maybe SQLGrouping } + +-- * QExpr type + +data QField = QField + { qFieldTblName :: T.Text + , qFieldTblOrd :: Maybe Int + , qFieldName :: T.Text } + deriving (Show, Eq, Ord) + +newtype QExpr t = QExpr (SQLExpr' QField) + deriving (Show, Eq) + +-- * Sql Projections +-- +-- Here we define a typeclass for all haskell data types that can be used +-- to create a projection in a SQL select statement. This includes all tables +-- as well as all tuple classes. Projections are only defined on tuples up to +-- size 5. If you need more, follow the implementations here. + +class Projectible a where + project :: a -> [SQLExpr' QField] +instance Typeable a => Projectible (QExpr a) where + project (QExpr x) = [x] +instance (Projectible a, Projectible b) => Projectible (a, b) where + project (a, b) = project a ++ project b +instance ( Projectible a + , Projectible b + , Projectible c ) => Projectible (a, b, c) where + project (a, b, c) = project a ++ project b ++ project c +instance ( Projectible a + , Projectible b + , Projectible c + , Projectible d ) => Projectible (a, b, c, d) where + project (a, b, c, d) = project a ++ project b ++ project c ++ project d +instance ( Projectible a + , Projectible b + , Projectible c + , Projectible d + , Projectible e ) => Projectible (a, b, c, d, e) where + project (a, b, c, d, e) = project a ++ project b ++ project c ++ project d ++ project e + +instance Table t => Projectible (t QExpr) where + project t = fieldAllValues (\(Columnar' (QExpr e)) -> e) t + +tableVal :: Table tbl => tbl Identity -> tbl QExpr +tableVal = changeRep valToQExpr . makeSqlValues + where valToQExpr :: Columnar' SqlValue' a -> Columnar' QExpr a + valToQExpr (Columnar' (SqlValue' v)) = Columnar' (QExpr (SQLValE v)) diff --git a/src/Database/Beam/Query/Types.hs b/src/Database/Beam/Query/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Query/Types.hs @@ -0,0 +1,119 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +module Database.Beam.Query.Types + ( Q, QExpr, QExprToIdentity(..), TopLevelQ, IsQuery + + , Projectible(..) + + , Aggregation(..) + + , queryToSQL' + + , allExprOpts, mkSqlField, optimizeExpr, optimizeExpr' ) where + +import Database.Beam.Query.Internal + +import Database.Beam.Schema.Tables +import Database.Beam.Schema.Fields +import Database.Beam.SQL +import Database.HDBC + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Writer hiding (All) +import Control.Monad.Identity + +import Data.Monoid hiding (All) +import Data.Proxy +import Data.Coerce +import Data.Data +import Data.Maybe +import Data.String +import qualified Data.Text as T +import Data.Generics.Uniplate.Data + +import Unsafe.Coerce + +-- * Beam queries + +type family QExprToIdentity x +type instance QExprToIdentity (table QExpr) = table Identity +type instance QExprToIdentity (QExpr a) = a +type instance QExprToIdentity (a, b) = (QExprToIdentity a, QExprToIdentity b) +type instance QExprToIdentity (a, b, c) = (QExprToIdentity a, QExprToIdentity b, QExprToIdentity c) + +instance IsQuery Q where + toQ = id +instance IsQuery TopLevelQ where + toQ (TopLevelQ q) = q + +-- * Aggregations + +data Aggregation a = GroupAgg (SQLExpr' QField) + | GenericAgg T.Text [SQLExpr' QField] + +-- * Rewriting and optimization + +-- rwE :: Monad m => (forall a. QExpr a -> m (Maybe (QExpr a))) -> QExpr a -> m (QExpr a) +-- rwE f x = do x' <- f x +-- case x' of +-- Nothing -> return x +-- Just x' +-- | x == x' -> return x +-- | otherwise -> rewriteExprM f x' + +-- rewriteExprM :: Monad m => (forall a . QExpr a -> m (Maybe (QExpr a))) -> QExpr a -> m (QExpr a) +-- rewriteExprM f (BinOpE op a b) = +-- do a' <- rewriteExprM f a +-- b' <- rewriteExprM f b +-- rwE f (BinOpE op a' b') +-- rewriteExprM f (UnOpE op a) = +-- do a' <- rewriteExprM f a +-- rwE f (UnOpE op a') +-- -- rewriteExprM f (JustE a) = do a' <- rewriteExprM f a +-- -- rwE f (JustE a') +-- rewriteExprM f (IsNothingE a) = do a' <- rewriteExprM f a +-- rwE f (IsNothingE a') +-- rewriteExprM f (IsJustE a) = do a' <- rewriteExprM f a +-- rwE f (IsJustE a') +-- -- rewriteExprM f (InE a b) = rewriteBin f InE a b +-- -- rewriteExprM f (ListE as) = do as' <- mapM (rewriteExprM f fq) as +-- -- rwE f (ListE as') +-- rewriteExprM f x = rwE f x + +booleanOpts :: SQLExpr -> Maybe SQLExpr +booleanOpts (SQLBinOpE "AND" (SQLValE (SqlBool False)) _) = Just (SQLValE (SqlBool False)) +booleanOpts (SQLBinOpE "AND" _ (SQLValE (SqlBool False))) = Just (SQLValE (SqlBool False)) +booleanOpts (SQLBinOpE "AND" (SQLValE (SqlBool True)) q) = Just q +booleanOpts (SQLBinOpE "AND" q (SQLValE (SqlBool True))) = Just q + +booleanOpts (SQLBinOpE "OR" q (SQLValE (SqlBool False))) = Just q +booleanOpts (SQLBinOpE "OR" (SQLValE (SqlBool False)) q) = Just q +booleanOpts (SQLBinOpE "OR" (SQLValE (SqlBool True)) (SQLValE (SqlBool True))) = Just (SQLValE (SqlBool True)) + +booleanOpts x = Nothing + +allExprOpts e = pure (booleanOpts e) + +optimizeExpr' :: SQLExpr' QField -> SQLExpr +optimizeExpr' = runIdentity . rewriteM allExprOpts . fmap mkSqlField +optimizeExpr :: QExpr a -> SQLExpr +optimizeExpr (QExpr e) = optimizeExpr' e + +mkSqlField :: QField -> SQLFieldName +mkSqlField (QField tblName (Just tblOrd) fieldName) = SQLQualifiedFieldName fieldName ("t" <> fromString (show tblOrd)) +mkSqlField (QField tblName Nothing fieldName) = SQLFieldName fieldName + +queryToSQL' :: Projectible a => Q db s a -> (a, SQLSelect) +queryToSQL' q = let (res, qb) = runState (runQ q) emptyQb + emptyQb = QueryBuilder 0 Nothing (QExpr (SQLValE (SqlBool True))) Nothing Nothing [] Nothing + projection = map (\q -> SQLAliased (optimizeExpr' q) Nothing) (project res) + + sel = SQLSelect + { selProjection = SQLProj projection + , selFrom = qbFrom qb + , selWhere = optimizeExpr (qbWhere qb) + , selGrouping = qbGrouping qb + , selOrderBy = qbOrdering qb + , selLimit = qbLimit qb + , selOffset = qbOffset qb } + in (res, sel) diff --git a/src/Database/Beam/SQL.hs b/src/Database/Beam/SQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/SQL.hs @@ -0,0 +1,224 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +module Database.Beam.SQL + ( -- * SQL pretty printing + ppSQL + + -- * Untyped SQL types + , module Database.Beam.SQL.Types ) where + +import Database.Beam.SQL.Types + +import Control.Applicative hiding (empty) +import Control.Arrow hiding ((<+>)) +import Control.Monad.Writer hiding ((<>)) + +import Data.Maybe +import Data.Text (Text, unpack) +import Data.String + +import Database.HDBC + +import Text.PrettyPrint + +-- * Pretty printing support + +-- | Convert a 'SQLCommand' into a SQL expression (with placeholders) and literal values to be submitted to the SQL server. +-- Splitting into a SQL expression and literals prevents SQL injection attacks. +ppSQL :: SQLCommand -> (String, [SqlValue]) +ppSQL c = first render (runWriter (ppCmd c)) + +type DocAndVals = Writer [SqlValue] Doc + +ppCmd :: SQLCommand -> DocAndVals +ppCmd (Select sel) = ppSel sel +ppCmd (CreateTable ct) = ppCreateTable ct +ppCmd (Insert i) = ppInsert i +ppCmd (Update u) = ppUpdate u +ppCmd (Delete d) = ppDelete d + +-- ** Create table printing support + +ppCreateTable :: SQLCreateTable -> DocAndVals +ppCreateTable (SQLCreateTable tblName schema) = + do fieldSchemas <- mapM ppFieldSchema schema + let primaryKeys = filter (elem SQLPrimaryKey . csConstraints . snd) schema + primaryKeyExpr = case primaryKeys of + [] -> [] + keys -> + let primaryKeys = map (text . unpack . fst) keys + in [text "PRIMARY KEY(" <+> hsep (punctuate comma primaryKeys) <+> text ")" ] + return (text "CREATE TABLE" <+> text (unpack tblName) <+> parens (hsep (punctuate comma (fieldSchemas ++ primaryKeyExpr)))) + +ppFieldSchema :: (Text, SQLColumnSchema) -> DocAndVals +ppFieldSchema (name, colSch) = (text (unpack name) <+>) <$> ppColSchema colSch + +ppColSchema :: SQLColumnSchema -> DocAndVals +ppColSchema (SQLColumnSchema type_ constraints) = + do typeDoc <- ppColType type_ + constraints <- mapM ppConstraint constraints + return (typeDoc <+> hsep constraints) + +ppConstraint :: SQLConstraint -> DocAndVals +ppConstraint SQLPrimaryKey = return empty --(text "PRIMARY KEY") +--ppConstraint SQLPrimaryKeyAutoIncrement = return (text "PRIMARY KEY") +ppConstraint SQLAutoIncrement = return (text "AUTOINCREMENT") -- TODO this is different dependingon the backend +ppConstraint SQLNotNull = return (text "NOT NULL") + +ppColType :: SqlColDesc -> DocAndVals +ppColType SqlColDesc { colType = SqlVarCharT + , colSize = size } = + return + (text "VARCHAR" <+> + case size of + Nothing -> empty + Just sz -> parens (text (show sz))) +ppColType SqlColDesc { colType = SqlCharT + , colSize = size } = + return + (text "CHAR" <+> + case size of + Nothing -> empty + Just sz -> parens (text (show sz))) +ppColType SqlColDesc { colType = SqlNumericT } = return (text "INTEGER") +ppColType SqlColDesc { colType = SqlUTCDateTimeT } = return (text "DATETIME") + +-- ** Insert printing support + +ppInsert :: SQLInsert -> DocAndVals +ppInsert (SQLInsert tblName values) = + do vals <- mapM ppVal values + return (text "INSERT INTO" <+> text (unpack tblName) <+> text "VALUES" <+> + parens (hsep (punctuate comma vals))) + +-- ** Update printing support + +ppAssignment :: SQLFieldName -> SQLExpr -> DocAndVals +ppAssignment field expr = + do fieldD <- ppFieldName field + exprD <- ppExpr expr + return (fieldD <> text "=" <> exprD) + +ppUpdate :: SQLUpdate -> DocAndVals +ppUpdate (SQLUpdate tbls assignments where_) = + do assignmentsDs <- mapM (uncurry ppAssignment) assignments + whereClause_ <- case where_ of + Nothing -> return empty + Just where_ -> ppWhere where_ + return (text "UPDATE" <+> hsep (punctuate comma (map (text . unpack) tbls)) <+> + text "SET" <+> hsep (punctuate comma assignmentsDs) <+> + whereClause_) + +-- ** Delete printing support + +ppDelete :: SQLDelete -> DocAndVals +ppDelete (SQLDelete tbl where_) = + do whereClause_ <- case where_ of + Nothing -> return empty + Just where_ -> ppWhere where_ + return (text "DELETE FROM" <+> text (unpack tbl) <+> whereClause_) + +-- ** Select printing support + +ppSel :: SQLSelect -> DocAndVals +ppSel sel = + do proj <- ppProj (selProjection sel) + source <- case selFrom sel of + Nothing -> pure empty + Just from -> do source <- ppFrom from + pure (text "FROM " <+> source) + where_ <- ppWhere (selWhere sel) + grouping <- case selGrouping sel of + Nothing -> return empty + Just grouping -> ppGrouping grouping + orderBy <- ppOrderBy (selOrderBy sel) + let limit = maybe empty ((text "LIMIT" <+>) . text . show) (selLimit sel) + offset = maybe empty ((text "OFFSET" <+>) . text . show) (selOffset sel) + return (text "SELECT" <+> proj <+> source <+> + where_ <+> grouping <+> orderBy <+> limit <+> offset) + +ppProj :: SQLProjection -> DocAndVals +ppProj SQLProjStar = return (text "*") +ppProj (SQLProj es) = + do es <- mapM (ppAliased ppExpr) es + return (hsep (punctuate comma es)) + +ppAliased :: (a -> DocAndVals) -> SQLAliased a -> DocAndVals +ppAliased ppSub (SQLAliased x (Just as)) = do sub <- ppSub x + return (sub <+> text "AS" <+> text (unpack as)) +ppAliased ppSub (SQLAliased x Nothing) = ppSub x + +ppSource :: SQLSource -> DocAndVals +ppSource (SQLSourceTable tbl) = return (text (unpack tbl)) +ppSource (SQLSourceSelect sel) = parens <$> ppSel sel + +ppWhere (SQLValE v) + | safeFromSql v == Right True = return empty +ppWhere expr = (text "WHERE" <+>) <$> ppExpr expr + +ppFieldName (SQLQualifiedFieldName t table) = return (text "`" <> text (unpack table) <> text "`.`" <> + text (unpack t) <> text "`") +ppFieldName (SQLFieldName t) = return (text (unpack t)) + +ppGrouping grouping = do exprs <- mapM ppExpr (sqlGroupBy grouping) + having <- ppHaving (sqlHaving grouping) + return (text "GROUP BY" <+> hsep (punctuate comma exprs) <+> having) + +ppHaving (SQLValE v) + | safeFromSql v == Right True = return empty +ppHaving expr = (text "HAVING" <+>) <$> ppExpr expr + +ppFrom x = fst <$> ppFrom' x + +ppFrom' (SQLFromSource a) = (,False) <$> ppAliased ppSource a +ppFrom' (SQLJoin jType x y on_) = do (xDoc, _) <- ppFrom' x + jTypeDoc <- ppJType jType + (yDoc, yIsJoin) <- ppFrom' y + onDoc <- ppOn on_ + return (xDoc <+> jTypeDoc <+> if yIsJoin then yDoc else yDoc <+> onDoc, True) + +ppJType SQLInnerJoin = return (text "INNER JOIN") +ppJType SQLLeftJoin = return (text "LEFT JOIN") +ppJType SQLRightJoin = return (text "RIGHT JOIN") +ppJType SQLOuterJoin = return (text "OUTER JOIN") + +ppOn (SQLValE v) + | safeFromSql v == Right True = return empty +ppOn expr = (text "ON" <+>) <$> ppExpr expr + +ppOrderBy [] = return empty +ppOrderBy xs = (text "ORDER BY" <+>) . hsep . punctuate comma <$> mapM ppOrdering xs + where ppOrdering (Asc e) = do eDoc <- ppExpr e + return (eDoc <+> text "ASC") + ppOrdering (Desc e) = do eDoc <- ppExpr e + return (eDoc <+> text "DESC") + +ppVal :: SqlValue -> DocAndVals +ppVal val = tell [val] >> return (text "?") + +ppExpr :: SQLExpr -> DocAndVals +ppExpr (SQLValE v) = ppVal v +ppExpr (SQLFieldE name) = ppFieldName name +ppExpr (SQLBinOpE op a b) = + do aD <- ppExpr a + bD <- ppExpr b + return (parens (aD <+> text (unpack op) <+> bD)) +ppExpr (SQLUnOpE op a) = do aDoc <- ppExpr a + return (parens (text (unpack op) <+> parens aDoc)) +ppExpr (SQLIsNothingE q) = do qDoc <- ppExpr q + return (qDoc <+> text "IS NULL") +ppExpr (SQLIsJustE q) = do qDoc <- ppExpr q + return (qDoc <+> text "IS NOT NULL") +ppExpr (SQLListE xs) = do xsDoc <- mapM ppExpr xs + return (parens (hsep (punctuate comma xsDoc))) +-- ppExpr (SQLCountE x) = do xDoc <- ppExpr x +-- return (text "COUNT" <> parens xDoc) +-- ppExpr (SQLMinE x) = do xDoc <- ppExpr x +-- return (text "MIN" <> parens xDoc) +-- ppExpr (SQLMaxE x) = do xDoc <- ppExpr x +-- return (text "MAX" <> parens xDoc) +-- ppExpr (SQLSumE x) = do xDoc <- ppExpr x +-- return (text "SUM" <> parens xDoc) +-- ppExpr (SQLAverageE x) = do xDoc <- ppExpr x +-- return (text "AVERAGE" <> parens xDoc) +ppExpr (SQLFuncE f args) = do argDocs <- mapM ppExpr args + return (text (unpack f) <> parens (hsep (punctuate comma argDocs)) ) diff --git a/src/Database/Beam/SQL/Types.hs b/src/Database/Beam/SQL/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/SQL/Types.hs @@ -0,0 +1,128 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +module Database.Beam.SQL.Types where + +import Data.Text (Text) +import Data.Time.Clock +import Data.Monoid +import Data.Data +import Data.Functor + +import Database.HDBC + +noConstraints, notNull :: SqlColDesc -> SQLColumnSchema +noConstraints desc = SQLColumnSchema desc [] +notNull desc = SQLColumnSchema desc [SQLNotNull] + +-- * SQL queries +-- +-- Types for most forms of SQL queries and data updates/inserts. This is the internal representation used by Beam. +-- Typically, you'd use the typed representation 'QExpr' and 'Q' to guarantee type-safety, and let Beam do the +-- low-level conversion to Sql + +data SQLCommand = Select SQLSelect + | Insert SQLInsert + | Update SQLUpdate + | Delete SQLDelete + + -- DDL + | CreateTable SQLCreateTable + deriving Show + +data SQLCreateTable = SQLCreateTable + { ctTableName :: Text + , ctFields :: [(Text, SQLColumnSchema)] } + deriving Show + +data SQLColumnSchema = SQLColumnSchema + { csType :: SqlColDesc + , csConstraints :: [SQLConstraint] } + deriving Show + +data SQLConstraint = SQLPrimaryKey + | SQLAutoIncrement + | SQLNotNull + deriving (Show, Eq) + +data SQLInsert = SQLInsert + { iTableName :: Text + , iValues :: [SqlValue] } + deriving Show + +data SQLUpdate = SQLUpdate + { uTableNames :: [Text] + , uAssignments :: [(SQLFieldName, SQLExpr)] + , uWhere :: Maybe SQLExpr } + deriving Show + +data SQLDelete = SQLDelete + { dTableName :: Text + , dWhere :: Maybe SQLExpr } + deriving Show + +data SQLSelect = SQLSelect + { selProjection :: SQLProjection + , selFrom :: Maybe SQLFrom + , selWhere :: SQLExpr + , selGrouping :: Maybe SQLGrouping + , selOrderBy :: [SQLOrdering] + , selLimit :: Maybe Integer + , selOffset :: Maybe Integer } + deriving Show + +data SQLFieldName = SQLFieldName Text + | SQLQualifiedFieldName Text Text + deriving (Show, Eq, Data) + +data SQLAliased a = SQLAliased a (Maybe Text) + deriving Show + +data SQLProjection = SQLProjStar -- ^ The * from SELECT * + | SQLProj [SQLAliased SQLExpr] + deriving Show + +data SQLSource = SQLSourceTable Text + | SQLSourceSelect SQLSelect + deriving Show + +data SQLJoinType = SQLInnerJoin + | SQLLeftJoin + | SQLRightJoin + | SQLOuterJoin + deriving Show + +data SQLFrom = SQLFromSource (SQLAliased SQLSource) + | SQLJoin SQLJoinType SQLFrom SQLFrom SQLExpr + deriving Show + +data SQLGrouping = SQLGrouping + { sqlGroupBy :: [SQLExpr] + , sqlHaving :: SQLExpr } + deriving (Show) + +instance Monoid SQLGrouping where + mappend (SQLGrouping group1 having1) (SQLGrouping group2 having2) = + SQLGrouping (group1 <> group2) (andE having1 having2) + where andE (SQLValE (SqlBool True)) h = h + andE h (SQLValE (SqlBool True)) = h + andE a b = SQLBinOpE "AND" a b + mempty = SQLGrouping mempty (SQLValE (SqlBool True)) + +data SQLOrdering = Asc SQLExpr + | Desc SQLExpr + deriving Show + +data SQLExpr' f = SQLValE SqlValue + | SQLFieldE f + + | SQLBinOpE Text (SQLExpr' f) (SQLExpr' f) + | SQLUnOpE Text (SQLExpr' f) + + | SQLIsNothingE (SQLExpr' f) + | SQLIsJustE (SQLExpr' f) + + | SQLListE [SQLExpr' f] + + | SQLFuncE Text [SQLExpr' f] + deriving (Show, Functor, Eq, Data) +deriving instance Data SqlValue +type SQLExpr = SQLExpr' SQLFieldName diff --git a/src/Database/Beam/Schema.hs b/src/Database/Beam/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Schema.hs @@ -0,0 +1,14 @@ +-- | Defines type classes for 'Table's and 'Database's. +-- +-- All important class methods of these classes can be derived automatically using 'Generic's and GHC's DefaultSignatures extension, +-- but you can override any method if necessary. +-- +-- To get started, see 'Table', 'Columnar', and 'Nullable'. +module Database.Beam.Schema + ( module Database.Beam.Schema.Tables + , module Database.Beam.Schema.Fields + , module Database.Beam.Schema.Lenses ) where + +import Database.Beam.Schema.Tables +import Database.Beam.Schema.Fields +import Database.Beam.Schema.Lenses diff --git a/src/Database/Beam/Schema/Fields.hs b/src/Database/Beam/Schema/Fields.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Schema/Fields.hs @@ -0,0 +1,109 @@ +module Database.Beam.Schema.Fields where + +import Database.Beam.Schema.Tables +import Database.Beam.SQL.Types + +import Control.Applicative +import Control.Arrow +import Control.Monad.State +import Control.Monad.Error + +import Data.Time.Clock +import Data.Text (Text, unpack) +import Data.Proxy +import Data.String +import Data.Typeable + +import Database.HDBC ( SqlColDesc(..), SqlTypeId(..), SqlValue(..) + , fromSql) + +import GHC.Generics hiding (R) +import qualified GHC.Generics as Generic + +-- * Fields + +instance (Enum a, Show a, Read a, Typeable a) => FieldSchema (BeamEnum a) where + data FieldSettings (BeamEnum a) = EnumSettings + { maxNameSize :: Maybe Int } + deriving Show + + defSettings = EnumSettings Nothing + + colDescFromSettings (EnumSettings nameSize) = colDescFromSettings (defSettings { charOrVarChar = Varchar nameSize }) + + makeSqlValue (BeamEnum x) = SqlString (show x) + fromSqlValue = BeamEnum . read . fromSql <$> popSqlValue +instance (Enum a, Show a, Read a, Typeable a) => FromSqlValues (BeamEnum a) + +-- ** Text field + +data CharOrVarchar = Char (Maybe Int) + | Varchar (Maybe Int) + deriving Show + +instance FieldSchema Text where + -- | Settings for a text field + data FieldSettings Text = TextFieldSettings + { charOrVarChar :: CharOrVarchar } + deriving Show + + defSettings = TextFieldSettings (Varchar Nothing) + + colDescFromSettings (TextFieldSettings (Char n)) = notNull $ + SqlColDesc + { colType = SqlCharT + , colSize = n + , colOctetLength = Nothing + , colDecDigits = Nothing + , colNullable = Nothing } + colDescFromSettings (TextFieldSettings (Varchar n)) = notNull $ + SqlColDesc + { colType = SqlVarCharT + , colSize = n + , colOctetLength = Nothing + , colDecDigits = Nothing + , colNullable = Nothing } + + makeSqlValue x = SqlString (unpack x) + fromSqlValue = fromSql <$> popSqlValue +instance FromSqlValues Text + +instance FieldSchema UTCTime where + data FieldSettings UTCTime = DateTimeDefault + deriving Show + + defSettings = DateTimeDefault + colDescFromSettings _ = notNull $ + SqlColDesc + { colType = SqlUTCDateTimeT + , colSize = Nothing + , colOctetLength = Nothing + , colDecDigits = Nothing + , colNullable = Nothing } + makeSqlValue = SqlUTCTime + fromSqlValue = fromSql <$> popSqlValue +instance FromSqlValues UTCTime + +-- ** Auto-increment fields + +data AutoId = UnassignedId + | AssignedId !Int + deriving (Show, Read, Eq, Ord, Generic) + +instance FieldSchema AutoId where + data FieldSettings AutoId = AutoIdDefault + deriving Show + defSettings = AutoIdDefault + colDescFromSettings _ = SQLColumnSchema desc [SQLNotNull, SQLAutoIncrement] + where desc = SqlColDesc + { colType = SqlNumericT + , colSize = Nothing + , colOctetLength = Nothing + , colDecDigits = Nothing + , colNullable = Nothing } + + makeSqlValue UnassignedId = SqlNull + makeSqlValue (AssignedId i) = SqlInteger (fromIntegral i) + fromSqlValue = maybe UnassignedId AssignedId . fromSql <$> popSqlValue + +instance FromSqlValues AutoId diff --git a/src/Database/Beam/Schema/Lenses.hs b/src/Database/Beam/Schema/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Schema/Lenses.hs @@ -0,0 +1,116 @@ +module Database.Beam.Schema.Lenses + ( tableConfigLenses ) where + +import Database.Beam.Internal +import Database.Beam.Schema.Tables +import Database.Beam.Schema.Fields + +import Control.Applicative +import Control.Monad.Identity + +import Data.Functor +import Data.Proxy + +import GHC.Generics + +import Lens.Micro hiding (to) + +class GTableLenses t (m :: * -> *) a (lensType :: * -> *) where + gTableLenses :: Proxy a -> Lens' (t m) (a p) -> lensType () +instance GTableLenses t m a al => GTableLenses t m (M1 s d a) (M1 s d al) where + gTableLenses (Proxy :: Proxy (M1 s d a)) lensToHere = M1 $ gTableLenses (Proxy :: Proxy a) (\f -> lensToHere (\(M1 x) -> M1 <$> f x)) +instance (GTableLenses t m a aLens, GTableLenses t m b bLens) => GTableLenses t m (a :*: b) (aLens :*: bLens) where + gTableLenses (Proxy :: Proxy (a :*: b)) lensToHere = leftLenses :*: rightLenses + where leftLenses = gTableLenses (Proxy :: Proxy a) (\f -> lensToHere (\(a :*: b) -> (:*: b) <$> f a)) + rightLenses = gTableLenses (Proxy :: Proxy b) (\f -> lensToHere (\(a :*: b) -> (a :*:) <$> f b)) +instance Generic (t m) => GTableLenses t m (K1 R x) (K1 R (LensFor (t m) x)) where + gTableLenses _ lensToHere = K1 (LensFor (\f -> lensToHere (\(K1 x) -> K1 <$> f x))) +instance ( Generic (PrimaryKey rel m) + , Generic (PrimaryKey rel (Lenses t m)) + , GTableLenses t m (Rep (PrimaryKey rel m)) (Rep (PrimaryKey rel (Lenses t m))) ) => + GTableLenses t m (K1 R (PrimaryKey rel m)) (K1 R (PrimaryKey rel (Lenses t m))) where + gTableLenses _ lensToHere = K1 (to (gTableLenses (Proxy :: Proxy (Rep (PrimaryKey rel m))) (\f -> lensToHere (\(K1 x) -> K1 . to <$> f (from x))))) + +tableLenses' :: ( lensType ~ Lenses t f + , Generic (t lensType) + , Generic (t f) + , GTableLenses t f (Rep (t f)) (Rep (t lensType)) ) => + Proxy t -> Proxy f -> t lensType +tableLenses' (Proxy :: Proxy t) (Proxy :: Proxy f) = + to (gTableLenses (Proxy :: Proxy (Rep (t f))) ((\f x -> to <$> f (from x)) :: Lens' (t f) (Rep (t f) ()))) + +tableLenses :: ( lensType ~ Lenses t f + , Generic (t lensType) + , Generic (t f) + , GTableLenses t f (Rep (t f)) (Rep (t lensType)) ) => + t (Lenses t f) +tableLenses = let res = tableLenses' (tProxy res) (fProxy res) + + tProxy :: t (Lenses t f) -> Proxy t + tProxy _ = Proxy + fProxy :: t (Lenses t f) -> Proxy f + fProxy _ = Proxy + in res + +simpleTableLenses :: ( lensType ~ Lenses t Identity + , Generic (t lensType) + , Generic (t Identity) + , GTableLenses t Identity (Rep (t Identity)) (Rep (t lensType)) ) => + t (Lenses t Identity) +simpleTableLenses = tableLenses + +-- | Automatically deduce lenses for 'TableSettings table'. You can expose the lenses at global level by doing a +-- top-level pattern match on 'tableConfigLenses', replacing every column in the pattern with `LensFor '. +-- +-- For example, +-- +-- > data AuthorT f = AuthorT +-- > { _authorEmail :: Columnar f Text +-- > , _authorFirstName :: Columnar f Text +-- > , _authorLastName :: Columnar f Text } +-- > deriving Generic +-- > +-- > data BlogPostT f = BlogPost +-- > { _blogPostSlug :: Columnar f Text +-- > , _blogPostBody :: Columnar f Text +-- > , _blogPostDate :: Columnar f UTCTime +-- > , _blogPostAuthor :: ForeignKey AuthorT f +-- > , _blogPostTagline :: Columnar f (Maybe Text) } +-- > deriving Generic +-- > instance Table BlogPostT where +-- > type PrimaryKey BlogPostT f = PK f Text +-- > primaryKey = PK . _blogPostSlug +-- > instance Table AuthorT where +-- > type PrimaryKey AuthorT f = PK f Text +-- > primaryKey = PK . _authorEmail +-- +-- > BlogPost (LensFor blogPostSlug +-- > (LensFor blogPostBody) +-- > (LensFor blogPostDate) +-- > (ForeignKey (PK (LensFor blogPostAuthorEmail))) +-- > (LensFor blogPostTagLine) = tableConfigLenses +tableConfigLenses :: ( lensType ~ Lenses t (TableField t) + , Generic (t lensType) + , Generic (t (TableField t)) + , GTableLenses t (TableField t) (Rep (t (TableField t))) (Rep (t lensType)) ) => + t (Lenses t (TableField t)) +tableConfigLenses = tableLenses + +-- dbLenses :: ( Generic (db (LensForT db)) +-- , Generic (db f) + +-- , GTableLenses db f (Rep (db f)) (Rep (db (LensFor db))) ) => +-- db (LensFor db) + +-- dbLenses :: ( Generic (db (LensFor db)) +-- , Generic (db f) + +-- , GTableLenses db f (Rep (db f)) (Rep (db (LensFor db))) ) => +-- db (LensFor db) +-- dbLenses = let res = dbLenses' (dbProxy res) (fProxy res) + +-- dbProxy :: t (Lenses t f) -> Proxy t +-- dbProxy _ = Proxy +-- fProxy :: t (Lenses t f) -> Proxy f +-- fProxy _ = Proxy +-- in res diff --git a/src/Database/Beam/Schema/Tables.hs b/src/Database/Beam/Schema/Tables.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/Schema/Tables.hs @@ -0,0 +1,644 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | Defines a generic schema type that can be used to define schemas for Beam tables +module Database.Beam.Schema.Tables + ( + -- * Database Types + Database(..), GenDatabaseTable(..), DatabaseTable(..), DatabaseSettings(..) + , ReifiedDatabaseSchema(..), ReifiedTableSchema(..) + , autoDbSettings + , allTableSettings + + , BeamEnum(..) + + , SqlValue'(..) + , Lenses, LensFor(..) + + -- * Columnar and Column Tags + , Columnar(..), Columnar'(..) + , Nullable(..), TableField(..) + , fieldName, fieldConstraints, fieldSettings + + , TableSettings(..) + + -- * Tables + , Table(..), defTblFieldSettings, defFieldSettings + , reifyTableSchema, tableValuesNeeded + , pk + + -- * Fields + , FieldSchema(..), FromSqlValuesM(..), FromSqlValues(..) + , popSqlValue, peekSqlValue ) + where + +import Database.Beam.SQL.Types + +import Control.Arrow +import Control.Applicative +import Control.Monad.State +import Control.Monad.Error +import Control.Monad.Identity + +import Data.Proxy +import Data.Coerce +import Data.Typeable +import Data.Text (Text) +import Data.List +import Data.Char +import Data.String +import Data.Void +import Data.Monoid +import qualified Data.Text as T + +import Database.HDBC ( SqlColDesc(..), SqlValue(..), SqlTypeId(..) + , fromSql) + +import GHC.Generics hiding (R) +import qualified GHC.Generics as Generic + +import Lens.Micro hiding (to) + +type ReifiedDatabaseSchema = [(Text, ReifiedTableSchema)] +type ReifiedTableSchema = [(Text, SQLColumnSchema)] + +class Database db where + allTables :: (forall tbl. Table tbl => f tbl -> b) -> db f -> [b] + default allTables :: ( Generic (db f) + , GAllTables f (Rep (db f) ()) ) => + (forall tbl. Table tbl => f tbl -> b) -> db f -> [b] + allTables f db = allTables' f (from' db) + +allTableSettings :: Database db => DatabaseSettings db -> [GenDatabaseTable db] +allTableSettings = allTables GenDatabaseTable + +autoDbSettings :: ( Generic (DatabaseSettings db) + , GAutoDbSettings (Rep (DatabaseSettings db) ()) ) => + DatabaseSettings db +autoDbSettings = to' autoDbSettings' + +data GenDatabaseTable db where + GenDatabaseTable :: DatabaseTable db table -> GenDatabaseTable db +data DatabaseTable (db :: ((((* -> *) -> *) -> *) -> *)) table where + DatabaseTable :: Table table => Proxy table -> Text -> DatabaseTable db table + +type DatabaseSettings db = db (DatabaseTable db) + +class GAutoDbSettings x where + autoDbSettings' :: x +instance GAutoDbSettings (x p) => GAutoDbSettings (D1 f x p) where + autoDbSettings' = M1 autoDbSettings' +instance GAutoDbSettings (x p) => GAutoDbSettings (C1 f x p) where + autoDbSettings' = M1 autoDbSettings' +instance (GAutoDbSettings (x p), GAutoDbSettings (y p)) => GAutoDbSettings ((x :*: y) p) where + autoDbSettings' = autoDbSettings' :*: autoDbSettings' +instance (Table tbl, Selector f) => GAutoDbSettings (S1 f (K1 Generic.R (DatabaseTable db tbl)) p) where + autoDbSettings' = M1 (K1 (DatabaseTable (Proxy :: Proxy tbl) (fromString name))) + where name = unCamelCaseSel (selName (undefined :: S1 f (K1 Generic.R (DatabaseTable db tbl)) p)) + +class GAllTables f x where + allTables' :: (forall tbl. Table tbl => f tbl -> b) -> x -> [b] +instance GAllTables f (x p) => GAllTables f (M1 s m x p) where + allTables' f (M1 x) = allTables' f x +instance (GAllTables f (x p), GAllTables f (y p)) => GAllTables f ((x :*: y) p) where + allTables' f (x :*: y) = allTables' f x ++ allTables' f y +instance Table tbl => GAllTables f (K1 Generic.R (f tbl) p) where + allTables' f (K1 x) = [f x] + +data Lenses (t :: (* -> *) -> *) (f :: * -> *) x +data LensFor t x where + LensFor :: Generic t => Lens' t x -> LensFor t x +newtype Exposed x = Exposed x +newtype SqlValue' x = SqlValue' SqlValue + +newtype BeamEnum a = BeamEnum { unBeamEnum :: a } + deriving (Show, Typeable) + +-- | A type family that we use to "tag" columns in our table datatypes. +-- +-- This is what allows us to use the same table type to hold table data, describe table settings, +-- derive lenses, and provide expressions. +-- +-- The basic rules are +-- +-- > Columnar Identity x = x +-- > Columnar Identity (BeamEnum x) = x +-- +-- Thus, any Beam table applied to 'Identity' will yield a simplified version of the data type, that contains +-- just what you'd expect. Enum types tagged with 'BeamEnum', are automatically unwrapped in the simplified data +-- structure. +-- +-- > Columnar (Nullable c) x = Columnar c (Maybe x) +-- +-- The 'Nullable' type is used when referencing 'PrimaryKey's that we want to include optionally. +-- For example, if we have a table with a 'PrimaryKey', like the following +-- +-- > data BeamTableT f = BeamTableT +-- > { _refToAnotherTable :: PrimaryKey AnotherTableT f +-- > , ... } +-- +-- we would typically be required to provide values for the 'PrimaryKey' embedded into 'BeamTableT'. We can use +-- 'Nullable' to lift this constraint. +-- +-- > data BeamTableT f = BeamTableT +-- > { _refToAnotherTable :: PrimaryKey AnotherTableT (Nullable f) +-- > , ... } +-- +-- Now we can use 'justRef' and 'nothingRef' to refer to this table optionally. The embedded 'PrimaryKey' in '_refToAnotherTable' +-- automatically has its fields converted into 'Maybe' using 'Nullable'. +-- +-- The last 'Columnar' rule is +-- +-- > Columnar f x = f x +-- +-- Use this rule if you'd like to parameterize your table type over any other functor. For example, this is used +-- in the query modules to write expressions such as 'TableT QExpr', which returns a table whose fields have been +-- turned into query expressions. +-- +-- The other rules are used within Beam to provide lenses and to expose the inner structure of the data type. +type family Columnar (f :: * -> *) x where + Columnar Exposed x = Exposed x + + Columnar Identity (BeamEnum x) = x + Columnar Identity x = x + + Columnar (Lenses t Identity) x = LensFor (t Identity) (Columnar Identity x) + Columnar (Lenses t f) x = LensFor (t f) (f x) + + Columnar (Nullable c) x = Columnar c (Maybe x) + + Columnar f x = f x + +newtype Columnar' f a = Columnar' (Columnar f a) + +-- | Support for NULLable Foreign Key references. +-- +-- > data MyTable f = MyTable +-- > { nullableRef :: PrimaryKey AnotherTable (Nullable f) +-- > , ... } +-- > deriving (Generic, Typeable) +-- +-- See 'Columnar' for more information. +data Nullable (c :: * -> *) x + +-- | Metadata for a field of type 'ty' in 'table'. +-- +-- > Columnar (TableField table) ty = TableField table ty +-- +-- This is used to declare 'tblFieldSettings' in the 'Table' class. +-- +-- It is easiest to access these fields through the lenses 'fieldName', 'fieldConstraints', and 'fieldSettings'. +-- +-- > data EmployeeT f = Employee +-- > { _employeeId :: Columnar f AutoId +-- > , _employeeDepartment :: Columnar f Text +-- > , _employeeFirstName :: Columnar f Text +-- > , _employeeLastName :: Columnar f Text } +-- > deriving Generic +-- +-- Now we can use 'tableConfigLenses' and the 'TableField' lenses to modify the default table configuration +-- +-- > Employee (LensFor employeeIdC) (LensFor employeeDepartmentC) (LensFor employeeFirstNameC) (LensFor employeeLastNameC) = tableConfigLenses +-- > +-- > instance Table EmployeeT where +-- > type PrimaryKey EmployeeT f = PK f AutoId +-- > primaryKey = PK . _beamEmployeeId +-- > +-- > tblFieldSettings = defTblFieldSettings +-- > & employeeFirstNameC . fieldName .~ "fname" +-- > & employeeLastNameC . fieldName .~ "lname" +-- > & employeeLastNameC . fieldSettings .~ Varchar (Just 128) -- Give it a 128 character limit +data TableField (table :: (* -> *) -> *) ty = TableField + { _fieldName :: Text -- ^ The field name + , _fieldConstraints :: [SQLConstraint] -- ^ Constraints for the field (such as AutoIncrement, PrimaryKey, etc) + , _fieldSettings :: FieldSettings ty -- ^ Settings for the field + } +deriving instance Show (FieldSettings ty) => Show (TableField t ty) + +fieldName :: Lens' (TableField table ty) Text +fieldName f (TableField name cs s) = (\name' -> TableField name' cs s) <$> f name +fieldConstraints :: Lens' (TableField table ty) [SQLConstraint] +fieldConstraints f (TableField name cs s) = (\cs' -> TableField name cs' s) <$> f cs +fieldSettings :: Lens (TableField table a) (TableField table b) (FieldSettings a) (FieldSettings b) +fieldSettings f (TableField name cs s) = (\s' -> TableField name cs s') <$> f s + +type TableSettings table = table (TableField table) + +from' :: Generic x => x -> Rep x () +from' = from + +to' :: Generic x => Rep x () -> x +to' = to + +-- | The big Kahuna! All beam tables implement this class. +-- +-- The kind of all table types is `(* -> *) -> *`. This is because all table types are actually /table type constructors/. +-- Every table type takes in another type constructor, called the /column tag/, and uses that constructor to instantiate the column types. +-- See the documentation for 'Columnar'. In order for the default deriving to work, every type passed into 'Columnar' must be an instance +-- of 'FieldSchema'. +-- +-- This class is mostly Generic-derivable. You need only specify a type for the table's primary key and a method to extract the primary key +-- given the table. +-- +-- Even though all methods are derivable, you are free to override them. Typically, you may want to override 'tblFieldSettings' if you want +-- to specify options for column storage or to rename columns. See 'TableField' for more information. You may want to use 'tableConfigLenses' +-- to simplify accessing 'tblFieldSettings'. +-- +-- An example table: +-- +-- > data BlogPostT f = BlogPost +-- > { _blogPostSlug :: Columnar f Text +-- > , _blogPostBody :: Columnar f Text +-- > , _blogPostDate :: Columnar f UTCTime +-- > , _blogPostAuthor :: PrimaryKey AuthorT f +-- > , _blogPostTagline :: Columnar f (Maybe Text) +-- > , _blogPostImageGallery :: PrimaryKey ImageGalleryT (Nullable f) } +-- > deriving Generic +-- > instance Table BlogPostT where +-- > type PrimaryKey BlogPostT f = PK f Text +-- > primaryKey = PK . _blogPostSlug +-- +-- We can interpret this as follows: +-- +-- * The `_blogPostSlug`, `_blogPostBody`, `_blogPostDate`, and `_blogPostTagline` fields are of types 'Text', 'Text', 'UTCTime', and 'Maybe Text' respectfully. +-- * Since `_blogPostSlug`, `_blogPostBody`, `_blogPostDate`, `_blogPostAuthor` must be provided (i.e, they cannot contain 'Nothing'), they will be given SQL NOT NULL constraints. +-- `_blogPostTagline` is declared 'Maybe' so 'Nothing' will be stored as NULL in the database. `_blogPostImageGallery` will be allowed to be empty because it uses the 'Nullable' tag modifier. +-- * `blogPostAuthor` references the `AuthorT` table (not given here) and is required. +-- * `blogPostImageGallery` references the `ImageGalleryT` table (not given here), but this relation is not required (i.e., it may be 'Nothing'. See 'Nullable'). +class Typeable table => Table (table :: (* -> *) -> *) where + + -- | A data type representing the types of primary keys for this table. + -- In order to play nicely with the default deriving mechanism, this type must be an instance of 'Generic'. + data PrimaryKey table (column :: * -> *) :: * + + -- | Given a table, this should return the PrimaryKey from the table. By keeping this polymorphic over column, + -- we ensure that the primary key values come directly from the table (i.e., they can't be arbitrary constants) + primaryKey :: table column -> PrimaryKey table column + + pkChangeRep :: (forall a. Columnar' f a -> Columnar' g a) -> PrimaryKey table f -> PrimaryKey table g + default pkChangeRep :: ( Generic (PrimaryKey table f) + , Generic (PrimaryKey table g) + , Generic (PrimaryKey table Exposed) + , GChangeRep (Rep (PrimaryKey table Exposed) ()) + (Rep (PrimaryKey table f) ()) (Rep (PrimaryKey table g) ()) + f g ) => + (forall a. Columnar' f a -> Columnar' g a) -> PrimaryKey table f -> PrimaryKey table g + pkChangeRep f x = to' (gChangeRep (Proxy :: Proxy (Rep (PrimaryKey table Exposed) ())) + f (from' x)) + + changeRep :: (forall a. FieldSchema a => Columnar' f a -> Columnar' g a) -> table f -> table g + default changeRep :: ( ChangeRep table f g ) => + (forall a. FieldSchema a => Columnar' f a -> Columnar' g a) -> table f -> table g + changeRep (f :: forall a. FieldSchema a => Columnar' f a -> Columnar' g a) = + changeRep' (Proxy :: Proxy f) (Proxy :: Proxy g) (Proxy :: Proxy table) f + + pkAllValues :: (forall a. FieldSchema a => Columnar' f a -> b) -> PrimaryKey table f -> [b] + default pkAllValues :: AllValues f (PrimaryKey table f) (PrimaryKey table Exposed) => + (forall a. FieldSchema a => Columnar' f a -> b) -> PrimaryKey table f -> [b] + pkAllValues = allValues' (Proxy :: Proxy (PrimaryKey table Exposed)) + + fieldAllValues :: (forall a. FieldSchema a => Columnar' f a -> b) -> table f -> [b] + default fieldAllValues :: AllValues f (table f) (table Exposed) => + (forall a. FieldSchema a => Columnar' f a -> b) -> table f -> [b] + fieldAllValues = allValues' (Proxy :: Proxy (table Exposed)) + + tblFieldSettings :: TableSettings table + default tblFieldSettings :: ( Generic (TableSettings table) + , GDefaultTableFieldSettings (Rep (TableSettings table) ())) => TableSettings table + tblFieldSettings = defTblFieldSettings + + pkMakeSqlValues :: PrimaryKey table Identity -> PrimaryKey table SqlValue' + default pkMakeSqlValues :: ( Generic (PrimaryKey table Identity) + , Generic (PrimaryKey table SqlValue') + , GMakeSqlValues (Rep (PrimaryKey table Exposed) ()) (Rep (PrimaryKey table Identity) ()) (Rep (PrimaryKey table SqlValue') ())) => + PrimaryKey table Identity -> PrimaryKey table SqlValue' + pkMakeSqlValues table = to' (gMakeSqlValues (Proxy :: Proxy (Rep (PrimaryKey table Exposed) ())) (from' table)) + + makeSqlValues :: table Identity -> table SqlValue' + default makeSqlValues :: ( Generic (table Identity) + , Generic (table SqlValue') + , GMakeSqlValues (Rep (table Exposed) ()) (Rep (table Identity) ()) (Rep (table SqlValue') ())) => + table Identity -> table SqlValue' + makeSqlValues table = to' (gMakeSqlValues (Proxy :: Proxy (Rep (table Exposed) ())) (from' table)) + + tableFromSqlValues :: FromSqlValuesM (table Identity) + default tableFromSqlValues :: ( Generic (table Identity) + , GFromSqlValues (Rep (table Exposed)) (Rep (table Identity)) ) => + FromSqlValuesM (table Identity) + tableFromSqlValues = to <$> gFromSqlValues (Proxy :: Proxy (Rep (table Exposed))) + +reifyTableSchema :: Table table => Proxy table -> ReifiedTableSchema +reifyTableSchema (Proxy :: Proxy table) = fieldAllValues (\(Columnar' (TableField name constraints settings)) -> + (name, fieldColDesc settings constraints)) (tblFieldSettings :: TableSettings table) + +tableValuesNeeded :: Table table => Proxy table -> Int +tableValuesNeeded (Proxy :: Proxy table) = length (fieldAllValues (const ()) (tblFieldSettings :: TableSettings table)) + +-- | Synonym for 'primaryKey' +pk :: Table t => t f -> PrimaryKey t f +pk = primaryKey + +instance FromSqlValues t => FromSqlValues (Maybe t) where + valuesNeeded (_ :: Proxy (Maybe t)) = valuesNeeded (Proxy :: Proxy t) + fromSqlValues' = mfix $ \(_ :: Maybe t) -> + do values <- get + let colCount = valuesNeeded (Proxy :: Proxy t) + colValues = take colCount values + if all (==SqlNull) colValues + then put (drop colCount values) >> return Nothing + else Just <$> fromSqlValues' + +defTblFieldSettings :: ( Generic (TableSettings table) + , GDefaultTableFieldSettings (Rep (TableSettings table) ())) => + TableSettings table +defTblFieldSettings = withProxy $ \proxy -> to' (gDefTblFieldSettings proxy) + where withProxy :: (Proxy (Rep (TableSettings table) ()) -> TableSettings table) -> TableSettings table + withProxy f = f Proxy + +defFieldSettings :: FieldSchema fs => Text -> TableField table fs +defFieldSettings name = TableField + { _fieldName = name + , _fieldConstraints = [] + , _fieldSettings = settings} + where settings = defSettings + +fieldColDesc :: FieldSchema fs => FieldSettings fs -> [SQLConstraint] -> SQLColumnSchema +fieldColDesc settings cs =let base = colDescFromSettings settings + in base { csConstraints = csConstraints base ++ cs } + +class GChangeRep (ty :: *) x y f g where + gChangeRep :: Proxy ty -> (forall a. FieldSchema a => Columnar' f a -> Columnar' g a) -> x -> y +instance GChangeRep (ty p) (a p) (b p) x y => GChangeRep (M1 s h ty p) (M1 s f a p) (M1 s g b p) x y where + gChangeRep _ f (M1 x) = M1 (gChangeRep (Proxy :: Proxy (ty p)) f x) +instance ( GChangeRep (t1 p) (a1 p) (a2 p) x y, GChangeRep (t2 p) (b1 p) (b2 p) x y) => GChangeRep ((t1 :*: t2) p) ((a1 :*: b1) p) ((a2 :*: b2) p) x y where + gChangeRep _ f (a :*: b) = + gChangeRep (Proxy :: Proxy (t1 p)) f a :*: gChangeRep (Proxy :: Proxy (t2 p)) f b +instance ( Generic (PrimaryKey rel x) + , Generic (PrimaryKey rel y) + , GChangeRep (Rep (PrimaryKey rel Exposed) ()) + (Rep (PrimaryKey rel x) ()) + (Rep (PrimaryKey rel y) ()) + x y ) => + GChangeRep (K1 Generic.R (PrimaryKey rel Exposed) p) (K1 Generic.R (PrimaryKey rel x) p) (K1 Generic.R (PrimaryKey rel y) p) x y where + gChangeRep _ f (K1 x) = + K1 (to' (gChangeRep (Proxy :: Proxy (Rep (PrimaryKey rel Exposed) ())) f (from' x))) + +instance ( xa ~ Columnar x a, ya ~ Columnar y a, FieldSchema a) => + GChangeRep (K1 Generic.R (Exposed a) p) (K1 Generic.R xa p) (K1 Generic.R ya p) x y where + + gChangeRep (_ :: Proxy (K1 Generic.R (Exposed a) p)) (f :: forall b. FieldSchema b => Columnar' f b -> Columnar' g b) (K1 x) = + let x' = Columnar' x :: Columnar' f a + Columnar' y' = f x' :: Columnar' g a + in K1 y' + +-- instance GChangeRep (K1 Generic.R (Nullable x a) p) (K1 Generic.R (Nullable y a) p) x y where +-- gChangeRep f (K1 (Nullable x)) = K1 (Nullable (f x)) +-- instance ( Generic (PrimaryKey table x) +-- , Generic (PrimaryKey table y) +-- , GChangeRep (Rep (PrimaryKey table x) ()) (Rep (PrimaryKey table y) ()) x y ) => +-- GChangeRep (K1 Generic.R (PrimaryKey table x) p) (K1 Generic.R (PrimaryKey table y) p) x y where +-- gChangeRep f (K1 (PrimaryKey x)) = K1 (PrimaryKey (to' (gChangeRep f (from' x)))) +-- instance ( Generic (PrimaryKey table (Nullable x)) +-- , Generic (PrimaryKey table (Nullable y)) +-- , GChangeRep (Rep (PrimaryKey table (Nullable x)) ()) (Rep (PrimaryKey table (Nullable y)) ()) x y ) => +-- GChangeRep (K1 Generic.R (PrimaryKey table (Nullable x)) p) (K1 Generic.R (PrimaryKey table (Nullable y)) p) x y where +-- gChangeRep f (K1 (PrimaryKey x)) = K1 (PrimaryKey (to' (gChangeRep f (from' x)))) +-- instance GChangeRep (Nullable f a) (Nullable g a) f g where +-- gChangeRep f (Nullable x) = Nullable (f x) + +class ChangeRep x f g where + changeRep' :: Proxy f -> Proxy g -> Proxy x -> (forall a. FieldSchema a => Columnar' f a -> Columnar' g a) -> x f -> x g +instance ( Generic (x f) + , Generic (x g) + , Generic (x Exposed) + , GChangeRep (Rep (x Exposed) ()) (Rep (x f) ()) (Rep (x g) ()) f g) => + ChangeRep x f g where + changeRep' _ _ (Proxy :: Proxy x) f x = to' (gChangeRep (Proxy :: Proxy (Rep (x Exposed) ())) f (from' x)) + +class GAllValues (f :: * -> *) (ty :: *) x where + gAllValues :: Proxy ty -> (forall a. FieldSchema a => Columnar' f a -> b) -> x -> [b] +instance (GAllValues f (t1 x) (a x), GAllValues f (t2 x) (b x)) => GAllValues f ((t1 :*: t2) x) ((a :*: b) x) where + gAllValues Proxy f (a :*: b) = gAllValues (Proxy :: Proxy (t1 x)) f a ++ gAllValues (Proxy :: Proxy (t2 x)) f b +instance (GAllValues f (ty x) (p x)) => GAllValues f (M1 s h ty x) (M1 s g p x) where + gAllValues Proxy f (M1 a) = gAllValues (Proxy :: Proxy (ty x)) f a +instance ( Generic (PrimaryKey rel f) + , GAllValues f (Rep (PrimaryKey rel Exposed) ()) (Rep (PrimaryKey rel f) ()) ) => + GAllValues f (K1 Generic.R (PrimaryKey rel Exposed) a) (K1 Generic.R (PrimaryKey rel f) a) where + gAllValues Proxy f (K1 x) = + gAllValues (Proxy :: Proxy (Rep (PrimaryKey rel Exposed) ())) f (from' x) +instance (FieldSchema x, fx ~ Columnar f x) => GAllValues f (K1 Generic.R (Exposed x) a) (K1 Generic.R fx a) where + gAllValues Proxy f (K1 a) = [f (Columnar' a :: Columnar' f x)] + +-- instance FieldSchema x => GAllValues f (K1 Generic.R (Nullable f x) a) where +-- gAllValues f (K1 (Nullable a)) = [f a] +-- instance ( Generic (PrimaryKey related g) +-- , GAllValues f (Rep (PrimaryKey related g) ()) ) => +-- GAllValues f (K1 Generic.R (PrimaryKey related g) a) where +-- gAllValues f (K1 (PrimaryKey x)) = gAllValues f (from' x) +-- instance FieldSchema a => GAllValues f (f a) where +-- gAllValues f x = [f x] + +type AllValues f xf xExposed = ( Generic xf + , Generic xExposed + , GAllValues f (Rep xExposed ()) (Rep xf ())) + +allValues' :: AllValues f xf xExposed => + Proxy xExposed -> (forall a. FieldSchema a => Columnar' f a -> b) -> xf -> [b] +allValues' (Proxy :: Proxy xExposed) f x = + gAllValues (Proxy :: Proxy (Rep xExposed ())) f (from' x) + +class GDefaultTableFieldSettings x where + gDefTblFieldSettings :: Proxy x -> x +instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (D1 f p x) where + gDefTblFieldSettings (_ :: Proxy (D1 f p x)) = M1 $ gDefTblFieldSettings (Proxy :: Proxy (p x)) +instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (C1 f p x) where + gDefTblFieldSettings (_ :: Proxy (C1 f p x)) = M1 $ gDefTblFieldSettings (Proxy :: Proxy (p x)) +instance (GDefaultTableFieldSettings (a p), GDefaultTableFieldSettings (b p)) => GDefaultTableFieldSettings ((a :*: b) p) where + gDefTblFieldSettings (_ :: Proxy ((a :*: b) p)) = gDefTblFieldSettings (Proxy :: Proxy (a p)) :*: gDefTblFieldSettings (Proxy :: Proxy (b p)) + +instance (Table table, FieldSchema field, Selector f ) => + GDefaultTableFieldSettings (S1 f (K1 Generic.R (TableField table field)) p) where + gDefTblFieldSettings (_ :: Proxy (S1 f (K1 Generic.R (TableField table field)) p)) = M1 (K1 s) + where s = defFieldSettings (T.pack name) + name = unCamelCaseSel (selName (undefined :: S1 f (K1 Generic.R (TableField table field)) ())) + +instance ( Table table, Table related + , Selector f + + , Generic (PrimaryKey related (TableField related)) + , Generic (PrimaryKey related (TableField table)) + , GChangeRep (Rep (PrimaryKey related Exposed) ()) + (Rep (PrimaryKey related (TableField related)) ()) (Rep (PrimaryKey related (TableField table)) ()) + (TableField related) (TableField table) ) => + GDefaultTableFieldSettings (S1 f (K1 Generic.R (PrimaryKey related (TableField table))) p) where + + gDefTblFieldSettings _ = M1 . K1 $ primaryKeySettings' + where tableSettings = tblFieldSettings :: TableSettings related + primaryKeySettings :: PrimaryKey related (TableField related) + primaryKeySettings = primaryKey tableSettings + + primaryKeySettings' :: PrimaryKey related (TableField table) + primaryKeySettings' = to' (gChangeRep (Proxy :: Proxy (Rep (PrimaryKey related Exposed) ())) convertToForeignKeyField (from' primaryKeySettings)) + + convertToForeignKeyField :: Columnar' (TableField related) c -> Columnar' (TableField table) c + convertToForeignKeyField (Columnar' tf) = + Columnar' $ + tf { _fieldName = keyName <> "__" <> _fieldName tf + , _fieldConstraints = removeConstraints (_fieldConstraints tf) } + + + removeConstraints = filter (\x -> x /= SQLPrimaryKey && x /= SQLAutoIncrement) + + keyName = T.pack (unCamelCaseSel (selName (undefined :: S1 f (K1 Generic.R (PrimaryKey related (TableField table))) ()))) + +instance ( Table table, Table related + , Selector f + + , Generic (PrimaryKey related (TableField related)) + , Generic (PrimaryKey related (TableField table)) + , Generic (PrimaryKey related (Nullable (TableField table))) + , GChangeRep (Rep (PrimaryKey related Exposed) ()) + (Rep (PrimaryKey related (TableField table)) ()) (Rep (PrimaryKey related (Nullable (TableField table))) ()) + (TableField table) (Nullable (TableField table)) + , GChangeRep (Rep (PrimaryKey related Exposed) ()) + (Rep (PrimaryKey related (TableField related)) ()) (Rep (PrimaryKey related (TableField table)) ()) (TableField related) (TableField table) ) => + GDefaultTableFieldSettings (S1 f (K1 Generic.R (PrimaryKey related (Nullable (TableField table)))) p) where + + gDefTblFieldSettings _ = + M1 . K1 $ settings + where M1 (K1 nonNullSettings) = gDefTblFieldSettings (Proxy :: Proxy (S1 f (K1 Generic.R (PrimaryKey related (TableField table))) p)) + nonNullSettingsRep = from' nonNullSettings :: Rep (PrimaryKey related (TableField table)) () + + settings :: PrimaryKey related (Nullable (TableField table)) + settings = to' (gChangeRep (Proxy :: Proxy (Rep (PrimaryKey related Exposed) ())) removeNotNullConstraints nonNullSettingsRep) + + removeNotNullConstraints :: Columnar' (TableField table) ty -> Columnar' (Nullable (TableField table)) ty + removeNotNullConstraints (Columnar' tf) = + Columnar' $ + tf { _fieldSettings = MaybeFieldSettings (_fieldSettings tf) } + +class GFromSqlValues (ty :: * -> *) (schema :: * -> *) where + gFromSqlValues :: Proxy ty -> FromSqlValuesM (schema a) +instance GFromSqlValues ty x => GFromSqlValues (M1 s f ty) (M1 s f x) where + gFromSqlValues _ = M1 <$> gFromSqlValues (Proxy :: Proxy ty) +instance FieldSchema x => GFromSqlValues (K1 Generic.R (Exposed x)) (K1 Generic.R x) where + gFromSqlValues _ = K1 <$> fromSqlValue +instance FieldSchema (BeamEnum x) => GFromSqlValues (K1 Generic.R (Exposed (BeamEnum x))) (K1 Generic.R x) where + gFromSqlValues _ = K1 . unBeamEnum <$> fromSqlValue +instance (GFromSqlValues t1 a, GFromSqlValues t2 b) => GFromSqlValues (t1 :*: t2) (a :*: b) where + gFromSqlValues _ = (:*:) <$> gFromSqlValues (Proxy :: Proxy t1) <*> gFromSqlValues (Proxy :: Proxy t2) +instance ( Generic (PrimaryKey related f) + , GFromSqlValues (Rep (PrimaryKey related Exposed)) (Rep (PrimaryKey related f)) ) => + GFromSqlValues (K1 Generic.R (PrimaryKey related Exposed)) (K1 Generic.R (PrimaryKey related f)) where + + gFromSqlValues _ = K1 . to' <$> gFromSqlValues (Proxy :: Proxy (Rep (PrimaryKey related Exposed))) +-- instance FieldSchema (Maybe x) => GFromSqlValues (K1 Generic.R (Nullable Column x)) where +-- gFromSqlValues = K1 . Nullable . Column <$> fromSqlValue + +class GMakeSqlValues ty x sql where + gMakeSqlValues :: Proxy ty -> x -> sql +instance GMakeSqlValues (ty a) (p a) (sql a) => GMakeSqlValues (M1 s f ty a) (M1 s f p a) (M1 s f sql a) where + gMakeSqlValues _ (M1 x) = M1 (gMakeSqlValues (Proxy :: Proxy (ty a)) x) +instance (GMakeSqlValues (t1 a) (f a) (sql1 a), GMakeSqlValues (t2 a) (g a) (sql2 a)) => GMakeSqlValues ((t1 :*: t2) a) ((f :*: g) a) ((sql1 :*: sql2) a) where + gMakeSqlValues _ (f :*: g) = gMakeSqlValues (Proxy :: Proxy (t1 a)) f :*: gMakeSqlValues (Proxy :: Proxy (t2 a)) g +instance GMakeSqlValues (U1 x) (U1 a) (U1 sql) where + gMakeSqlValues _ _ = U1 +instance FieldSchema x => GMakeSqlValues (K1 Generic.R (Exposed x) a) (K1 Generic.R x a) (K1 Generic.R (SqlValue' x) a) where + gMakeSqlValues _ (K1 x) = K1 (SqlValue' (makeSqlValue x)) +instance FieldSchema (BeamEnum x) => GMakeSqlValues (K1 Generic.R (Exposed (BeamEnum x)) a) (K1 Generic.R x a) (K1 Generic.R (SqlValue' (BeamEnum x)) a) where + gMakeSqlValues _ (K1 x) = K1 (SqlValue' (makeSqlValue (BeamEnum x))) +-- instance FieldSchema x => GMakeSqlValues (K1 Generic.R (Nullable Column x) a) where +-- gMakeSqlValues (K1 (Nullable x)) = [makeSqlValue (columnValue x)] +instance ( Generic (PrimaryKey related f) + , Generic (PrimaryKey related SqlValue') + , GMakeSqlValues (Rep (PrimaryKey related Exposed) ()) (Rep (PrimaryKey related f) ()) (Rep (PrimaryKey related SqlValue') ()) ) => + GMakeSqlValues (K1 Generic.R (PrimaryKey related Exposed) a) (K1 Generic.R (PrimaryKey related f) a) (K1 Generic.R (PrimaryKey related SqlValue') ()) where + gMakeSqlValues _ (K1 x) = K1 (to' (gMakeSqlValues (Proxy :: Proxy (Rep (PrimaryKey related Exposed) ())) (from' x))) + +class ( Show (FieldSettings fs), Typeable fs + , Show fs ) => FieldSchema fs where + data FieldSettings fs :: * + + defSettings :: FieldSettings fs + + colDescFromSettings :: FieldSettings fs -> SQLColumnSchema + + makeSqlValue :: fs -> SqlValue + fromSqlValue :: FromSqlValuesM fs + +type FromSqlValuesM a = ErrorT String (State [SqlValue]) a +popSqlValue, peekSqlValue :: FromSqlValuesM SqlValue +popSqlValue = do st <- get + put (tail st) + return (head st) +peekSqlValue = head <$> get +class FromSqlValues a where + fromSqlValues' :: FromSqlValuesM a + valuesNeeded :: Proxy a -> Int + + default fromSqlValues' :: FieldSchema a => FromSqlValuesM a + fromSqlValues' = fromSqlValue + default valuesNeeded :: FieldSchema a => Proxy a -> Int + valuesNeeded _ = 1 +instance Table tbl => FromSqlValues (tbl Identity) where + fromSqlValues' = tableFromSqlValues + valuesNeeded _ = tableValuesNeeded (Proxy :: Proxy tbl) +instance (FromSqlValues a, FromSqlValues b) => FromSqlValues (a, b) where + fromSqlValues' = (,) <$> fromSqlValues' <*> fromSqlValues' + valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b) +instance (FromSqlValues a, FromSqlValues b, FromSqlValues c) => FromSqlValues (a, b, c) where + fromSqlValues' = (,,) <$> fromSqlValues' <*> fromSqlValues' <*> fromSqlValues' + valuesNeeded _ = valuesNeeded (Proxy :: Proxy a) + valuesNeeded (Proxy :: Proxy b) + valuesNeeded (Proxy :: Proxy c) + +instance FieldSchema Int where + data FieldSettings Int = IntFieldDefault + deriving Show + defSettings = IntFieldDefault + colDescFromSettings _ = notNull + SqlColDesc + { colType = SqlNumericT + , colSize = Nothing + , colOctetLength = Nothing + , colDecDigits = Nothing + , colNullable = Nothing } + makeSqlValue i = SqlInteger (fromIntegral i) + fromSqlValue = fromSql <$> popSqlValue +instance FromSqlValues Int + +instance FieldSchema a => FieldSchema (Maybe a) where + data FieldSettings (Maybe a) = MaybeFieldSettings (FieldSettings a) + + defSettings = MaybeFieldSettings defSettings + + colDescFromSettings (MaybeFieldSettings settings) = let SQLColumnSchema desc constraints = colDescFromSettings settings + in SQLColumnSchema desc (filter (/=SQLNotNull) constraints) + + makeSqlValue Nothing = SqlNull + makeSqlValue (Just x) = makeSqlValue x + fromSqlValue = do val <- peekSqlValue + case val of + SqlNull -> Nothing <$ popSqlValue + val -> Just <$> fromSqlValue +deriving instance Show (FieldSettings a) => Show (FieldSettings (Maybe a)) + +-- Internal functions + +unCamelCase :: String -> [String] +unCamelCase "" = [] +unCamelCase s + | (comp@(_:_), next) <- break isUpper s = + let next' = case next of + [] -> [] + x:xs -> toLower x:xs + in map toLower comp:unCamelCase next' + | otherwise = + let (comp@(_:_), next) = span isUpper s + next' = case next of + [] -> [] + x:xs -> toLower x:xs + in map toLower comp:unCamelCase next' + +unCamelCaseSel :: String -> String +unCamelCaseSel ('_':xs) = unCamelCaseSel xs +unCamelCaseSel xs = case unCamelCase xs of + [xs] -> xs + _:xs -> intercalate "_" xs