add types and instances for converting json <-> sql

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

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