WIP: More files converted to Hasql

dbapi.cabal

@@ -36,7 +36,9 @@ executable dbapi
                      , network-uri >= 2.6
                      , resource-pool, process
                      , blaze-builder
+                     , vector
   Other-Modules:       App
+                     , Auth
                      , Config
                      , PgStructure
                      , PgQuery
@@ -52,7 +54,7 @@ Test-Suite spec
   Hs-Source-Dirs:      test, src
   ghc-options:         -Wall -W -Werror
   Main-Is:             Main.hs
-  Other-Modules:       App, Config, Spec, SpecHelper
+  Other-Modules:       App, Auth, Config, Spec, SpecHelper
   Build-Depends:       base, hspec2, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
                      , hasql, hasql-backend, hasql-postgres
@@ -78,3 +80,4 @@ Test-Suite spec
                      , network-uri >= 2.6
                      , resource-pool
                      , blaze-builder
+                     , vector

src/App.hs

@@ -23,7 +23,6 @@ import Network.HTTP.Base (urlEncodeVars)
 import Network.Wai
 
 import Data.Aeson
-import Database.PostgreSQL.Simple
 import qualified Hasql as H
 import qualified Hasql.Postgres as H
 

src/Auth.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-}
 module Auth where
 
 import qualified Data.Aeson as JSON
@@ -7,7 +8,6 @@ import Control.Applicative ( (<*>), (<$>) )
 import Crypto.BCrypt
 import qualified Hasql as H
 import qualified Hasql.Postgres as H
-import GHC.Int
 
 data AuthUser = AuthUser {
     userId :: String
@@ -20,7 +20,7 @@ instance JSON.FromJSON AuthUser where
                          v JSON..: "id" <*>
                          v JSON..: "pass" <*>
                          v JSON..: "role"
-  parseJSON _          = mzero
+  parseJSON _ = mzero
 
 type DbRole = BS.ByteString
 
@@ -34,25 +34,25 @@ data LoginAttempt =
 checkPass :: BS.ByteString -> BS.ByteString -> Bool
 checkPass = validatePassword
 
-setRole :: Connection -> DbRole -> IO Int64
+setRole :: BS.ByteString -> H.Tx H.Postgres s ()
-setRole conn role = execute conn "set role ?" (Only role)
+setRole role = H.unit $ [H.q| set role ?|] role
 
-resetRole :: Connection -> IO Int64
+resetRole :: H.Tx H.Postgres s ()
-resetRole = flip execute_ "reset role"
+resetRole = H.unit [H.q|reset role|]
 
-addUser :: Connection -> BS.ByteString -> BS.ByteString -> BS.ByteString -> IO Int64
+addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> IO(H.Tx H.Postgres s ())
-addUser c identity pass role = do
+addUser identity pass role = do
   Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy pass
-  execute c
+  return $ H.unit $
-    "insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)"
+    [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|]
-    (identity, hashed, role)
+      identity hashed role
 
-signInRole :: Connection -> BS.ByteString -> BS.ByteString -> IO LoginAttempt
+signInRole :: BS.ByteString -> BS.ByteString -> H.Tx H.Postgres s LoginAttempt
-signInRole c user pass = do
+signInRole user pass = do
-  u <- query c "select pass, rolname from dbapi.auth where id = ?" $ Only user
+  u <- H.single $ [H.q|select pass, rolname from dbapi.auth where id = ?|] user
-  return $ case u of
+  return $ maybe LoginFailed (\r ->
-    [[hashed, role]] ->
+      let (hashed, role) = r in
       if checkPass hashed pass
          then LoginSuccess role
          else LoginFailed
-    _ -> LoginFailed
+    ) u

src/PgQuery.hs

@@ -1,22 +1,21 @@
 module PgQuery where
 
 import RangeQuery
-import qualified Hasql as H
+
 import qualified Hasql.Postgres as H
 import qualified Hasql.Backend as H
+
 import Data.Text hiding (map)
-import Text.Regex.TDFA
+import Text.Regex.TDFA ( (=~) )
-import Text.Regex.TDFA.Text
+import Text.Regex.TDFA.Text ()
 import qualified Data.ByteString.Char8 as BS
-import Data.ByteString.Search (split)
 import qualified Network.HTTP.Types.URI as Net
-import Blaze.ByteString.Builder.ByteString (fromByteString)
 import Data.Monoid
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Functor ( (<$>) )
 import Control.Monad (join)
 import Data.String.Conversions (cs)
-import Data.Aeson (Value(..), encode)
+import qualified Data.Aeson as JSON
 import qualified Data.List as L
 
 type StatementT = H.Statement H.Postgres -> H.Statement H.Postgres
@@ -54,8 +53,8 @@ orderT ts q =
   where
    clause = mconcat $ L.intersperse commaq (map queryTerm ts)
    queryTerm :: OrderTerm -> H.Statement H.Postgres
-   queryTerm t = (" " <> (pgFmtIdent $ otTerm t) <> " "
+   queryTerm t = (" " <> pgFmtIdent (otTerm t) <> " "
-                      <> otDirection t           <> " "
+                      <> otDirection t         <> " "
                   , [])
 
 parentheticT :: StatementT
@@ -83,7 +82,7 @@ selectStar :: QualifiedTable -> H.Statement H.Postgres
 selectStar t =
   ("select * from " <> fromQt t, [])
 
-insertInto :: QualifiedTable -> [BS.ByteString] -> [Value] ->
+insertInto :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] ->
               H.Statement H.Postgres
 insertInto t [] _ =
   ("insert into " <> fromQt t <> " default values returning *", [])
@@ -93,26 +92,22 @@ insertInto t cols vals =
     ") values (" <>
     BS.intercalate ", " (map (const "?") vals) <>
     ") returning *"
-  , vals
+  , map pgParam vals
   )
 
