Permalink
Browse files

Initial commit.

  • Loading branch information...
0 parents commit 147c23e3bd82c0bf5040532dca580eb78bdbd014 @bos bos committed Apr 29, 2011
@@ -0,0 +1,5 @@
+^(?:cabal-dev|dist)$
+\.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp)$
+~$
+syntax: glob
+.\#*
@@ -0,0 +1,60 @@
+module Database.MySQL.Simple
+ (
+ execute
+ , query
+ , formatQuery
+ ) where
+
+import Control.Applicative
+import Data.Int (Int64)
+import Control.Monad.Fix
+import Blaze.ByteString.Builder
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString (ByteString)
+import Data.Monoid
+import Database.MySQL.Base (Connection)
+import qualified Database.MySQL.Base as Base
+import Database.MySQL.Simple.Param
+import Database.MySQL.Simple.QueryParams
+import Database.MySQL.Simple.QueryResults
+import Database.MySQL.Simple.Types
+
+formatQuery :: QueryParams q => Connection -> Query -> q -> IO ByteString
+formatQuery conn (Query template) qs
+ | '?' `B.notElem` template = return template
+ | otherwise =
+ toByteString . zipParams (split template) <$> mapM sub (renderParams qs)
+ where sub (Plain b) = pure b
+ sub (Escape s) = (inQuotes . fromByteString) <$> Base.escape conn s
+ split q = fromByteString h : if B.null t then [] else split (B.tail t)
+ where (h,t) = B.break (=='?') q
+ zipParams (t:ts) (p:ps) = t `mappend` p `mappend` zipParams ts ps
+ zipParams [] [] = mempty
+ zipParams [] _ = fmtError "more parameters than '?' characters"
+ zipParams _ [] = fmtError "more '?' characters than parameters"
+
+execute :: (QueryParams q) => Connection -> Query -> q -> IO Int64
+execute conn template qs = do
+ Base.query conn =<< formatQuery conn template qs
+ ncols <- Base.fieldCount (Left conn)
+ if ncols /= 0
+ then error "execute: executed a select!"
+ else Base.affectedRows conn
+
+query :: (QueryParams q, QueryResults r) => Connection -> Query -> q -> IO [r]
+query conn template qs = do
+ Base.query conn =<< formatQuery conn template qs
+ r <- Base.storeResult conn
+ ncols <- Base.fieldCount (Right r)
+ if ncols == 0
+ then return []
+ else do
+ fs <- Base.fetchFields r
+ flip fix [] $ \loop acc -> do
+ row <- Base.fetchRow r
+ case row of
+ [] -> return (reverse acc)
+ _ -> loop (convertResults fs row:acc)
+
+fmtError :: String -> a
+fmtError msg = error $ "Database.MySQL.formatQuery: " ++ msg
@@ -0,0 +1,143 @@
+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}
+
+module Database.MySQL.Simple.Param
+ (
+ Action(..)
+ , Param(..)
+ , inQuotes
+ ) where
+
+import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
+import Blaze.Text (integral, double, float)
+import Data.ByteString (ByteString)
+import Data.Monoid (mappend)
+import Database.MySQL.Simple.Types (Null)
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Time.Calendar (Day, showGregorian)
+import Data.Time.Clock (UTCTime)
+import Data.Time.LocalTime (TimeOfDay)
+import Data.Time.Format (formatTime)
+import Data.Word (Word, Word8, Word16, Word32, Word64)
+import System.Locale (defaultTimeLocale)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
+import qualified Data.ByteString as SB
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Text as ST
+import qualified Data.Text.Encoding as ST
+import qualified Data.Text.Lazy as LT
+
+data Action = Plain Builder
+ | Escape ByteString
+
+class Param a where
+ render :: a -> Action
+
+instance Param Action where
+ render a = a
+ {-# INLINE render #-}
+
+instance (Param a) => Param (Maybe a) where
+ render Nothing = renderNull
+ render (Just a) = render a
+ {-# INLINE render #-}
+
+renderNull :: Action
+renderNull = Plain (fromByteString "null")
+
+instance Param Null where
+ render _ = renderNull
+ {-# INLINE render #-}
+
+instance Param Bool where
+ render = Plain . integral . fromEnum
+ {-# INLINE render #-}
+
+instance Param Int8 where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Int16 where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Int32 where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Int where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Int64 where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Integer where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Word8 where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Word16 where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Word32 where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Word where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Word64 where
+ render = Plain . integral
+ {-# INLINE render #-}
+
+instance Param Float where
+ render v | isNaN v || isInfinite v = renderNull
+ | otherwise = Plain (float v)
+ {-# INLINE render #-}
+
+instance Param Double where
+ render v | isNaN v || isInfinite v = renderNull
+ | otherwise = Plain (double v)
+ {-# INLINE render #-}
+
+instance Param SB.ByteString where
+ render = Escape
+ {-# INLINE render #-}
+
+instance Param LB.ByteString where
+ render = render . SB.concat . LB.toChunks
+ {-# INLINE render #-}
+
+instance Param ST.Text where
+ render = Escape . ST.encodeUtf8
+ {-# INLINE render #-}
+
+instance Param [Char] where
+ render = Escape . toByteString . Utf8.fromString
+ {-# INLINE render #-}
+
+instance Param LT.Text where
+ render = render . LT.toStrict
+ {-# INLINE render #-}
+
+instance Param UTCTime where
+ render = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T'"
+ {-# INLINE render #-}
+
+instance Param Day where
+ render = Plain . inQuotes . Utf8.fromString . showGregorian
+ {-# INLINE render #-}
+
+instance Param TimeOfDay where
+ render = Plain . inQuotes . Utf8.fromString . show
+ {-# INLINE render #-}
+
+inQuotes :: Builder -> Builder
+inQuotes b = quote `mappend` b `mappend` quote
+ where quote = Utf8.fromChar '\''
@@ -0,0 +1,64 @@
+module Database.MySQL.Simple.QueryParams
+ (
+ QueryParams(..)
+ ) where
+
+import Database.MySQL.Simple.Param
+import Database.MySQL.Simple.Types
+
+class QueryParams a where
+ renderParams :: a -> [Action]
+
+instance QueryParams () where
+ renderParams _ = []
+
+instance (Param a) => QueryParams (Only a) where
+ renderParams (Only v) = [render v]
+
+instance (Param a, Param b) => QueryParams (a,b) where
+ renderParams (a,b) = [render a, render b]
+
+instance (Param a, Param b, Param c) => QueryParams (a,b,c) where
+ renderParams (a,b,c) = [render a, render b, render c]
+
+instance (Param a, Param b, Param c, Param d) => QueryParams (a,b,c,d) where
+ renderParams (a,b,c,d) = [render a, render b, render c, render d]
+
+instance (Param a, Param b, Param c, Param d, Param e)
+ => QueryParams (a,b,c,d,e) where
+ renderParams (a,b,c,d,e) =
+ [render a, render b, render c, render d, render e]
+
+instance (Param a, Param b, Param c, Param d, Param e, Param f)
+ => QueryParams (a,b,c,d,e,f) where
+ renderParams (a,b,c,d,e,f) =
+ [render a, render b, render c, render d, render e, render f]
+
+instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g)
+ => QueryParams (a,b,c,d,e,f,g) where
+ renderParams (a,b,c,d,e,f,g) =
+ [render a, render b, render c, render d, render e, render f, render g]
+
+instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
+ Param h)
+ => QueryParams (a,b,c,d,e,f,g,h) where
+ renderParams (a,b,c,d,e,f,g,h) =
+ [render a, render b, render c, render d, render e, render f, render g,
+ render h]
+
+instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
+ Param h, Param i)
+ => QueryParams (a,b,c,d,e,f,g,h,i) where
+ renderParams (a,b,c,d,e,f,g,h,i) =
+ [render a, render b, render c, render d, render e, render f, render g,
+ render h, render i]
+
+instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
+ Param h, Param i, Param j)
+ => QueryParams (a,b,c,d,e,f,g,h,i,j) where
+ renderParams (a,b,c,d,e,f,g,h,i,j) =
+ [render a, render b, render c, render d, render e, render f, render g,
+ render h, render i, render j]
+
+instance (Param a) => QueryParams [a] where
+ renderParams = map render
@@ -0,0 +1,83 @@
+module Database.MySQL.Simple.QueryResults
+ (
+ QueryResults(..)
+ ) where
+
+import Data.ByteString (ByteString)
+import Database.MySQL.Base.Types
+import Database.MySQL.Simple.Result
+import Database.MySQL.Simple.Types
+
+class QueryResults a where
+ convertResults :: [Field] -> [Maybe ByteString] -> a
+
+instance (Result a) => QueryResults (Only a) where
+ convertResults [fa] [va] = Only (convert fa va)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b) => QueryResults (a,b) where
+ convertResults [fa,fb] [va,vb] = (convert fa va, convert fb vb)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b, Result c) => QueryResults (a,b,c) where
+ convertResults [fa,fb,fc] [va,vb,vc] =
+ (convert fa va, convert fb vb, convert fc vc)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b, Result c, Result d) =>
+ QueryResults (a,b,c,d) where
+ convertResults [fa,fb,fc,fd] [va,vb,vc,vd] =
+ (convert fa va, convert fb vb, convert fc vc, convert fd vd)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b, Result c, Result d, Result e) =>
+ QueryResults (a,b,c,d,e) where
+ convertResults [fa,fb,fc,fd,fe] [va,vb,vc,vd,ve] =
+ (convert fa va, convert fb vb, convert fc vc, convert fd vd,
+ convert fe ve)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b, Result c, Result d, Result e, Result f) =>
+ QueryResults (a,b,c,d,e,f) where
+ convertResults [fa,fb,fc,fd,fe,ff] [va,vb,vc,vd,ve,vf] =
+ (convert fa va, convert fb vb, convert fc vc, convert fd vd,
+ convert fe ve, convert ff vf)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b, Result c, Result d, Result e, Result f,
+ Result g) =>
+ QueryResults (a,b,c,d,e,f,g) where
+ convertResults [fa,fb,fc,fd,fe,ff,fg] [va,vb,vc,vd,ve,vf,vg] =
+ (convert fa va, convert fb vb, convert fc vc, convert fd vd,
+ convert fe ve, convert ff vf, convert fg vg)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b, Result c, Result d, Result e, Result f,
+ Result g, Result h) =>
+ QueryResults (a,b,c,d,e,f,g,h) where
+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh] [va,vb,vc,vd,ve,vf,vg,vh] =
+ (convert fa va, convert fb vb, convert fc vc, convert fd vd,
+ convert fe ve, convert ff vf, convert fg vg, convert fh vh)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b, Result c, Result d, Result e, Result f,
+ Result g, Result h, Result i) =>
+ QueryResults (a,b,c,d,e,f,g,h,i) where
+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi] [va,vb,vc,vd,ve,vf,vg,vh,vi] =
+ (convert fa va, convert fb vb, convert fc vc, convert fd vd,
+ convert fe ve, convert ff vf, convert fg vg, convert fh vh,
+ convert fi vi)
+ convertResults fs vs = convError fs vs
+
+instance (Result a, Result b, Result c, Result d, Result e, Result f,
+ Result g, Result h, Result i, Result j) =>
+ QueryResults (a,b,c,d,e,f,g,h,i,j) where
+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj]
+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj] =
+ (convert fa va, convert fb vb, convert fc vc, convert fd vd,
+ convert fe ve, convert ff vf, convert fg vg, convert fh vh,
+ convert fi vi, convert fj vj)
+ convertResults fs vs = convError fs vs
+
+convError :: [Field] -> [Maybe ByteString] -> a
+convError = error "convError"
Oops, something went wrong.

0 comments on commit 147c23e

Please sign in to comment.