Initial commit.

.hgignore

@@ -0,0 +1,5 @@
+^(?:cabal-dev|dist)$
+\.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp)$
+~$
+syntax: glob
+.\#*

Database/MySQL/Simple.hs

@@ -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

Database/MySQL/Simple/Param.hs

@@ -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 '\''

Database/MySQL/Simple/QueryParams.hs

@@ -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

Database/MySQL/Simple/QueryResults.hs

@@ -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"