Skip to content

Commit 147c23e

Browse files
bosbos
committed
Initial commit.
0 parents  commit 147c23e

11 files changed

+721
-0
lines changed

‎.hgignore

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

‎Database/MySQL/Simple.hs

+60
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,60 @@
1+
module Database.MySQL.Simple
2+
(
3+
execute
4+
, query
5+
, formatQuery
6+
) where
7+
8+
import Control.Applicative
9+
import Data.Int (Int64)
10+
import Control.Monad.Fix
11+
import Blaze.ByteString.Builder
12+
import qualified Data.ByteString.Char8 as B
13+
import Data.ByteString (ByteString)
14+
import Data.Monoid
15+
import Database.MySQL.Base (Connection)
16+
import qualified Database.MySQL.Base as Base
17+
import Database.MySQL.Simple.Param
18+
import Database.MySQL.Simple.QueryParams
19+
import Database.MySQL.Simple.QueryResults
20+
import Database.MySQL.Simple.Types
21+
22+
formatQuery :: QueryParams q => Connection -> Query -> q -> IO ByteString
23+
formatQuery conn (Query template) qs
24+
| '?' `B.notElem` template = return template
25+
| otherwise =
26+
toByteString . zipParams (split template) <$> mapM sub (renderParams qs)
27+
where sub (Plain b) = pure b
28+
sub (Escape s) = (inQuotes . fromByteString) <$> Base.escape conn s
29+
split q = fromByteString h : if B.null t then [] else split (B.tail t)
30+
where (h,t) = B.break (=='?') q
31+
zipParams (t:ts) (p:ps) = t `mappend` p `mappend` zipParams ts ps
32+
zipParams [] [] = mempty
33+
zipParams [] _ = fmtError "more parameters than '?' characters"
34+
zipParams _ [] = fmtError "more '?' characters than parameters"
35+
36+
execute :: (QueryParams q) => Connection -> Query -> q -> IO Int64
37+
execute conn template qs = do
38+
Base.query conn =<< formatQuery conn template qs
39+
ncols <- Base.fieldCount (Left conn)
40+
if ncols /= 0
41+
then error "execute: executed a select!"
42+
else Base.affectedRows conn
43+
44+
query :: (QueryParams q, QueryResults r) => Connection -> Query -> q -> IO [r]
45+
query conn template qs = do
46+
Base.query conn =<< formatQuery conn template qs
47+
r <- Base.storeResult conn
48+
ncols <- Base.fieldCount (Right r)
49+
if ncols == 0
50+
then return []
51+
else do
52+
fs <- Base.fetchFields r
53+
flip fix [] $ \loop acc -> do
54+
row <- Base.fetchRow r
55+
case row of
56+
[] -> return (reverse acc)
57+
_ -> loop (convertResults fs row:acc)
58+
59+
fmtError :: String -> a
60+
fmtError msg = error $ "Database.MySQL.formatQuery: " ++ msg

‎Database/MySQL/Simple/Param.hs

