Use Text for textual data

Also upgrade Hasql

dbapi.cabal

@@ -16,7 +16,7 @@ executable dbapi
   default-extensions:  OverloadedStrings
   other-extensions:    QuasiQuotes
   build-depends:       base >=4.6 && <5
-                     , hasql, hasql-backend, hasql-postgres
+                     , hasql >= 0.2.0, hasql-backend, hasql-postgres
                      , warp >= 3.0.2, wai >= 3.0.1
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
@@ -34,7 +34,7 @@ executable dbapi
                      , transformers
                      , bcrypt, base64-string
                      , network-uri >= 2.6
-                     , resource-pool, process
+                     , resource-pool
                      , blaze-builder
                      , vector
                      , mtl
@@ -58,7 +58,7 @@ Test-Suite spec
   Other-Modules:       App, Auth, Config, Spec, SpecHelper
   Build-Depends:       base, hspec >= 2.0, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
-                     , hasql, hasql-backend, hasql-postgres
+                     , hasql >= 0.2.0, hasql-backend, hasql-postgres
                      , warp >= 3.0.2, wai >= 3.0.1
                      , HTTP, convertible
                      , case-insensitive

src/App.hs

@@ -2,7 +2,6 @@
 module App (app) where
 
 import Control.Monad (join)
-import Data.Monoid ( (<>) )
 import Control.Arrow ((***))
 import Control.Applicative
 import Control.Monad.IO.Class (liftIO, MonadIO)
@@ -13,7 +12,6 @@ import Text.Regex.TDFA ((=~))
 import Data.Ord (comparing)
 import Data.Ranged.Ranges (emptyRange)
 import Data.HashMap.Strict (keys, elems, filterWithKey, toList)
-import Data.ByteString.Char8 hiding (zip, map, elem)
 import Data.String.Conversions (cs)
 import Data.List (sortBy)
 import qualified Data.Set as S
@@ -25,6 +23,8 @@ import Network.HTTP.Base (urlEncodeVars)
 import Network.Wai
 
 import Data.Aeson
+import Data.Coerce
+import Data.Monoid
 import qualified Hasql as H
 import qualified Hasql.Postgres as H
 
@@ -53,8 +53,8 @@ app req =
       then return $ responseLBS status416 [] "HTTP Range error"
       else do
         let qt = QualifiedTable schema (cs table)
-        let select =
+        let select = coerce $
-              ("select ",[]) <>
+              ("select ",[],mempty) <>
                   parentheticT (
                     whereT qq $ countRows qt
                   ) <> commaq <> (
@@ -102,7 +102,7 @@ app req =
     ([table], "POST") ->
       handleJsonObj req $ \obj -> H.tx Nothing $ do
         let qt = QualifiedTable schema (cs table)
-        H.unit $ insertInto qt (map cs $ keys obj) (elems obj)
+        H.unit . coerce $ insertInto qt (map cs $ keys obj) (elems obj)
         primaryKeys <- map cs <$> primaryKeyColumns qt
         let primaries = filterWithKey (const . (`elem` primaryKeys)) obj
         let params = urlEncodeVars
@@ -126,7 +126,7 @@ app req =
             let cols = map cs $ keys obj
             if S.fromList tableCols == S.fromList cols then do
               let vals = elems obj
-              H.unit $ iffNotT
+              H.unit . coerce $ iffNotT
                       (whereT qq $ update qt cols vals)
                       (insertInto qt cols vals)
               return $ responseLBS status204 [ jsonH ] ""
@@ -140,6 +140,7 @@ app req =
      handleJsonObj req $ \obj -> H.tx Nothing $ do
         let qt = QualifiedTable schema (cs table)
         H.unit
+          $ coerce
           $ whereT qq
           $ update qt (map cs $ keys obj) (elems obj)
         return $ responseLBS status204 [ jsonH ] ""
@@ -173,15 +174,15 @@ contentRangeH from to total =
        <> cs (show total)
   )
 
-requestedSchema :: RequestHeaders -> ByteString
+requestedSchema :: RequestHeaders -> Text
 requestedSchema hdrs =
   case verStr of
        Just [[_, ver]] -> ver
        _ -> "1"
 
   where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
-        accept = lookup hAccept hdrs :: Maybe ByteString
+        accept = cs <$> lookup hAccept hdrs :: Maybe Text
-        verStr = (=~ verRegex) <$> accept :: Maybe [[ByteString]]
+        verStr = (=~ verRegex) <$> accept :: Maybe [[Text]]
 
 jsonH :: Header
 jsonH = (hContentType, "application/json")

src/Auth.hs