-rawJsonValue :: Value -> BS.ByteString
+update :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] ->
-rawJsonValue (String s) = cs s
-rawJsonValue v = cs $ encode v
-
-update :: QualifiedTable -> [BS.ByteString] -> [Value] ->
           H.Statement H.Postgres
 update t cols vals =
   ("update " <> fromQt t <> " set (" <>
     BS.intercalate ", " (map pgFmtIdent cols) <>
     ") = (" <>
     BS.intercalate ", " (map (const "?") vals) <> ")"
-  , vals
+  , map pgParam vals
   )
 
 wherePred :: Net.QueryItem -> H.Statement H.Postgres
 wherePred (col, predicate) =
-  (" " <> pgFmtIdent col <> " " <> op <> " ? ", [value])
+  (" " <> pgFmtIdent col <> " " <> op <> " ? ", [H.renderValue value])
 
   where
     opCode:rest = BS.split '.' $ fromMaybe "." predicate
@@ -128,13 +123,13 @@ wherePred (col, predicate) =
 
 orderParse :: Net.Query -> [OrderTerm]
 orderParse q =
-  mapMaybe orderParseTerm . BS.split "," $ cs order
+  mapMaybe orderParseTerm . BS.split ',' $ cs order
   where
     order = fromMaybe "" $ join (lookup "order" q)
 
 orderParseTerm :: BS.ByteString -> Maybe OrderTerm
 orderParseTerm s =
-  case BS.split "." s of
+  case BS.split '.' s of
        [d,c] ->
          if d `elem` ["asc", "desc"]
             then Just $ OrderTerm (cs c) $
@@ -171,3 +166,11 @@ trimNullChars = Data.Text.takeWhile (/= '\x0')
 
 fromQt :: QualifiedTable -> BS.ByteString
 fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
+
+pgParam :: JSON.Value -> H.StatementArgument H.Postgres
+pgParam (JSON.Number n) = H.renderValue n
+pgParam (JSON.String s) = H.renderValue s
+pgParam (JSON.Bool      b) = H.renderValue b
+pgParam JSON.Null       = H.renderValue (Nothing :: Maybe String)
+pgParam (JSON.Object o) = H.renderValue $ JSON.encode o
+pgParam (JSON.Array  a) = H.renderValue $ JSON.encode a

src/PgStructure.hs

@@ -1,23 +1,27 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes, MultiParamTypeClasses, ScopedTypeVariables #-}
 module PgStructure where
 
 import PgQuery (QualifiedTable(..))
 import Data.Functor ( (<$>) )
 import Data.Text hiding (foldl, map, zipWith, concat)
 import Data.Aeson
+import Data.Functor.Identity
+import qualified Data.Vector as V
+import qualified Data.ByteString.Char8 as BS
+import Data.String.Conversions (cs)
 
 import Control.Applicative ( (<*>) )
 
 import qualified Data.List as L
 import qualified Data.Map as Map
 
-import Database.PostgreSQL.Simple
+import qualified Hasql as H
-import Database.PostgreSQL.Simple.SqlQQ
+import qualified Hasql.Backend as H
-import Database.PostgreSQL.Simple.FromRow
+import qualified Hasql.Postgres as H
 
-foreignKeys :: Connection -> QualifiedTable -> IO (Map.Map Text ForeignKey)
+foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map BS.ByteString ForeignKey)
-foreignKeys c table = do
+foreignKeys table = do
-  r <- query c [sql|
+  r :: [(BS.ByteString, BS.ByteString, BS.ByteString)] <- H.list $ [H.q|
       select kcu.column_name, ccu.table_name AS foreign_table_name,
         ccu.column_name AS foreign_column_name
       from information_schema.table_constraints AS tc
@@ -28,29 +32,27 @@ foreignKeys c table = do
       where constraint_type = 'FOREIGN KEY'
         and tc.table_name=? and tc.table_schema = ?
         order by kcu.column_name
-    |]
+    |] (qtName table) (qtSchema table)
-    (qtName table, qtSchema table)
 
   return $ foldl addKey Map.empty r
   where