+143
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,143 @@
1+
{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}
2+
3+
module Database.MySQL.Simple.Param
4+
(
5+
Action(..)
6+
, Param(..)
7+
, inQuotes
8+
) where
9+
10+
import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
11+
import Blaze.Text (integral, double, float)
12+
import Data.ByteString (ByteString)
13+
import Data.Monoid (mappend)
14+
import Database.MySQL.Simple.Types (Null)
15+
import Data.Int (Int8, Int16, Int32, Int64)
16+
import Data.Time.Calendar (Day, showGregorian)
17+
import Data.Time.Clock (UTCTime)
18+
import Data.Time.LocalTime (TimeOfDay)
19+
import Data.Time.Format (formatTime)
20+
import Data.Word (Word, Word8, Word16, Word32, Word64)
21+
import System.Locale (defaultTimeLocale)
22+
import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
23+
import qualified Data.ByteString as SB
24+
import qualified Data.ByteString.Lazy as LB
25+
import qualified Data.Text as ST
26+
import qualified Data.Text.Encoding as ST
27+
import qualified Data.Text.Lazy as LT
28+
29+
data Action = Plain Builder
30+
| Escape ByteString
31+
32+
class Param a where
33+
render :: a -> Action
34+
35+
instance Param Action where
36+
render a = a
37+
{-# INLINE render #-}
38+
39+
instance (Param a) => Param (Maybe a) where
40+
render Nothing = renderNull
41+
render (Just a) = render a
42+
{-# INLINE render #-}
43+
44+
renderNull :: Action
45+
renderNull = Plain (fromByteString "null")
46+
47+
instance Param Null where
48+
render _ = renderNull
49+
{-# INLINE render #-}
50+
51+
instance Param Bool where
52+
render = Plain . integral . fromEnum
53+
{-# INLINE render #-}
54+
55+
instance Param Int8 where
56+
render = Plain . integral
57+
{-# INLINE render #-}
58+
59+
instance Param Int16 where
60+
render = Plain . integral
61+
{-# INLINE render #-}
62+
63+
instance Param Int32 where
64+
render = Plain . integral
65+
{-# INLINE render #-}
66+
67+
instance Param Int where
68+
render = Plain . integral
69+
{-# INLINE render #-}
70+
71+
instance Param Int64 where
72+
render = Plain . integral
73+
{-# INLINE render #-}
74+
75+
instance Param Integer where
76+
render = Plain . integral
77+
{-# INLINE render #-}
78+
79+
instance Param Word8 where
80+
render = Plain . integral
81+
{-# INLINE render #-}
82+
83+
instance Param Word16 where
84+
render = Plain . integral
85+
{-# INLINE render #-}
86+
87+
instance Param Word32 where
88+
render = Plain . integral
89+
{-# INLINE render #-}
90+
91+
instance Param Word where
92+
render = Plain . integral
93+
{-# INLINE render #-}
94+
95+
instance Param Word64 where
96+
render = Plain . integral
97+
{-# INLINE render #-}
98+
99+
instance Param Float where
100+
render v | isNaN v || isInfinite v = renderNull
101+
| otherwise = Plain (float v)
102+
{-# INLINE render #-}
103+
104+
instance Param Double where
105+
render v | isNaN v || isInfinite v = renderNull
106+
| otherwise = Plain (double v)
107+
{-# INLINE render #-}
108+
109+
instance Param SB.ByteString where
110+
render = Escape
111+
{-# INLINE render #-}
112+
113+
instance Param LB.ByteString where
114+
render = render . SB.concat . LB.toChunks
115+
{-# INLINE render #-}
116+
117+
instance Param ST.Text where
118+
render = Escape . ST.encodeUtf8
119+
{-# INLINE render #-}
120+
121+
instance Param [Char] where
122+
render = Escape . toByteString . Utf8.fromString
123+
{-# INLINE render #-}
124+
125+
instance Param LT.Text where
126+
render = render . LT.toStrict
127+
{-# INLINE render #-}
128+
129+
instance Param UTCTime where
130+
render = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T'"
131+
{-# INLINE render #-}
132+
133+
instance Param Day where
134+
render = Plain . inQuotes . Utf8.fromString . showGregorian
135+
{-# INLINE render #-}
136+
137+
instance Param TimeOfDay where
138+
render = Plain . inQuotes . Utf8.fromString . show
139+
{-# INLINE render #-}
140+
141+
inQuotes :: Builder -> Builder
142+
inQuotes b = quote `mappend` b `mappend` quote
143+
where quote = Utf8.fromChar '\''

‎Database/MySQL/Simple/QueryParams.hs

+64
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,64 @@
1+
module Database.MySQL.Simple.QueryParams
2+
(
3+
QueryParams(..)
4+
) where
5+
6+
import Database.MySQL.Simple.Param
7+
import Database.MySQL.Simple.Types
8+
9+
class QueryParams a where
10+
renderParams :: a -> [Action]
11+
12+
instance QueryParams () where
13+
renderParams _ = []
14+
15+
instance (Param a) => QueryParams (Only a) where
16+
renderParams (Only v) = [render v]
17+
18+
instance (Param a, Param b) => QueryParams (a,b) where
19+
renderParams (a,b) = [render a, render b]
20+
21+
instance (Param a, Param b, Param c) => QueryParams (a,b,c) where
22+
renderParams (a,b,c) = [render a, render b, render c]
23+
24+
instance (Param a, Param b, Param c, Param d) => QueryParams (a,b,c,d) where
25+
renderParams (a,b,c,d) = [render a, render b, render c, render d]
26+
27+
instance (Param a, Param b, Param c, Param d, Param e)
28+
=> QueryParams (a,b,c,d,e) where
29+
renderParams (a,b,c,d,e) =
30+
[render a, render b, render c, render d, render e]
31+
32+
instance (Param a, Param b, Param c, Param d, Param e, Param f)
33+
=> QueryParams (a,b,c,d,e,f) where
34+
renderParams (a,b,c,d,e,f) =
35+
[render a, render b, render c, render d, render e, render f]
36+
37+
instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g)
38+
=> QueryParams (a,b,c,d,e,f,g) where
39+
renderParams (a,b,c,d,e,f,g) =
40+
[render a, render b, render c, render d, render e, render f, render g]
41+
42+
instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
43+
Param h)
44+
=> QueryParams (a,b,c,d,e,f,g,h) where
45+
renderParams (a,b,c,d,e,f,g,h) =
46+
[render a, render b, render c, render d, render e, render f, render g,
47+
render h]
48+
49+
instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
50+
Param h, Param i)
51+
=> QueryParams (a,b,c,d,e,f,g,h,i) where
52+
renderParams (a,b,c,d,e,f,g,h,i) =
53+
[render a, render b, render c, render d, render e, render f, render g,
54+
render h, render i]
55+
56+
instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
57+
Param h, Param i, Param j)
58+
=> QueryParams (a,b,c,d,e,f,g,h,i,j) where
59+
renderParams (a,b,c,d,e,f,g,h,i,j) =
60+
[render a, render b, render c, render d, render e, render f, render g,
61+
render h, render i, render j]
62+
63+
instance (Param a) => QueryParams [a] where
64+
renderParams = map render

‎Database/MySQL/Simple/QueryResults.hs

+83
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,83 @@
1+
module Database.MySQL.Simple.QueryResults
2+
(
3+
QueryResults(..)
4+
) where
5+
6+
import Data.ByteString (ByteString)
7+
import Database.MySQL.Base.Types
8+
import Database.MySQL.Simple.Result
9+
import Database.MySQL.Simple.Types
10+
11+
class QueryResults a where
12+
convertResults :: [Field] -> [Maybe ByteString] -> a
13+
14+
instance (Result a) => QueryResults (Only a) where
15+
convertResults [fa] [va] = Only (convert fa va)
16+
convertResults fs vs = convError fs vs
17+
18+
instance (Result a, Result b) => QueryResults (a,b) where
19+
convertResults [fa,fb] [va,vb] = (convert fa va, convert fb vb)
20+
convertResults fs vs = convError fs vs
21+
22+
instance (Result a, Result b, Result c) => QueryResults (a,b,c) where
23+
convertResults [fa,fb,fc] [va,vb,vc] =
24+
(convert fa va, convert fb vb, convert fc vc)
25+
convertResults fs vs = convError fs vs
26+
27+
instance (Result a, Result b, Result c, Result d) =>
28+
QueryResults (a,b,c,d) where
29+
convertResults [fa,fb,fc,fd] [va,vb,vc,vd] =
30+
(convert fa va, convert fb vb, convert fc vc, convert fd vd)
31+
convertResults fs vs = convError fs vs
32+
33+
instance (Result a, Result b, Result c, Result d, Result e) =>
34+
QueryResults (a,b,c,d,e) where
35+
convertResults [fa,fb,fc,fd,fe] [va,vb,vc,vd,ve] =
36+
(convert fa va, convert fb vb, convert fc vc, convert fd vd,
37+
convert fe ve)
38+
convertResults fs vs = convError fs vs
39+
40+
instance (Result a, Result b, Result c, Result d, Result e, Result f) =>
41+
QueryResults (a,b,c,d,e,f) where
42+
convertResults [fa,fb,fc,fd,fe,ff] [va,vb,vc,vd,ve,vf] =
43+
(convert fa va, convert fb vb, convert fc vc, convert fd vd,
44+
convert fe ve, convert ff vf)
45+
convertResults fs vs = convError fs vs
46+
47+
instance (Result a, Result b, Result c, Result d, Result e, Result f,
48+
Result g) =>
49+
QueryResults (a,b,c,d,e,f,g) where
50+
convertResults [fa,fb,fc,fd,fe,ff,fg] [va,vb,vc,vd,ve,vf,vg] =
51+
(convert fa va, convert fb vb, convert fc vc, convert fd vd,
52+
convert fe ve, convert ff vf, convert fg vg)
53+
convertResults fs vs = convError fs vs
54+
55+
instance (Result a, Result b, Result c, Result d, Result e, Result f,
56+
Result g, Result h) =>
57+
QueryResults (a,b,c,d,e,f,g,h) where
58+
convertResults [fa,fb,fc,fd,fe,ff,fg,fh] [va,vb,vc,vd,ve,vf,vg,vh] =
59+
(convert fa va, convert fb vb, convert fc vc, convert fd vd,
60+
convert fe ve, convert ff vf, convert fg vg, convert fh vh)
61+
convertResults fs vs = convError fs vs
62+
63+
instance (Result a, Result b, Result c, Result d, Result e, Result f,
64+
Result g, Result h, Result i) =>
65+
QueryResults (a,b,c,d,e,f,g,h,i) where
66+
convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi] [va,vb,vc,vd,ve,vf,vg,vh,vi] =
67+
(convert fa va, convert fb vb, convert fc vc, convert fd vd,
68+
convert fe ve, convert ff vf, convert fg vg, convert fh vh,
69+
convert fi vi)
70+
convertResults fs vs = convError fs vs
71+
72+
instance (Result a, Result b, Result c, Result d, Result e, Result f,
73+
Result g, Result h, Result i, Result j) =>
74+
QueryResults (a,b,c,d,e,f,g,h,i,j) where
75+
convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj]
76+
[va,vb,vc,vd,ve,vf,vg,vh,vi,vj] =
77+
(convert fa va, convert fb vb, convert fc vc, convert fd vd,
78+
convert fe ve, convert ff vf, convert fg vg, convert fh vh,
79+
convert fi vi, convert fj vj)
80+
convertResults fs vs = convError fs vs
81+
82+
convError :: [Field] -> [Maybe ByteString] -> a
83+
convError = error "convError"

0 commit comments

Comments
 (0)