@@ -2,12 +2,13 @@
 module Auth where
 
 import qualified Data.Aeson as JSON
-import qualified Data.ByteString.Char8 as BS
 import Control.Monad (mzero)
 import Control.Applicative ( (<*>), (<$>) )
 import Crypto.BCrypt
+import Data.Text
 import qualified Hasql as H
 import qualified Hasql.Postgres as H
+import Data.String.Conversions (cs)
 
 data AuthUser = AuthUser {
     userId :: String
@@ -22,7 +23,7 @@ instance JSON.FromJSON AuthUser where
                          v JSON..: "role"
   parseJSON _ = mzero
 
-type DbRole = BS.ByteString
+type DbRole = Text
 
 data LoginAttempt =
     NoCredentials
@@ -31,23 +32,23 @@ data LoginAttempt =
   | LoginSuccess DbRole
   deriving (Eq, Show)
 
-checkPass :: BS.ByteString -> BS.ByteString -> Bool
+checkPass :: Text -> Text -> Bool
-checkPass = validatePassword
+checkPass = (. cs) . validatePassword . cs
 
-setRole :: BS.ByteString -> H.Tx H.Postgres s ()
+setRole :: Text -> H.Tx H.Postgres s ()
 setRole role = H.unit $ [H.q| set role ?|] role
 
 resetRole :: H.Tx H.Postgres s ()
 resetRole = H.unit [H.q|reset role|]
 
-addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> IO(H.Tx H.Postgres s ())
+addUser :: Text -> Text -> Text -> IO(H.Tx H.Postgres s ())
 addUser identity pass role = do
-  Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy pass
+  Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
   return $ H.unit $
     [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|]
       identity hashed role
 
-signInRole :: BS.ByteString -> BS.ByteString -> H.Tx H.Postgres s LoginAttempt
+signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt
 signInRole user pass = do
   u <- H.single $ [H.q|select pass, rolname from dbapi.auth where id = ?|] user
   return $ maybe LoginFailed (\r ->

src/PgQuery.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
 module PgQuery where
 
 import RangeQuery
@@ -8,8 +9,8 @@ import qualified Hasql.Backend as H
 import Data.Text hiding (map)
 import Text.Regex.TDFA ( (=~) )
 import Text.Regex.TDFA.Text ()
-import qualified Data.ByteString.Char8 as BS
 import qualified Network.HTTP.Types.URI as Net
+import qualified Data.ByteString.Char8 as BS
 import Data.Monoid
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Functor ( (<$>) )
@@ -18,29 +19,32 @@ import Data.String.Conversions (cs)
 import qualified Data.Aeson as JSON
 import qualified Data.List as L
 
-type StatementT = H.Statement H.Postgres -> H.Statement H.Postgres
+type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All)
+
+type StatementT = DynamicSQL -> DynamicSQL
+
 data QualifiedTable = QualifiedTable {
-  qtSchema :: BS.ByteString
+  qtSchema :: Text
-, qtName   :: BS.ByteString
+, qtName   :: Text
 } deriving (Show)
 
 data OrderTerm = OrderTerm {
-  otTerm :: BS.ByteString
+  otTerm :: Text
 , otDirection :: BS.ByteString
 }
 
 limitT :: Maybe NonnegRange -> StatementT
 limitT r q =
-  q <> (" LIMIT " <> limit <> " OFFSET " <> (cs . show) offset <> " ", [])
+  q <> (" LIMIT " <> limit <> " OFFSET " <> offset <> " ", [], mempty)
   where
-    limit  = cs $ fromMaybe "ALL" $ show . rangeLimit <$> r
+    limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
-    offset = fromMaybe 0     $ rangeOffset <$> r
+    offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
 
 whereT :: Net.Query -> StatementT
 whereT params q =
  if L.null params
    then q
-   else q <> (" where ",[]) <> conjunction
+   else q <> (" where ",[],mempty) <> conjunction
  where
    cols = [ col | col <- params, fst col `notElem` ["order"] ]
    conjunction = mconcat $ L.intersperse andq (map wherePred cols)
@@ -49,69 +53,70 @@ orderT :: [OrderTerm] -> StatementT
 orderT ts q =
   if L.null ts
     then q
-    else q <> (" order by ",[]) <> clause
+    else q <> (" order by ",[],mempty) <> clause
   where
    clause = mconcat $ L.intersperse commaq (map queryTerm ts)
-   queryTerm :: OrderTerm -> H.Statement H.Postgres
+   queryTerm :: OrderTerm -> DynamicSQL
-   queryTerm t = (" " <> pgFmtIdent (otTerm t) <> " "
+   queryTerm t = (" " <> cs (pgFmtIdent $ otTerm t) <> " "
-                      <> otDirection t         <> " "
+                      <> otDirection t              <> " "
-                  , [])
+                  , [], mempty)
 
 parentheticT :: StatementT
-parentheticT (sql, params) =
+parentheticT (sql, params, pre) =
-  (" (" <> sql <> ") ", params)
+  (" (" <> sql <> ") ", params, pre)
 
-iffNotT :: H.Statement H.Postgres -> StatementT
+iffNotT :: DynamicSQL -> StatementT
-iffNotT (aq, ap) (bq, bp) =
+iffNotT (aq, ap, apre) (bq, bp, bpre) =
   ("WITH aaa AS (" <> aq <> " returning *) " <>
     bq <> "WHERE NOT EXISTS (SELECT * FROM aaa)"
   , ap ++ bp
+  , All $ getAll apre && getAll bpre
   )
 
-countRows :: QualifiedTable -> H.Statement H.Postgres
+countRows :: QualifiedTable -> DynamicSQL
 countRows t =
-  ("select count(1) from " <> fromQt t, [])
+  ("select count(1) from " <> fromQt t, [], mempty)
 
 asJsonWithCount :: StatementT
-asJsonWithCount (sql, params) = (
+asJsonWithCount (sql, params, pre) = (
     "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t"
-  , params
+  , params, pre
   )
 
-selectStar :: QualifiedTable -> H.Statement H.Postgres
+selectStar :: QualifiedTable -> DynamicSQL
 selectStar t =
-  ("select * from " <> fromQt t, [])
+  ("select * from " <> fromQt t, [], mempty)
 
-insertInto :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] ->
+insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
-              H.Statement H.Postgres
 insertInto t [] _ =
-  ("insert into " <> fromQt t <> " default values returning *", [])
+  ("insert into " <> fromQt t <> " default values returning *", [], mempty)
 insertInto t cols vals =
   ("insert into " <> fromQt t <> " (" <>
-    BS.intercalate ", " (map pgFmtIdent cols) <>
+    cs (intercalate ", " (map pgFmtIdent cols)) <>
     ") values (" <>
-    BS.intercalate ", " (map (const "?") vals) <>
+    cs (intercalate ", " (map (const "?") vals)) <>
-    ") returning *"
+    ")"
   , map pgParam vals
+  , mempty
   )
 
-update :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] ->
+update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
-          H.Statement H.Postgres
 update t cols vals =
   ("update " <> fromQt t <> " set (" <>
-    BS.intercalate ", " (map pgFmtIdent cols) <>
+    cs (intercalate ", " (map pgFmtIdent cols)) <>
     ") = (" <>
-    BS.intercalate ", " (map (const "?") vals) <> ")"
+    cs (intercalate ", " (map (const "?") vals)) <> ")"
   , map pgParam vals
+  , mempty
   )
 
