From 5befd3dd8b49745dcaa15a90967e3d879a2fc1cc Mon Sep 17 00:00:00 2001
From: "Adam C. Baker" <adam.durandal@gmail.com>
Date: Thu, 7 Aug 2014 02:04:25 -0700
Subject: [PATCH] add types and instances for converting json <-> sql

---
 Types.hs    | 56 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 dbapi.cabal |  3 ++-
 2 files changed, 58 insertions(+), 1 deletion(-)
 create mode 100644 Types.hs

diff --git a/Types.hs b/Types.hs
new file mode 100644
index 000000000..446492e02
--- /dev/null
+++ b/Types.hs
@@ -0,0 +1,56 @@
+module Types(SqlRow(SqlRow), getRow) where
+
+import Database.HDBC (toSql, SqlValue(..))
+
+import qualified Data.Aeson as JSON
+import Data.Aeson.Types (Parser)
+
+import Data.Scientific (toRealFloat)
+import Data.HashMap.Strict (foldlWithKey')
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Time.Calendar (showGregorian)
+
+import Control.Monad(mzero)
+
+instance JSON.FromJSON SqlValue where
+  parseJSON (JSON.String s) = return $ toSql s
+  parseJSON (JSON.Number n) = return $ toSql (toRealFloat n::Double)
+  parseJSON (JSON.Bool   b) = return $ toSql b
+  parseJSON JSON.Null       = return SqlNull
+  parseJSON (JSON.Object o) = return . toSql $ JSON.encode o
+  parseJSON (JSON.Array  a) = return . toSql $ JSON.encode a
+
+instance JSON.ToJSON SqlValue where
+  toJSON (SqlString s)     = JSON.toJSON s
+  toJSON (SqlByteString s) = JSON.toJSON $ decodeUtf8 s
+  toJSON (SqlWord32 w)     = JSON.toJSON w
+  toJSON (SqlWord64 w)     = JSON.toJSON w
+  toJSON (SqlInt32 i)      = JSON.toJSON i
+  toJSON (SqlInt64 i)      = JSON.toJSON i
+  toJSON (SqlInteger i)    = JSON.toJSON i
+  toJSON (SqlChar c)       = JSON.toJSON c
+  toJSON (SqlBool b)       = JSON.toJSON b
+  toJSON (SqlDouble n)     = JSON.toJSON n
+  toJSON (SqlRational n)   = JSON.toJSON n
+  toJSON (SqlLocalDate d)  = JSON.toJSON $ showGregorian d
+  toJSON (SqlLocalTimeOfDay t) = JSON.toJSON $ show t
+  toJSON (SqlLocalTime t)  = JSON.toJSON $ show t
+  toJSON SqlNull = JSON.Null
+  {-toJSON (SqlZonedLocalTimeOfDay t tz)-}
+  {-toJSON (SqlZonedTime t)-}
+  {-toJSON (SqlDiffTime t)-}
+  {-toJSON (SqlPOSIXTime t)-}
+  toJSON x = JSON.toJSON $ show x
+
+
+newtype SqlRow = SqlRow {getRow :: [(Text, SqlValue)] }
+instance JSON.FromJSON SqlRow where
+  parseJSON (JSON.Object m) = foldlWithKey' add (return $ SqlRow []) m
+    where
+      add :: Parser SqlRow -> Text -> JSON.Value -> Parser SqlRow
+      add parser k v = do
+        SqlRow l <- parser
+        sqlV <- JSON.parseJSON v
+        return . SqlRow $ (k, sqlV) : l
+  parseJSON _ = mzero
diff --git a/dbapi.cabal b/dbapi.cabal
index a6818d129..f5f0fa32b 100644
--- a/dbapi.cabal
+++ b/dbapi.cabal
@@ -19,7 +19,8 @@ executable dbapi
   other-extensions:    OverloadedStrings
   build-depends:       base >=4.6 && <5
                      , HDBC, HDBC-postgresql
-                     , warp, wai, http-types
+                     , warp, wai >= 3.0.1 && < 3.0.2
+                     , http-types, scientific, time
                      , bytestring, aeson, network
                      , text, optparse-applicative
                      , unordered-containers