Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 6e58251b77
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 200 lines (163 sloc) 5.996 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances,
OverloadedStrings #-}

-- |
-- Module: Database.MySQL.Simple.Param
-- Copyright: (c) 2011 MailRank, Inc.
-- License: BSD3
-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
-- Stability: experimental
-- Portability: portable
--
-- The 'Param' typeclass, for rendering a parameter to a SQL query.

module Database.MySQL.Simple.Param
    (
      Action(..)
    , Param(..)
    , inQuotes
    ) where

import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString,
                                 toByteString)
import Blaze.ByteString.Builder.Char8 (fromChar)
import Blaze.Text (integral, double, float)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base16.Lazy as L16
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List (intersperse)
import Data.Monoid (mappend)
import Data.Time.Calendar (Day, showGregorian)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (formatTime)
import Data.Time.LocalTime (TimeOfDay)
import Data.Typeable (Typeable)
import Data.Word (Word, Word8, Word16, Word32, Word64)
import Database.MySQL.Simple.Types (Binary(..), In(..), Null)
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

-- | How to render an element when substituting it into a query.
data Action =
    Plain Builder
    -- ^ Render without escaping or quoting. Use for non-text types
    -- such as numbers, when you are /certain/ that they will not
    -- introduce formatting vulnerabilities via use of characters such
    -- as spaces or \"@'@\".
  | Escape ByteString
    -- ^ Escape and enclose in quotes before substituting. Use for all
    -- text-like types, and anything else that may contain unsafe
    -- characters when rendered.
  | Many [Action]
    -- ^ Concatenate a series of rendering actions.
    deriving (Typeable)

instance Show Action where
    show (Plain b) = "Plain " ++ show (toByteString b)
    show (Escape b) = "Escape " ++ show b
    show (Many b) = "Many " ++ show b

-- | A type that may be used as a single parameter to a SQL query.
class Param a where
    render :: a -> Action
    -- ^ Prepare a value for substitution into a query string.

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 #-}

instance (Param a) => Param (In [a]) where
    render (In []) = Plain $ fromByteString "(null)"
    render (In xs) = Many $
        Plain (fromChar '(') :
        (intersperse (Plain (fromChar ',')) . map render $ xs) ++
        [Plain (fromChar ')')]

instance Param (Binary SB.ByteString) where
    render (Binary bs) = Plain $ fromByteString "x'" `mappend`
                                 fromByteString (B16.encode bs) `mappend`
                                 fromChar '\''

instance Param (Binary LB.ByteString) where
    render (Binary bs) = Plain $ fromByteString "x'" `mappend`
                                 fromLazyByteString (L16.encode bs) `mappend`
                                 fromChar '\''

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 #-}

-- | Surround a string with single-quote characters: \"@'@\"
--
-- This function /does not/ perform any other escaping.
inQuotes :: Builder -> Builder
inQuotes b = quote `mappend` b `mappend` quote
  where quote = Utf8.fromChar '\''
Something went wrong with that request. Please try again.