-wherePred :: Net.QueryItem -> H.Statement H.Postgres
+wherePred :: Net.QueryItem -> DynamicSQL
 wherePred (col, predicate) =
-  (" " <> pgFmtIdent col <> " " <> op <> " ? ", [H.renderValue value])
+  (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> " ", [], mempty)
 
   where
-    opCode:rest = BS.split '.' $ fromMaybe "." predicate
+    opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate
-    value = BS.intercalate "." rest
+    value = intercalate "." rest
     op = case opCode of
          "eq"  -> "="
          "gt"  -> ">"
@@ -123,41 +128,41 @@ wherePred (col, predicate) =
 
 orderParse :: Net.Query -> [OrderTerm]
 orderParse q =
-  mapMaybe orderParseTerm . BS.split ',' $ cs order
+  mapMaybe orderParseTerm . split (==',') $ cs order
   where
     order = fromMaybe "" $ join (lookup "order" q)
 
-orderParseTerm :: BS.ByteString -> Maybe OrderTerm
+orderParseTerm :: Text -> Maybe OrderTerm
 orderParseTerm s =
-  case BS.split '.' s of
+  case split (=='.') s of
        [d,c] ->
          if d `elem` ["asc", "desc"]
-            then Just $ OrderTerm (cs c) $
+            then Just $ OrderTerm c $
               if d == "asc" then "asc" else "desc"
             else Nothing
        _ -> Nothing
 
-commaq :: H.Statement H.Postgres
+commaq :: DynamicSQL
-commaq  = (", ", [])
+commaq  = (", ", [], mempty)
 
-andq :: H.Statement H.Postgres
+andq :: DynamicSQL
-andq = (" and ", [])
+andq = (" and ", [], mempty)
 
