{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
module Database.ODBC.SQLServer
(
Internal.connect
, Internal.close
, Internal.Connection
, exec
, query
, Value(..)
, Query
, ToSql(..)
, FromValue(..)
, FromRow(..)
, Internal.Binary(..)
, Datetime2(..)
, Smalldatetime(..)
, stream
, Internal.Step(..)
, Internal.ODBCException(..)
, renderQuery
) where
import Control.DeepSeq
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Data
import Data.Fixed
import Data.Foldable
import Data.Int
import Data.Monoid (Monoid, (<>))
import Data.Semigroup (Semigroup)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Time
import Data.Word
import Database.ODBC.Conversion
import Database.ODBC.Internal (Value(..), Connection)
import qualified Database.ODBC.Internal as Internal
import qualified Formatting
import Formatting ((%))
import Formatting.Time as Formatting
import GHC.Generics
import Text.Printf
#if MIN_VERSION_base(4,9,0)
import GHC.TypeLits
#endif
newtype Query =
Query (Seq Part)
deriving (Monoid, Eq, Show, Typeable, Ord, Generic, Data, Semigroup)
instance NFData Query
instance IsString Query where
fromString = Query . Seq.fromList . pure . fromString
data Part
= TextPart !Text
| ValuePart !Value
deriving (Eq, Show, Typeable, Ord, Generic, Data)
instance NFData Part
instance IsString Part where
fromString = TextPart . T.pack
newtype Datetime2 = Datetime2
{ unDatetime2 :: LocalTime
} deriving (Eq, Ord, Show, Typeable, Generic, Data, FromValue)
newtype Smalldatetime = Smalldatetime
{ unSmalldatetime :: LocalTime
} deriving (Eq, Ord, Show, Typeable, Generic, Data, FromValue)
class ToSql a where
toSql :: a -> Query
instance ToSql Value where
toSql = Query . Seq.fromList . pure . ValuePart
instance ToSql Text where
toSql = toSql . TextValue
instance ToSql LT.Text where
toSql = toSql . TextValue . LT.toStrict
instance ToSql ByteString where
toSql = toSql . ByteStringValue
instance ToSql Internal.Binary where
toSql = toSql . BinaryValue
instance ToSql L.ByteString where
toSql = toSql . ByteStringValue . L.toStrict
instance ToSql Bool where
toSql = toSql . BoolValue
instance ToSql Double where
toSql = toSql . DoubleValue
instance ToSql Float where
toSql = toSql . FloatValue
instance ToSql Int where
toSql = toSql . IntValue
instance ToSql Int16 where
toSql = toSql . IntValue . fromIntegral
instance ToSql Int32 where
toSql = toSql . IntValue . fromIntegral
instance ToSql Word8 where
toSql = toSql . ByteValue
instance ToSql Day where
toSql = toSql . DayValue
instance ToSql TimeOfDay where
toSql = toSql . TimeOfDayValue
#if MIN_VERSION_base(4,9,0)
instance GHC.TypeLits.TypeError ('GHC.TypeLits.Text "Instance for LocalTime is disabled:" 'GHC.TypeLits.:$$: 'GHC.TypeLits.Text "Wrap your value in either (Datetime2 foo) or (Smalldatetime foo).") =>
ToSql LocalTime where
toSql = toSql
-- | You cannot use this instance. Wrap your value in either
-- 'Datetime2' or 'Smalldatetime'.
instance GHC.TypeLits.TypeError ('GHC.TypeLits.Text "Instance for UTCTime is not possible:" 'GHC.TypeLits.:$$: 'GHC.TypeLits.Text "SQL Server does not support time zones. "'GHC.TypeLits.:$$: 'GHC.TypeLits.Text "You can use utcToLocalTime to make a LocalTime, and" 'GHC.TypeLits.:$$: 'GHC.TypeLits.Text "wrap your value in either (Datetime2 foo) or (Smalldatetime foo).") =>
ToSql UTCTime where
toSql = toSql
#endif
-- | Corresponds to DATETIME/DATETIME2 type of SQL Server.
--
-- The 'Datetime2' type has more accuracy than the @datetime@ type and
-- the @datetime2@ types can hold; so you will lose precision when you
-- insert.
instance ToSql Datetime2 where
toSql = toSql . LocalTimeValue . unDatetime2
-- | Corresponds to SMALLDATETIME type of SQL Server. Precision up to
-- minutes. Consider the seconds field always 0.
instance ToSql Smalldatetime where
toSql = toSql . LocalTimeValue . shrink . unSmalldatetime
where
shrink (LocalTime dd (TimeOfDay hh mm _ss)) =
LocalTime dd (TimeOfDay hh mm 0)
--------------------------------------------------------------------------------
-- Top-level functions
-- | Query and return a list of rows.
--
-- The @row@ type is inferred based on use or type-signature. Examples
-- might be @(Int, Text, Bool)@ for concrete types, or @[Maybe Value]@
-- if you don't know ahead of time how many columns you have and their
-- type. See the top section for example use.
query ::
(MonadIO m, FromRow row)
=> Connection -- ^ A connection to the database.
-> Query -- ^ SQL query.
-> m [row]
query c (Query ps) = do
rows <- Internal.query c (renderParts (toList ps))
case mapM fromRow rows of
Right rows' -> pure rows'
Left e -> liftIO (throwIO (Internal.DataRetrievalError e))
-- | Render a query to a plain text string. Useful for debugging and
-- testing.
renderQuery :: Query -> Text
renderQuery (Query ps) = (renderParts (toList ps))
-- | Stream results like a fold with the option to stop at any time.
stream ::
(MonadUnliftIO m, FromRow row)
=> Connection -- ^ A connection to the database.
-> Query -- ^ SQL query.
-> (state -> row -> m (Internal.Step state))
-- ^ A stepping function that gets as input the current @state@ and
-- a row, returning either a new @state@ or a final @result@.
-> state
-- ^ A state that you can use for the computation. Strictly
-- evaluated each iteration.
-> m state
-- ^ Final result, produced by the stepper function.
stream c (Query ps) cont nil =
Internal.stream
c
(renderParts (toList ps))
(\state row ->
case fromRow row of
Left e -> liftIO (throwIO (Internal.DataRetrievalError e))
Right row' -> cont state row')
nil
-- | Execute a statement on the database.
exec ::
MonadIO m
=> Connection -- ^ A connection to the database.
-> Query -- ^ SQL statement.
-> m ()
exec c (Query ps) = Internal.exec c (renderParts (toList ps))
--------------------------------------------------------------------------------
-- Query building
-- | Convert a list of parts into a query.
renderParts :: [Part] -> Text
renderParts = T.concat . map renderPart
-- | Render a query part to a query.
renderPart :: Part -> Text
renderPart =
\case
TextPart t -> t
ValuePart v -> renderValue v
-- | Render a value to a query.
renderValue :: Value -> Text
renderValue =
\case
TextValue t -> "(N'" <> T.concatMap escapeChar t <> "')"
BinaryValue (Internal.Binary bytes) ->
"0x" <>
T.concat
(map
(Formatting.sformat
(Formatting.left 2 '0' Formatting.%. Formatting.hex))
(S.unpack bytes))
ByteStringValue xs ->
"('" <> T.concat (map escapeChar8 (S.unpack xs)) <> "')"
BoolValue True -> "1"
BoolValue False -> "0"
ByteValue n -> Formatting.sformat Formatting.int n
DoubleValue d -> Formatting.sformat Formatting.float d
FloatValue d -> Formatting.sformat Formatting.float (realToFrac d :: Double)
IntValue d -> Formatting.sformat Formatting.int d
DayValue d -> Formatting.sformat ("'" % Formatting.dateDash % "'") d
TimeOfDayValue (TimeOfDay hh mm ss) ->
Formatting.sformat
("'" % Formatting.left 2 '0' % ":" % Formatting.left 2 '0' % ":" %
Formatting.string %
"'")
hh
mm
(renderFractional ss)
LocalTimeValue (LocalTime d (TimeOfDay hh mm ss)) ->
Formatting.sformat
("'" % Formatting.dateDash % " " % Formatting.left 2 '0' % ":" %
Formatting.left 2 '0' %
":" %
Formatting.string %
"'")
d
hh
mm
(renderFractional ss)
-- | Obviously, this is not fast. But it is correct. A faster version
-- can be written later.
renderFractional :: Pico -> String
renderFractional x = trim (printf "%.7f" (realToFrac x :: Double) :: String)
where
trim s =
reverse (case dropWhile (== '0') (reverse s) of
s'@('.':_) -> '0' : s'
s' -> s')
-- | A very conservative character escape.
escapeChar8 :: Word8 -> Text
escapeChar8 ch =
if allowedChar (toEnum (fromIntegral ch))
then T.singleton (toEnum (fromIntegral ch))
else "'+CHAR(" <> Formatting.sformat Formatting.int ch <> ")+'"
-- | A very conservative character escape.
escapeChar :: Char -> Text
escapeChar ch =
if allowedChar ch
then T.singleton ch
else "'+NCHAR(" <> Formatting.sformat Formatting.int (fromEnum ch) <> ")+'"
-- | Is the character allowed to be printed unescaped? We only print a
-- small subset of ASCII just for visually debugging later
-- on. Everything else is escaped.
allowedChar :: Char -> Bool
allowedChar c = (isAlphaNum c && isAscii c) || elem c (" ,.-_" :: [Char])