beam-mysql (empty) → 0.2.0.0
raw patch · 6 files changed
+1279/−0 lines, 6 filesdep +aesondep +attoparsecdep +base
Dependencies added: aeson, attoparsec, base, beam-core, bytestring, case-insensitive, free, hashable, mtl, mysql, network-uri, scientific, text, time
Files
- Database/Beam/MySQL.hs +6/−0
- Database/Beam/MySQL/Connection.hs +325/−0
- Database/Beam/MySQL/FromField.hs +297/−0
- Database/Beam/MySQL/Syntax.hs +589/−0
- LICENSE +8/−0
- beam-mysql.cabal +54/−0
+ Database/Beam/MySQL.hs view
@@ -0,0 +1,6 @@+module Database.Beam.MySQL+ ( module Database.Beam.MySQL.Connection+ , module Database.Beam.MySQL.Syntax ) where++import Database.Beam.MySQL.Connection+import Database.Beam.MySQL.Syntax
+ Database/Beam/MySQL/Connection.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}++module Database.Beam.MySQL.Connection+ ( MySQL(..), MySQL.Connection+ , MySQLM(..)++ , runBeamMySQL, runBeamMySQLDebug++ , MysqlCommandSyntax(..)+ , MysqlSelectSyntax(..), MysqlInsertSyntax(..)+ , MysqlUpdateSyntax(..), MysqlDeleteSyntax(..)+ , MysqlExpressionSyntax(..)++ , MySQL.connect, MySQL.close++ , mysqlUriSyntax ) where++import Database.Beam.MySQL.Syntax+import Database.Beam.MySQL.FromField++import Database.Beam.Backend+import Database.Beam.Backend.URI+import Database.Beam.Query+import Database.Beam.Query.SQL92++import Database.MySQL.Base as MySQL+import qualified Database.MySQL.Base.Types as MySQL++import Control.Exception+import Control.Monad.Except+import Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail as Fail+import Control.Monad.Free.Church+import Control.Monad.Reader++import qualified Data.Aeson as A (Value)+import Data.ByteString.Builder+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BL+import Data.Int+import Data.List+import Data.Maybe+import Data.Ratio+import Data.Scientific+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay)+import Data.Word++import Network.URI++import Text.Read hiding (step)++data MySQL = MySQL++instance BeamSqlBackendIsString MySQL String+instance BeamSqlBackendIsString MySQL T.Text++instance BeamBackend MySQL where+ type BackendFromField MySQL = FromField++instance BeamSqlBackend MySQL+type instance BeamSqlBackendSyntax MySQL = MysqlCommandSyntax++newtype MySQLM a = MySQLM (ReaderT (String -> IO (), Connection) IO a)+ deriving (Monad, MonadIO, Applicative, Functor)++instance MonadFail MySQLM where+ fail e = fail $ "Internal Error with: " <> show e++data NotEnoughColumns+ = NotEnoughColumns+ { _errColCount :: Int+ } deriving Show++instance Exception NotEnoughColumns where+ displayException (NotEnoughColumns colCnt) =+ mconcat [ "Not enough columns while reading MySQL row. Only have "+ , show colCnt, " column(s)" ]++data CouldNotReadColumn+ = CouldNotReadColumn+ { _errColIndex :: Int+ , _errColMsg :: String }+ deriving Show++instance Exception CouldNotReadColumn where+ displayException (CouldNotReadColumn idx msg) =+ mconcat [ "Could not read column ", show idx, ": ", msg ]++runBeamMySQLDebug :: (String -> IO ()) -> Connection -> MySQLM a -> IO a+runBeamMySQLDebug = withMySQL++runBeamMySQL :: Connection -> MySQLM a -> IO a+runBeamMySQL = runBeamMySQLDebug (\_ -> pure ())++instance MonadBeam MySQL MySQLM where+ runReturningMany (MysqlCommandSyntax (MysqlSyntax cmd))+ (consume :: MySQLM (Maybe x) -> MySQLM a) =+ MySQLM . ReaderT $ \(dbg, conn) -> do+ cmdBuilder <- cmd (\_ b _ -> pure b) (MySQL.escape conn) mempty conn+ let cmdStr = BL.toStrict (toLazyByteString cmdBuilder)++ dbg (T.unpack (TE.decodeUtf8 cmdStr))++ MySQL.query conn cmdStr++ bracket (useResult conn) freeResult $ \res -> do+ fieldDescs <- MySQL.fetchFields res++ let fetchRow' :: MySQLM (Maybe x)+ fetchRow' =+ MySQLM . ReaderT $ \_ -> do+ fields <- MySQL.fetchRow res++ case fields of+ [] -> pure Nothing+ _ -> do+ let FromBackendRowM go = fromBackendRow+ rowRes <- runF go (\x _ _ -> pure (Right x)) step+ 0 (zip fieldDescs fields)+ case rowRes of+ Left err -> throwIO err+ Right x -> pure (Just x)++ parseField :: forall field. FromField field+ => MySQL.Field -> Maybe BS.ByteString+ -> IO (Either ColumnParseError field)+ parseField ty d = runExceptT (fromField ty d)++ step :: forall y+ . FromBackendRowF MySQL (Int -> [(MySQL.Field, Maybe BS.ByteString)] -> IO (Either BeamRowReadError y))+ -> Int -> [(MySQL.Field, Maybe BS.ByteString)] -> IO (Either BeamRowReadError y)+ step (ParseOneField _) curCol [] =+ pure (Left (BeamRowReadError (Just curCol) (ColumnNotEnoughColumns curCol)))+ step (ParseOneField next) curCol ((desc, field):fields) =+ do d <- parseField desc field+ case d of+ Left e -> pure (Left (BeamRowReadError (Just curCol) e))+ Right d' -> next d' (curCol + 1) fields++ step (Alt (FromBackendRowM a) (FromBackendRowM b) next) curCol cols =+ do aRes <- runF a (\x curCol' cols' -> pure (Right (next x curCol' cols'))) step curCol cols+ case aRes of+ Right next' -> next'+ Left aErr -> do+ bRes <- runF b (\x curCol' cols' -> pure (Right (next x curCol' cols'))) step curCol cols+ case bRes of+ Right next' -> next'+ Left _ -> pure (Left aErr)++ step (FailParseWith err) _ _ = pure (Left err)++ MySQLM doConsume = consume fetchRow'++ runReaderT doConsume (dbg, conn)++withMySQL :: (String -> IO ()) -> Connection+ -> MySQLM a -> IO a+withMySQL dbg conn (MySQLM a) =+ runReaderT a (dbg, conn)++mysqlUriSyntax :: c MySQL Connection MySQLM+ -> BeamURIOpeners c+mysqlUriSyntax =+ mkUriOpener (withMySQL (const (pure ()))) "mysql:"+ (\uri ->+ let stripSuffix s a =+ reverse <$> stripPrefix (reverse s) (reverse a)++ (user, pw) =+ fromMaybe ("root", "") $ do+ userInfo <- fmap uriUserInfo (uriAuthority uri)+ userInfo' <- stripSuffix "@" userInfo+ let (user', pw') = break (== ':') userInfo'+ pw'' = fromMaybe "" (stripPrefix ":" pw')+ pure (user', pw'')+ host =+ fromMaybe "localhost" .+ fmap uriRegName . uriAuthority $ uri+ port =+ fromMaybe 3306 $ do+ portStr <- fmap uriPort (uriAuthority uri)+ portStr' <- stripPrefix ":" portStr+ readMaybe portStr'++ db = fromMaybe "test" $+ stripPrefix "/" (uriPath uri)++ options =+ fromMaybe [CharsetName "utf-8"] $ do+ opts <- stripPrefix "?" (uriQuery uri)+ let getKeyValuePairs "" a = a []+ getKeyValuePairs d a =+ let (keyValue, d') = break (=='&') d+ attr = parseKeyValue keyValue+ in getKeyValuePairs d' (a . maybe id (:) attr)++ pure (getKeyValuePairs opts id)++ parseBool (Just "true") = pure True+ parseBool (Just "false") = pure False+ parseBool _ = Nothing++ parseKeyValue kv = do+ let (key, value) = break (==':') kv+ value' = stripPrefix ":" value++ case (key, value') of+ ("connectTimeout", Just secs) ->+ ConnectTimeout <$> readMaybe secs+ ( "compress", _) -> pure Compress+ ( "namedPipe", _ ) -> pure NamedPipe+ ( "initCommand", Just cmd ) ->+ pure (InitCommand (BS.pack cmd))+ ( "readDefaultFile", Just fp ) ->+ pure (ReadDefaultFile fp)+ ( "readDefaultGroup", Just grp ) ->+ pure (ReadDefaultGroup (BS.pack grp))+ ( "charsetDir", Just fp ) ->+ pure (CharsetDir fp)+ ( "charsetName", Just nm ) ->+ pure (CharsetName nm)+ ( "localInFile", b ) ->+ LocalInFile <$> parseBool b+ ( "protocol", Just p) ->+ case p of+ "tcp" -> pure (Protocol TCP)+ "socket" -> pure (Protocol Socket)+ "pipe" -> pure (Protocol Pipe)+ "memory" -> pure (Protocol Memory)+ _ -> Nothing+ ( "sharedMemoryBaseName", Just fp ) ->+ pure (SharedMemoryBaseName (BS.pack fp))+ ( "readTimeout", Just secs ) ->+ ReadTimeout <$> readMaybe secs+ ( "writeTimeout", Just secs ) ->+ WriteTimeout <$> readMaybe secs+ ( "useRemoteConnection", _ ) -> pure UseRemoteConnection+ ( "useEmbeddedConnection", _ ) -> pure UseEmbeddedConnection+ ( "guessConnection", _ ) -> pure GuessConnection+ ( "clientIp", Just fp) ->+ pure (ClientIP (BS.pack fp))+ ( "secureAuth", b ) ->+ SecureAuth <$> parseBool b+ ( "reportDataTruncation", b ) ->+ ReportDataTruncation <$> parseBool b+ ( "reconnect", b ) ->+ Reconnect <$> parseBool b+ ( "sslVerifyServerCert", b) ->+ SSLVerifyServerCert <$> parseBool b+ ( "foundRows", _ ) -> pure FoundRows+ ( "ignoreSIGPIPE", _ ) -> pure IgnoreSIGPIPE+ ( "ignoreSpace", _ ) -> pure IgnoreSpace+ ( "interactive", _ ) -> pure Interactive+ ( "localFiles", _ ) -> pure LocalFiles+ ( "multiResults", _ ) -> pure MultiResults+ ( "multiStatements", _ ) -> pure MultiStatements+ ( "noSchema", _ ) -> pure NoSchema+ _ -> Nothing++ connInfo = ConnectInfo+ { connectHost = host, connectPort = port+ , connectUser = user, connectPassword = pw+ , connectDatabase = db, connectOptions = options+ , connectPath = "", connectSSL = Nothing }+ in connect connInfo >>= \hdl -> pure (hdl, close hdl))++#define FROM_BACKEND_ROW(ty) instance FromBackendRow MySQL ty++FROM_BACKEND_ROW(Bool)+FROM_BACKEND_ROW(Word)+FROM_BACKEND_ROW(Word8)+FROM_BACKEND_ROW(Word16)+FROM_BACKEND_ROW(Word32)+FROM_BACKEND_ROW(Word64)+FROM_BACKEND_ROW(Int)+FROM_BACKEND_ROW(Int8)+FROM_BACKEND_ROW(Int16)+FROM_BACKEND_ROW(Int32)+FROM_BACKEND_ROW(Int64)+FROM_BACKEND_ROW(Float)+FROM_BACKEND_ROW(Double)+FROM_BACKEND_ROW(Scientific)+FROM_BACKEND_ROW((Ratio Integer))+FROM_BACKEND_ROW(BS.ByteString)+FROM_BACKEND_ROW(BL.ByteString)+FROM_BACKEND_ROW(T.Text)+FROM_BACKEND_ROW(TL.Text)+FROM_BACKEND_ROW(LocalTime)+FROM_BACKEND_ROW(A.Value)+FROM_BACKEND_ROW(SqlNull)++-- * Equality checks+#define HAS_MYSQL_EQUALITY_CHECK(ty) \+ instance HasSqlEqualityCheck MySQL (ty); \+ instance HasSqlQuantifiedEqualityCheck MySQL (ty);++HAS_MYSQL_EQUALITY_CHECK(Bool)+HAS_MYSQL_EQUALITY_CHECK(Double)+HAS_MYSQL_EQUALITY_CHECK(Float)+HAS_MYSQL_EQUALITY_CHECK(Int)+HAS_MYSQL_EQUALITY_CHECK(Int8)+HAS_MYSQL_EQUALITY_CHECK(Int16)+HAS_MYSQL_EQUALITY_CHECK(Int32)+HAS_MYSQL_EQUALITY_CHECK(Int64)+HAS_MYSQL_EQUALITY_CHECK(Integer)+HAS_MYSQL_EQUALITY_CHECK(Word)+HAS_MYSQL_EQUALITY_CHECK(Word8)+HAS_MYSQL_EQUALITY_CHECK(Word16)+HAS_MYSQL_EQUALITY_CHECK(Word32)+HAS_MYSQL_EQUALITY_CHECK(Word64)+HAS_MYSQL_EQUALITY_CHECK(T.Text)+HAS_MYSQL_EQUALITY_CHECK(TL.Text)+HAS_MYSQL_EQUALITY_CHECK([Char])+HAS_MYSQL_EQUALITY_CHECK(Scientific)+HAS_MYSQL_EQUALITY_CHECK(Day)+HAS_MYSQL_EQUALITY_CHECK(TimeOfDay)+HAS_MYSQL_EQUALITY_CHECK(NominalDiffTime)+HAS_MYSQL_EQUALITY_CHECK(LocalTime)++instance HasQBuilder MySQL where+ buildSqlQuery = buildSql92Query' True
+ Database/Beam/MySQL/FromField.hs view
@@ -0,0 +1,297 @@+-- | Beam defines a custom 'FromField' type class for types that can be read from+-- MySQL fields. The ones in 'mysql-simple' are inadequate because they rely on+-- bizarre asynchronous exceptions that cannot be used consistently++{-# LANGUAGE BangPatterns #-}++module Database.Beam.MySQL.FromField+ ( FieldParser+ , FromField(..)++ , atto ) where++import Database.Beam.Backend.SQL (SqlNull(..))+import Database.Beam.Backend.SQL.Row (ColumnParseError(..))++import Database.MySQL.Base+import Database.MySQL.Base.Types++import Control.Applicative+import Control.Monad.Except++import qualified Data.Aeson as A (Value, eitherDecodeStrict)+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString.Char8 as SB+import qualified Data.ByteString.Lazy.Char8 as LB+import Data.Char+import Data.Fixed+import Data.Int+import Data.Proxy+import Data.Ratio+import Data.Scientific+import qualified Data.Text as TS+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import Data.Time+import Data.Typeable+import Data.Word++import Text.Printf++type FieldParser a = ExceptT ColumnParseError IO a++class FromField a where+ fromField :: Field -> Maybe SB.ByteString -> FieldParser a++instance FromField Bool where+ fromField f d = (/= (0::Word8)) <$> fromField f d++instance FromField Word where+ fromField = atto check64 decimal+instance FromField Word8 where+ fromField = atto check8 decimal+instance FromField Word16 where+ fromField = atto check16 decimal+instance FromField Word32 where+ fromField = atto check32 decimal+instance FromField Word64 where+ fromField = atto check64 decimal++instance FromField Int where+ fromField = atto check64 (signed decimal)+instance FromField Int8 where+ fromField = atto check8 (signed decimal)+instance FromField Int16 where+ fromField = atto check16 (signed decimal)+instance FromField Int32 where+ fromField = atto check32 (signed decimal)+instance FromField Int64 where+ fromField = atto check64 (signed decimal)++instance FromField Float where+ fromField = atto check (realToFrac <$> double)+ where+ check ty | check16 ty = True+ check Int24 = True+ check Float = True+ check Decimal = True+ check NewDecimal = True+ check Double = True+ check _= False++instance FromField Double where+ fromField = atto check double+ where+ check ty | check32 ty = True+ check Float = True+ check Double = True+ check Decimal = True+ check NewDecimal = True+ check _ = False++instance FromField Scientific where+ fromField = atto checkScientific rational++instance FromField (Ratio Integer) where+ fromField = atto checkScientific rational++instance FromField a => FromField (Maybe a) where+ fromField _ Nothing = pure Nothing+ fromField field (Just d) = Just <$> fromField field (Just d)++instance FromField SqlNull where+ fromField _ Nothing = pure SqlNull+ fromField f _ = throwError (ColumnTypeMismatch "SqlNull"+ (show (fieldType f))+ "Non-null value found")++instance FromField SB.ByteString where+ fromField = doConvert checkBytes pure++instance FromField LB.ByteString where+ fromField f d = fmap (LB.fromChunks . pure) (fromField f d)++instance FromField TS.Text where+ fromField = doConvert checkText (either (Left . show) Right . TE.decodeUtf8')++instance FromField TL.Text where+ fromField f d = fmap (TL.fromChunks . pure) (fromField f d)++instance FromField LocalTime where+ fromField = atto checkDate localTime+ where+ checkDate DateTime = True+ checkDate Timestamp = True+ checkDate Date = True+ checkDate _ = False++ localTime = do+ (day, time) <- dayAndTime+ pure (LocalTime day time)++instance FromField Day where+ fromField = atto checkDay dayP+ where+ checkDay Date = True+ checkDay _ = False++instance FromField TimeOfDay where+ fromField = atto checkTime timeP+ where+ checkTime Time = True+ checkTime _ = False++instance FromField NominalDiffTime where+ fromField = atto checkTime durationP+ where+ checkTime Time = True+ checkTime _ = False++instance FromField A.Value where+ fromField f bs =+ case (maybeToRight "Failed to extract JSON bytes." bs) >>= A.eitherDecodeStrict of+ Left err -> conversionFailed f err+ Right x -> pure x++dayAndTime :: Parser (Day, TimeOfDay)+dayAndTime = do+ day <- dayP+ _ <- char ' '+ time <- timeP++ pure (day, time)++timeP :: Parser TimeOfDay+timeP = do+ hour <- lengthedDecimal 2+ _ <- char ':'+ minute <- lengthedDecimal 2+ _ <- char ':'+ seconds <- lengthedDecimal 2+ microseconds <- (char '.' *> maxLengthedDecimal 6) <|>+ pure 0++ let pico = seconds + microseconds * 1e-6+ case makeTimeOfDayValid hour minute pico of+ Nothing -> fail (printf "Invalid time part: %02d:%02d:%s" hour minute (showFixed False pico))+ Just tod -> pure tod++durationP :: Parser NominalDiffTime+durationP = do+ negative <- (True <$ char '-') <|> pure False+ hour <- lengthedDecimal 3+ _ <- char ':'+ minute <- lengthedDecimal 2+ _ <- char ':'+ seconds <- lengthedDecimal 2+ microseconds <- (char '.' *> maxLengthedDecimal 6) <|>+ pure 0++ let v = hour * 3600 + minute * 60 + seconds ++ microseconds * 1e-6++ pure (if negative then negate v else v)++dayP :: Parser Day+dayP = do+ year <- lengthedDecimal 4+ _ <- char '-'+ month <- lengthedDecimal 2+ _ <- char '-'+ day <- lengthedDecimal 2++ case fromGregorianValid year month day of+ Nothing -> fail (printf "Invalid date part: %04d-%02d-%02d" year month day)+ Just day' -> pure day'++lengthedDecimal :: Num a => Int -> Parser a+lengthedDecimal = lengthedDecimal' 0+ where+ lengthedDecimal' !a 0 = pure a+ lengthedDecimal' !a n = do+ d <- digitToInt <$> digit+ lengthedDecimal' (a * 10 + fromIntegral d) (n - 1)++maxLengthedDecimal :: Num a => Int -> Parser a+maxLengthedDecimal = go1 0+ where+ go1 a n = do+ d <- digitToInt <$> digit+ go' (a * 10 + fromIntegral d) (n - 1)++ go' !a 0 = pure a+ go' !a n =+ go1 a n <|> pure (a * 10 ^ n)++incompatibleTypes, unexpectedNull, conversionFailed+ :: forall a. Typeable a => Field -> String -> FieldParser a+incompatibleTypes f msg =+ throwError (ColumnTypeMismatch (show (typeRep (Proxy :: Proxy a)))+ (show (fieldType f))+ msg)+unexpectedNull _ _ =+ throwError ColumnUnexpectedNull+conversionFailed f msg =+ throwError (ColumnTypeMismatch (show (typeRep (Proxy :: Proxy a)))+ (show (fieldType f))+ msg)++check8, check16, check32, check64, checkScientific, checkBytes, checkText+ :: Type -> Bool++check8 Tiny = True+check8 NewDecimal = True+check8 _ = False++check16 ty | check8 ty = True+check16 Short = True+check16 _= False++check32 ty | check16 ty = True+check32 Int24 = True+check32 Long = True+check32 _ = False++check64 ty | check32 ty = True+check64 LongLong = True+check64 _ = False++checkScientific ty | check64 ty = True+checkScientific Float = True+checkScientific Double = True+checkScientific Decimal = True+checkScientific NewDecimal = True+checkScientific _ = True++checkBytes ty | checkText ty = True+checkBytes TinyBlob = True+checkBytes MediumBlob = True+checkBytes LongBlob = True+checkBytes Blob = True+checkBytes _ = False++checkText VarChar = True+checkText VarString = True+checkText String = True+checkText Enum = True+checkText _ = False++doConvert :: Typeable a => (Type -> Bool)+ -> (SB.ByteString -> Either String a)+ -> Field -> Maybe SB.ByteString -> FieldParser a+doConvert _ _ f Nothing = unexpectedNull f ""+doConvert checkType parser field (Just d)+ | checkType (fieldType field) =+ case parser d of+ Left err -> conversionFailed field err+ Right r -> pure r+ | otherwise = incompatibleTypes field ""++atto :: Typeable a => (Type -> Bool) -> Parser a+ -> Field -> Maybe SB.ByteString -> FieldParser a+atto checkType parser =+ doConvert checkType (parseOnly parser)++maybeToRight :: b -> Maybe a -> Either b a+maybeToRight _ (Just x) = Right x+maybeToRight y Nothing = Left y
+ Database/Beam/MySQL/Syntax.hs view
@@ -0,0 +1,589 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Database.Beam.MySQL.Syntax where++import Database.Beam.Backend.SQL+import Database.Beam.Query++import Database.MySQL.Base (Connection)++import qualified Data.Aeson as A (Value, encode)+import Data.ByteString (ByteString)+import Data.ByteString.Builder+import Data.ByteString.Builder.Scientific (scientificBuilder)+import qualified Data.ByteString.Lazy as BL (toStrict)+import Data.Fixed+import Data.Int+import Data.Maybe (maybe)+import Data.Monoid (Monoid)+import Data.Scientific (Scientific)+import Data.Semigroup (Semigroup, (<>))+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import Data.Time+import Data.Word++newtype MysqlSyntax+ = MysqlSyntax+ { fromMysqlSyntax :: forall m. Monad m+ => ((ByteString -> m ByteString) ->+ Builder -> Connection -> m Builder)+ -> (ByteString -> m ByteString)+ -> Builder -> Connection -> m Builder+ }++newtype MysqlCommandSyntax = MysqlCommandSyntax { fromMysqlCommand :: MysqlSyntax }+newtype MysqlSelectSyntax = MysqlSelectSyntax { fromMysqlSelect :: MysqlSyntax }+newtype MysqlInsertSyntax = MysqlInsertSyntax { fromMysqlInsert :: MysqlSyntax }+newtype MysqlUpdateSyntax = MysqlUpdateSyntax { fromMysqlUpdate :: MysqlSyntax }+newtype MysqlDeleteSyntax = MysqlDeleteSyntax { fromMysqlDelete :: MysqlSyntax }+newtype MysqlTableNameSyntax = MysqlTableNameSyntax { fromMysqlTableName :: MysqlSyntax }+newtype MysqlFieldNameSyntax = MysqlFieldNameSyntax { fromMysqlFieldName :: MysqlSyntax }+newtype MysqlExpressionSyntax = MysqlExpressionSyntax { fromMysqlExpression :: MysqlSyntax } deriving Eq+newtype MysqlValueSyntax = MysqlValueSyntax { fromMysqlValue :: MysqlSyntax }+newtype MysqlInsertValuesSyntax = MysqlInsertValuesSyntax { fromMysqlInsertValues :: MysqlSyntax }+newtype MysqlSelectTableSyntax = MysqlSelectTableSyntax { fromMysqlSelectTable :: MysqlSyntax }+newtype MysqlSetQuantifierSyntax = MysqlSetQuantifierSyntax { fromMysqlSetQuantifier :: MysqlSyntax }+newtype MysqlComparisonQuantifierSyntax = MysqlComparisonQuantifierSyntax { fromMysqlComparisonQuantifier :: MysqlSyntax }+newtype MysqlOrderingSyntax = MysqlOrderingSyntax { fromMysqlOrdering :: MysqlSyntax }+newtype MysqlFromSyntax = MysqlFromSyntax { fromMysqlFrom :: MysqlSyntax }+newtype MysqlGroupingSyntax = MysqlGroupingSyntax { fromMysqlGrouping :: MysqlSyntax }+newtype MysqlTableSourceSyntax = MysqlTableSourceSyntax { fromMysqlTableSource :: MysqlSyntax }+newtype MysqlProjectionSyntax = MysqlProjectionSyntax { fromMysqlProjection :: MysqlSyntax }+data MysqlDataTypeSyntax+ = MysqlDataTypeSyntax { fromMysqlDataType :: MysqlSyntax+ , fromMysqlDataTypeCast :: MysqlSyntax }+newtype MysqlExtractFieldSyntax = MysqlExtractFieldSyntax { fromMysqlExtractField :: MysqlSyntax }++instance Eq MysqlSyntax where+ _ == _ = False++instance Semigroup MysqlSyntax where+ (<>) = mappend++instance Monoid MysqlSyntax where+ mempty = MysqlSyntax id+ mappend (MysqlSyntax a) (MysqlSyntax b) =+ MysqlSyntax $ \next -> a (b next)++emit :: Builder -> MysqlSyntax+emit b = MysqlSyntax (\next doEscape before -> next doEscape (before <> b))++escape :: ByteString -> MysqlSyntax+escape b = MysqlSyntax (\next doEscape before conn ->+ doEscape b >>= \b' ->+ next doEscape (before <> byteString b') conn)++-- We use backticks in MySQL, because the double quote mode requires+-- ANSI_QUOTES, which may not always be enabled+mysqlIdentifier :: Text -> MysqlSyntax+mysqlIdentifier t =+ emit "`" <>+ MysqlSyntax (\next doEscape before ->+ next doEscape (before <> TE.encodeUtf8Builder t)) <>+ emit "`"++mysqlSepBy :: MysqlSyntax -> [MysqlSyntax] -> MysqlSyntax+mysqlSepBy _ [] = mempty+mysqlSepBy _ [a] = a+mysqlSepBy sep (a:as) = a <> foldMap (sep <>) as++mysqlParens :: MysqlSyntax -> MysqlSyntax+mysqlParens a = emit "(" <> a <> emit ")"++instance IsSql92Syntax MysqlCommandSyntax where+ type Sql92SelectSyntax MysqlCommandSyntax = MysqlSelectSyntax+ type Sql92InsertSyntax MysqlCommandSyntax = MysqlInsertSyntax+ type Sql92UpdateSyntax MysqlCommandSyntax = MysqlUpdateSyntax+ type Sql92DeleteSyntax MysqlCommandSyntax = MysqlDeleteSyntax++ selectCmd = MysqlCommandSyntax . fromMysqlSelect+ insertCmd = MysqlCommandSyntax . fromMysqlInsert+ deleteCmd = MysqlCommandSyntax . fromMysqlDelete+ updateCmd = MysqlCommandSyntax . fromMysqlUpdate++instance IsSql92UpdateSyntax MysqlUpdateSyntax where+ type Sql92UpdateFieldNameSyntax MysqlUpdateSyntax = MysqlFieldNameSyntax+ type Sql92UpdateExpressionSyntax MysqlUpdateSyntax = MysqlExpressionSyntax+ type Sql92UpdateTableNameSyntax MysqlUpdateSyntax = MysqlTableNameSyntax++ updateStmt tbl fields where_ =+ MysqlUpdateSyntax $+ emit "UPDATE " <> fromMysqlTableName tbl <>+ (case fields of+ [] -> mempty+ _ ->+ emit " SET " <>+ mysqlSepBy (emit ", ") (map (\(field, val) -> fromMysqlFieldName field <> emit "=" <>+ fromMysqlExpression val) fields)) <>+ maybe mempty (\where' -> emit " WHERE " <> fromMysqlExpression where') where_++instance IsSql92InsertSyntax MysqlInsertSyntax where+ type Sql92InsertValuesSyntax MysqlInsertSyntax = MysqlInsertValuesSyntax+ type Sql92InsertTableNameSyntax MysqlInsertSyntax = MysqlTableNameSyntax++ insertStmt tblName fields values =+ MysqlInsertSyntax $+ emit "INSERT INTO " <> fromMysqlTableName tblName <> emit "(" <>+ mysqlSepBy (emit ", ") (map mysqlIdentifier fields) <> emit ")" <>+ fromMysqlInsertValues values++instance IsSql92InsertValuesSyntax MysqlInsertValuesSyntax where+ type Sql92InsertValuesExpressionSyntax MysqlInsertValuesSyntax = MysqlExpressionSyntax+ type Sql92InsertValuesSelectSyntax MysqlInsertValuesSyntax = MysqlSelectSyntax++ insertSqlExpressions es =+ MysqlInsertValuesSyntax $+ emit "VALUES " <>+ mysqlSepBy (emit ", ")+ (map (\es' -> emit "(" <>+ mysqlSepBy (emit ", ")+ (fmap fromMysqlExpression es') <>+ emit ")")+ es)+ insertFromSql a = MysqlInsertValuesSyntax (fromMysqlSelect a)++instance IsSql92DeleteSyntax MysqlDeleteSyntax where+ type Sql92DeleteExpressionSyntax MysqlDeleteSyntax = MysqlExpressionSyntax+ type Sql92DeleteTableNameSyntax MysqlDeleteSyntax = MysqlTableNameSyntax++ deleteStmt tbl _ where_ =+ MysqlDeleteSyntax $+ emit "DELETE FROM " <> fromMysqlTableName tbl <>+ maybe mempty (\where' -> emit " WHERE " <> fromMysqlExpression where') where_+ deleteSupportsAlias _ = False++instance IsSql92SelectSyntax MysqlSelectSyntax where+ type Sql92SelectSelectTableSyntax MysqlSelectSyntax = MysqlSelectTableSyntax+ type Sql92SelectOrderingSyntax MysqlSelectSyntax = MysqlOrderingSyntax++ selectStmt tbl ordering limit offset =+ MysqlSelectSyntax $+ fromMysqlSelectTable tbl <>+ (case ordering of+ [] -> mempty+ _ -> emit " ORDER BY " <>+ mysqlSepBy (emit ", ") (map fromMysqlOrdering ordering)) <>+ case (limit, offset) of+ (Just limit', Just offset') ->+ emit " LIMIT " <> emit (integerDec offset') <>+ emit ", " <> emit (integerDec limit')+ (Just limit', Nothing) ->+ emit " LIMIT " <> emit (integerDec limit')+ (Nothing, Just offset') ->+ -- TODO figure out a betterlimit+ emit " LIMIT 1000000000 OFFSET " <> emit (integerDec offset')+ _ -> mempty++instance IsSql92SelectTableSyntax MysqlSelectTableSyntax where+ type Sql92SelectTableSelectSyntax MysqlSelectTableSyntax = MysqlSelectSyntax+ type Sql92SelectTableExpressionSyntax MysqlSelectTableSyntax = MysqlExpressionSyntax+ type Sql92SelectTableProjectionSyntax MysqlSelectTableSyntax = MysqlProjectionSyntax+ type Sql92SelectTableFromSyntax MysqlSelectTableSyntax = MysqlFromSyntax+ type Sql92SelectTableGroupingSyntax MysqlSelectTableSyntax = MysqlGroupingSyntax+ type Sql92SelectTableSetQuantifierSyntax MysqlSelectTableSyntax = MysqlSetQuantifierSyntax++ selectTableStmt setQuantifier proj from where_ grouping having =+ MysqlSelectTableSyntax $+ emit "SELECT " <>+ maybe mempty (\sq' -> fromMysqlSetQuantifier sq' <> emit " ") setQuantifier <>+ fromMysqlProjection proj <>+ maybe mempty (emit " FROM " <>) (fmap fromMysqlFrom from) <>+ maybe mempty (emit " WHERE " <>) (fmap fromMysqlExpression where_) <>+ maybe mempty (emit " GROUP BY " <>) (fmap fromMysqlGrouping grouping) <>+ maybe mempty (emit " HAVING " <>) (fmap fromMysqlExpression having)++ unionTables True = mysqlTblOp "UNION ALL"+ unionTables False = mysqlTblOp "UNION"+ intersectTables _ = mysqlTblOp "INTERSECT"+ exceptTable _ = mysqlTblOp "EXCEPT"++mysqlTblOp :: Builder -> MysqlSelectTableSyntax -> MysqlSelectTableSyntax -> MysqlSelectTableSyntax+mysqlTblOp op a b =+ MysqlSelectTableSyntax (fromMysqlSelectTable a <> emit " " <> emit op <>+ emit " " <> fromMysqlSelectTable b)++instance IsSql92AggregationSetQuantifierSyntax MysqlSetQuantifierSyntax where+ setQuantifierDistinct = MysqlSetQuantifierSyntax (emit "DISTINCT")+ setQuantifierAll = MysqlSetQuantifierSyntax (emit "ALL")++instance IsSql92GroupingSyntax MysqlGroupingSyntax where+ type Sql92GroupingExpressionSyntax MysqlGroupingSyntax = MysqlExpressionSyntax++ groupByExpressions es =+ MysqlGroupingSyntax $+ mysqlSepBy (emit ", ") (map fromMysqlExpression es)++instance IsSql92FromSyntax MysqlFromSyntax where+ type Sql92FromExpressionSyntax MysqlFromSyntax = MysqlExpressionSyntax+ type Sql92FromTableSourceSyntax MysqlFromSyntax = MysqlTableSourceSyntax++ fromTable tableSrc Nothing = MysqlFromSyntax (fromMysqlTableSource tableSrc)+ fromTable tableSrc (Just (nm, cols)) =+ MysqlFromSyntax $+ fromMysqlTableSource tableSrc <> emit " AS " <> mysqlIdentifier nm <>+ maybe mempty (mysqlParens . mysqlSepBy (emit ",") . fmap mysqlIdentifier) cols++ innerJoin = mysqlJoin "JOIN"++ leftJoin = mysqlJoin "LEFT JOIN"+ rightJoin = mysqlJoin "RIGHT JOIN"++instance IsSql92FromOuterJoinSyntax MysqlFromSyntax where+ outerJoin = mysqlJoin "OUTER JOIN"++mysqlJoin :: Builder -> MysqlFromSyntax -> MysqlFromSyntax+ -> Maybe MysqlExpressionSyntax -> MysqlFromSyntax+mysqlJoin joinType a b (Just e) =+ MysqlFromSyntax (fromMysqlFrom a <> emit " " <> emit joinType <> emit " " <>+ fromMysqlFrom b <> emit " ON " <> fromMysqlExpression e)+mysqlJoin joinType a b Nothing =+ MysqlFromSyntax (fromMysqlFrom a <> emit " " <> emit joinType <>+ emit " " <> fromMysqlFrom b)++instance IsSql92TableSourceSyntax MysqlTableSourceSyntax where+ type Sql92TableSourceSelectSyntax MysqlTableSourceSyntax = MysqlSelectSyntax+ type Sql92TableSourceTableNameSyntax MysqlTableSourceSyntax = MysqlTableNameSyntax+ type Sql92TableSourceExpressionSyntax MysqlTableSourceSyntax = MysqlExpressionSyntax++ tableNamed t = MysqlTableSourceSyntax (fromMysqlTableName t)+ tableFromSubSelect s = MysqlTableSourceSyntax (emit "(" <> fromMysqlSelect s <> emit ")")+ tableFromValues vss = MysqlTableSourceSyntax . mysqlParens $+ mysqlSepBy (emit " UNION ")+ (map (mappend (emit "SELECT ") . mysqlSepBy (emit ", ") .+ map (mysqlParens . fromMysqlExpression)) vss)++instance IsSql92OrderingSyntax MysqlOrderingSyntax where+ type Sql92OrderingExpressionSyntax MysqlOrderingSyntax = MysqlExpressionSyntax++ ascOrdering e = MysqlOrderingSyntax (fromMysqlExpression e <> emit " ASC")+ descOrdering e = MysqlOrderingSyntax (fromMysqlExpression e <> emit " DESC")++instance IsSql92TableNameSyntax MysqlTableNameSyntax where+ tableName Nothing t = MysqlTableNameSyntax $ mysqlIdentifier t+ tableName (Just schema) t = MysqlTableNameSyntax $ mysqlIdentifier schema <> emit "." <> mysqlIdentifier t++instance IsSql92FieldNameSyntax MysqlFieldNameSyntax where+ qualifiedField a b =+ MysqlFieldNameSyntax $+ mysqlIdentifier a <> emit "." <> mysqlIdentifier b+ unqualifiedField b =+ MysqlFieldNameSyntax (mysqlIdentifier b)++-- | Note: MySQL does not allow timezones in date/time types+instance IsSql92DataTypeSyntax MysqlDataTypeSyntax where+ domainType t = MysqlDataTypeSyntax (mysqlIdentifier t) (mysqlIdentifier t)+ charType len cs = MysqlDataTypeSyntax (emit "CHAR(" <> mysqlCharLen len <> emit ")" <> mysqlOptCharSet cs) (emit "CHAR")+ varCharType len cs = MysqlDataTypeSyntax (emit "VARCHAR(" <> mysqlCharLen len <> emit ")" <> mysqlOptCharSet cs) (emit "CHAR")+ nationalCharType len = MysqlDataTypeSyntax (emit "NATIONAL CHAR(" <> mysqlCharLen len <> emit ")") (emit "CHAR")+ nationalVarCharType len = MysqlDataTypeSyntax (emit "NATIONAL CHAR VARYING(" <> mysqlCharLen len <> emit ")") (emit "CHAR")+ bitType len = MysqlDataTypeSyntax (emit "BIT(" <> mysqlCharLen len <> emit ")") (emit "BINARY")+ varBitType len = MysqlDataTypeSyntax (emit "VARBINARY(" <> mysqlCharLen len <> emit ")") (emit "BINARY")+ numericType prec = MysqlDataTypeSyntax (emit "NUMERIC" <> mysqlNumPrec prec) (emit "DECIMAL" <> mysqlNumPrec prec)+ decimalType prec = MysqlDataTypeSyntax ty ty+ where ty = emit "DECIMAL" <> mysqlNumPrec prec+ intType = MysqlDataTypeSyntax (emit "INT") (emit "INTEGER")+ smallIntType = MysqlDataTypeSyntax (emit "SMALL INT") (emit "INTEGER")+ floatType prec = MysqlDataTypeSyntax (emit "FLOAT" <> maybe mempty (mysqlParens . emit . fromString . show) prec) (emit "DECIMAL")+ doubleType = MysqlDataTypeSyntax (emit "DOUBLE") (emit "DECIMAL")+ realType = MysqlDataTypeSyntax (emit "REAL") (emit "DECIMAL")++ dateType = MysqlDataTypeSyntax ty ty+ where ty = emit "DATE"+ timeType _prec _withTimeZone = MysqlDataTypeSyntax ty ty+ where ty = emit "TIME"+ timestampType _prec _withTimeZone = MysqlDataTypeSyntax (emit "TIMESTAMP") (emit "DATETIME")++instance IsSql92ProjectionSyntax MysqlProjectionSyntax where+ type Sql92ProjectionExpressionSyntax MysqlProjectionSyntax = MysqlExpressionSyntax++ projExprs exprs =+ MysqlProjectionSyntax $+ mysqlSepBy (emit ", ")+ (map (\(expr, nm) ->+ fromMysqlExpression expr <>+ maybe mempty+ (\nm' -> emit " AS " <> mysqlIdentifier nm') nm)+ exprs)++instance IsCustomSqlSyntax MysqlExpressionSyntax where+ newtype CustomSqlSyntax MysqlExpressionSyntax =+ MysqlCustomExpressionSyntax { fromMysqlCustomExpression :: MysqlSyntax }+ deriving (Monoid, Semigroup)+ customExprSyntax = MysqlExpressionSyntax . fromMysqlCustomExpression+ renderSyntax = MysqlCustomExpressionSyntax . mysqlParens . fromMysqlExpression++instance IsString (CustomSqlSyntax MysqlExpressionSyntax) where+ fromString = MysqlCustomExpressionSyntax . emit . fromString++instance IsSql92ExpressionSyntax MysqlExpressionSyntax where+ type Sql92ExpressionValueSyntax MysqlExpressionSyntax = MysqlValueSyntax+ type Sql92ExpressionSelectSyntax MysqlExpressionSyntax = MysqlSelectSyntax+ type Sql92ExpressionFieldNameSyntax MysqlExpressionSyntax = MysqlFieldNameSyntax+ type Sql92ExpressionQuantifierSyntax MysqlExpressionSyntax = MysqlComparisonQuantifierSyntax+ type Sql92ExpressionCastTargetSyntax MysqlExpressionSyntax = MysqlDataTypeSyntax+ type Sql92ExpressionExtractFieldSyntax MysqlExpressionSyntax = MysqlExtractFieldSyntax++ addE = mysqlBinOp "+"; subE = mysqlBinOp "-"+ mulE = mysqlBinOp "*"; divE = mysqlBinOp "/"; modE = mysqlBinOp "%"++ orE = mysqlBinOp "OR"; andE = mysqlBinOp "AND"+ likeE = mysqlBinOp "LIKE"; overlapsE = mysqlBinOp "OVERLAPS"++ eqE = mysqlCompOp "="; neqE = mysqlCompOp "<>"+ ltE = mysqlCompOp "<"; gtE = mysqlCompOp ">"+ leE = mysqlCompOp "<="; geE = mysqlCompOp ">="++ negateE = mysqlUnOp "-"; notE = mysqlUnOp "NOT"++ existsE s = MysqlExpressionSyntax (emit "EXISTS(" <> fromMysqlSelect s <> emit ")")+ uniqueE s = MysqlExpressionSyntax (emit "UNIQUE(" <> fromMysqlSelect s <> emit ")")++ isNotNullE = mysqlPostFix "IS NOT NULL"; isNullE = mysqlPostFix "IS NULL"+ isTrueE = mysqlPostFix "IS TRUE"; isFalseE = mysqlPostFix "IS FALSE"+ isNotTrueE = mysqlPostFix "IS NOT TRUE"; isNotFalseE = mysqlPostFix "IS NOT FALSE"+ isUnknownE = mysqlPostFix "IS UNKNOWN"; isNotUnknownE = mysqlPostFix "IS NOT UNKNOWN"++ betweenE a b c =+ MysqlExpressionSyntax (emit "(" <> fromMysqlExpression a <> emit ") BETWEEN (" <>+ fromMysqlExpression b <> emit ") AND (" <>+ fromMysqlExpression c <> emit ")")++ valueE e = MysqlExpressionSyntax (fromMysqlValue e)+ rowE vs =+ MysqlExpressionSyntax (emit "(" <> mysqlSepBy (emit ", ") (map fromMysqlExpression vs) <> emit ")")+ fieldE fn = MysqlExpressionSyntax (fromMysqlFieldName fn)+ subqueryE s = MysqlExpressionSyntax (emit "(" <> fromMysqlSelect s <> emit ")")++ positionE needle haystack =+ MysqlExpressionSyntax $+ emit "POSITION((" <> fromMysqlExpression needle <> emit ") IN (" <>+ fromMysqlExpression haystack <> emit "))"++ nullIfE a b =+ MysqlExpressionSyntax $+ emit "NULLIF(" <> fromMysqlExpression a <> emit ", " <>+ fromMysqlExpression b <> emit ")"++ absE a = MysqlExpressionSyntax (emit "ABS(" <> fromMysqlExpression a <> emit ")")+ bitLengthE a = MysqlExpressionSyntax (emit "BIT_LENGTH(" <> fromMysqlExpression a <> emit ")")+ charLengthE a = MysqlExpressionSyntax (emit "CHAR_LENGTH(" <> fromMysqlExpression a <> emit ")")+ octetLengthE a = MysqlExpressionSyntax (emit "OCTET_LENGTH(" <> fromMysqlExpression a <> emit ")")+ coalesceE es = MysqlExpressionSyntax (emit "COALESCE(" <>+ mysqlSepBy (emit ", ")+ (map fromMysqlExpression es) <>+ emit ")")+ extractE field from = MysqlExpressionSyntax (emit "EXTRACT(" <> fromMysqlExtractField field <>+ emit " FROM (" <> fromMysqlExpression from <> emit ")")+ castE e to = MysqlExpressionSyntax (emit "CAST((" <> fromMysqlExpression e <> emit ") AS " <>+ fromMysqlDataTypeCast to <> emit ")")+ caseE cases else' =+ MysqlExpressionSyntax $+ emit "CASE " <>+ foldMap (\(cond, res) -> emit "WHEN " <> fromMysqlExpression cond <>+ emit " THEN " <> fromMysqlExpression res <>+ emit " ") cases <>+ emit "ELSE " <> fromMysqlExpression else' <> emit " END"++ currentTimestampE = MysqlExpressionSyntax (emit "CURRENT_TIMESTAMP")+ defaultE = MysqlExpressionSyntax (emit "DEFAULT")++ inE e es = MysqlExpressionSyntax $+ emit "(" <> fromMysqlExpression e <> emit ") IN ( " <>+ mysqlSepBy (emit ", ") (map fromMysqlExpression es) <> emit ")"++ trimE x = MysqlExpressionSyntax (emit "TRIM(" <> fromMysqlExpression x <> emit ")")+ lowerE x = MysqlExpressionSyntax (emit "LOWER(" <> fromMysqlExpression x <> emit ")")+ upperE x = MysqlExpressionSyntax (emit "UPPER(" <> fromMysqlExpression x <> emit ")")++instance IsSql92ExtractFieldSyntax MysqlExtractFieldSyntax where+ secondsField = MysqlExtractFieldSyntax (emit "SECOND")+ minutesField = MysqlExtractFieldSyntax (emit "MINUTE")+ hourField = MysqlExtractFieldSyntax (emit "HOUR")+ dayField = MysqlExtractFieldSyntax (emit "DAY")+ monthField = MysqlExtractFieldSyntax (emit "MONTH")+ yearField = MysqlExtractFieldSyntax (emit "YEAR")++instance IsSql99ConcatExpressionSyntax MysqlExpressionSyntax where+ concatE [] = valueE (sqlValueSyntax ("" :: T.Text))+ concatE xs =+ MysqlExpressionSyntax . mconcat $+ [ emit "CONCAT("+ , mysqlSepBy (emit ", ") (map fromMysqlExpression xs)+ , emit ")" ]++mysqlUnOp :: Builder -> MysqlExpressionSyntax -> MysqlExpressionSyntax+mysqlUnOp op e = MysqlExpressionSyntax (emit op <> emit " (" <>+ fromMysqlExpression e <> emit ")")++mysqlPostFix :: Builder -> MysqlExpressionSyntax -> MysqlExpressionSyntax+mysqlPostFix op e = MysqlExpressionSyntax (emit "(" <> fromMysqlExpression e <>+ emit ") " <> emit op)++mysqlCompOp :: Builder -> Maybe MysqlComparisonQuantifierSyntax+ -> MysqlExpressionSyntax -> MysqlExpressionSyntax+ -> MysqlExpressionSyntax+mysqlCompOp op quantifier a b =+ MysqlExpressionSyntax $+ emit "(" <> fromMysqlExpression a <>+ emit ") " <> emit op <>+ maybe mempty (\q -> emit " " <> fromMysqlComparisonQuantifier q <> emit " ") quantifier <>+ emit " (" <> fromMysqlExpression b <> emit ")"++mysqlBinOp :: Builder -> MysqlExpressionSyntax+ -> MysqlExpressionSyntax -> MysqlExpressionSyntax+mysqlBinOp op a b =+ MysqlExpressionSyntax $+ emit "(" <> fromMysqlExpression a <> emit ") " <> emit op <>+ emit " (" <> fromMysqlExpression b <> emit ")"++instance IsSql92AggregationExpressionSyntax MysqlExpressionSyntax where+ type Sql92AggregationSetQuantifierSyntax MysqlExpressionSyntax = MysqlSetQuantifierSyntax++ countAllE = MysqlExpressionSyntax (emit "COUNT(*)")+ countE = mysqlUnAgg "COUNT"+ avgE = mysqlUnAgg "AVG"+ sumE = mysqlUnAgg "SUM"+ minE = mysqlUnAgg "MIN"+ maxE = mysqlUnAgg "MAX"++mysqlUnAgg :: Builder -> Maybe MysqlSetQuantifierSyntax+ -> MysqlExpressionSyntax -> MysqlExpressionSyntax+mysqlUnAgg fn q e =+ MysqlExpressionSyntax $+ emit fn <> emit "(" <>+ maybe mempty (\q' -> fromMysqlSetQuantifier q' <> emit " ") q <>+ fromMysqlExpression e <> emit")"++-- Remove this dependence on Sql99ExpressionSyntax++-- instance IsSql2003EnhancedNumericFunctionsExpressionSyntax MysqlExpressionSyntax where+-- lnE x = MysqlExpressionSyntax (emit "LN(" <> fromMysqlExpression x <> emit ")")+-- expE x = MysqlExpressionSyntax (emit "EXP(" <> fromMysqlExpression x <> emit ")")+-- sqrtE x = MysqlExpressionSyntax (emit "SQRT(" <> fromMysqlExpression x <> emit ")")+-- ceilE x = MysqlExpressionSyntax (emit "CEIL(" <> fromMysqlExpression x <> emit ")")+-- floorE x = MysqlExpressionSyntax (emit "FLOOR(" <> fromMysqlExpression x <> emit ")")+-- powerE x y = MysqlExpressionSyntax (emit "POWER(" <> fromMysqlExpression x <> emit ", " <>+-- fromMysqlExpression y <> emit ")")++instance IsSql92QuantifierSyntax MysqlComparisonQuantifierSyntax where+ quantifyOverAll = MysqlComparisonQuantifierSyntax (emit "ALL")+ quantifyOverAny = MysqlComparisonQuantifierSyntax (emit "ANY")++instance HasSqlValueSyntax MysqlValueSyntax SqlNull where+ sqlValueSyntax _ = MysqlValueSyntax $ emit "NULL"+instance HasSqlValueSyntax MysqlValueSyntax Bool where+ sqlValueSyntax True = MysqlValueSyntax $ emit "TRUE"+ sqlValueSyntax False = MysqlValueSyntax $ emit "FALSE"++instance HasSqlValueSyntax MysqlValueSyntax Double where+ sqlValueSyntax d = MysqlValueSyntax $ emit (doubleDec d)+instance HasSqlValueSyntax MysqlValueSyntax Float where+ sqlValueSyntax d = MysqlValueSyntax $ emit (floatDec d)++instance HasSqlValueSyntax MysqlValueSyntax Int where+ sqlValueSyntax d = MysqlValueSyntax $ emit (intDec d)+instance HasSqlValueSyntax MysqlValueSyntax Int8 where+ sqlValueSyntax d = MysqlValueSyntax $ emit (int8Dec d)+instance HasSqlValueSyntax MysqlValueSyntax Int16 where+ sqlValueSyntax d = MysqlValueSyntax $ emit (int16Dec d)+instance HasSqlValueSyntax MysqlValueSyntax Int32 where+ sqlValueSyntax d = MysqlValueSyntax $ emit (int32Dec d)+instance HasSqlValueSyntax MysqlValueSyntax Int64 where+ sqlValueSyntax d = MysqlValueSyntax $ emit (int64Dec d)+instance HasSqlValueSyntax MysqlValueSyntax Integer where+ sqlValueSyntax d = MysqlValueSyntax $ emit (integerDec d)++instance HasSqlValueSyntax MysqlValueSyntax Word where+ sqlValueSyntax d = MysqlValueSyntax $ emit (wordDec d)+instance HasSqlValueSyntax MysqlValueSyntax Word8 where+ sqlValueSyntax d = MysqlValueSyntax $ emit (word8Dec d)+instance HasSqlValueSyntax MysqlValueSyntax Word16 where+ sqlValueSyntax d = MysqlValueSyntax $ emit (word16Dec d)+instance HasSqlValueSyntax MysqlValueSyntax Word32 where+ sqlValueSyntax d = MysqlValueSyntax $ emit (word32Dec d)+instance HasSqlValueSyntax MysqlValueSyntax Word64 where+ sqlValueSyntax d = MysqlValueSyntax $ emit (word64Dec d)++instance HasSqlValueSyntax MysqlValueSyntax T.Text where+ sqlValueSyntax t =+ MysqlValueSyntax $ MysqlSyntax+ (\next doEscape before conn ->+ do escaped <- doEscape (TE.encodeUtf8 t)+ next doEscape (before <> "'" <> byteString escaped <> "'") conn)+instance HasSqlValueSyntax MysqlValueSyntax TL.Text where+ sqlValueSyntax = sqlValueSyntax . TL.toStrict+instance HasSqlValueSyntax MysqlValueSyntax [Char] where+ sqlValueSyntax = sqlValueSyntax . T.pack++instance HasSqlValueSyntax MysqlValueSyntax Scientific where+ sqlValueSyntax = MysqlValueSyntax . emit . scientificBuilder++instance HasSqlValueSyntax MysqlValueSyntax Day where+ sqlValueSyntax d = MysqlValueSyntax (emit ("'" <> dayBuilder d <> "'"))++instance HasSqlValueSyntax MysqlValueSyntax TimeOfDay where+ sqlValueSyntax d = MysqlValueSyntax (emit ("'" <> todBuilder d <> "'"))++dayBuilder :: Day -> Builder+dayBuilder d =+ integerDec year <> "-" <>+ (if month < 10 then "0" else mempty) <> intDec month <> "-" <>+ (if day < 10 then "0" else mempty) <> intDec day+ where+ (year, month, day) = toGregorian d++todBuilder :: TimeOfDay -> Builder+todBuilder d =+ (if todHour d < 10 then "0" else mempty) <> intDec (todHour d) <> ":" <>+ (if todMin d < 10 then "0" else mempty) <> intDec (todMin d) <> ":" <>+ (if secs6 < 10 then "0" else mempty) <> fromString (showFixed False secs6)+ where+ secs6 :: Fixed E6+ secs6 = fromRational (toRational (todSec d))++instance HasSqlValueSyntax MysqlValueSyntax NominalDiffTime where+ sqlValueSyntax d =+ let dWhole = abs (floor d) :: Int+ hours = dWhole `div` 3600 :: Int++ d' = dWhole - (hours * 3600)+ minutes = d' `div` 60++ seconds = abs d - fromIntegral ((hours * 3600) + (minutes * 60))++ secondsFixed :: Fixed E12+ secondsFixed = fromRational (toRational seconds)+ in+ MysqlValueSyntax $+ emit ((if d < 0 then "-" else mempty) <>+ (if hours < 10 then "0" else mempty) <> intDec hours <> ":" <>+ (if minutes < 10 then "0" else mempty) <> intDec minutes <> ":" <>+ (if secondsFixed < 10 then "0" else mempty) <> fromString (showFixed False secondsFixed))++instance HasSqlValueSyntax MysqlValueSyntax LocalTime where+ sqlValueSyntax d = MysqlValueSyntax (emit ("'" <> dayBuilder (localDay d) <>+ " " <> todBuilder (localTimeOfDay d) <> "'"))++instance HasSqlValueSyntax MysqlValueSyntax x => HasSqlValueSyntax MysqlValueSyntax (Maybe x) where+ sqlValueSyntax Nothing = sqlValueSyntax SqlNull+ sqlValueSyntax (Just x) = sqlValueSyntax x++instance HasSqlValueSyntax MysqlValueSyntax A.Value where+ sqlValueSyntax = MysqlValueSyntax . (\x -> emit "'" <> x <> emit "'") . escape . BL.toStrict . A.encode++mysqlCharLen :: Maybe Word -> MysqlSyntax+mysqlCharLen = maybe (emit "MAX") (emit . fromString . show)++mysqlNumPrec :: Maybe (Word, Maybe Word) -> MysqlSyntax+mysqlNumPrec Nothing = mempty+mysqlNumPrec (Just (d, Nothing)) = mysqlParens (emit . fromString . show $ d)+mysqlNumPrec (Just (d, Just n)) = mysqlParens (emit (fromString (show d)) <> emit ", " <> emit (fromString (show n)))++mysqlOptCharSet :: Maybe T.Text -> MysqlSyntax+mysqlOptCharSet Nothing = mempty+mysqlOptCharSet (Just cs) = emit " CHARACTER SET " <> mysqlIdentifier cs
+ LICENSE view
@@ -0,0 +1,8 @@+The MIT License (MIT)+Copyright (c) 2018 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.
+ beam-mysql.cabal view
@@ -0,0 +1,54 @@+name: beam-mysql+version: 0.2.0.0+synopsis: Connection layer between beam and MySQL/MariaDB+description: Beam driver for MySQL or MariaDB databases, two popular open-source databases.++ Supports most beam features, but does not yet have support for "beam-migrate".+homepage: https://github.com/tathougies/beam-mysql+license: MIT+license-file: LICENSE+author: Travis Athougies+maintainer: travis@athougies.net+category: Database+build-type: Simple+cabal-version: 1.18+bug-reports: https://github.com/tathougies/beam-mysql/issues++library+ exposed-modules: Database.Beam.MySQL+ Database.Beam.MySQL.Connection+ Database.Beam.MySQL.Syntax+ Database.Beam.MySQL.FromField+ build-depends: base >=4.7 && <5.0,+ beam-core >=0.8 && <0.9,++ mysql >=0.1 && <0.2,++ text >=1.0 && <1.3,+ bytestring >=0.10 && <0.11,++ attoparsec,+ aeson >=0.11 && <1.5,+ hashable >=1.1 && <1.3,+ time >=1.6 && <1.10,+ mtl >=2.1 && <2.3,+ case-insensitive >=1.2 && <1.3,+ scientific >=0.3 && <0.4,+ free >=4.12 && <5.2,+ network-uri+ default-language: Haskell2010+ default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances,+ DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings,+ CPP, TypeApplications, FlexibleContexts+ ghc-options: -Wall+ if flag(werror)+ ghc-options: -Werror++flag werror+ description: Enable -Werror during development+ default: False+ manual: True++source-repository head+ type: git+ location: https://github.com/tathougies/beam-mysql.git