-pgFmtIdent :: BS.ByteString -> BS.ByteString
+pgFmtIdent :: Text -> Text
 pgFmtIdent x =
   let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in
-  cs $ if escaped =~ danger
+  if escaped =~ danger
     then "\"" <> escaped <> "\""
     else escaped
 
-  where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString
+  where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: Text
 
 pgFmtLit :: Text -> Text
 pgFmtLit x =
   let trimmed = trimNullChars x
       escaped = "'" <> replace "'" "''" trimmed <> "'"
       slashed = replace "\\" "\\\\" escaped in
-  if escaped =~ ("\\\\" :: Text)
+  cs $ if escaped =~ ("\\\\" :: Text)
     then "E" <> slashed
     else slashed
 
@@ -165,7 +170,7 @@ trimNullChars :: Text -> Text
 trimNullChars = Data.Text.takeWhile (/= '\x0')
 
 fromQt :: QualifiedTable -> BS.ByteString
-fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
+fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
 
 pgParam :: JSON.Value -> H.StatementArgument H.Postgres
 pgParam (JSON.Number n) = H.renderValue n

src/PgStructure.hs

@@ -7,7 +7,6 @@ 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 ( (<*>) )
@@ -19,9 +18,9 @@ import qualified Hasql as H
 import qualified Hasql.Backend as H
 import qualified Hasql.Postgres as H
 
-foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map BS.ByteString ForeignKey)
+foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey)
 foreignKeys table = do
-  r :: [(BS.ByteString, BS.ByteString, BS.ByteString)] <- H.list $ [H.q|
+  r :: [(Text, Text, Text)] <- 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
@@ -39,7 +38,7 @@ foreignKeys table = do
     addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m
 
 
-tables :: BS.ByteString -> H.Tx H.Postgres s [Table]
+tables :: Text -> H.Tx H.Postgres s [Table]
 tables schema =
   H.list $ [H.q|
       select table_schema, table_name,
@@ -85,9 +84,9 @@ columns table = do
   return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols
 
 
-primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [BS.ByteString]
+primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text]
 primaryKeyColumns table = do
-  r :: [Identity BS.ByteString] <- H.list $ [H.q|
+  r :: [Identity Text] <- H.list $ [H.q|
     select kc.column_name
       from
         information_schema.table_constraints tc,
@@ -101,19 +100,6 @@ primaryKeyColumns table = do
   return $ map runIdentity r
 
 
--- instance FromRow Table where
---   fromRow = Table <$> field <*> field <*> (toBool <$> field)
-
--- instance FromRow Column where
---   fromRow = Column <$>
---     field <*> field <*> field <*> field
---     <*> (toBool <$> field)
---     <*> field
---     <*> (toBool <$> field)
---     <*> field <*> field <*> field
---     <*> (vanishNull . splitOn "," <$> field)
---     <*> return Nothing
-
 vanishNull :: [a] -> Maybe [a]
 vanishNull xs = if L.null xs then Nothing else Just xs
 
@@ -151,9 +137,9 @@ instance H.RowParser H.Postgres Column where
         table      = H.parseResult $ r V.! 1
         name       = H.parseResult $ r V.! 2
         position   = H.parseResult $ r V.! 3
-        nullable   = H.parseResult $ r V.! 4
+        nullable   = toBool <$> (H.parseResult $ r V.! 4 :: Either Text Text)
         typ        = H.parseResult $ r V.! 5
-        updatable  = H.parseResult $ r V.! 6
+        updatable  = toBool <$> (H.parseResult $ r V.! 6 :: Either Text Text)
         maxLen     = H.parseResult $ r V.! 7
         precision  = H.parseResult $ r V.! 8
         defValue   = H.parseResult $ r V.! 9
@@ -169,7 +155,7 @@ 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
+        insertable = toBool <$> (H.parseResult $ r V.! 3 :: Either Text Text) in
     if V.length r /= 3
        then Left "Wrong number of fields in Table"
        else Table <$> schema <*> name <*> insertable

test/Main.hs

@@ -13,7 +13,7 @@ main :: IO ()
 main = do
   roles <- loadFixture "roles"
   schema <- loadFixture "schema"
-  H.session pgSettings testSettings $ do
+  H.session pgSettings testSettings $
     H.tx Nothing $ do
       H.unit [H.q| drop schema if exists "1" cascade |]
       H.unit [H.q| drop schema if exists private cascade |]
@@ -26,4 +26,4 @@ main = do
 loadFixture :: FilePath -> IO(H.Statement H.Postgres)
 loadFixture name = do
   query <- BS.readFile $ "test/fixtures/" ++ name ++ ".sql"
-  return (query, [])
+  return (query, [], False)