-    addKey m [col, ftab, fcol] = Map.insert col (ForeignKey ftab fcol) m
+    addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m
-    addKey _ _ = error "foreignKeys: should never happen"
 
 
-tables :: Connection -> Text -> IO [Table]
+tables :: BS.ByteString -> H.Tx H.Postgres s [Table]
-tables c schema =
+tables schema =
-  query c [sql|
+  H.list $ [H.q|
       select table_schema, table_name,
              is_insertable_into
         from information_schema.tables
        where table_schema = ?
        order by table_name
-    |] $ Only schema
+    |] schema
 
 
-columns :: Connection -> QualifiedTable -> IO [Column]
+columns :: QualifiedTable -> H.Tx H.Postgres s [Column]
-columns c table = do
+columns table = do
-  cols <- query c [sql|
+  cols <- H.list $ [H.q|
     select info.table_schema as schema, info.table_name as table_name,
            info.column_name as name, info.ordinal_position as position,
            info.is_nullable as nullable, info.data_type as col_type,
@@ -77,15 +79,15 @@ columns c table = do
          group by s, n
        ) as enum_info
        on (info.udt_name = enum_info.n)
-    order by position |] (qtSchema table, qtName table)
+    order by position |] (qtSchema table) (qtName table)
 
-  fks <- foreignKeys c table
+  fks <- foreignKeys table
-  return $ map (\col -> col { colFK = Map.lookup (colName col) fks }) cols
+  return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols
 
 
-primaryKeyColumns :: Connection -> QualifiedTable -> IO [Text]
+primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [BS.ByteString]
-primaryKeyColumns c table = do
+primaryKeyColumns table = do
-  r <- query c [sql|
+  r :: [Identity BS.ByteString] <- H.list $ [H.q|
     select kc.column_name
       from
         information_schema.table_constraints tc,
@@ -95,28 +97,22 @@ primaryKeyColumns c table = do
       and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema
       and kc.constraint_name = tc.constraint_name
       and kc.table_schema = ?
-      and kc.table_name  = ? |] (qtSchema table, qtName table)
+      and kc.table_name  = ? |] (qtSchema table) (qtName table)
-  return $ concat r
+  return $ map runIdentity r
 
 
-data Table = Table {
+-- instance FromRow Table where
-  tableSchema :: Text
+--   fromRow = Table <$> field <*> field <*> (toBool <$> field)
-, tableName :: Text
-, tableInsertable :: Bool
-} deriving (Show)
 
-instance FromRow Table where
+-- instance FromRow Column where
-  fromRow = Table <$> field <*> field <*> (toBool <$> field)
+--   fromRow = Column <$>
-
+--     field <*> field <*> field <*> field
-instance FromRow Column where
+--     <*> (toBool <$> field)
-  fromRow = Column <$>
+--     <*> field
-    field <*> field <*> field <*> field
+--     <*> (toBool <$> field)
-    <*> (toBool <$> field)
+--     <*> field <*> field <*> field
-    <*> field
+--     <*> (vanishNull . splitOn "," <$> field)
-    <*> (toBool <$> field)
+--     <*> return Nothing
-    <*> field <*> field <*> field
-    <*> (vanishNull . splitOn "," <$> field)
-    <*> return Nothing
 
 vanishNull :: [a] -> Maybe [a]
 vanishNull xs = if L.null xs then Nothing else Just xs
@@ -124,6 +120,12 @@ vanishNull xs = if L.null xs then Nothing else Just xs
 toBool :: Text -> Bool
 toBool = (== "YES")
 
+data Table = Table {
+  tableSchema :: Text
+, tableName :: Text
+, tableInsertable :: Bool
+} deriving (Show)
+
 data ForeignKey = ForeignKey {
   fkTable::Text, fkCol::Text
 } deriving (Eq, Show)
@@ -143,6 +145,35 @@ data Column = Column {
 , colFK :: Maybe ForeignKey
 } deriving (Show)
 
+instance H.RowParser H.Postgres Column where
+  parseRow r =
+    let schema     = H.parseResult $ r V.! 0
+        table      = H.parseResult $ r V.! 1
+        name       = H.parseResult $ r V.! 2
+        position   = H.parseResult $ r V.! 3
+        nullable   = H.parseResult $ r V.! 4
+        typ        = H.parseResult $ r V.! 5
+        updatable  = H.parseResult $ r V.! 6
+        maxLen     = H.parseResult $ r V.! 7
+        precision  = H.parseResult $ r V.! 8
+        defValue   = H.parseResult $ r V.! 9
+        enum       = H.parseResult $ r V.! 10 in
+    if V.length r /= 11
+       then Left "Wrong number of fields in Column"
+       else Column <$> schema <*> table <*> name <*> position <*> nullable
+                   <*> typ <*> updatable <*> maxLen <*> precision
+                   <*> defValue <*> enum <*> return Nothing
+
+
+instance H.RowParser H.Postgres Table where
+  parseRow r =
+    let schema     = H.parseResult $ r V.! 0
+        name       = H.parseResult $ r V.! 2
+        insertable = H.parseResult $ r V.! 3 in
+    if V.length r /= 3
+       then Left "Wrong number of fields in Table"
+       else Table <$> schema <*> name <*> insertable
+
 instance ToJSON Column where
   toJSON c = object [
       "schema"    .= colSchema c

src/Types.hs

@@ -9,7 +9,6 @@ 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