diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2019, Kristof Bastiaensen +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the {organization} nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/hasqly-mysql.cabal b/hasqly-mysql.cabal new file mode 100644 --- /dev/null +++ b/hasqly-mysql.cabal @@ -0,0 +1,32 @@ +Name: hasqly-mysql +Version: 0.0.1 +Synopsis: composable SQL generation +Category: Database +Copyright: Kristof Bastiaensen (2020) +Stability: Unstable +License: BSD3 +License-file: LICENSE +Author: Kristof Bastiaensen +Maintainer: Kristof Bastiaensen +Bug-Reports: https://github.com/kuribas/hasqly-mysql/issues +Build-type: Simple +Cabal-version: >=1.10 +Description: A mid level applicative SQL generation library + . + Haskqly intends to be a mid-level SQL generation library. It doesn't use advanced type extensions + to encode the schema in the types., but provides a light applicative layer to easy the conversion + between haskell and SQL. It is inspired by the clojures honeysql library. + +source-repository head + type: git + location: https://github.com/kuribas/hasqly-mysql + +Library + Ghc-options: -Wall + default-language: Haskell2010 + Build-depends: base >= 3 && < 5, mtl >= 2.1.3, mysql-haskell, text, bytestring, time, dlist, scientific, binary, dlist + hs-source-dirs: + src + Exposed-Modules: + Database.Hasqly + diff --git a/src/Database/Hasqly.hs b/src/Database/Hasqly.hs new file mode 100644 --- /dev/null +++ b/src/Database/Hasqly.hs @@ -0,0 +1,774 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Database.Hasqly +Description : SQL generation +Copyright : (c) Kristof Bastiaensen, 2020 +License : BSD-3 +Maintainer : kristof@resonata.be +Stability : unstable +Portability : ghc + + +-} + +module Database.Hasqly + ( -- * Querying + Query, Command, select, mergeSelect, replaceSelect, + + -- * Query Clauses + QueryClauses, from, innerJoin, leftJoin, rightJoin, outerJoin, emptyJoins, + where_, emptyWhere, groupBy_, having, emptyHaving, orderBy, limit, limitOffset, + + -- * Selectors + Selector, as, + + -- ** polymorphic selector + col, + -- ** specialised selectors + -- | The following are specialised versions of `col`. Using these + -- may make refactoring easier, for example accidently swapping + -- @`col` "age"@ and @`col` "name"@ would not give a type error, + -- while @intCol "age"@ and @textCol "name"@ most likely would. + intCol, integerCol, doubleCol, floatCol, scientificCol, + localTimeCol, timeOfDayCol, diffTimeCol, dayCol, byteStringCol, + textCol, + -- ** other selectors + values, values_, + + -- * Expressions + subQuery, + arg, fun, op, (.>), (.+), (.-), + + -- * Insertion + Insertor, insertValues, insertSelect, into, lensInto, + insert1, insert2, insert3, insert4, insert5, + insert6, insert7, insert8, insert9, insert10, + ToSql, + + -- * Rendering Queries + renderStmt, renderPreparedStmt, SQLError(..), QueryBuilder, ToQueryBuilder, FromSql + ) + +where + +import Database.MySQL.Base hiding (Query, Command) +import Prelude hiding (unwords) +import Control.Monad.State +import Control.Applicative +import Control.Monad.Except +import Data.Monoid hiding ((<>)) +import Data.String hiding (unwords) +import Data.List hiding (unwords) +import qualified Data.DList as DList + +import Data.DList (DList) +import Data.Scientific +import Data.Word +import Data.Int +import Data.Time +import qualified Data.ByteString as StrictBS +import qualified Data.ByteString.Lazy as LazyBS +import Data.ByteString.Lazy.Builder (Builder) +import qualified Data.ByteString.Lazy.Builder as Builder +import qualified Data.Text.Encoding as Text +import Data.Text (Text) +import Data.Binary.Put + +class FromSql a where + fromSql :: MySQLValue -> Either SQLError a + +class ToSql a where + toSqlValue :: a -> MySQLValue + +instance FromSql a => IsString (Selector a) where + fromString = col . fromString + +class ToQueryBuilder a where + toQueryBuilder :: a -> QueryBuilder + +renderStmt :: ToQueryBuilder a => a -> LazyBS.ByteString +renderStmt a = Builder.toLazyByteString stmt + where + QueryBuilder stmt _ _ = toQueryBuilder a + +renderPreparedStmt :: ToQueryBuilder a => a -> (LazyBS.ByteString, [MySQLValue]) +renderPreparedStmt a = (Builder.toLazyByteString pstmt, DList.toList args) + where + QueryBuilder _ pstmt args = toQueryBuilder a + +selectOne :: (MySQLValue -> Either SQLError a) -> QueryBuilder -> Selector a +selectOne f fieldName = + Selector (DList.singleton fieldName) $ do + results <- get + case results of + [] -> throwError ResultSetCountError + (r1:rest) -> do + put rest + lift $ f r1 + +-- | The polymorphic selector. The return type is determined by type +-- inference. +col :: FromSql a => QueryBuilder -> Selector a +col fieldName = selectOne fromSql fieldName + +-- | an integer field (TINYINT.. BIGINT). Any bounded haskell integer +-- type can be used here , for example `Int`, `Int32`, `Word32`. An +-- `Overflow` ur `Underflow` error will be raised if the value doesn't +-- fit the type. +intCol :: (Show a, Bounded a, Integral a) => QueryBuilder -> Selector a +intCol e = selectOne intFromSql e + +-- | Un unbounded integer field, either a bounded integer (TINYINT, +-- etc...) or DECIMAL in the database. Will throw a type error if the +-- stored value is actually fractional. +-- +-- /WARNING/: this function could potentially create huge integers with DECIMAL, +-- if the exponent is large, even fillup the space and crash your +-- program! Only use this on trusted inputs, or use Scientific +-- instead. +integerCol :: QueryBuilder -> Selector Integer +integerCol = col + +-- | a DOUBLE field. +doubleCol :: QueryBuilder -> Selector Double +doubleCol = col + +-- | a FLOAT field. +floatCol :: QueryBuilder -> Selector Float +floatCol = col + +-- | A DECIMAL or NUMERIC field. +scientificCol :: QueryBuilder -> Selector Scientific +scientificCol = col + +-- | a DATETIME or a TIMESTAMP field. +localTimeCol :: QueryBuilder -> Selector LocalTime +localTimeCol = col + +-- | A TIME field taken as a specific time. +timeOfDayCol :: QueryBuilder -> Selector TimeOfDay +timeOfDayCol = col + +-- | a TIME field taken as a time duration. +diffTimeCol :: QueryBuilder -> Selector DiffTime +diffTimeCol = col + +-- | A DATE field. +dayCol :: QueryBuilder -> Selector Day +dayCol = col + +-- | A binary BLOB field. +byteStringCol :: QueryBuilder -> Selector StrictBS.ByteString +byteStringCol = col + +-- | a TEXT field. +textCol :: QueryBuilder -> Selector Text +textCol = col + +data SQLError = SQLError String + | ResultSetCountError + | TypeError MySQLValue String + | Underflow + | Overflow + +-- | Selectors contain the target fields or expressions in a SQL +-- SELECT statement, and perform the conversion to haskell. Selectors +-- are instances of `Applicative`, so they can return the desired +-- haskell type. +data Selector a = Selector (DList QueryBuilder) + (StateT [MySQLValue] (Either SQLError) a) + + +instance Functor Selector where + fmap f (Selector cols cast) = Selector cols (fmap f cast) + +instance Applicative Selector where + Selector cols1 cast1 <*> Selector cols2 cast2 = + Selector (cols1 <> cols2) (cast1 <*> cast2) + pure x = Selector DList.empty (pure x) + +instance Semigroup a => Semigroup (Selector a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (Selector a) where + mempty = pure mempty + +data Query a = Query (Selector a) QueryBody +data Command = Update QueryBuilder [(QueryBuilder, QueryBuilder)] QueryBody + | InsertSelect QueryBuilder [QueryBuilder] [QueryBuilder] QueryBody + | forall a.InsertValues QueryBuilder (Insertor a) [a] + | forall a.Delete (Query a) + +-- | An @`Insertor` a@ provides a mapping of parts of values of type +-- @a@ to columns in the database. Insertors can be combined using `<>`. +data Insertor a = Insertor [Text] (a -> [MySQLValue]) + +data Join = Join JoinType [QueryBuilder] [QueryBuilder] +data JoinType = InnerJoin | LeftJoin | RightJoin | OuterJoin + +instance ToQueryBuilder Command where + toQueryBuilder (Update table setting body) = + let pairQuery (a, b) = a <> " = " <> b + in unwords $ + [ "UPDATE", table + , "SET", commaSep $ map pairQuery setting + , toQueryBuilder body + ] + + toQueryBuilder (InsertValues (QueryBuilder table _ _) + (Insertor cols convert) values__) = + let builder, valuesB :: Builder + valuesB = commaSep $ + map (parentized . commaSep . map mysqlValueBuilder . convert) + values__ + builder = unwords [ "INSERT INTO", table + , parentized $ commaSep $ + map (Builder.byteString . Text.encodeUtf8) cols + , "VALUES", valuesB] + in QueryBuilder builder builder (DList.empty) + toQueryBuilder (InsertSelect table cols rows queryBody) = + unwords $ + [ "INSERT INTO", table + , parentized $ commaSep cols + , "SELECT", parentized $ commaSep rows + , toQueryBuilder queryBody + ] + toQueryBuilder (Delete query__) = + "DELETE " <> toQueryBuilder query__ + +instance ToQueryBuilder QueryBody where + toQueryBuilder body = + unwords $ + fromB (_from body) <> + (joinB <$> _joins body) <> + renderPredicates "WHERE" (_where_ body) <> + (groupByB $ _groupBy body) <> + renderPredicates "HAVING" (_having body) <> + orderByB (_orderBy body) <> + limitB (_limit body) + where + fromB Nothing = [] + fromB (Just table) = ["FROM", table] + + joinB (Join _ [] _) = error "list of join tables cannot be empty" + joinB (Join joinType tables joinConditions) = + unwords $ [toQueryBuilder joinType, renderList tables] ++ + renderPredicates "ON" joinConditions + + groupByB [] = [] + groupByB e = ["GROUP BY", commaSep e] + + orderByB [] = [] + orderByB e = ["ORDER BY", commaSep $ map toQueryBuilder e] + + limitB Nothing = [] + limitB (Just (count, Nothing)) = ["LIMIT", fromString (show count)] + limitB (Just (count, Just offset)) = + [ "LIMIT" , fromString (show count) + , "OFFSET", fromString (show offset) ] + +instance ToQueryBuilder (Query a) where + toQueryBuilder (Query _ body) = toQueryBuilder body + +instance ToQueryBuilder JoinType where + toQueryBuilder InnerJoin = "INNER JOIN" + toQueryBuilder LeftJoin = "LEFT JOIN" + toQueryBuilder RightJoin = "RIGHT JOIN" + toQueryBuilder OuterJoin = "OUTER JOIN" + +data QueryBody = QueryBody + { _from :: Maybe QueryBuilder + , _joins :: [Join] + , _where_ :: [QueryBuilder] + , _groupBy :: [QueryBuilder] + , _having :: [QueryBuilder] + , _orderBy :: [QueryOrdering] + , _limit :: Maybe (Int, Maybe Int) + } + +data QueryOrdering = + Asc QueryBuilder | Desc QueryBuilder + +instance ToQueryBuilder QueryOrdering where + toQueryBuilder (Asc b) = b <> " ASC" + toQueryBuilder (Desc b) = b <> " DESC" + +data QueryBuilder = QueryBuilder Builder Builder (DList MySQLValue) + +instance IsString QueryBuilder where + fromString s = QueryBuilder b b DList.empty + where b = Builder.string8 s + +instance Semigroup QueryBuilder where + QueryBuilder stmt1 prepStmt1 vals1 <> QueryBuilder stmt2 prepStmt2 vals2 = + QueryBuilder (stmt1 <> stmt2) (prepStmt1 <> prepStmt2) (vals1 <> vals2) + +instance Monoid QueryBuilder where + mempty = QueryBuilder mempty mempty mempty + +newtype QueryClauses = QueryClauses (Endo QueryBody) + deriving (Semigroup, Monoid) + +instance Semigroup (Insertor a) where + Insertor fields1 conv1 <> Insertor fields2 conv2 = + Insertor (fields1 <> fields2) (conv1 <> conv2) + +instance Monoid (Insertor a) where + mempty = Insertor mempty mempty + +class HasQueryClauses a where + mergeClauses :: a -> QueryClauses -> a + +instance HasQueryClauses (Query a) where + mergeClauses (Query selector body) (QueryClauses clauses) = + Query selector (clauses `appEndo` body) + +instance HasQueryClauses Command where + mergeClauses (Update table setting body) (QueryClauses clauses) = + Update table setting (clauses `appEndo` body) + mergeClauses (InsertSelect table toColumns fromColumns queryBody) + (QueryClauses clauses) = + InsertSelect table toColumns fromColumns (appEndo clauses queryBody) + mergeClauses command__@(InsertValues _ _ _) _ = + command__ + mergeClauses (Delete query__) clauses = + Delete $ mergeClauses query__ clauses + +fromText :: Text -> QueryBuilder +fromText s = QueryBuilder b b DList.empty + where b = Builder.byteString $ Text.encodeUtf8 s + +sepBy :: Monoid a => a -> [a] -> a +sepBy sep builder = mconcat $ intersperse sep builder +{-# INLINE sepBy #-} + +commaSep :: (IsString a, Monoid a) => [a] -> a +commaSep = sepBy ", " +{-# INLINE commaSep #-} + +unwords :: (IsString a, Monoid a) => [a] -> a +unwords = sepBy " " +{-# INLINE unwords #-} + +parentized :: (IsString a, Monoid a) => a -> a +parentized expr = "(" <> expr <> ")" +{-# INLINE parentized #-} + +renderList :: [QueryBuilder] -> QueryBuilder +renderList [] = "" +renderList [e] = e +renderList es = parentized $ commaSep es + +renderPredicates :: QueryBuilder -> [QueryBuilder] -> [QueryBuilder] +renderPredicates _ [] = [] +renderPredicates keyword [e] = [keyword, e] +renderPredicates keyword es = + keyword : intersperse "AND" (map parentized $ reverse es) + +mysqlValueBuilder :: MySQLValue -> Builder +mysqlValueBuilder = Builder.lazyByteString . runPut . putTextField + +arg :: ToSql a => a -> QueryBuilder +arg a = QueryBuilder + (mysqlValueBuilder $ toSqlValue a) + (Builder.lazyByteString "?") + (DList.singleton $ toSqlValue a) + +fun :: Text -> [QueryBuilder] -> QueryBuilder +fun name exprs = fromText name <> parentized (commaSep exprs) + +op :: Text -> QueryBuilder -> QueryBuilder -> QueryBuilder +op name e1 e2 = e1 <> " " <> fromText name <> " " <> e2 + +(.>), (.+), (.-) :: QueryBuilder -> QueryBuilder -> QueryBuilder +(.>) = op ">" +(.+) = op "+" +(.-) = op "-" + +-- | insert a single value directly +insert1 :: ToSql a => Text -> Insertor a +insert1 s = Insertor [s] (\t -> [toSqlValue t]) + +-- | insert the values of a tuple +insert2 :: (ToSql a1, ToSql a2) => Text -> Text -> Insertor (a1, a2) +insert2 s1 s2 = Insertor [s1, s2] $ + \(t1, t2) -> [toSqlValue t1, toSqlValue t2] + +insert3 :: (ToSql a1, ToSql a2, ToSql a3) + => Text -> Text -> Text -> Insertor (a1, a2, a3) +insert3 s1 s2 s3 = Insertor [s1, s2, s3] $ + \(t1, t2, t3) -> [toSqlValue t1, toSqlValue t2, toSqlValue t3] + +insert4 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4) + => Text -> Text -> Text -> Text -> Insertor (a1, a2, a3, a4) +insert4 s1 s2 s3 s4 = Insertor [s1, s2, s3, s4] $ + \(t1, t2, t3, t4) -> [toSqlValue t1, toSqlValue t2, toSqlValue t3, + toSqlValue t4] + + +insert5 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5) + => Text -> Text -> Text -> Text -> Text + -> Insertor (a1, a2, a3, a4, a5) +insert5 s1 s2 s3 s4 s5 = Insertor [s1, s2, s3, s4, s5] $ + \(t1, t2, t3, t4, t5) -> [toSqlValue t1, toSqlValue t2, toSqlValue t3, + toSqlValue t4, toSqlValue t5] + +insert6 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6) + => Text -> Text -> Text -> Text -> Text -> Text + -> Insertor (a1, a2, a3, a4, a5, a6) +insert6 s1 s2 s3 s4 s5 s6 = Insertor [s1, s2, s3, s4, s5, s6] $ + \(t1, t2, t3, t4, t5, t6) -> [toSqlValue t1, toSqlValue t2, toSqlValue t3, + toSqlValue t4, toSqlValue t5, toSqlValue t6] + +insert7 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6, + ToSql a7) + => Text -> Text -> Text -> Text -> Text -> Text -> Text + -> Insertor (a1, a2, a3, a4, a5, a6, a7) +insert7 s1 s2 s3 s4 s5 s6 s7 = + Insertor [s1, s2, s3, s4, s5, s6, s7] $ + \(t1, t2, t3, t4, t5, t6, t7) -> + [toSqlValue t1, toSqlValue t2, toSqlValue t3, + toSqlValue t4, toSqlValue t5, toSqlValue t6, + toSqlValue t7] + +insert8 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6, + ToSql a7, ToSql a8) + => Text -> Text -> Text -> Text -> Text -> Text -> Text + -> Text + -> Insertor (a1, a2, a3, a4, a5, a6, a7, a8) +insert8 s1 s2 s3 s4 s5 s6 s7 s8 = + Insertor [s1, s2, s3, s4, s5, s6, s7, s8] $ + \(t1, t2, t3, t4, t5, t6, t7, t8) -> + [toSqlValue t1, toSqlValue t2, toSqlValue t3, + toSqlValue t4, toSqlValue t5, toSqlValue t6, + toSqlValue t7, toSqlValue t8] + +insert9 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6, + ToSql a7, ToSql a8, ToSql a9) + => Text -> Text -> Text -> Text -> Text -> Text -> Text + -> Text -> Text + -> Insertor (a1, a2, a3, a4, a5, a6, a7, a8, a9) +insert9 s1 s2 s3 s4 s5 s6 s7 s8 s9 = + Insertor [s1, s2, s3, s4, s5, s6, s7, s8, s9] $ + \(t1, t2, t3, t4, t5, t6, t7, t8, t9) -> + [toSqlValue t1, toSqlValue t2, toSqlValue t3, + toSqlValue t4, toSqlValue t5, toSqlValue t6, + toSqlValue t7, toSqlValue t8, toSqlValue t9] + +insert10 :: (ToSql a1, ToSql a2, ToSql a3, ToSql a4, ToSql a5, ToSql a6, + ToSql a7, ToSql a8, ToSql a9, ToSql a10) + => Text -> Text -> Text -> Text -> Text -> Text + -> Text -> Text -> Text -> Text + -> Insertor (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) +insert10 s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 = + Insertor [s1, s2, s3, s4, s5, s6, s7, s8, s9, s10] $ + \(t1, t2, t3, t4, t5, t6, t7, t8, t9, t10) -> + [toSqlValue t1, toSqlValue t2, toSqlValue t3, + toSqlValue t4, toSqlValue t5, toSqlValue t6, + toSqlValue t7, toSqlValue t8, toSqlValue t9, + toSqlValue t10] + +-- | `into` uses the given extractor function to map the part to a +-- field. For example: +-- +-- > insertValues "Person" (fst `into` "name" <> snd `into` "age") +-- > [("Bart Simpson", 10), ("Lisa Simpson", 8)] +into :: ToSql b => (a -> b) -> Text -> Insertor a +into toVal theField = Insertor [theField] ((:[]) . toSqlValue . toVal) + +-- | `lensInto` uses a lens to map the part to a field. For example: +-- +-- > insertValues "Person" (_1 `lensInto` "name" <> _2 `lensInto` "age") +-- > [("Bart Simpson", 10), ("Lisa Simpson", 8)] + +lensInto :: ToSql b => ((b -> Const b b) -> (a -> Const b a)) -> Text + -> Insertor a +lensInto lens theField = into (getConst . lens Const) theField + +subQuery :: ToQueryBuilder a => a -> QueryBuilder +subQuery = parentized . toQueryBuilder + +from :: QueryBuilder -> QueryClauses +from table = QueryClauses $ Endo $ \qc -> qc {_from = Just table} + +joinClause :: JoinType -> [QueryBuilder] -> [QueryBuilder] -> QueryClauses +joinClause tp tables conditions = QueryClauses $ Endo $ \qc -> + qc { _joins = Join tp tables conditions : _joins qc } + +innerJoin :: [QueryBuilder] -> [QueryBuilder] -> QueryClauses +innerJoin = joinClause InnerJoin + +leftJoin :: [QueryBuilder] -> [QueryBuilder] -> QueryClauses +leftJoin = joinClause LeftJoin + +rightJoin :: [QueryBuilder] -> [QueryBuilder] -> QueryClauses +rightJoin = joinClause RightJoin + +outerJoin :: [QueryBuilder] -> [QueryBuilder] -> QueryClauses +outerJoin = joinClause OuterJoin + +emptyJoins :: QueryClauses +emptyJoins = QueryClauses $ Endo $ \qc -> + qc { _joins = [] } + +where_ :: [QueryBuilder] -> QueryClauses +where_ conditions = QueryClauses $ Endo $ \qc -> + qc { _where_ = reverse conditions ++ _where_ qc} + +emptyWhere :: QueryClauses +emptyWhere = QueryClauses $ Endo $ \qc -> + qc { _where_ = [] } + +groupBy_ :: [QueryBuilder] -> QueryClauses +groupBy_ columns = QueryClauses $ Endo $ \qc -> + qc { _groupBy = columns } + +having :: [QueryBuilder] -> QueryClauses +having conditions = QueryClauses $ Endo $ \qc -> + qc { _having = reverse conditions ++ _having qc } + +emptyHaving :: QueryClauses +emptyHaving = QueryClauses $ Endo $ \qc -> + qc { _having = [] } + +orderBy :: [QueryOrdering] -> QueryClauses +orderBy ordering = QueryClauses $ Endo $ \qc -> + qc { _orderBy = ordering } + +limit :: Int -> QueryClauses +limit count = QueryClauses $ Endo $ \qc -> + qc { _limit = Just (count, Nothing) } + +limitOffset :: Int -> Int -> QueryClauses +limitOffset count offset = QueryClauses $ Endo $ \qc -> + qc { _limit = Just (count, Just offset) } + +emptyQueryBody :: QueryBody +emptyQueryBody = QueryBody Nothing [] [] [] [] [] Nothing + +select :: Selector a -> QueryClauses -> Query a +select selector (QueryClauses clauses) = + Query selector (clauses `appEndo` emptyQueryBody) + +mergeSelect :: Query b -> (a -> b -> c) -> Selector a -> Query c +mergeSelect (Query selector2 body) f selector1 = + Query (liftA2 f selector1 selector2) body + +replaceSelect :: Selector a -> Query b -> Query a +replaceSelect s (Query _ body) = Query s body + +insertValues :: QueryBuilder -> Insertor a -> [a] -> Command +insertValues = InsertValues + +insertSelect :: QueryBuilder -> [QueryBuilder] -> [QueryBuilder] -> QueryClauses + -> Command +insertSelect table toColumns fromColumns (QueryClauses clauses) = + InsertSelect table (toColumns) (fromColumns) (appEndo clauses emptyQueryBody) + +-- | combinator for aliasing columns. +as :: QueryBuilder -> QueryBuilder -> QueryBuilder +as e1 e2 = e1 <> " AS " <> e2 + +-- | Read the columns directly as a `MySQLValue` type without conversion. +values :: [QueryBuilder] -> Selector [MySQLValue] +values cols = Selector (DList.fromList cols) $ + state $ splitAt (length cols) + +-- | Ignore the content of the given columns +values_ :: [QueryBuilder] -> Selector () +values_ cols = () <$ values cols + +-- selector for any bounded integer type +intFromSql :: forall a.(Show a, Bounded a, Integral a) + => MySQLValue -> Either SQLError a +intFromSql r = case r of + MySQLInt8U u -> castFromWord $ fromIntegral u + MySQLInt8 i -> castFromInt $ fromIntegral i + MySQLInt16U u -> castFromWord $ fromIntegral u + MySQLInt16 i -> castFromInt $ fromIntegral i + MySQLInt32U u -> castFromWord $ fromIntegral u + MySQLInt32 i -> castFromInt $ fromIntegral i + MySQLInt64U u -> castFromWord $ fromIntegral u + MySQLInt64 i -> castFromInt $ fromIntegral i + MySQLYear y -> castFromWord $ fromIntegral y + _ -> Left $ TypeError r $ + "Int (" <> show (minBound :: a) <> ", " <> show (maxBound :: a) <> ")" + where castFromInt :: Int64 -> Either SQLError a + castFromInt i + | i < fromIntegral (minBound :: a) = throwError Underflow + | i > fromIntegral (maxBound :: a) = throwError Overflow + | otherwise = pure $ fromIntegral i + castFromWord :: Word64 -> Either SQLError a + castFromWord i + | i > fromIntegral (maxBound :: a) = throwError Overflow + | otherwise = pure $ fromIntegral i + +integerFromSql :: MySQLValue -> Either SQLError Integer +integerFromSql (MySQLInt8U u) = pure $ fromIntegral u +integerFromSql (MySQLInt8 i) = pure $ fromIntegral i +integerFromSql (MySQLInt16U u) = pure $ fromIntegral u +integerFromSql (MySQLInt16 i) = pure $ fromIntegral i +integerFromSql (MySQLInt32U u) = pure $ fromIntegral u +integerFromSql (MySQLInt32 i) = pure $ fromIntegral i +integerFromSql (MySQLInt64U u) = pure $ fromIntegral u +integerFromSql (MySQLInt64 i) = pure $ fromIntegral i +integerFromSql (MySQLYear y) = pure $ fromIntegral y +integerFromSql (MySQLDecimal d) = case floatingOrInteger d of + Left (_ :: Double) -> throwError $ TypeError (MySQLDecimal d) "Integer" + Right i -> pure i +integerFromSql v = throwError $ TypeError v "Integer" + +instance FromSql Int where + fromSql = intFromSql + +instance FromSql Int8 where + fromSql = intFromSql + +instance FromSql Word8 where + fromSql = intFromSql + +instance FromSql Int16 where + fromSql = intFromSql + +instance FromSql Word16 where + fromSql = intFromSql + +instance FromSql Int32 where + fromSql = intFromSql + +instance FromSql Word32 where + fromSql = intFromSql + +instance FromSql Int64 where + fromSql = intFromSql + +instance FromSql Word64 where + fromSql = intFromSql + +instance FromSql Integer where + fromSql = integerFromSql + +instance FromSql Float where + fromSql r = case r of + MySQLFloat f -> pure f + _ -> Left $ TypeError r "Float" + +instance FromSql Double where + fromSql r = case r of + MySQLFloat f -> pure $ realToFrac f + MySQLDouble f -> pure f + _ -> Left $ TypeError r "Double" + +instance FromSql Scientific where + fromSql r = case r of + MySQLDecimal f -> pure f + _ -> Left $ TypeError r "Scientific" + +instance FromSql LocalTime where + fromSql r = case r of + MySQLTimeStamp t -> pure t + MySQLDateTime t -> pure t + _ -> Left $ TypeError r "LocalTime" + +instance FromSql TimeOfDay where + fromSql r = case r of + MySQLTime sign_ t | sign_ >= 0 -> pure t + | otherwise -> throwError Overflow + _ -> Left $ TypeError r "TimeOfDay" + +instance FromSql DiffTime where + fromSql r = case r of + MySQLTime sign_ t | sign_ == 1 -> pure $ negate $ timeOfDayToTime t + | otherwise -> pure $ timeOfDayToTime t + _ -> Left $ TypeError r "DiffTime" + +instance FromSql Day where + fromSql r = case r of + MySQLDate d -> pure d + _ -> Left $ TypeError r "Day" + +instance FromSql StrictBS.ByteString where + fromSql r = case r of + MySQLBytes b -> pure b + _ -> Left $ TypeError r "ByteString" + +instance FromSql Text where + fromSql r = case r of + MySQLText t -> pure t + _ -> Left $ TypeError r "Text" + +instance FromSql a => FromSql (Maybe a) where + fromSql r = case r of + MySQLNull -> pure Nothing + _ -> Just <$> fromSql r + +instance ToSql Int where + toSqlValue = MySQLInt64 . fromIntegral + +instance ToSql Int8 where + toSqlValue = MySQLInt8 + +instance ToSql Word8 where + toSqlValue = MySQLInt8U + +instance ToSql Int16 where + toSqlValue = MySQLInt16 + +instance ToSql Word16 where + toSqlValue = MySQLInt16U + +instance ToSql Int32 where + toSqlValue = MySQLInt32 + +instance ToSql Word32 where + toSqlValue = MySQLInt32U + +instance ToSql Int64 where + toSqlValue = MySQLInt64 + +instance ToSql Word64 where + toSqlValue = MySQLInt64U + +instance ToSql Integer where + toSqlValue = MySQLDecimal . fromIntegral + +instance ToSql Float where + toSqlValue = MySQLFloat + +instance ToSql Double where + toSqlValue = MySQLDouble + +instance ToSql Scientific where + toSqlValue = MySQLDecimal + +instance ToSql LocalTime where + toSqlValue = MySQLDateTime + +instance ToSql TimeOfDay where + toSqlValue = MySQLTime 0 + +instance ToSql DiffTime where + toSqlValue dt | dt < 0 = MySQLTime 1 $ timeToTimeOfDay $ negate dt + | otherwise = MySQLTime 0 $ timeToTimeOfDay dt + +instance ToSql Day where + toSqlValue = MySQLDate + +instance ToSql StrictBS.ByteString where + toSqlValue = MySQLBytes + +instance ToSql Text where + toSqlValue = MySQLText + +instance ToSql a => ToSql (Maybe a) where + toSqlValue Nothing = MySQLNull + toSqlValue (Just v) = toSqlValue v