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/hasqlator-mysql.cabal b/hasqlator-mysql.cabal new file mode 100644 --- /dev/null +++ b/hasqlator-mysql.cabal @@ -0,0 +1,52 @@ +Name: hasqlator-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/hasqlator-mysql/issues +Build-type: Simple +Cabal-version: >=1.10 +Description: A simple but expressive applicative SQL generation library for mysql + . + Haskqlator is a simple but expressive SQL generation library. Instead of + matching haskell records, or using complicate type level computations to match + haskell types to database schemas, it uses a simple applicative interface to + convert between SQL and haskell. The produced SQL matches exactly the SQL + written by the user. An addition layer is provided to encode database schemas + as haskell values, and give more type safety. + +source-repository head + type: git + location: https://github.com/kuribas/hasqlator-mysql + +Library + Ghc-options: -Wall + default-language: Haskell2010 + Build-depends: base >= 3 && < 5, + binary, + bytestring, + containers, + dlist, + dlist, + io-streams >= 1.5.2.1, + megaparsec, + mtl >= 2.1.3, + mysql-haskell, + prettyprinter, + scientific, + text, + time, + template-haskell, + aeson, + pretty-simple + hs-source-dirs: + src + Exposed-Modules: + Database.MySQL.Hasqlator + Database.MySQL.Hasqlator.Typed + Database.MySQL.Hasqlator.Typed.Schema diff --git a/src/Database/MySQL/Hasqlator.hs b/src/Database/MySQL/Hasqlator.hs new file mode 100644 --- /dev/null +++ b/src/Database/MySQL/Hasqlator.hs @@ -0,0 +1,818 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} + +{-| +Module : Database.Hasqelator +Description : SQL generation +Copyright : (c) Kristof Bastiaensen, 2020 +License : BSD-3 +Maintainer : kristof@resonata.be +Stability : unstable +Portability : ghc + + +-} + +module Database.MySQL.Hasqlator + ( -- * Querying + Query, Command, select, mergeSelect, replaceSelect, + + -- * Query Clauses + QueryClauses, from, innerJoin, leftJoin, rightJoin, outerJoin, emptyJoins, + where_, emptyWhere, groupBy_, having, emptyHaving, QueryOrdering(..), + orderBy, limit, limitOffset, + + -- * Selectors + Selector, as, + + -- ** polymorphic selector + sel, + -- ** specialised selectors + -- | The following are specialised versions of `sel`. Using these + -- may make refactoring easier, for example accidently swapping + -- @`sel` "age"@ and @`sel` "name"@ would not give a type error, + -- while @intSel "age"@ and @textSel "name"@ most likely would. + intSel, integerSel, doubleSel, floatSel, scientificSel, + localTimeSel, timeOfDaySel, diffTimeSel, daySel, byteStringSel, + textSel, + -- ** other selectors + values, values_, + + -- * Expressions + subQuery, + arg, fun, op, (>.), (<.), (>=.), (<=.), (+.), (-.), (*.), (/.), (=.), (++.), + (/=.), (&&.), (||.), abs_, negate_, signum_, sum_, rawSql, substr, in_, + + -- * Insertion + Insertor, insertValues, insertSelect, insertData, skipInsert, into, Getter, + lensInto, insertOne, ToSql, + + -- * Rendering Queries + renderStmt, renderPreparedStmt, SQLError(..), QueryBuilder, + ToQueryBuilder(..), FromSql, + + -- * Executing Queries + executeQuery, executeCommand + ) + +where + +import Database.MySQL.Base hiding (Query, Command) +import qualified Database.MySQL.Base as MySQL +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 GHC.Generics hiding (Selector, from) +import qualified GHC.Generics as Generics (from) + +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 +import Data.Traversable +import Data.Functor.Contravariant +import qualified System.IO.Streams as Streams +import Control.Exception (throw, Exception) +import Data.Aeson + +class FromSql a where + fromSql :: MySQLValue -> Either SQLError a + +class ToSql a where + toSqlValue :: a -> MySQLValue + +instance FromSql a => IsString (Selector a) where + fromString = sel . 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 + +-- | Execute a Query which returns a resultset. May throw a +-- `SQLError` exception. See the mysql-haskell package for other +-- exceptions it may throw. +executeQuery :: MySQLConn -> Query a -> IO [a] +executeQuery conn q@(Query s _) = + do is <- fmap snd $ MySQL.query_ conn $ MySQL.Query $ renderStmt q + results <- Streams.toList is + for results $ either throw pure . runSelector s + +-- | Execute a Command which doesn't return a result-set. May throw a +-- `SQLError` exception. See the mysql-haskell package for other +-- exceptions it may throw. +executeCommand :: MySQLConn -> Command -> IO OK +executeCommand conn c = MySQL.execute_ conn $ MySQL.Query $ renderStmt c + +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. +sel :: FromSql a => QueryBuilder -> Selector a +sel 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. +intSel :: (Show a, Bounded a, Integral a) => QueryBuilder -> Selector a +intSel 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. +integerSel :: QueryBuilder -> Selector Integer +integerSel = sel + +-- | a DOUBLE field. +doubleSel :: QueryBuilder -> Selector Double +doubleSel = sel + +-- | a FLOAT field. +floatSel :: QueryBuilder -> Selector Float +floatSel = sel + +-- | A DECIMAL or NUMERIC field. +scientificSel :: QueryBuilder -> Selector Scientific +scientificSel = sel + +-- | a DATETIME or a TIMESTAMP field. +localTimeSel :: QueryBuilder -> Selector LocalTime +localTimeSel = sel + +-- | A TIME field taken as a specific time. +timeOfDaySel :: QueryBuilder -> Selector TimeOfDay +timeOfDaySel = sel + +-- | a TIME field taken as a time duration. +diffTimeSel :: QueryBuilder -> Selector DiffTime +diffTimeSel = sel + +-- | A DATE field. +daySel :: QueryBuilder -> Selector Day +daySel = sel + +-- | A binary BLOB field. +byteStringSel :: QueryBuilder -> Selector StrictBS.ByteString +byteStringSel = sel + +-- | a TEXT field. +textSel :: QueryBuilder -> Selector Text +textSel = sel + + +data SQLError = SQLError String + | ResultSetCountError + | TypeError MySQLValue String + | Underflow + | Overflow + deriving Show + +instance Exception SQLError +-- | 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) + +runSelector :: Selector a -> [MySQLValue] -> Either SQLError a +runSelector (Selector _ run) = evalStateT run + +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 (Selector dl _) body) = + "SELECT " <> commaSep (DList.toList dl) <> " " <> toQueryBuilder body + +rawSql :: Text -> QueryBuilder +rawSql t = QueryBuilder builder builder DList.empty where + builder = Builder.byteString (Text.encodeUtf8 t) + +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 + +instance Contravariant Insertor where + contramap f (Insertor x g) = Insertor x (g . f) + +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 = parentized $ e1 <> " " <> fromText name <> " " <> e2 + +substr :: QueryBuilder -> QueryBuilder -> QueryBuilder -> QueryBuilder +substr field start end = fun "substr" [field, start, end] + +(>.), (<.), (>=.), (<=.), (+.), (-.), (/.), (*.), (=.), (/=.), (++.), (&&.), + (||.) + :: QueryBuilder -> QueryBuilder -> QueryBuilder +(>.) = op ">" +(<.) = op "<" +(>=.) = op ">=" +(<=.) = op "<=" +(+.) = op "+" +(*.) = op "*" +(/.) = op "/" +(-.) = op "-" +(=.) = op "=" +(/=.) = op "<>" +a ++. b = fun "concat" [a, b] +(&&.) = op "and" +(||.) = op "or" + +abs_, signum_, negate_, sum_ :: QueryBuilder -> QueryBuilder +abs_ x = fun "abs" [x] +signum_ x = fun "sign" [x] +negate_ x = fun "-" [x] +sum_ x = fun "sum" [x] + + +-- | insert a single value directly +insertOne :: ToSql a => Text -> Insertor a +insertOne s = Insertor [s] (\t -> [toSqlValue t]) + +-- | insert a datastructure +class InsertGeneric (fields :: *) (data_ :: *) where + insertDataGeneric :: fields -> Insertor data_ + +genFst :: (a :*: b) () -> a () +genFst (a :*: _) = a + +genSnd :: (a :*: b) () -> b () +genSnd (_ :*: b) = b + +instance (InsertGeneric (a ()) (c ()), + InsertGeneric (b ()) (d ())) => + InsertGeneric ((a :*: b) ()) ((c :*: d) ()) where + insertDataGeneric (a :*: b) = + contramap genFst (insertDataGeneric a) <> + contramap genSnd (insertDataGeneric b) + +instance InsertGeneric (a ()) (b ()) => + InsertGeneric (M1 m1 m2 a ()) (M1 m3 m4 b ()) where + insertDataGeneric = contramap unM1 . insertDataGeneric . unM1 + +instance ToSql b => InsertGeneric (K1 r Text ()) (K1 r b ()) where + insertDataGeneric = contramap unK1 . insertOne . unK1 + +instance InsertGeneric (K1 r (Insertor a) ()) (K1 r a ()) where + insertDataGeneric = contramap unK1 . unK1 + +-- | `insertData` inserts a tuple or other product type into the given +-- fields. It uses generics to match the input to the fields. For +-- example: +-- +-- > insert "Person" (insertData ("name", "age")) +-- > [Person "Bart Simpson" 10, Person "Lisa Simpson" 8] + +insertData :: (Generic a, Generic b, InsertGeneric (Rep a ()) (Rep b ())) + => a -> Insertor b +insertData = contramap from' . insertDataGeneric . from' + where from' :: Generic a => a -> Rep a () + from' = Generics.from + +-- | skipInsert is mempty specialized to an Insertor. It can be used +-- to skip fields when using insertData. +skipInsert :: Insertor a +skipInsert = mempty + +-- | `into` uses the given accessor 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 = contramap toVal . insertOne + +-- | A Getter type compatible with the lens library +type Getter s a = (a -> Const a a) -> s -> Const a s + +-- | `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 => Getter a b -> Text -> Insertor a +lensInto lens = into (getConst . lens Const) + +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 + +in_ :: QueryBuilder -> [QueryBuilder] -> QueryBuilder +in_ e l = e <> " IN " <> parentized (commaSep l) + +-- | 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 Bool where + fromSql (MySQLInt8U x) = pure $ x /= 0 + fromSql (MySQLInt8 x) = pure $ x /= 0 + fromSql v = throwError $ TypeError v "Bool" + +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 + +instance ToSql Bool where + toSqlValue = MySQLInt8U . fromIntegral . fromEnum + diff --git a/src/Database/MySQL/Hasqlator/Typed.hs b/src/Database/MySQL/Hasqlator/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Database/MySQL/Hasqlator/Typed.hs @@ -0,0 +1,624 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} + +module Database.MySQL.Hasqlator.Typed + ( -- * Database Types + Table(..), Field(..), Tbl(..), (@@), Nullable (..), + + + -- * Querying + Query, + + -- * Selectors + H.Selector, sel, selMaybe, + + -- * Expressions + Expression, SomeExpression, someExpr, Operator, + arg, argMaybe, nullable, cast, unsafeCast, + op, fun1, fun2, fun3, (>.), (<.), (>=.), (<=.), (&&.), (||.), + substr, true_, false_, + + -- * Clauses + from, fromSubQuery, innerJoin, leftJoin, joinSubQuery, leftJoinSubQuery, + where_, groupBy_, having, orderBy, limit, limitOffset, + + -- * Insertion + Insertor, insertValues, insertSelect, insertData, skipInsert, into, + lensInto, insertOne, exprInto, Into, + + -- * imported from Database.MySQL.Hasqlator + H.Getter, H.ToSql, H.FromSql, subQueryExpr + ) +where +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Coerce +import qualified Data.ByteString as StrictBS +import Data.Scientific +import Data.Word +import Data.Int +import Data.Time +import Data.String +import qualified Data.DList as DList +import qualified Data.Map.Strict as Map +import Control.Monad.State +import Control.Monad.Reader +import GHC.Exts (Constraint) +import GHC.TypeLits as TL +import Data.Functor.Contravariant +import Control.Applicative +import qualified GHC.Generics as Generics (from, to) +import GHC.Generics hiding (from, Selector) +import qualified Database.MySQL.Hasqlator as H +import Data.Proxy + +data Nullable = Nullable | NotNull +data JoinType = LeftJoined | InnerJoined + +type family CheckInsertable (fieldNullable :: Nullable) fieldType a + :: Constraint where + CheckInsertable 'Nullable a (Maybe a) = () + CheckInsertable 'Nullable a a = () + CheckInsertable 'NotNull a a = () + CheckInsertable n t ft = + TypeError ('TL.Text "Cannot insert value of type " ':<>: + 'ShowType t ':<>: + 'TL.Text " into " ':<>: + 'ShowType n ':<>: + 'TL.Text " field of type " ':<>: + 'ShowType ft) + +type Insertable nullable field a = + (CheckInsertable nullable field a, H.ToSql a) + +-- | check if field can be used in nullable context +type family CheckExprNullable (expr :: Nullable) (context :: Nullable) + :: Constraint + where + CheckExprNullable 'Nullable 'Nullable = () + CheckExprNullable 'Nullable 'NotNull = + TypeError ('Text "A nullable expression can be only used in a nullable context") + -- a NotNull expressions can be used in both contexts + CheckExprNullable 'NotNull _ = () + +-- | check if a field is nullable after being joined +type family JoinNullable (leftJoined :: JoinType) (field :: Nullable) + :: Nullable + where + JoinNullable 'InnerJoined nullable = nullable + JoinNullable 'LeftJoined _ = 'Nullable + +data Field (table :: Symbol) database (nullable :: Nullable) a = + Field Text Text + +newtype Expression (nullable :: Nullable) a = + Expression {runExpression :: QueryInner H.QueryBuilder } + +-- | An expression of any type +newtype SomeExpression = + SomeExpression { runSomeExpression :: QueryInner H.QueryBuilder } + +newtype Selector a = Selector (QueryInner (H.Selector a)) + +instance Functor Selector where + fmap f (Selector s) = Selector (fmap f <$> s) +instance Applicative Selector where + pure x = Selector $ pure $ pure x + Selector a <*> Selector b = Selector $ liftA2 (<*>) a b +instance Semigroup a => Semigroup (Selector a) where + Selector a <> Selector b = Selector $ liftA2 (<>) a b +instance Monoid a => Monoid (Selector a) where + mempty = Selector $ pure mempty + +-- | Remove types of an expression +someExpr :: Expression nullable a -> SomeExpression +someExpr = coerce + +instance IsString (Expression nullable Text) where + fromString = arg . fromString + +instance Semigroup (Expression nullable Text) where + (<>) = fun2 (H.++.) + +instance Monoid (Expression nullable Text) where + mempty = arg "" + +instance (Num n, H.ToSql n) => Num (Expression nullable n) where + (+) = op (H.+.) + (-) = op (H.-.) + (*) = op (H.*.) + negate = fun1 H.negate_ + abs = fun1 H.abs_ + signum = fun1 H.signum_ + fromInteger = arg . fromInteger + +instance (Fractional n, H.ToSql n) + => Fractional (Expression nullable n) where + (/) = op (H./.) + fromRational = arg . fromRational + +data Table (table :: Symbol) database = Table (Maybe Text) Text + +-- | An table alias that can be used inside the Query. The function +-- inside the newtype can also be applied directly to create an +-- expression from a field. +newtype Tbl table database (joinType :: JoinType) = + Tbl { getTableAlias :: + forall fieldNull exprNull a . + CheckExprNullable (JoinNullable joinType fieldNull) exprNull => + Field table database fieldNull a -> + Expression exprNull a } + +newtype Insertor (table :: Symbol) database a = Insertor (H.Insertor a) + deriving (Monoid, Semigroup, Contravariant) + +data ClauseState = ClauseState + { clausesBuild :: H.QueryClauses -- clauses build so far + , aliases :: Map.Map Text Int -- map of aliases to times used + } + +emptyClauseState :: ClauseState +emptyClauseState = ClauseState mempty Map.empty + +type QueryInner a = State ClauseState a + +newtype Query database a = Query (QueryInner a) + deriving (Functor, Applicative, Monad) + +instance H.ToQueryBuilder (Query database (H.Selector a)) where + toQueryBuilder (Query query) = + let (selector, clauseState) = runState query emptyClauseState + -- TODO: finalize query + in H.toQueryBuilder $ H.select selector $ clausesBuild clauseState + +type Operator a b c = forall nullable . + (Expression nullable a -> + Expression nullable b -> + Expression nullable c) + +infixl 9 @@ + +-- | Create an expression from an aliased table and a field. +(@@) :: CheckExprNullable (JoinNullable joinType fieldNull) exprNull + => Tbl table database (joinType :: JoinType) + -> Field table database fieldNull a + -> Expression exprNull a +(@@) = getTableAlias + +mkTableAlias :: Text -> Tbl table database leftJoined +mkTableAlias tableName = Tbl $ \(Field _ fieldName) -> + Expression $ pure $ H.rawSql $ tableName <> "." <> fieldName + +data QueryOrdering = Asc SomeExpression | Desc SomeExpression + +-- | make a selector from a column +sel :: H.FromSql a + => Expression 'NotNull a + -> Selector a +sel (Expression expr) = Selector $ H.sel <$> expr + +-- | make a selector from a column that can be null +selMaybe :: H.FromSql (Maybe a) + => Expression 'Nullable a + -> Selector (Maybe a) +selMaybe (Expression expr) = Selector $ H.sel <$> expr + +-- | pass an argument +arg :: H.ToSql a => a -> Expression nullable a +arg x = Expression $ pure $ H.arg x + +-- | pass an argument which can be null +argMaybe :: H.ToSql a => Maybe a -> Expression 'Nullable a +argMaybe x = Expression $ pure $ H.arg x + +-- | create an operator +op :: (H.QueryBuilder -> H.QueryBuilder -> H.QueryBuilder) + -> Operator a b c +op = fun2 + +fun1 :: (H.QueryBuilder -> H.QueryBuilder) + -> Expression nullable a + -> Expression nullable b +fun1 f (Expression x) = Expression $ f <$> x + +fun2 :: (H.QueryBuilder -> H.QueryBuilder -> H.QueryBuilder) + -> Expression nullable a + -> Expression nullable b + -> Expression nullable c +fun2 f (Expression x1) (Expression x2) = Expression $ liftA2 f x1 x2 + +fun3 :: (H.QueryBuilder -> H.QueryBuilder -> H.QueryBuilder -> H.QueryBuilder) + -> Expression nullable a + -> Expression nullable b + -> Expression nullable c + -> Expression nullable d +fun3 f (Expression x1) (Expression x2) (Expression x3) = + Expression $ liftA3 f x1 x2 x3 + +substr :: Expression nullable Text -> Expression nullable Int + -> Expression nullable Int + -> Expression nullable Text +substr = fun3 H.substr + +(>.), (<.), (>=.), (<=.) :: H.ToSql a => Operator a a Bool +(>.) = op (H.>.) +(<.) = op (H.<.) +(>=.) = op (H.>=.) +(<=.) = op (H.<=.) + +(||.), (&&.) :: Operator Bool Bool Bool +(||.) = op (H.||.) +(&&.) = op (H.&&.) + +true_, false_ :: Expression nullable Bool +true_ = Expression $ pure $ H.rawSql "true" +false_ = Expression $ pure $ H.rawSql "false" + +-- | make expression nullable +nullable :: Expression nullable a -> Expression 'Nullable a +nullable = coerce + +class Castable a where + -- | Safe cast. This uses the SQL CAST function to convert safely + -- from one type to another. + cast :: Expression nullable b + -> Expression nullable a + +castTo :: H.QueryBuilder + -> Expression nullable b + -> Expression nullable a +castTo tp (Expression e) = Expression $ do + x <- e + pure $ H.fun "cast" [x `H.as` tp] + +instance Castable StrictBS.ByteString where + cast = castTo "BINARY" + +instance Castable Text where + cast = castTo "CHAR UNICODE" + +instance Castable Day where + cast = castTo "DATE" + +instance Castable LocalTime where + cast = castTo "DATETIME" + +instance Castable Scientific where + cast = castTo "DECIMAL" + +instance Castable Double where + cast = castTo "FLOAT[53]" + +instance Castable Int where + cast = castTo "SIGNED" + +instance Castable Int8 where + cast = castTo "SIGNED" + +instance Castable Int16 where + cast = castTo "SIGNED" + +instance Castable Int32 where + cast = castTo "SIGNED" + +instance Castable Int64 where + cast = castTo "SIGNED" + +instance Castable TimeOfDay where + cast = castTo "TIME" + +instance Castable DiffTime where + cast = castTo "TIME" + +instance Castable Word where + cast = castTo "UNSIGNED" + +instance Castable Word8 where + cast = castTo "UNSIGNED" + +instance Castable Word16 where + cast = castTo "UNSIGNED" + +instance Castable Word32 where + cast = castTo "UNSIGNED" + +instance Castable Word64 where + cast = castTo "UNSIGNED" + +-- | Cast the return type of an expression to any other type, without +-- changing the query. Since this library adds static typing on top of +-- SQL, you may sometimes want to use this to get back the lenient +-- behaviour of SQL. This opens up more possibilies for runtime +-- errors, so it's up to the programmer to ensure type correctness. +unsafeCast :: Expression nullable a -> Expression nullable b +unsafeCast = coerce + +fieldText :: Field table database nullable a -> Text +fieldText (Field table fieldName) = table <> "." <> fieldName + +insertOne :: Insertable fieldNull fieldType a + => Field table database fieldNull fieldType + -> Insertor table database a +insertOne = Insertor . H.insertOne. fieldText + +genFst :: (a :*: b) () -> a () +genFst (a :*: _) = a + +genSnd :: (a :*: b) () -> b () +genSnd (_ :*: b) = b + +class InsertGeneric table database (fields :: *) (data_ :: *) where + insertDataGeneric :: fields -> Insertor table database data_ + +instance (InsertGeneric tbl db (a ()) (c ()), + InsertGeneric tbl db (b ()) (d ())) => + InsertGeneric tbl db ((a :*: b) ()) ((c :*: d) ()) where + insertDataGeneric (a :*: b) = + contramap genFst (insertDataGeneric a) <> + contramap genSnd (insertDataGeneric b) + +instance InsertGeneric tbl db (a ()) (b ()) => + InsertGeneric tbl db (M1 m1 m2 a ()) (M1 m3 m4 b ()) where + insertDataGeneric = contramap unM1 . insertDataGeneric . unM1 + +instance Insertable fieldNull a b => + InsertGeneric tbl db (K1 r (Field tbl db fieldNull a) ()) (K1 r b ()) where + insertDataGeneric = contramap unK1 . insertOne . unK1 + +instance InsertGeneric tbl db (K1 r (Insertor tbl db a) ()) (K1 r a ()) where + insertDataGeneric = contramap unK1 . unK1 + +insertData :: (Generic a, Generic b, InsertGeneric tbl db (Rep a ()) (Rep b ())) + => a -> Insertor tbl db b +insertData = contramap from' . insertDataGeneric . from' + where from' :: Generic a => a -> Rep a () + from' = Generics.from + +skipInsert :: Insertor tbl db a +skipInsert = mempty + +{- +personInsertor :: Insertor table database Person +personInsertor = insertData (name, age) +-} + +into :: Insertable fieldNull fieldType b + => (a -> b) + -> Field table database fieldNull fieldType + -> Insertor table database a +into f = Insertor . H.into f . fieldText + +lensInto :: Insertable fieldNull fieldType b + => H.Getter a b + -> Field table database fieldNull fieldType + -> Insertor table database a +lensInto lens a = Insertor $ H.lensInto lens $ fieldText a + +insertValues :: Table table database + -> Insertor table database a + -> [a] + -> H.Command +insertValues (Table _schema tableName) (Insertor i) = + H.insertValues (H.rawSql tableName) i + +newAlias :: Text -> QueryInner Text +newAlias prefix = do + clsState <- get + let newIndex = Map.findWithDefault 0 prefix (aliases clsState) + 1 + put $ clsState { aliases = Map.insert prefix newIndex $ aliases clsState} + pure $ prefix <> Text.pack (show newIndex) + +addClauses :: H.QueryClauses -> QueryInner () +addClauses c = modify $ \clsState -> + clsState { clausesBuild = clausesBuild clsState <> c } + +from :: Table table database + -> Query database (Tbl table database 'InnerJoined) +from (Table schema tableName) = Query $ + do alias <- newAlias (Text.take 1 tableName) + addClauses $ H.from $ + H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as` H.rawSql alias + pure $ mkTableAlias alias + +innerJoin :: Table table database + -> (Tbl table database 'InnerJoined -> + Expression nullable Bool) + -> Query database (Tbl table database 'InnerJoined) +innerJoin (Table schema tableName) joinCondition = Query $ do + alias <- newAlias (Text.take 1 tableName) + let tblAlias = mkTableAlias alias + exprBuilder <- runExpression $ joinCondition tblAlias + addClauses $ + H.innerJoin [H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as` + H.rawSql alias] + [exprBuilder] + pure tblAlias + +leftJoin :: Table table database + -> (Tbl table database 'LeftJoined -> + Expression nullable Bool) + -> Query database (Tbl table database 'LeftJoined) +leftJoin (Table schema tableName) joinCondition = Query $ do + alias <- newAlias (Text.take 1 tableName) + let tblAlias = mkTableAlias alias + exprBuilder <- runExpression $ joinCondition tblAlias + addClauses $ + H.leftJoin [H.rawSql (maybe mempty (<> ".") schema <> tableName) `H.as` + H.rawSql alias] + [exprBuilder] + pure tblAlias + + +class SubQueryExpr (joinType :: JoinType) inExpr outExpr where + -- The ReaderT monad takes the alias of the subquery table. + -- The State monad uses the index of the last expression in the select clause. + -- It generates SELECT clause expressions with aliases e1, e2, ... + -- The outExpr contains just the output aliases. + -- input and output should be product types, and have the same number of + -- elements. + subJoinGeneric :: Proxy joinType + -> inExpr + -> ReaderT Text (State Int) + (DList.DList SomeExpression, outExpr) + +instance ( SubQueryExpr joinType (a ()) (c ()) + , SubQueryExpr joinType (b ()) (d ())) => + SubQueryExpr joinType ((a :*: b) ()) ((c :*: d) ()) where + subJoinGeneric p (l :*: r) = do + (lftBuilder, outLft) <- subJoinGeneric p l + (rtBuilder, outRt) <- subJoinGeneric p r + pure (lftBuilder <> rtBuilder, outLft :*: outRt) + +instance SubQueryExpr joinType (a ()) (b ()) => + SubQueryExpr joinType (M1 m1 m2 a ()) (M1 m3 m4 b ()) where + subJoinGeneric p (M1 x) = fmap M1 <$> subJoinGeneric p x + +instance JoinNullable joinType nullable ~ nullable2 => + SubQueryExpr + joinType + (K1 r (Expression nullable a) ()) + (K1 r (Expression nullable2 b) ()) + where + subJoinGeneric _ (K1 (Expression exprBuilder)) = + ReaderT $ \alias -> state $ \i -> + let name = Text.pack ('e': show i) + in ( ( DList.singleton $ SomeExpression $ + (`H.as` H.rawSql name) <$> exprBuilder + , K1 $ Expression $ pure $ H.rawSql $ alias <> "." <> name) + , i+1 + ) + +-- update the aliases, but create and return new query clauses +runAsSubQuery :: Query database a -> QueryInner (H.QueryClauses, a) +runAsSubQuery (Query sq) = + do ClauseState currentClauses currentAliases <- get + let (subQueryRet, ClauseState subQueryBody newAliases) = + runState sq (ClauseState mempty currentAliases) + put $ ClauseState currentClauses newAliases + pure (subQueryBody, subQueryRet) + +subQueryExpr :: Query database (Expression nullable a) -> Expression nullable a +subQueryExpr sq = Expression $ + do (subQueryBody, Expression subQuerySelect) <- runAsSubQuery sq + selectBuilder <- subQuerySelect + pure $ H.subQuery $ H.select (H.values_ [selectBuilder]) subQueryBody + +-- +subJoinBody :: (Generic inExprs, + Generic outExprs, + SubQueryExpr joinType (Rep inExprs ()) (Rep outExprs ())) + => Proxy joinType + -> Query database inExprs + -> QueryInner (H.QueryBuilder, outExprs) +subJoinBody p sq = do + sqAlias <- newAlias "sq" + (subQueryBody, sqExprs) <- runAsSubQuery sq + let from' :: Generic inExprs => inExprs -> Rep inExprs () + from' = Generics.from + to' :: Generic outExpr => Rep outExpr () -> outExpr + to' = Generics.to + (selectExprs, outExprRep) = flip evalState 1 $ + flip runReaderT sqAlias $ + subJoinGeneric p $ + from' sqExprs + outExpr = to' outExprRep + selectBuilder <- DList.toList <$> traverse runSomeExpression selectExprs + pure ( H.subQuery $ H.select (H.values_ selectBuilder) subQueryBody + , outExpr) + +joinSubQuery :: (Generic inExprs, + Generic outExprs, + SubQueryExpr 'InnerJoined (Rep inExprs ()) (Rep outExprs ())) + => Query database inExprs + -> (outExprs -> Expression nullable Bool) + -> Query database outExprs +joinSubQuery sq condition = Query $ do + (subQueryBody, outExpr) <- subJoinBody (Proxy :: Proxy 'InnerJoined) sq + conditionBuilder <- runExpression $ condition outExpr + addClauses $ H.innerJoin [subQueryBody] [conditionBuilder] + pure outExpr + +leftJoinSubQuery :: (Generic inExprs, + Generic outExprs, + SubQueryExpr 'LeftJoined (Rep inExprs ()) (Rep outExprs ())) + => Query database inExprs + -> (outExprs -> Expression nullable Bool) + -> Query database outExprs +leftJoinSubQuery sq condition = Query $ do + (subQueryBody, outExpr) <- subJoinBody (Proxy :: Proxy 'LeftJoined) sq + conditionBuilder <- runExpression $ condition outExpr + addClauses $ H.leftJoin [subQueryBody] [conditionBuilder] + pure outExpr + +fromSubQuery :: (Generic inExprs, + Generic outExprs, + SubQueryExpr 'LeftJoined (Rep inExprs ()) (Rep outExprs ())) + => Query database inExprs + -> Query database outExprs +fromSubQuery sq = Query $ do + (subQueryBody, outExpr) <- subJoinBody (Proxy :: Proxy 'LeftJoined) sq + addClauses $ H.from subQueryBody + pure outExpr + +where_ :: Expression nullable Bool -> Query database () +where_ expr = Query $ do + exprBuilder <- runExpression expr + addClauses $ H.where_ [exprBuilder] + +groupBy_ :: [SomeExpression] -> Query database () +groupBy_ columns = Query $ do + columnBuilders <- traverse runSomeExpression columns + addClauses $ H.groupBy_ columnBuilders + +having :: Expression nullable Bool -> Query database () +having expr = Query $ do + exprBuilder <- runExpression expr + addClauses $ H.having [exprBuilder] + +orderBy :: [QueryOrdering] -> Query database () +orderBy ordering = Query $ + do newOrdering <- traverse orderingToH ordering + addClauses $ H.orderBy newOrdering + where orderingToH (Asc x) = H.Asc <$> runSomeExpression x + orderingToH (Desc x) = H.Desc <$> runSomeExpression x + +limit :: Int -> Query database () +limit count = Query $ addClauses $ H.limit count + +limitOffset :: Int -> Int -> Query database () +limitOffset count offset = Query $ addClauses $ H.limitOffset count offset + +newtype Into database (table :: Symbol) = + Into { runInto :: QueryInner (Text, H.QueryBuilder) } + +exprInto :: CheckExprNullable exprNullable fieldNullable + => Expression exprNullable a -> + Field table database fieldNullable a -> + Into database table +exprInto expr (Field _ fieldName) = + Into $ (fieldName,) <$> runExpression expr + +insertSelect :: Table table database + -> Query database [Into database table] + -> H.Command +insertSelect (Table schema tbl) (Query query) = + H.insertSelect (H.rawSql (maybe mempty (<> ".") schema <> tbl)) + (map (H.rawSql . fst) intos) + (map snd intos) clauses + where (intos, ClauseState clauses _) = + runState (query >>= traverse runInto) emptyClauseState + diff --git a/src/Database/MySQL/Hasqlator/Typed/Schema.hs b/src/Database/MySQL/Hasqlator/Typed/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/MySQL/Hasqlator/Typed/Schema.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +module Database.MySQL.Hasqlator.Typed.Schema + (TableInfo(..), ColumnInfo(..), fetchTableInfo, Sign(..), ColumnType(..), + pprTableInfo, Properties(..), defaultProperties, makeDBTypes) where +import Database.MySQL.Hasqlator +import qualified Database.MySQL.Hasqlator.Typed as T +import Database.MySQL.Base(MySQLConn) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import Text.Megaparsec +import qualified Data.Map as Map +import qualified Data.Set as Set +import Text.Megaparsec.Char +import Data.Text (Text) +import Control.Applicative (liftA2) +import Language.Haskell.TH +import Data.Word +import Data.Int +import Data.Scientific +import Data.Time +import Control.Monad +import qualified Data.ByteString as StrictBS +import Data.Aeson(Value) +import Data.Char +import Data.List +import GHC.TypeLits(Symbol) +import Text.Pretty.Simple + +data Sign = Signed | Unsigned + deriving Show + +data ColumnType = + TinyIntColumn Sign | + SmallIntColumn Sign | + MediumIntColumn Sign | + IntColumn Sign | + BigIntColumn Sign | + DecimalColumn Int Int Sign | + VarCharColumn Int | + CharColumn Int | + TextColumn | + BlobColumn | + DateTimeColumn Int | + TimestampColumn Int | + DateColumn | + TimeColumn Int | + DoubleColumn | + FloatColumn | + EnumColumn [Text] | + SetColumn [Text] | + BinaryColumn Int | + VarBinaryColumn Int | + BitColumn Int | + JsonColumn + deriving (Show) + +data ColumnInfo = ColumnInfo + { columnTableSchema :: Text + , columnTableName :: Text + , columnName :: Text + , columnType :: ColumnType + , columnNullable :: Bool + , primaryKey :: Bool + , autoIncrement :: Bool + , foreignKey :: Maybe (Text, Text, Text) + } deriving (Show) + +data TableInfo = TableInfo + { tableName :: Text + , tableSchema :: Text + , tableColumns :: [ColumnInfo] + } deriving (Show) + +argsP :: Parsec () Text a -> Parsec () Text [a] +argsP p = between (single '(') (single ')') $ sepBy p (single ',') + +arg1P :: Parsec () Text a -> Parsec () Text a +arg1P = between (single '(') (single ')') + +arg2P :: Parsec () Text a -> Parsec () Text (a, a) +arg2P p = between (single '(') (single ')') $ liftA2 (,) p (single ',' >> p) + +stringP :: Parsec () Text Text +stringP = fmap Text.pack $ between (single '\'') (single '\'') $ many $ + noneOf ['\'', '\\'] <|> (single '\\' >> anySingle) + +intP :: Parsec () Text Int +intP = read <$> many digitChar + +signP :: Parsec () Text Sign +signP = option Signed $ Unsigned <$ string "unsigned" + +parseType :: Text -> ColumnType +parseType t = case runParser typeParser "COLUMN_TYPE" t of + Left err -> error $ show err + Right res -> res + +typeParser :: Parsec () Text ColumnType +typeParser = do + typename <- many letterChar + case typename of + -- ignore the "display width" argument + "tinyint" -> fmap TinyIntColumn $ optional (argsP intP) *> space *> signP + "smallint" -> fmap SmallIntColumn $ optional (argsP intP) *> space *> signP + "mediumint" -> fmap MediumIntColumn $ optional (argsP intP) *> space *> signP + "int" -> fmap IntColumn $ optional (argsP intP) *> space *> signP + "bigint" -> fmap BigIntColumn $ optional (argsP intP) *> space *> signP + "decimal" -> do (m, d) <- arg2P intP + space + sign <- signP + pure $ DecimalColumn m d sign + "varchar" -> VarCharColumn <$> arg1P intP + "char" -> CharColumn <$> arg1P intP + "tinytext" -> pure TextColumn + "text" -> pure TextColumn + "mediumtext" -> pure TextColumn + "longtext" -> pure TextColumn + "tinyblob" -> pure BlobColumn + "blob" -> pure BlobColumn + "mediumblob" -> pure BlobColumn + "longblob" -> pure BlobColumn + "datetime" -> fmap DateTimeColumn $ option 0 $ arg1P intP + "date" -> pure DateColumn + "time" -> fmap TimeColumn $ option 0 $ arg1P intP + "timestamp" -> fmap TimestampColumn $ option 0 $ arg1P intP + "float" -> pure FloatColumn + "double" -> pure DoubleColumn + "enum" -> EnumColumn <$> argsP stringP + "set" -> SetColumn <$> argsP stringP + "binary" -> VarBinaryColumn <$> arg1P intP + "varbinary" -> VarBinaryColumn <$> arg1P intP + "json" -> pure JsonColumn + "bit" -> BitColumn <$> arg1P intP + x -> fail $ "Don't know how to parse COLUMN_TYPE " <> show x + +tableQuery :: [Text] -> Query TableInfo +tableQuery schemas = + select tableSelector $ + from "information_schema.TABLES" <> + where_ ["TABLE_SCHEMA" `in_` map arg schemas] + where tableSelector = do + tableName_ <- textSel "TABLE_NAME" + tableSchema_ <- textSel "TABLE_SCHEMA" + pure $ TableInfo{ tableName = tableName_ + , tableSchema = tableSchema_ + , tableColumns = []} + +columnsQuery :: [Text] -> Query ColumnInfo +columnsQuery schemas = + select columnSelector $ + from ("information_schema.COLUMNS" `as` "c") + <> leftJoin ["information_schema.KEY_COLUMN_USAGE" `as` "k"] + [ "k.TABLE_SCHEMA" =. "c.TABLE_SCHEMA" + , "k.TABLE_NAME" =. "c.TABLE_NAME" + , "k.COLUMN_NAME" =. "c.COLUMN_NAME" + , "k.REFERENCED_COLUMN_NAME IS NOT NULL" + ] + <> where_ ["c.TABLE_SCHEMA" `in_` map arg schemas] + where columnSelector = do + tableName_ <- textSel "c.TABLE_NAME" + tableSchema_ <- textSel "c.TABLE_SCHEMA" + columnName_ <- textSel "c.COLUMN_NAME" + nullable <- textSel "c.IS_NULLABLE" + columnType_ <- textSel "c.COLUMN_TYPE" + columnKey <- textSel "c.COLUMN_KEY" + extra <- textSel "c.EXTRA" + referencedTableSchema <- + sel "k.REFERENCED_TABLE_SCHEMA" :: Selector (Maybe Text) + referencedTableName <- + sel "k.REFERENCED_TABLE_NAME" :: Selector (Maybe Text) + referencedColumnName <- + sel "k.REFERENCED_COLUMN_NAME" :: Selector (Maybe Text) + pure $ ColumnInfo + { columnTableSchema = tableSchema_ + , columnTableName = tableName_ + , columnType = parseType columnType_ + , columnName = columnName_ + , columnNullable = nullable == "YES" + , primaryKey = columnKey == "PRI" + , autoIncrement = "auto_increment" `Text.isInfixOf` extra + , foreignKey = (,,) + <$> referencedTableSchema + <*> referencedTableName + <*> referencedColumnName + } + +-- | Fetch TableInfo structures for each of the given schemas, using +-- the given `MySQLConn` connection. +fetchTableInfo :: MySQLConn -> [Text] -> IO [TableInfo] +fetchTableInfo conn schemas = do + tables <- executeQuery conn $ tableQuery schemas + columns <- executeQuery conn $ columnsQuery schemas + let columnMap = Map.fromListWith (++) $ + map (\ci -> ( (columnTableSchema ci, columnTableName ci) + , [ci])) + columns + pure $ + map (\tbl@TableInfo{tableName, tableSchema} -> + tbl {tableColumns = Map.findWithDefault [] (tableSchema, tableName) + columnMap} ) + tables + +pprTableInfo :: LazyText.Text -> [TableInfo] -> LazyText.Text +pprTableInfo name ti = + LazyText.unlines $ ((name <> " = ") : ) $ + map (" " <>) $ LazyText.lines $ pShowNoColor ti + +columnTHType :: ColumnInfo -> Q Type +columnTHType ColumnInfo{ columnType, columnNullable} + | columnNullable = [t| Maybe $(tp) |] + | otherwise = tp + where tp = case columnType of + TinyIntColumn _ -> [t| Int |] + SmallIntColumn _ -> [t| Int |] + MediumIntColumn _ -> [t| Int |] + IntColumn _ -> [t| Int |] + BigIntColumn Signed -> [t| Int64 |] + BigIntColumn Unsigned -> [t| Word64 |] + DecimalColumn{} -> [t| Scientific |] + VarCharColumn _ -> [t| Text |] + CharColumn _ -> [t| Text |] + TextColumn -> [t| Text |] + DateTimeColumn _ -> [t| LocalTime |] + TimestampColumn _ -> [t| LocalTime |] + DateColumn -> [t| Day |] + TimeColumn _ -> [t| TimeOfDay |] + DoubleColumn -> [t| Double |] + FloatColumn -> [t| Float |] + EnumColumn _ -> [t| Text |] + SetColumn _ -> [t| Text |] + BinaryColumn _ -> [t| StrictBS.ByteString |] + VarBinaryColumn _ -> [t| StrictBS.ByteString |] + BlobColumn -> [t| StrictBS.ByteString |] + BitColumn _ -> [t| Word64 |] + JsonColumn -> [t| Value |] + +data Properties = Properties + { fieldNameModifier :: String -> String + , tableNameModifier :: String -> String + , classNameModifier :: String -> String + , includeInsertor :: Bool + , insertorTypeModifier :: String -> String + , insertorNameModifier :: String -> String + , insertorFieldModifier :: String -> String + } + + +downcase :: String -> String +downcase (c:cs) + | isAlpha c = let (l, r) = span isUpper (c:cs) + in map toLower l ++ r + | otherwise = '_' : c : cs +downcase "" = "" + +upcase :: String -> String +upcase (c:cs) + | isAlpha c = toUpper c : cs + | otherwise = '_' : c : cs +upcase "" = "" + +removeUnderscore :: String -> String +removeUnderscore ('_':c:cs) + | isAlpha c = toUpper c : removeUnderscore cs +removeUnderscore (c:cs) = c:removeUnderscore cs +removeUnderscore [] = [] + +defaultProperties :: Properties +defaultProperties = Properties + { fieldNameModifier = \n -> + downcase n <> (if downcase n `elem` reserved then "_" else mempty) + , tableNameModifier = \n -> + downcase n <> (if downcase n `elem` reserved then "_" else mempty) <> "_tbl" + , classNameModifier = \n -> "Has_" <> n <> "_Field" + , includeInsertor = True + , insertorTypeModifier = \n -> removeUnderscore (upcase n) <> "Fields" + , insertorNameModifier = \n -> + downcase (removeUnderscore n) <> "Insertor" + , insertorFieldModifier = \n -> downcase n <> "_field" + } + where reserved :: [String] + reserved = ["id", "class", "data", "type", "foreign", "import", + "default", "case"] + +makeField :: Properties -> Name -> ColumnInfo -> Q [Dec] +makeField props dbName ci@ColumnInfo{columnTableName, + columnName, + columnNullable} = + sequence [ sigD + (mkName $ fieldNameModifier props fieldName) + [t| T.Field + $(litT $ strTyLit tableName) + $(conT dbName) + $(if columnNullable + then promotedT 'T.Nullable + else promotedT 'T.NotNull) + $(columnTHType ci) + |] + , valD (varP $ mkName $ fieldNameModifier props fieldName) + (normalB [e| T.Field + $(litE $ stringL tableName) + $(litE $ stringL fieldName) + |]) + [] + ] + where fieldName = Text.unpack columnName + tableName = Text.unpack columnTableName + +makeTable :: Properties -> Name -> TableInfo -> Q [Dec] +makeTable props dbname TableInfo{tableName} = + sequence [ sigD + (mkName $ tableNameModifier props tableString) + [t| T.Table + $(litT $ strTyLit tableString) + $(conT dbname) + |] + , valD (varP $ mkName $ tableNameModifier props tableString) + (normalB [e| T.Table + $(conE 'Nothing) + $(litE $ stringL tableString) + |]) + [] + ] + where tableString = Text.unpack tableName + +fieldClass :: Properties -> Name -> String -> Q Dec +fieldClass props dbName columnName = + classD (pure []) (mkName $ classNameModifier props columnName) + [ kindedTV (mkName "table") (ConT ''Symbol) + , kindedTV (mkName "nullable") (ConT ''T.Nullable) + , plainTV $ mkName "a"] + [FunDep [mkName "table"] [mkName "nullable", mkName "a"]] + [ sigD + (mkName columnName) + [t| T.Field + $(varT $ mkName "table") + $(conT dbName) + $(varT $ mkName "nullable") + $(varT $ mkName "a") + |]] + +fieldInstance :: Properties -> ColumnInfo -> Q Dec +fieldInstance props ci@ColumnInfo{columnName, + columnNullable, + columnTableName} = + instanceD (pure []) + [t| $(conT $ mkName $ classNameModifier props $ fieldNameModifier props $ + Text.unpack columnName) + $(litT $ strTyLit $ Text.unpack columnTableName) + $(promotedT $ if columnNullable then 'T.Nullable else 'T.NotNull) + $(columnTHType ci) + |] + [valD (varP $ mkName $ fieldNameModifier props fieldName) + (normalB [e| T.Field + $(litE $ stringL tableName) + $(litE $ stringL fieldName) + |]) + []] + where fieldName = Text.unpack columnName + tableName = Text.unpack columnTableName + + +insertorType :: Properties -> TableInfo -> Q Dec +insertorType props ti = + dataD (pure []) + (mkName typeName) + [] + Nothing + [recC (mkName typeName) $ map columnTypes (tableColumns ti) ] + [] + where typeName = insertorTypeModifier props (Text.unpack $ tableName ti) + columnTypes ci = + ( (mkName $ insertorFieldModifier props $ Text.unpack $ columnName ci) + , Bang NoSourceUnpackedness NoSourceStrictness + , + ) <$> columnTHType ci + + +insertor :: Properties -> Name -> TableInfo -> Q [Dec] +insertor props dbName ti = + sequence [ sigD + insertorName + [t| T.Insertor + $(litT $ strTyLit $ Text.unpack $ tableName ti) + $(conT dbName) + $(conT insertorTypeName) + |] + , valD (varP insertorName) + (normalB $ foldr1 (\x y -> [| $(x) <> $(y) |]) $ + map insertorField $ tableColumns ti) + [] + ] + where + insertorName = mkName $ insertorNameModifier props $ Text.unpack $ + tableName ti + insertorTypeName = mkName $ insertorTypeModifier props $ Text.unpack $ + tableName ti + insertorField :: ColumnInfo -> Q Exp + insertorField ci = [e| $(sigE + (varE $ mkName $ insertorFieldModifier props $ + Text.unpack $ columnName ci) + [t| $(conT insertorTypeName) -> $(columnTHType ci) |]) + `T.into` + $(varE $ mkName $ fieldNameModifier props $ + Text.unpack $ columnName ci) |] + + +makeDBTypes :: Properties -> Name -> [TableInfo] -> Q [Dec] +makeDBTypes props dbName tis = + liftA2 (++) classDecs $ concat <$> traverse tableDecs tis + where + classDecs :: Q [Dec] + classDecs = traverse (fieldClass props dbName) $ Set.toList duplicateCols + + tableDecs :: TableInfo -> Q [Dec] + tableDecs ti = concat <$> sequence + [ makeTable props dbName ti + , fmap concat $ traverse (makeField props dbName) $ + filter (not . duplicateCol . getFieldName) $ tableColumns ti + , traverse (fieldInstance props) $ filter (duplicateCol . getFieldName) $ + tableColumns ti + , if includeInsertor props + then (:) <$> insertorType props ti <*> insertor props dbName ti + else pure mempty + ] + + getFieldName :: ColumnInfo -> String + getFieldName ti = fieldNameModifier props $ Text.unpack $ columnName ti + + duplicateCols :: Set.Set String + duplicateCols = Set.fromList $ map fst $ filter ((> 1) . snd) $ Map.toList $ + Map.fromListWith (+) $ + map (\c -> (getFieldName c, 1 :: Int)) $ + tis >>= tableColumns + duplicateCol :: String -> Bool + duplicateCol c = c `Set.member` duplicateCols