Merge branch 'logisch'

.travis.yml

@@ -1,20 +0,0 @@
-language: haskell
-ghc: 7.8
-addons:
-  postgresql: "9.3"
-before_install:
-  - createuser --superuser --no-password dbapi_test
-  - createdb -O dbapi_test -U postgres dbapi_test
-  - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
-  - travis_retry sudo apt-get update
-  - travis_retry sudo apt-get install --force-yes happy-1.19.3 alex-3.1.3
-  - export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.3/bin:$PATH
-install:
-  - travis_retry curl http://bin.begriffs.com/dbapi/cabal-sandbox.tar.xz | tar xJ
-  - chmod a+x .cabal-sandbox/bin/*
-  - cabal sandbox init
-  - cabal install --enable-test --dependencies-only
-  - cabal install --enable-test
-script:
-  - cabal test --show-details=always --test-options="--color"
-  - .cabal-sandbox/bin/hlint src/*.hs test/**/*.hs

README.md

@@ -1,6 +1,6 @@
 ## Serve a RESTful API from any Postgres database
 
-[![Build Status](https://travis-ci.org/begriffs/postrest.svg?branch=master)](https://travis-ci.org/begriffs/dbapi)
+![Build Status](https://circleci.com/gh/begriffs/postgrest.png?circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2)
 
 ### Installation
 

circle.yml

@@ -0,0 +1,6 @@
+machine:
+  pre:
+    - createuser --superuser --no-password dbapi_test
+    - createdb -O dbapi_test -U ubuntu dbapi_test
+  ghc:
+    version: 7.8.3

dbapi.cabal

@@ -1,5 +1,5 @@
 name:                  dbapi
-version:               0.2.4.5
+version:               0.2.4.6
 synopsis:              The database is your api
 license:               MIT
 license-file:          LICENSE
@@ -14,8 +14,9 @@ executable dbapi
   ghc-options:         -Wall -W -Werror -O2
   default-language:    Haskell2010
   default-extensions:  OverloadedStrings
+  other-extensions:    QuasiQuotes
   build-depends:       base >=4.6 && <5
-                     , HDBC, HDBC-postgresql
+                     , hasql >= 0.2.3 && < 0.3.0, hasql-backend, hasql-postgres
                      , warp >= 3.0.2, wai >= 3.0.1
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
@@ -24,6 +25,7 @@ executable dbapi
                      , scientific, time
                      , aeson, network >= 2.6
                      , bytestring, text, split, string-conversions
+                     , stringsearch
                      , containers, unordered-containers
                      , optparse-applicative >= 0.9.1 && < 0.10
                      , regex-base, regex-tdfa
@@ -32,8 +34,13 @@ executable dbapi
                      , transformers
                      , bcrypt, base64-string
                      , network-uri >= 2.6
-                     , resource-pool, process
+                     , resource-pool
-  Other-Modules:       Dbapi
+                     , blaze-builder
+                     , vector
+                     , mtl
+  Other-Modules:       App
+                     , Auth
+                     , Config
                      , PgStructure
                      , PgQuery
                      , RangeQuery
@@ -47,11 +54,11 @@ Test-Suite spec
   other-extensions:    QuasiQuotes
   Hs-Source-Dirs:      test, src
   ghc-options:         -Wall -W -Werror
-  Main-Is:             Main.hs
+  Main-Is:             Spec.hs
-  Other-Modules:       Dbapi, Spec, SpecHelper
+  Other-Modules:       App, Auth, Config, Spec, SpecHelper
-  Build-Depends:       base, hspec2, QuickCheck
+  Build-Depends:       base, hspec >= 2.0, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
-                     , HDBC, HDBC-postgresql
+                     , hasql >= 0.2.3 && < 0.3.0, hasql-backend, hasql-postgres
                      , warp >= 3.0.2, wai >= 3.0.1
                      , HTTP, convertible
                      , case-insensitive
@@ -60,6 +67,7 @@ Test-Suite spec
                      , http-types, scientific, time
                      , bytestring, aeson, network >= 2.6
                      , text, optparse-applicative
+                     , stringsearch
                      , unordered-containers
                      , regex-base
                      , string-conversions
@@ -72,3 +80,7 @@ Test-Suite spec
                      , split
                      , network-uri >= 2.6
                      , resource-pool
+                     , blaze-builder
+                     , vector
+                     , mtl
+                     , process

src/App.hs

@@ -0,0 +1,243 @@
+{-# LANGUAGE FlexibleContexts #-}
+module App (app, sqlErrHandler, isSqlError) where
+
+import Control.Monad (join)
+import Control.Arrow ((***))
+import Control.Applicative
+import Control.Monad.IO.Class (liftIO, MonadIO)
+-- import Control.Exception.Base
+
+import Data.Text hiding (map)
+import Data.Maybe (fromMaybe)
+import Text.Regex.TDFA ((=~))
+import Data.Ord (comparing)
+import Data.Ranged.Ranges (emptyRange)
+import Data.HashMap.Strict (keys, elems, filterWithKey, toList)
+import Data.String.Conversions (cs)
+import Data.List (sortBy)
+import Data.Functor.Identity
+import Data.Scientific (isInteger, formatScientific, FPFormat(..))
+import qualified Data.Set as S
+
+import Network.HTTP.Types.Status
+import Network.HTTP.Types.Header
+import Network.HTTP.Types.URI (parseSimpleQuery)
+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.Backend as HB
+import qualified Hasql.Postgres as H
+
+import PgQuery
+import RangeQuery
+import PgStructure
+import Auth
+
+app :: Request -> H.Session H.Postgres IO Response
+app req =
+  case (path, verb) of
+    ([], _) -> do
+      body <- H.tx Nothing $ encode <$> tables (cs schema)
+      return $ responseLBS status200 [jsonH] $ cs body
+
+    ([table], "OPTIONS") -> do
+      let t = QualifiedTable schema (cs table)
+      H.tx Nothing $ do
+        cols <- columns t
+        pkey <- map cs <$> primaryKeyColumns t
+        return $ responseLBS status200 [jsonH, allOrigins]
+          $ encode (TableOptions cols pkey)
+
+    ([table], "GET") ->
+      if range == Just emptyRange
+      then return $ responseLBS status416 [] "HTTP Range error"
+      else do
+        let qt = QualifiedTable schema (cs table)
+        let select = coerce $
+              ("select ",[],mempty) <>
+                  parentheticT (
+                    whereT qq $ countRows qt
+                  ) <> commaq <> (
+                  asJsonWithCount
+                  . limitT range
+                  . orderT (orderParse qq)
+                  . whereT qq
+                  $ selectStar qt
+                )
+        row <- H.tx Nothing $ H.single select
+        let (tableTotal, queryTotal, body) =
+              fromMaybe (0, 0, Just "" :: Maybe Text) row
+            from = fromMaybe 0 $ rangeOffset <$> range
+            to = from+queryTotal-1
+            contentRange = contentRangeH from to tableTotal
+            status = rangeStatus from to tableTotal
+            canonical = urlEncodeVars
+                          . sortBy (comparing fst)
+                          . map (join (***) cs)
+                          . parseSimpleQuery
+                          $ rawQueryString req
+        return $ responseLBS status
+          [jsonH, contentRange,
+            ("Content-Location",
+             "/" <> cs table <>
+                if Prelude.null canonical then "" else "?" <> cs canonical
+            )
+          ] (cs $ fromMaybe "[]" body)
+
+    (["dbapi", "users"], "POST") -> do
+      body <- liftIO $ strictRequestBody req
+      let user = decode body :: Maybe AuthUser
+
+      case user of
+        Nothing -> return $ responseLBS status400 [jsonH] $
+          encode . object $ [("error", String "Failed to parse user.")]
+        Just u -> do
+          _ <- addUser (cs $ userId u)
+            (cs $ userPass u) (cs $ userRole u)
+          return $ responseLBS status201
+            [ jsonH
+            , (hLocation, "/dbapi/users?id=eq." <> cs (userId u))
+            ] ""
+
+    ([table], "POST") ->
+      handleJsonObj req $ \obj -> H.tx Nothing $ do
+        let qt = QualifiedTable schema (cs table)
+            query = coerce $
+              insertInto qt (map cs $ keys obj) (elems obj)
+        row <- H.single query
+        let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row
+            Just inserted = decode (cs insertedJson) :: Maybe Object
+
+        primaryKeys <- map cs <$> primaryKeyColumns qt
+        let primaries = if Prelude.null primaryKeys
+            then inserted
+            else filterWithKey (const . (`elem` primaryKeys)) inserted
+        let params = urlEncodeVars
+              $ map (\t -> (cs $ fst t, "eq." <> cs (unquoted $ snd t)))
+              $ sortBy (comparing fst) $ toList primaries
+        return $ responseLBS status201
+          [ jsonH
+          , (hLocation, "/" <> cs table <> "?" <> cs params)
+          ] ""
+
+    ([table], "PUT") ->
+      handleJsonObj req $ \obj -> H.tx Nothing $ do
+        let qt = QualifiedTable schema (cs table)
+        primaryKeys <- primaryKeyColumns qt
+        let specifiedKeys = map (cs . fst) qq
+        if S.fromList primaryKeys /= S.fromList specifiedKeys
+          then return $ responseLBS status405 []
+               "You must speficy all and only primary keys as params"
+          else do
+            tableCols <- map (cs . colName) <$> columns qt
+            let cols = map cs $ keys obj
+            if S.fromList tableCols == S.fromList cols then do
+              let vals = elems obj
+              H.unit . coerce $ iffNotT
+                      (whereT qq $ update qt cols vals)
+                      (insertSelect qt cols vals)
+              return $ responseLBS status204 [ jsonH ] ""
+
+              else return $ if Prelude.null tableCols
+                then responseLBS status404 [] ""
+                else responseLBS status400 []
+                   "You must specify all columns in PUT request"
+
+    ([table], "PATCH") ->
+     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 ] ""
+
+    (_, _) ->
+      return $ responseLBS status404 [] ""
+
+  where
+    path   = pathInfo req
+    verb   = requestMethod req
+    qq     = queryString req
+    hdrs   = requestHeaders req
+    schema = requestedSchema hdrs
+    range  = rangeRequested hdrs
+    allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
+
+
+isSqlError :: HB.Error -> Maybe HB.Error
+isSqlError (HB.ErroneousResult x) = Just $ HB.ErroneousResult x
+isSqlError _ = Nothing
+
+sqlErrHandler :: HB.Error -> IO Response
+sqlErrHandler (HB.ErroneousResult err) =
+  return $ if "42P01" `isInfixOf` err
+    then responseLBS status404 [] ""
+    else responseLBS status400 [] (cs err)
+sqlErrHandler _ = error "just for debugging"
+
+rangeStatus :: Int -> Int -> Int -> Status
+rangeStatus from to total
+  | from > total            = status416
+  | (1 + to - from) < total = status206
+  | otherwise               = status200
+
+contentRangeH :: Int -> Int -> Int -> Header
+contentRangeH from to total =
+  ("Content-Range",
+    if total == 0 || from > total
+    then "*/" <> cs (show total)
+    else cs (show from)  <> "-"
+       <> cs (show to)    <> "/"
+       <> cs (show total)
+  )
+
+requestedSchema :: RequestHeaders -> Text
+requestedSchema hdrs =
+  case verStr of
+       Just [[_, ver]] -> ver
+       _ -> "1"
+
+  where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
+        accept = cs <$> lookup hAccept hdrs :: Maybe Text
+        verStr = (=~ verRegex) <$> accept :: Maybe [[Text]]
+
+jsonH :: Header
+jsonH = (hContentType, "application/json")
+
+handleJsonObj :: MonadIO m => Request -> (Object -> m Response) -> m Response
+handleJsonObj req handler = do
+  parse <- liftIO $ fmap eitherDecode . strictRequestBody $ req
+  case parse of
+    Left err ->
+      return $ responseLBS status400 [jsonH] jErr
+      where
+        jErr = encode . object $
+          [("error", String $ "Failed to parse JSON payload. " <> cs err)]
+    Right (Object o) -> handler o
+    Right _ ->
+      return $ responseLBS status400 [jsonH] jErr
+      where
+        jErr = encode . object $
+          [("error", String "Expecting a JSON object")]
+
+unquoted :: Value -> Text
+unquoted (String t) = t
+unquoted (Number n) =
+  cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
+unquoted (Bool b) = cs . show $ b
+unquoted _ = ""
+
+data TableOptions = TableOptions {
+  tblOptcolumns :: [Column]
+, tblOptpkey :: [Text]
+}
+
+instance ToJSON TableOptions where
+  toJSON t = object [
+      "columns" .= tblOptcolumns t
+    , "pkey"   .= tblOptpkey t ]

src/Auth.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}
+module Auth where
+
+import Data.Aeson
+import Control.Monad (mzero)
+import Control.Applicative ( (<*>), (<$>) )
+import Control.Monad.IO.Class (liftIO)
+import Crypto.BCrypt
+import Data.Text
+import Data.Monoid
+import qualified Hasql as H
+import qualified Hasql.Postgres as H
+import Data.String.Conversions (cs)
+import PgQuery (pgFmtLit)
+
+data AuthUser = AuthUser {
+    userId :: String
+  , userPass :: String
+  , userRole :: String
+  } deriving (Show)
+
+instance FromJSON AuthUser where
+  parseJSON (Object v) = AuthUser <$>
+                         v .: "id" <*>
+                         v .: "pass" <*>
+                         v .: "role"
+  parseJSON _ = mzero
+
+instance ToJSON AuthUser where
+  toJSON u = object [
+      "id" .= userId u
+    , "pass" .= userPass u
+    , "role" .= userRole u ]
+
+type DbRole = Text
+
+data LoginAttempt =
+    NoCredentials
+  | MalformedAuth
+  | LoginFailed
+  | LoginSuccess DbRole
+  deriving (Eq, Show)
+
+checkPass :: Text -> Text -> Bool
+checkPass = (. cs) . validatePassword . cs
+
+setRole :: Text -> H.Tx H.Postgres s ()
+setRole role = H.unit ("set role " <> cs (pgFmtLit role), [], True)
+
+resetRole :: H.Tx H.Postgres s ()
+resetRole = H.unit [H.q|reset role|]
+
+addUser :: Text -> Text -> Text -> H.Session H.Postgres IO ()
+addUser identity pass role = do
+  Just hashed <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
+  H.tx Nothing $ H.unit $
+    [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|]
+      identity (cs hashed :: Text) role
+
+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 ->
+      let (hashed, role) = r in
+      if checkPass hashed pass
+         then LoginSuccess role
+         else LoginFailed
+    ) u

src/Config.hs

@@ -0,0 +1,49 @@
+module Config where
+
+import Network.Wai
+import Control.Applicative
+import Data.Text (strip)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.ByteString.Char8 as BS
+import Data.String.Conversions (cs)
+import Options.Applicative hiding (columns)
+import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
+
+data AppConfig = AppConfig {
+    configDbUri :: String
+  , configPort  :: Int
+  , configAnonRole :: String
+  , configSecure :: Bool
+  , configPool :: Int
+  }
+
+argParser :: Parser AppConfig
+argParser = AppConfig
+  <$> strOption (long "db" <> short 'd' <> metavar "URI"
+    <> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
+  <*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
+    <> help "port number on which to run HTTP server")
+  <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE"
+    <> help "postgres role to use for non-authenticated requests")
+  <*> switch (long "secure" <> short 's'
+    <> help "Redirect all requests to HTTPS")
+  <*> option (long "db-pool" <> metavar "NUMBER" <> value 10
+    <> help "Max connections in database pool")
+
+defaultCorsPolicy :: CorsResourcePolicy
+defaultCorsPolicy =  CorsResourcePolicy Nothing
+  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
+  (Just $ 60*60*24) False False True
+
+corsPolicy :: Request -> Maybe CorsResourcePolicy
+corsPolicy req = case lookup "origin" headers of
+  Just origin -> Just defaultCorsPolicy {
+      corsOrigins = Just ([origin], True)
+    , corsRequestHeaders = "Authentication":accHeaders
+    }
+  Nothing -> Nothing
+  where
+    headers = requestHeaders req
+    accHeaders = case lookup "access-control-request-headers" headers of
+      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
+      Nothing -> []

src/Dbapi.hs

@@ -1,237 +0,0 @@
--- {{{ Imports
-module Dbapi where
-
-import Types (SqlRow, getRow)
-
-import Control.Monad (join, mzero)
-import Control.Arrow ((***))
-import Control.Applicative
-import Options.Applicative hiding (columns)
-
-import Data.Maybe (fromMaybe, isJust)
-import Text.Regex.TDFA ((=~))
-import Data.Map (intersection, fromList, toList, Map)
-import Data.List (sort)
-import qualified Data.Set as S
-import Data.Convertible.Base (convert)
-import Data.Text (strip, Text)
-
-import Network.HTTP.Types.Status
-import Network.HTTP.Types.Header
-import Network.HTTP.Types.URI
-
-import Network.HTTP.Base (urlEncodeVars)
-
-import Network.Wai
-import Network.Wai.Internal
-import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
-
-import qualified Data.ByteString.Char8 as BS
-import Data.String.Conversions (cs)
-import qualified Data.CaseInsensitive as CI
-
-import Database.HDBC.PostgreSQL (Connection)
-import PgStructure (printTables, printColumns, primaryKeyColumns,
-                    columns, Column(colName))
-
-import qualified Data.Aeson as JSON
-
-import PgQuery
-import RangeQuery
-import Data.Ranged.Ranges (emptyRange)
-
--- }}}
-
-data AppConfig = AppConfig {
-    configDbUri :: String
-  , configPort  :: Int
-  , configAnonRole :: String
-  , configSecure :: Bool
-  , configPool :: Int
-  }
-
-data AuthUser = AuthUser {
-    userId :: String
-  , userPass :: String
-  , userRole :: String
-  }
-
-instance JSON.FromJSON AuthUser where
-  parseJSON (JSON.Object v) = AuthUser <$>
-                         v JSON..: "id" <*>
-                         v JSON..: "pass" <*>
-                         v JSON..: "role"
-  parseJSON _          = mzero
-
-jsonContentType :: (HeaderName, BS.ByteString)
-jsonContentType = (hContentType, "application/json")
-
-jsonBodyAction :: Request -> (SqlRow -> IO Response) -> IO Response
-jsonBodyAction req handler = do
-  parse <- jsonBody req
-  case parse of
-    Left err -> return $ responseLBS status400 [jsonContentType] json
-      where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ]
-    Right body -> handler body
-
-jsonBody :: Request -> IO (Either String SqlRow)
-jsonBody = fmap JSON.eitherDecode . strictRequestBody
-
-filterByKeys :: Ord a => Map a b -> [a] -> Map a b
-filterByKeys m keys =
-  if null keys then m else
-    m `intersection` fromList (zip keys $ repeat undefined)
-
-app :: Connection -> Application
-app conn req respond =
-  respond =<< case (path, verb) of
-    ([], _) ->
-      responseLBS status200 [jsonContentType] <$> printTables ver conn
-
-    (["dbapi", "users"], "POST") -> do
-      body <- strictRequestBody req
-      let parse = JSON.eitherDecode body
-
-      case parse of
-        Left err -> return $ responseLBS status400 [jsonContentType] json
-          where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ]
-        Right u -> do
-          addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) conn
-          return $ responseLBS status201
-            [ jsonContentType
-            , (hLocation, "/dbapi/users?id=eq." <> cs (userId u))
-            ] ""
-
-    ([table], "OPTIONS") ->
-      responseLBS status200 [jsonContentType, allOrigins] <$>
-        printColumns ver (cs table) conn
-
-    ([table], "GET") ->
-      if range == Just emptyRange
-      then return $ responseLBS status416 [] "HTTP Range error"
-      else do
-        r <- respondWithRangedResult <$> getRows ver (cs table) qq range conn
-        let canonical = urlEncodeVars $ sort $
-                        map (join (***) cs) $
-                        parseSimpleQuery $
-                        rawQueryString req
-        return $ addHeaders [
-          ("Content-Location",
-           "/" <> cs table <> if null canonical then "" else "?" <> cs canonical
-          )] r
-
-    ([table], "POST") ->
-      jsonBodyAction req (\row -> do
-        allvals <- insert ver table row conn
-        keys <- map cs <$> primaryKeyColumns ver (cs table) conn
-        let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList $ filterByKeys allvals keys
-        return $ responseLBS status201
-          [ jsonContentType
-          , (hLocation, "/" <> cs table <> "?" <> cs params)
-          ] ""
-      )
-
-    ([table], "PUT") ->
-      jsonBodyAction req (\row -> do
-        keys <- primaryKeyColumns ver (cs table) conn
-        let specifiedKeys = map (cs . fst) qq
-        if S.fromList keys /= S.fromList specifiedKeys
-          then return $ responseLBS status405 []
-               "You must speficy all and only primary keys as params"
-          else
-            if isJust cRange
-               then return $ responseLBS status400 []
-                    "Content-Range is not allowed in PUT request"
-            else do
-              cols <- columns ver (cs table) conn
-              let colNames = S.fromList $ map (cs . colName) cols
-              let specifiedCols = S.fromList $ map fst $ getRow row
-              if colNames == specifiedCols then do
-                _ <- upsert ver table row qq conn
-                return $ responseLBS status204 [ jsonContentType ] ""
-
-                else return $ if S.null colNames then responseLBS status404 [] ""
-                  else responseLBS status400 []
-                     "You must specify all columns in PUT request"
-      )
-
-    ([table], "PATCH") ->
-      jsonBodyAction req (\row -> do
-        _ <- update ver table row qq conn
-        return $ responseLBS status204 [ jsonContentType ] ""
-      )
-
-    (_, _) ->
-      return $ responseLBS status404 [] ""
-
-  where
-    path   = pathInfo req
-    verb   = requestMethod req
-    qq     = queryString req
-    hdrs   = requestHeaders req
-    ver    = fromMaybe "1" $ requestedVersion hdrs
-    range  = requestedRange hdrs
-    cRange = requestedContentRange hdrs
-    allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
-
-defaultCorsPolicy :: CorsResourcePolicy
-defaultCorsPolicy =  CorsResourcePolicy Nothing
-  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
-  (Just $ 60*60*24) False False True
-
-corsPolicy :: Request -> Maybe CorsResourcePolicy
-corsPolicy req = case lookup "origin" headers of
-  Just origin -> Just defaultCorsPolicy {
-      corsOrigins = Just ([origin], True)
-    , corsRequestHeaders = "Authentication":accHeaders
-    }
-  Nothing -> Nothing
-  where
-    headers = requestHeaders req
-    accHeaders = case lookup "access-control-request-headers" headers of
-      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
-      Nothing -> []
-
-
-respondWithRangedResult :: RangedResult -> Response
-respondWithRangedResult rr =
-  responseLBS status [
-    jsonContentType,
-    ("Content-Range",
-      if total == 0 || from > total
-      then "*/" <> cs (show total)
-      else cs (show from)  <> "-"
-         <> cs (show to)    <> "/"
-         <> cs (show total)
-    )
-  ] (rrBody rr)
-
-  where
-    from   = rrFrom rr
-    to     = rrTo   rr
-    total  = rrTotal rr
-    status
-      | from > total            = status416
-      | (1 + to - from) < total = status206
-      | otherwise               = status200
-
-requestedVersion :: RequestHeaders -> Maybe Text
-requestedVersion hdrs =
-  case verStr of
-       Just [[_, ver]] -> Just ver
-       _ -> Nothing
-
-  where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
-        accept = cs <$> lookup hAccept hdrs :: Maybe Text
-        verStr = (=~ verRegex) <$> accept :: Maybe [[Text]]
-
-
-addHeaders :: ResponseHeaders -> Response -> Response
-addHeaders hdrs (ResponseFile    s headers fp m) =
-                 ResponseFile    s (headers ++ hdrs) fp m
-addHeaders hdrs (ResponseBuilder s headers b)    =
-                 ResponseBuilder s (headers ++ hdrs) b
-addHeaders hdrs (ResponseStream  s headers b)    =
-                 ResponseStream  s (headers ++ hdrs) b
-addHeaders hdrs (ResponseRaw     s resp)         =
-                 ResponseRaw     s (addHeaders hdrs resp)

src/Main.hs

@@ -2,61 +2,60 @@ module Main where
 
 import Paths_dbapi (version)
 
-import Dbapi
+import App
-import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
+import Middleware
-  redirectInsecure, withDBConnection, Environment(..))
-import Network.Wai.Handler.Warp hiding (Connection)
-import Data.String.Conversions (cs)
 
 import Control.Monad (unless)
-import Control.Applicative
+import Control.Monad.IO.Class (liftIO)
-import Control.Exception(bracket)
+import Control.Monad.Reader (runReaderT, ask)
-import Options.Applicative hiding (columns)
+import Control.Exception
-import Network.Wai.Middleware.Gzip (gzip, def)
+import Data.String.Conversions (cs)
 import Network.Wai.Middleware.Cors (cors)
+import Network.Wai.Handler.Warp hiding (Connection)
+import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Static (staticPolicy, only)
-import Database.HDBC (disconnect)
-import Database.HDBC.PostgreSQL (connectPostgreSQL')
-import Data.Pool(createPool, destroyAllResources)
 import Data.List (intercalate)
 import Data.Version (versionBranch)
+import qualified Hasql as H
+import qualified Hasql.Postgres as H
+import Options.Applicative hiding (columns)
 
-argParser :: Parser AppConfig
+import Config (AppConfig(..), argParser, corsPolicy)
-argParser = AppConfig
-  <$> strOption (long "db" <> short 'd' <> metavar "URI"
-    <> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
-  <*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
-    <> help "port number on which to run HTTP server")
-  <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE"
-    <> help "postgres role to use for non-authenticated requests")
-  <*> switch (long "secure" <> short 's'
-    <> help "Redirect all requests to HTTPS")
-  <*> option (long "db-pool" <> metavar "NUMBER" <> value 10
-    <> help "Max connections in database pool")
 
 main :: IO ()
 main = do
   conf <- execParser (info (helper <*> argParser) describe)
-  bracket
+  let port = configPort conf
-    (createPool (connectPostgreSQL' (configDbUri conf))
-      disconnect 1 600 (configPool conf))
-    destroyAllResources
-    (\pool -> do
-      let port = configPort conf
 
-      unless (configSecure conf) $
+  unless (configSecure conf) $
-        putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
+    putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
 
-      Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
+  Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
-      let settings = setPort port
+
-                   . setServerName (cs $ "dbapi/" <> prettyVersion)
+
-                   $ defaultSettings
+  let pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test"
-      runSettings settings $ (if configSecure conf then redirectInsecure else id)
+
+  sessSettings <- maybe (fail "Improper session settings") return $
+                    H.sessionSettings 95 30
+
+  let appSettings = setPort port
+                  . setServerName (cs $ "dbapi/" <> prettyVersion)
+                  $ defaultSettings
+      middle =
+        (if configSecure conf then redirectInsecure else id)
         . gzip def . cors corsPolicy . clientErrors
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
-        . withDBConnection pool . inTransaction Production
+
-        . authenticated (cs $ configAnonRole conf) . withSavepoint Production $ app
+  H.session pgSettings sessSettings $ do
-      )
+    session' <- flip runReaderT <$> ask
+    let runApp req respond =
+          respond =<< catchJust isSqlError
+            (session' $ authenticated (cs $ configAnonRole conf) app req)
+            sqlErrHandler
+
+    liftIO $ runSettings appSettings $ middle runApp
+ --     . authenticated (cs $ configAnonRole conf) $ app
+
   where
     describe = progDesc "create a REST API to an existing Postgres database"
     prettyVersion = intercalate "." $ map show $ versionBranch version

src/Middleware.hs

@@ -2,103 +2,93 @@
 
 module Middleware where
 
-import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
+--import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
 import Data.Maybe (fromMaybe)
 import Data.Monoid (mconcat)
-import Data.Pool(withResource, Pool)
+import Data.Text
-
+-- import Data.Pool(withResource, Pool)
-import Database.HDBC (runRaw)
-import Database.HDBC.PostgreSQL (Connection)
-import Database.HDBC.Types (SqlError(..))
 
+import qualified Hasql as H
+import qualified Hasql.Postgres as H
 import Data.String.Conversions(cs)
-import qualified Data.ByteString.Char8 as BS
+import Control.Exception (catchJust)
-import Control.Exception (finally, throw, catchJust, catch, SomeException,
-    bracket_)
 
-import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
+import Network.HTTP.Types.Header (hLocation, hContentType, hAuthorization)
-  hLocation)
+import Network.HTTP.Types (RequestHeaders)
-import Network.HTTP.Types.Status (status400, status401, status404, status301)
+import Network.HTTP.Types.Status (status400, status401, status301)
 import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
-                   rawQueryString, isSecure, requestMethod, Request)
+                   rawQueryString, isSecure, Request(..), Response)
 import Network.URI (URI(..), parseURI)
 
-import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
+import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
 import Debug.Trace
 
-data Environment = Test | Production deriving (Eq)
+-- data Environment = Test | Production deriving (Eq)
 
-withDBConnection :: Pool Connection -> (Connection -> Application) -> Application
+-- safeAction :: Request -> Bool
-withDBConnection pool app req respond =
+-- safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod
-  withResource pool (\c -> app c req respond)
 
-safeAction :: Request -> Bool
+-- withSavepoint :: Environment -> (Connection -> Application) ->
-safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod
+--                  Connection -> Application
+-- withSavepoint env app conn req respond =
+--   if env == Production && safeAction req
+--     then go
+--     else Database.PostgreSQL.Simple.withSavepoint conn go
+--   where go = app conn req respond
 
-inTransaction :: Environment -> (Connection -> Application) ->
+authenticated :: Text -> (Request -> H.Session H.Postgres IO Response) ->
-                 Connection -> Application
+       Request -> H.Session H.Postgres IO Response
-inTransaction env app conn req respond =
+authenticated anon app req = do
-  if env == Production && safeAction req
-    then
-      app conn req respond
-    else
-      finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
-
-withSavepoint :: Environment -> (Connection -> Application) ->
-                 Connection -> Application
-withSavepoint env app conn req respond =
-  if env == Production && safeAction req
-    then app conn req respond
-    else do
-      runRaw conn "savepoint req_sp"
-      catch (app conn req respond) (\e -> let _ = (e::SomeException) in
-        runRaw conn "rollback to savepoint req_sp" >> throw e)
-
-authenticated :: BS.ByteString -> (Connection -> Application) ->
-                 Connection -> Application
-authenticated anon app conn req respond = do
   attempt <- httpRequesterRole (requestHeaders req)
   case attempt of
     MalformedAuth ->
-      respond $ responseLBS status400 [] "Malformed basic auth header"
+      return $ responseLBS status400 [] "Malformed basic auth header"
     LoginFailed ->
-      respond $ responseLBS status401 [] "Invalid username or password"
+      return $ responseLBS status401 [] "Invalid username or password"
-    LoginSuccess role ->
+    LoginSuccess role -> runInRole role
-      bracket_ (setRole conn role) (resetRole conn) $ app conn req respond
+    NoCredentials -> runInRole anon
-    NoCredentials ->
-      bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond
 
  where
-   httpRequesterRole :: RequestHeaders -> IO LoginAttempt
+   httpRequesterRole :: RequestHeaders -> H.Session H.Postgres IO LoginAttempt
    httpRequesterRole hdrs = do
     let auth = fromMaybe "" $ lookup hAuthorization hdrs
-    case BS.split ' ' (cs auth) of
+    case split (==' ') (cs auth) of
       ("Basic" : b64 : _) ->
-        case BS.split ':' $ cs (decode $ cs b64) of
+        case split (==':') (cs . decode . cs $ b64) of
-          (u:p:_) -> signInRole u p conn
+          (u:p:_) -> H.tx Nothing $ signInRole u p
           _ -> return MalformedAuth
       _ -> return NoCredentials
 
-instance ToJSON SqlError where
+   runInRole :: Text -> H.Session H.Postgres IO Response
-  toJSON t = object [
+   runInRole r = do
-      "error" .= object [
+     H.tx Nothing $ setRole r
-          "code"    .= seNativeError t
+     resp <- app req
-        , "message" .= seErrorMsg t
+     H.tx Nothing resetRole
-        , "state"   .= seState t
+     return resp
-      ]
+
-    ]
+-- instance ToJSON SqlError where
+--   toJSON t = object [
+--       "error" .= object [
+--           "message" .= (cs $ sqlErrorMsg t :: String)
+--         , "detail"  .= (cs $ sqlErrorDetail t :: String)
+--         , "state"   .= (cs $ sqlState t :: String)
+--         , "hint"    .= (cs $ sqlErrorHint t :: String)
+--       ]
+--     ]
 
 clientErrors :: Application -> Application
 clientErrors app req respond =
   catchJust isPgException (app req respond) $ \err ->
-    respond $ if seState err == "42P01"
+    respond $
-       then responseLBS status404 [] ""
+      responseLBS status400 [(hContentType, "application/json")] (cs $ show err)
-       else responseLBS status400 [(hContentType, "application/json")] (encode err)
+      -- if sqlState err == "42P01"
+      --  then responseLBS status404 [] ""
+      --  else responseLBS status400 [(hContentType, "application/json")] (encode err)
 
   where
-    isPgException :: SqlError -> Maybe SqlError
+    isPgException :: H.Error -> Maybe H.Error
     isPgException x = Just (traceShow x x)
 
 

src/PgQuery.hs

@@ -1,242 +1,173 @@
--- {{{ Imports
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-module PgQuery (
+module PgQuery where
-  getRows
-, insert
-, update
-, upsert
-, addUser
-, signInRole
-, setRole
-, resetRole
-, checkPass
-, pgFmtIdent
-, pgFmtLit
-, RangedResult(..)
-, LoginAttempt(..)
-, DbRole
-) where
 
-import Data.Text (Text, splitOn, intercalate, replace, takeWhile)
+import RangeQuery
-import Data.String.Conversions (cs)
-import Data.Functor ( (<$>) )
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Monoid ((<>), mconcat)
-import qualified Data.Map as M
 
-import Text.Regex.TDFA ((=~))
+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.Text ()
-
+import qualified Network.HTTP.Types.URI as Net
-import Control.Monad (join)
-
-import qualified RangeQuery as R
 import qualified Data.ByteString.Char8 as BS
-import qualified Data.ByteString.Lazy as BL
+import Data.Monoid
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Functor ( (<$>) )
+import Control.Monad (join)
+import Data.String.Conversions (cs)
+import qualified Data.Aeson as JSON
 import qualified Data.List as L
 
-import Database.HDBC hiding (colType, colNullable)
+type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All)
-import Database.HDBC.PostgreSQL
 
-import qualified Network.HTTP.Types.URI as Net
+type StatementT = DynamicSQL -> DynamicSQL
 
-import Types (SqlRow(..), getRow, sqlRowColumns, sqlRowValues)
+data QualifiedTable = QualifiedTable {
-import Crypto.BCrypt (hashPasswordUsingPolicy, fastBcryptHashingPolicy, validatePassword)
+  qtSchema :: Text
-
+, qtName   :: Text
--- }}}
-
-data RangedResult = RangedResult {
-  rrFrom  :: Int
-, rrTo    :: Int
-, rrTotal :: Int
-, rrBody  :: BL.ByteString
 } deriving (Show)
 
-type Schema = Text
-type DbRole = BS.ByteString
-
-data LoginAttempt =
-    NoCredentials
-  | MalformedAuth
-  | LoginFailed
-  | LoginSuccess DbRole
-  deriving (Eq, Show)
-
-getRows :: Schema -> Text -> Net.Query -> Maybe R.NonnegRange -> Connection -> IO RangedResult
-getRows schema table qq range conn = do
-  r <- quickQuery conn (cs query) []
-
-  return $ case r of
-           [[total, _, SqlNull]] -> RangedResult offset 0 (fromSql total) "[]"
-           [[total, limited_total, json]] ->
-            RangedResult offset (offset + fromSql limited_total - 1)
-                         (fromSql total) (fromSql json)
-           _ -> RangedResult 0 0 0 "[]"
-
-  where
-    offset = fromMaybe 0 $ R.offset <$> range
-    query  = globalAndLimitedCounts schema table qq <> jsonArrayRows (
-        selectStarClause schema table
-        <> whereClause qq
-        <> orderClause qq
-        <> limitClause range)
-
-
-whereClause :: Net.Query -> Text
-whereClause qs =
-  if null qs then "" else " where " <> conjunction
-
-  where
-    cols = [ col | col <- qs, fst col `notElem` ["order"] ]
-    conjunction = mconcat $ L.intersperse " and " (map wherePred cols)
-
-
-orderClause :: Net.Query -> Text
-orderClause qs = do
-  let order = fromMaybe "" $ join $ lookup "order" qs
-      terms = mapMaybe parseOrderTerm $ splitOn "," $ cs order
-      termPred = mconcat $ L.intersperse ", " (map orderTermSql terms)
-
-  if null terms
-     then ""
-     else " order by " <> termPred
-
-  where
-    parseOrderTerm :: Text -> Maybe OrderTerm
-    parseOrderTerm s =
-      case splitOn "." s of
-           [d,c] ->
-             if d `elem` ["asc", "desc"]
-                then Just $ OrderTerm d c
-                else Nothing
-           _ -> Nothing
-
-    orderTermSql :: OrderTerm -> Text
-    orderTermSql t = pgFmtIdent (otColumn t) <> " " <> otDirection t
-
-
 data OrderTerm = OrderTerm {
-  otDirection :: Text
+  otTerm :: Text
-, otColumn :: Text
+, otDirection :: BS.ByteString
 }
 
+limitT :: Maybe NonnegRange -> StatementT
+limitT r q =
+  q <> (" LIMIT " <> limit <> " OFFSET " <> offset <> " ", [], mempty)
+  where
+    limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
+    offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
 
-wherePred :: Net.QueryItem -> Text
+whereT :: Net.Query -> StatementT
-wherePred (column, predicate) =
+whereT params q =
-  pgFmtIdent (cs column) <> " " <> op <> " " <> pgFmtLit (cs value)
+ if L.null params
+   then q
+   else q <> (" where ",[],mempty) <> conjunction
+ where
+   cols = [ col | col <- params, fst col `notElem` ["order"] ]
+   conjunction = mconcat $ L.intersperse andq (map wherePred cols)
+
+orderT :: [OrderTerm] -> StatementT
+orderT ts q =
+  if L.null ts
+    then q
+    else q <> (" order by ",[],mempty) <> clause
+  where
+   clause = mconcat $ L.intersperse commaq (map queryTerm ts)
+   queryTerm :: OrderTerm -> DynamicSQL
+   queryTerm t = (" " <> cs (pgFmtIdent $ otTerm t) <> " "
+                      <> otDirection t              <> " "
+                  , [], mempty)
+
+parentheticT :: StatementT
+parentheticT (sql, params, pre) =
+  (" (" <> sql <> ") ", params, pre)
+
+iffNotT :: DynamicSQL -> StatementT
+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 -> DynamicSQL
+countRows t =
+  ("select count(1) from " <> fromQt t, [], mempty)
+
+asJsonWithCount :: StatementT
+asJsonWithCount (sql, params, pre) = (
+    "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t"
+  , params, pre
+  )
+
+asJsonRow :: StatementT
+asJsonRow (sql, params, pre) = (
+    "row_to_json(t) from (" <> sql <> ") t", params, pre
+  )
+
+selectStar :: QualifiedTable -> DynamicSQL
+selectStar t =
+  ("select * from " <> fromQt t, [], mempty)
+
+insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
+insertInto t [] _ =
+  ("insert into " <> fromQt t <> " default values returning *", [], mempty)
+insertInto t cols vals =
+  ("insert into " <> fromQt t <> " (" <>
+    cs (intercalate ", " (map pgFmtIdent cols)) <>
+    ") values (" <>
+    cs (intercalate ", " (map (const "?") vals)) <>
+    ") returning row_to_json(" <> fromQt t <> ".*)"
+  , map pgParam vals
+  , mempty
+  )
+
+insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
+insertSelect t [] _ =
+  ("insert into " <> fromQt t <> " default values returning *", [], mempty)
+insertSelect t cols vals =
+  ("insert into " <> fromQt t <> " (" <>
+    cs (intercalate ", " (map pgFmtIdent cols)) <>
+    ") select " <>
+    cs (intercalate ", " (map (const "?") vals))
+  , map pgParam vals
+  , mempty
+  )
+
+update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
+update t cols vals =
+  ("update " <> fromQt t <> " set (" <>
+    cs (intercalate ", " (map pgFmtIdent cols)) <>
+    ") = (" <>
+    cs (intercalate ", " (map (const "?") vals)) <> ")"
+  , map pgParam vals
+  , mempty
+  )
+
+wherePred :: Net.QueryItem -> DynamicSQL
+wherePred (col, predicate) =
+  (" " <> 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"  -> "="
+         "eq"  -> "="
-              "gt"  -> ">"
+         "gt"  -> ">"
-              "lt"  -> "<"
+         "lt"  -> "<"
-              "gte" -> ">="
+         "gte" -> ">="
-              "lte" -> "<="
+         "lte" -> "<="
-              "neq" -> "<>"
+         "neq" -> "<>"
-              _     -> "="
+         _     -> "="
-
-limitClause :: Maybe R.NonnegRange -> Text
-limitClause range =
-  cs $ " LIMIT " <> limit <> " OFFSET " <> show offset <> " "
 
+orderParse :: Net.Query -> [OrderTerm]
+orderParse q =
+  mapMaybe orderParseTerm . split (==',') $ cs order
   where
-    limit  = fromMaybe "ALL" $ show <$> (R.limit =<< range)
+    order = fromMaybe "" $ join (lookup "order" q)
-    offset = fromMaybe 0     $ R.offset <$> range
 
-globalAndLimitedCounts :: Schema -> Text -> Net.Query -> Text
+orderParseTerm :: Text -> Maybe OrderTerm
-globalAndLimitedCounts schema table qq =
+orderParseTerm s =
-  " select "
+  case split (=='.') s of
-  <> "(select count(1) from " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " "
+       [d,c] ->
-  <> whereClause qq
+         if d `elem` ["asc", "desc"]
-  <> "), count(t), "
+            then Just $ OrderTerm c $
+              if d == "asc" then "asc" else "desc"
+            else Nothing
+       _ -> Nothing
 
-selectStarClause :: Schema -> Text -> Text
+commaq :: DynamicSQL
-selectStarClause schema table =
+commaq  = (", ", [], mempty)
-  " select * from " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " "
 
-jsonArrayRows :: Text -> Text
+andq :: DynamicSQL
-jsonArrayRows q =
+andq = (" and ", [], mempty)
-  "array_to_json(array_agg(row_to_json(t))) from (" <> q <> ") t"
-
-insert :: Schema -> Text -> SqlRow -> Connection -> IO (M.Map String SqlValue)
-insert schema table row conn = do
-  stmt   <- prepare conn $ cs sql
-  _      <- execute stmt $ sqlRowValues row
-  Just m <- fetchRowMap stmt
-  return m
-
-  where sql = insertClause schema table row
-
-addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Connection -> IO ()
-addUser identity pass role conn = do
-  Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy $ cs pass
-  _ <- quickQuery conn
-         "insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)"
-         $ map toSql [identity, hashed, role]
-  return ()
-
-signInRole :: BS.ByteString -> BS.ByteString -> Connection -> IO LoginAttempt
-signInRole user pass conn = do
-  u <- quickQuery conn "select pass, rolname from dbapi.auth where id = ?" [toSql user]
-  return $ case u of
-    [[hashed, role]] ->
-      if checkPass (fromSql hashed) (cs pass)
-         then LoginSuccess $ fromSql role
-         else LoginFailed
-    _ -> LoginFailed
-
-checkPass :: BS.ByteString -> BS.ByteString -> Bool
-checkPass = validatePassword
-
-upsert :: Schema -> Text -> SqlRow -> Net.Query -> Connection ->
-          IO (M.Map String SqlValue)
-upsert schema table row qq conn = do
-  stmt   <- prepare conn $ cs $ upsertClause schema table row qq
-  _      <- execute stmt $ join $ replicate 2 $ sqlRowValues row
-  m <- fetchRowMap stmt
-  return $ fromMaybe M.empty m
-
-update :: Schema -> Text -> SqlRow -> Net.Query -> Connection ->
-          IO (M.Map String SqlValue)
-update schema table row qq conn = do
-  stmt   <- prepare conn $ cs $ updateClause schema table row qq
-  _      <- execute stmt $ sqlRowValues row
-  m <- fetchRowMap stmt
-  return $ fromMaybe M.empty m
-
-placeholders :: Text -> SqlRow -> Text
-placeholders symbol = intercalate ", " . map (const symbol) . getRow
-
-insertClause :: Schema -> Text -> SqlRow -> Text
-insertClause schema table (SqlRow []) =
-  "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " default values returning *"
-insertClause schema table row =
-  "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " (" <>
-    intercalate ", " (map pgFmtIdent (sqlRowColumns row))
-  <> ") values (" <> placeholders "?" row <> ") returning *"
-
-insertClauseViaSelect :: Schema -> Text -> SqlRow -> Text
-insertClauseViaSelect schema table row =
-    "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " (" <>
-      intercalate ", " (map pgFmtIdent (sqlRowColumns row))
-  <> ") select " <> placeholders "?" row
-
-updateClause :: Schema -> Text -> SqlRow -> Net.Query -> Text
-updateClause schema table row qq =
-    "update " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " set (" <>
-      intercalate ", " (map pgFmtIdent (sqlRowColumns row))
-  <> ") = (" <> placeholders "?" row <> ")"
-  <> whereClause qq
-
-upsertClause :: Schema -> Text -> SqlRow -> Net.Query -> Text
-upsertClause schema table row qq =
-  "with upsert as (" <> updateClause schema table row qq
-  <> " returning *) " <> insertClauseViaSelect schema table row
-  <> " where not exists (select * from upsert) returning *"
 
 pgFmtIdent :: Text -> Text
 pgFmtIdent x =
-  let escaped = replace "\"" "\"\"" (trimNullChars x) in
+  let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in
   if escaped =~ danger
     then "\"" <> escaped <> "\""
     else escaped
@@ -248,15 +179,20 @@ 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
 
 trimNullChars :: Text -> Text
 trimNullChars = Data.Text.takeWhile (/= '\x0')
 
-setRole :: Connection -> DbRole -> IO ()
+fromQt :: QualifiedTable -> BS.ByteString
-setRole conn role = runRaw conn $ "set role " <> cs role
+fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
 
-resetRole :: Connection -> IO ()
+pgParam :: JSON.Value -> H.StatementArgument H.Postgres
-resetRole conn = runRaw conn "reset role"
+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,22 +1,111 @@
+{-# LANGUAGE QuasiQuotes, OverloadedStrings,
+             MultiParamTypeClasses, ScopedTypeVariables #-}
 module PgStructure where
 
+import PgQuery (QualifiedTable(..))
 import Data.Functor ( (<$>) )
-import Data.Maybe (mapMaybe)
 import Data.Text hiding (foldl, map, zipWith, concat)
-import Data.Monoid ((<>))
+import Data.Aeson
+import Data.Functor.Identity
+import qualified Data.Vector as V
 import Data.String.Conversions (cs)
 
 import Control.Applicative ( (<*>) )
 
-import qualified Data.ByteString.Lazy as BL
+import qualified Data.List as L
-
-import qualified Data.Aeson as JSON
 import qualified Data.Map as Map
 
-import Database.HDBC hiding (colType, colNullable)
+import qualified Hasql as H
-import Database.HDBC.PostgreSQL
+import qualified Hasql.Backend as H
+import qualified Hasql.Postgres as H
 
-import Data.Aeson ((.=))
+foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey)
+foreignKeys table = do
+  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
+        join information_schema.key_column_usage AS kcu
+          on tc.constraint_name = kcu.constraint_name
+        join information_schema.constraint_column_usage AS ccu
+          on ccu.constraint_name = tc.constraint_name
+      where constraint_type = 'FOREIGN KEY'
+        and tc.table_name=? and tc.table_schema = ?
+        order by kcu.column_name
+    |] (qtName table) (qtSchema table)
+
+  return $ foldl addKey Map.empty r
+  where
+    addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m
+
+
+tables :: Text -> H.Tx H.Postgres s [Table]
+tables schema =
+  H.list $ [H.q|
+      select table_schema, table_name,
+             is_insertable_into
+        from information_schema.tables
+       where table_schema = ?
+       order by table_name
+    |] schema
+
+
+columns :: QualifiedTable -> H.Tx H.Postgres s [Column]
+columns table = do
+  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,
+           info.is_updatable as updatable,
+           info.character_maximum_length as max_len,
+           info.numeric_precision as precision,
+           info.column_default as default_value,
+           array_to_string(enum_info.vals, ',') as enum
+       from (
+         select table_schema, table_name, column_name, ordinal_position,
+                is_nullable, data_type, is_updatable,
+                character_maximum_length, numeric_precision,
+                column_default, udt_name
+           from information_schema.columns
+          where table_schema = ? and table_name = ?
+       ) as info
+       left outer join (
+         select n.nspname as s,
+                t.typname as n,
+                array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals
+         from pg_type t
+            join pg_enum e on t.oid = e.enumtypid
+            join pg_catalog.pg_namespace n ON n.oid = t.typnamespace
+         group by s, n
+       ) as enum_info
+       on (info.udt_name = enum_info.n)
+    order by position |] (qtSchema table) (qtName table)
+
+  fks <- foreignKeys table
+  return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols
+
+
+primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text]
+primaryKeyColumns table = do
+  r :: [Identity Text] <- H.list $ [H.q|
+    select kc.column_name
+      from
+        information_schema.table_constraints tc,
+        information_schema.key_column_usage kc
+    where
+      tc.constraint_type = 'PRIMARY KEY'
+      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)
+  return $ map runIdentity r
+
+
+vanishNull :: [a] -> Maybe [a]
+vanishNull xs = if L.null xs then Nothing else Just xs
+
+toBool :: Text -> Bool
+toBool = (== "YES")
 
 data Table = Table {
   tableSchema :: Text
@@ -24,40 +113,10 @@ data Table = Table {
 , tableInsertable :: Bool
 } deriving (Show)
 
-instance JSON.ToJSON Table where
-  toJSON v = JSON.object [
-      "schema"     .= tableSchema v
-    , "name"       .= tableName v
-    , "insertable" .= tableInsertable v ]
-
-toBool :: Text -> Bool
-toBool = (== "YES")
-
 data ForeignKey = ForeignKey {
   fkTable::Text, fkCol::Text
 } deriving (Eq, Show)
 
-instance JSON.ToJSON ForeignKey where
-  toJSON fk = JSON.object ["table".=fkTable fk, "column".=fkCol fk]
-
-foreignKeys :: Text -> Text -> Connection -> IO (Map.Map Text ForeignKey)
-foreignKeys schema table conn = do
-  r <- quickQuery conn
-    "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 \
-    \  join information_schema.key_column_usage AS kcu \
-    \    on tc.constraint_name = kcu.constraint_name \
-    \  join information_schema.constraint_column_usage AS ccu \
-    \    on ccu.constraint_name = tc.constraint_name \
-    \where constraint_type = 'FOREIGN KEY' \
-    \  and tc.table_name=? and tc.table_schema = ? \
-    \order by kcu.column_name" (map toSql [table, schema])
-  return $ foldl addKey Map.empty $ map (map fromSql) r
-  where
-    addKey m [col, ftab, fcol] = Map.insert col (ForeignKey ftab fcol) m
-    addKey m _ = m --should never happen
-
 data Column = Column {
   colSchema :: Text
 , colTable :: Text
@@ -69,12 +128,44 @@ data Column = Column {
 , colMaxLen :: Maybe Int
 , colPrecision :: Maybe Int
 , colDefault :: Maybe Text
-, colEnum :: Maybe [Text]
+, colEnum :: [Text]
 , colFK :: Maybe ForeignKey
 } deriving (Show)
 
-instance JSON.ToJSON Column where
+instance H.RowParser H.Postgres Column where
-  toJSON c = JSON.object [
+  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   = toBool <$> (H.parseResult $ r V.! 4 :: Either Text Text)
+        typ        = H.parseResult $ r V.! 5
+        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
+        enum       = either (const $ Right []) (Right . split (==','))
+                       (H.parseResult $ r V.! 10 :: Either Text Text)
+      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.! 1
+        insertable = toBool <$> (H.parseResult $ r V.! 2 :: Either Text Text) 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
     , "name"      .= colName c
     , "position"  .= colPosition c
@@ -87,107 +178,11 @@ instance JSON.ToJSON Column where
     , "default"   .= colDefault c
     , "enum"      .= colEnum c ]
 
-data TableOptions = TableOptions {
+instance ToJSON ForeignKey where
-  tblOptcolumns :: [Column]
+  toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
-, tblOptpkey :: [Text]
-}
 
-instance JSON.ToJSON TableOptions where
+instance ToJSON Table where
-  toJSON t = JSON.object [
+  toJSON v = object [
-      "columns" .= tblOptcolumns t
+      "schema"     .= tableSchema v
-    , "pkey"    .= tblOptpkey t ]
+    , "name"       .= tableName v
-
+    , "insertable" .= tableInsertable v ]
-tables :: Text -> Connection -> IO [Table]
-tables s conn = do
-  r <- quickQuery conn
-        "select table_schema, table_name,\
-        \       is_insertable_into\
-        \  from information_schema.tables\
-        \ where table_schema = ?\
-        \ order by table_name" [toSql s]
-  return $ mapMaybe mkTable r
-
-  where
-    mkTable [schema, name, insertable] =
-      Just $ Table (fromSql schema)
-        (fromSql name)
-        (toBool (fromSql insertable))
-    mkTable _ = Nothing
-
-columns :: Text -> Text -> Connection -> IO [Column]
-columns s t conn = do
-  r <- quickQuery conn
-    "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, \
-    \       info.is_updatable as updatable, \
-    \       info.character_maximum_length as max_len, \
-    \       info.numeric_precision as precision, \
-    \       info.column_default as default_value, \
-    \       array_to_string(enum_info.vals, ',') as enum \
-    \   from ( \
-    \     select table_schema, table_name, column_name, ordinal_position, \
-    \            is_nullable, data_type, is_updatable, \
-    \            character_maximum_length, numeric_precision, \
-    \            column_default, udt_name \
-    \       from information_schema.columns \
-    \      where table_schema = ? and table_name = ? \
-    \   ) as info \
-    \   left outer join ( \
-    \     select n.nspname as s, \
-    \            t.typname as n, \
-    \            array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals \
-    \     from pg_type t \
-    \        join pg_enum e on t.oid = e.enumtypid \
-    \        join pg_catalog.pg_namespace n ON n.oid = t.typnamespace \
-    \     group by s, n \
-    \   ) as enum_info \
-    \   on (info.udt_name = enum_info.n) \
-    \order by position" [toSql s, toSql t]
-  fks <- foreignKeys s t conn
-  let lookupFK (_:_:name:_) = Map.lookup (fromSql name) fks
-      lookupFK _ = Nothing
-  let cols = zipWith ($) (map mkColumn r) (map lookupFK r)
-  return cols
-
-  where
-    mkColumn [schema, table, name, pos, nullable, colT, updatable, maxlen, precision, defVal, enum] = Column (fromSql schema)
-        (fromSql table)
-        (fromSql name)
-        (fromSql pos)
-        (toBool (fromSql nullable))
-        (fromSql colT)
-        (toBool (fromSql updatable))
-        (fromSql maxlen)
-        (fromSql precision)
-        (fromSql defVal)
-        (Data.Text.splitOn "," <$> fromSql enum)
-    mkColumn _ =  error $ "Incomplete column data received for table " <>
-      cs t <> " in schema " <> cs s <> "."
-
-printTables :: Text -> Connection -> IO BL.ByteString
-printTables schema conn = JSON.encode <$> tables schema conn
-
-printColumns :: Text -> Text -> Connection -> IO BL.ByteString
-printColumns schema table conn =
-  JSON.encode <$> (TableOptions <$> cols <*> pkey)
-  where
-    cols :: IO [Column]
-    cols = columns schema table conn
-    pkey :: IO [Text]
-    pkey = primaryKeyColumns schema table conn
-
-primaryKeyColumns :: Text -> Text -> Connection -> IO [Text]
-primaryKeyColumns s t conn = do
-  r <- quickQuery conn
-        "select kc.column_name \
-        \  from \
-        \    information_schema.table_constraints tc, \
-        \    information_schema.key_column_usage kc \
-        \where \
-        \  tc.constraint_type = 'PRIMARY KEY' \
-        \  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  = ?" [toSql s, toSql t]
-  return $ map fromSql (concat r)

src/RangeQuery.hs

@@ -1,8 +1,16 @@
-module RangeQuery where
+module RangeQuery (
+  rangeParse
+, rangeRequested
+, rangeLimit
+, rangeOffset
+, NonnegRange
+) where
 
 import Control.Applicative
 import Network.HTTP.Types.Header
 
+import qualified Data.ByteString.Char8 as BS
+
 import Data.Ranged.Boundaries
 import Data.Ranged.Ranges
 
@@ -14,6 +22,33 @@ import Data.Maybe (fromMaybe, listToMaybe)
 
 type NonnegRange = Range Int
 
+rangeParse :: BS.ByteString -> Maybe NonnegRange
+rangeParse range = do
+  let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString
+
+  parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]])
+
+  let [_, from, to] = readMaybe . cs <$> parsedRange
+  let lower = fromMaybe emptyRange   (rangeGeq <$> from)
+  let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to)
+
+  return $ rangeIntersection lower upper
+
+rangeRequested :: RequestHeaders -> Maybe NonnegRange
+rangeRequested = (rangeParse =<<) . lookup hRange
+
+rangeLimit :: NonnegRange -> Maybe Int
+rangeLimit range =
+  case [rangeLower range, rangeUpper range]
+    of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)
+       _ -> Nothing
+
+rangeOffset :: NonnegRange -> Int
+rangeOffset range =
+  case rangeLower range
+    of BoundaryBelow from -> from
+       _ -> error "range without lower bound" -- should never happen
+
 rangeGeq :: Int -> NonnegRange
 rangeGeq n =
   Range (BoundaryBelow n) BoundaryAboveAll
@@ -21,33 +56,3 @@ rangeGeq n =
 rangeLeq :: Int -> NonnegRange
 rangeLeq n =
   Range BoundaryBelowAll (BoundaryAbove n)
-
-parseRange :: String -> Maybe NonnegRange
-parseRange range = do
-  let rangeRegex = "^([0-9]+)-([0-9]*)$" :: String
-
-  parsedRange <- listToMaybe (range =~ rangeRegex :: [[String]])
-
-  let [_, from, to] = readMaybe <$> parsedRange
-  let lower = fromMaybe emptyRange   (rangeGeq <$> from)
-  let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to)
-
-  return $ rangeIntersection lower upper
-
-requestedRange :: RequestHeaders -> Maybe NonnegRange
-requestedRange hdrs = parseRange =<< cs <$> lookup hRange hdrs
-
-requestedContentRange :: RequestHeaders -> Maybe NonnegRange
-requestedContentRange hdrs = parseRange =<< cs <$> lookup "Content-Range" hdrs
-
-limit :: NonnegRange -> Maybe Int
-limit range =
-  case [rangeLower range, rangeUpper range]
-    of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)
-       _ -> Nothing
-
-offset :: NonnegRange -> Int
-offset range =
-  case rangeLower range
-    of BoundaryBelow from -> from
-       _ -> error "range without lower bound" -- should never happen

src/Types.hs

@@ -1,8 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Types where
 
-import Database.HDBC (toSql, iToSql, SqlValue(..))
-
 import qualified Data.Aeson as JSON
 import Data.Aeson.Types (Parser)
 
@@ -11,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

test/Feature/AuthSpec.hs

@@ -11,7 +11,7 @@ import SpecHelper
 -- }}}
 
 spec :: Spec
-spec = around appWithFixture $
+spec = before resetDb $ around withApp $
   describe "authorization" $ do
     it "hides tables that anonymous does not own" $
       get "/authors_only" `shouldRespondWith` 400 -- TODO: should be 404

test/Feature/CorsSpec.hs

@@ -12,7 +12,7 @@ import Network.HTTP.Types
 -- }}}
 
 spec :: Spec
-spec = around appWithFixture $
+spec = before resetDb $ around withApp $
   describe "CORS" $ do
     let preflightHeaders = [
           ("Accept", "*/*"),

test/Feature/InsertSpec.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Feature.InsertSpec where
 
--- {{{ Imports
 import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
@@ -17,19 +16,21 @@ import Control.Monad (replicateM_)
 
 import TestTypes(IncPK(..), CompoundPK(..))
 
--- }}}
+--import Debug.Trace
 
 spec :: Spec
-spec = around appWithFixture $ do
+spec = before resetDb $ around withApp $ do
   describe "Posting new record" $ do
-    it "accepts disparate json types" $
+    it "accepts disparate json types" $ do
-      post "/menagerie"
+      p <- post "/menagerie"
         [json| {
           "integer": 13, "double": 3.14159, "varchar": "testing!"
         , "boolean": false, "date": "01/01/1900", "money": "$3.99"
         , "enum": "foo"
         } |]
-        `shouldRespondWith` 201
+      liftIO $ do
+        simpleBody p `shouldBe` ""
+        simpleStatus p `shouldBe` created201
 
     context "with no pk supplied" $ do
       context "into a table with auto-incrementing pk" $
@@ -94,13 +95,6 @@ spec = around appWithFixture $ do
 
       context "with a fully-specified primary key" $ do
 
-        context "with Content-Range header" $
-          it "fails as per RFC7231" $
-            request methodPut "/compound_pk?k1=eq.1&k2=eq.2"
-              [("Content-Range", "0-0")]
-              [json| { "k1":1, "k2":2, "extra":3 } |]
-                `shouldRespondWith` 400
-
         context "not specifying every column in the table" $
           it "is rejected for lack of idempotence" $
             request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []

test/Feature/QuerySpec.hs

@@ -6,7 +6,7 @@ import Test.Hspec.Wai
 import SpecHelper
 
 spec :: Spec
-spec = around appWithFixture $ do
+spec = before resetDb $ around withApp $ do
   describe "Querying a nonexistent table" $
     it "causes a 404" $
       get "/faketable" `shouldRespondWith` 404

test/Feature/RangeSpec.hs

@@ -8,7 +8,7 @@ import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
 import SpecHelper
 
 spec :: Spec
-spec = around appWithFixture $
+spec = before resetDb $ around withApp $
   describe "GET /items" $ do
 
     context "without range headers" $

test/Feature/StructureSpec.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 module Feature.StructureSpec where
 
 import Test.Hspec
@@ -8,22 +8,14 @@ import Test.Hspec.Wai.JSON
 import SpecHelper
 
 import Network.HTTP.Types
-import Codec.Binary.Base64.String (encode)
-import Data.Monoid ((<>))
-import Data.String.Conversions (cs)
 
 spec :: Spec
-spec = let {uName = "a user"; uPass = "nobody can ever know";
+spec = before resetDb $ around withApp $ do
-uRole = "dbapi_test"} in
+  describe "GET /" $ do
-  around withDatabaseConnection $
-  aroundWith (withUser uName uPass uRole) $ aroundWith withApp $ do
-  describe "GET /" $
     it "lists views in schema" $
-      request methodGet "/"
+      request methodGet "/" [] ""
-        [("Authorization", "Basic "<>(cs.encode $ cs uName<>":"<>cs uPass))] ""
         `shouldRespondWith` [json| [
-        {"schema":"1","name":"authors_only","insertable":true}
+          {"schema":"1","name":"auto_incrementing_pk","insertable":true}
-        , {"schema":"1","name":"auto_incrementing_pk","insertable":true}
         , {"schema":"1","name":"compound_pk","insertable":true}
         , {"schema":"1","name":"has_fk","insertable":true}
         , {"schema":"1","name":"items","insertable":true}
@@ -33,6 +25,17 @@ uRole = "dbapi_test"} in
         ] |]
         {matchStatus = 200}
 
+    it "lists only views user has permission to see" $ do
+      _ <- post "/dbapi/users" [json| { "id":"jdoe", "pass": "1234", "role": "dbapi_test_author" } |]
+      let auth = authHeader "jdoe" "1234"
+
+      request methodGet "/" [auth] ""
+        `shouldRespondWith` [json| [
+          {"schema":"1","name":"authors_only","insertable":true}
+        ] |]
+        {matchStatus = 200}
+
+
   describe "Table info" $ do
     it "is available with OPTIONS verb" $
       request methodOptions "/menagerie" [] "" `shouldRespondWith`
@@ -48,7 +51,7 @@ uRole = "dbapi_test"} in
             "name": "integer",
             "type": "integer",
             "maxLen": null,
-            "enum": null,
+            "enum": [],
             "nullable": false,
             "position": 1,
             "references": null,
@@ -61,7 +64,7 @@ uRole = "dbapi_test"} in
             "name": "double",
             "type": "double precision",
             "maxLen": null,
-            "enum": null,
+            "enum": [],
             "nullable": false,
             "references": null,
             "position": 2
@@ -73,7 +76,7 @@ uRole = "dbapi_test"} in
             "name": "varchar",
             "type": "character varying",
             "maxLen": null,
-            "enum": null,
+            "enum": [],
             "nullable": false,
             "position": 3,
             "references": null,
@@ -86,7 +89,7 @@ uRole = "dbapi_test"} in
             "name": "boolean",
             "type": "boolean",
             "maxLen": null,
-            "enum": null,
+            "enum": [],
             "nullable": false,
             "references": null,
             "position": 4
@@ -98,7 +101,7 @@ uRole = "dbapi_test"} in
             "name": "date",
             "type": "date",
             "maxLen": null,
-            "enum": null,
+            "enum": [],
             "nullable": false,
             "references": null,
             "position": 5
@@ -110,7 +113,7 @@ uRole = "dbapi_test"} in
             "name": "money",
             "type": "money",
             "maxLen": null,
-            "enum": null,
+            "enum": [],
             "nullable": false,
             "position": 6,
             "references": null,
@@ -137,8 +140,7 @@ uRole = "dbapi_test"} in
       |]
 
     it "includes foreign key data" $
-      request methodOptions "/has_fk"
+      request methodOptions "/has_fk" [] ""
-        [("Authorization", "Basic "<>(cs.encode $ cs uName<>":"<>cs uPass))] ""
         `shouldRespondWith` [json|
       {
         "pkey": ["id"],
@@ -153,7 +155,7 @@ uRole = "dbapi_test"} in
             "maxLen": null,
             "nullable": false,
             "position": 1,
-            "enum": null,
+            "enum": [],
             "references": null
           }, {
             "default": null,
@@ -165,7 +167,7 @@ uRole = "dbapi_test"} in
             "maxLen": null,
             "nullable": true,
             "position": 2,
-            "enum": null,
+            "enum": [],
             "references": {"table": "auto_incrementing_pk", "column": "id"}
           }, {
             "default": null,
@@ -177,7 +179,7 @@ uRole = "dbapi_test"} in
             "maxLen": 255,
             "nullable": true,
             "position": 3,
-            "enum": null,
+            "enum": [],
             "references": {"table": "simple_pk", "column": "k"}
           }
         ]

test/Main.hs

@@ -1,17 +0,0 @@
-module Main where
-
-import Database.HDBC (runRaw, disconnect)
-import Test.Hspec
-import Spec
-import SpecHelper (openConnection, loadFixture)
-
-main :: IO ()
-main = do
-  c <-openConnection
-  runRaw c "drop schema if exists \"1\" cascade"
-  runRaw c "drop schema if exists private cascade"
-  runRaw c "drop schema if exists dbapi cascade"
-  loadFixture "roles" c
-  loadFixture "schema" c
-  disconnect c
-  hspec spec

test/Spec.hs

@@ -1 +1 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

test/SpecHelper.hs

@@ -1,27 +1,35 @@
+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
+
 module SpecHelper where
 
 import Network.Wai
 import Test.Hspec
 import Test.Hspec.Wai
 
-import Database.HDBC
+import Hasql as H
-import Database.HDBC.PostgreSQL
+import Hasql.Postgres as H
 
 import Data.String.Conversions (cs)
-import Control.Exception.Base (bracket, finally)
+-- import Control.Exception.Base (bracket, finally)
+import Control.Monad.Reader (runReaderT, ask)
+import Control.Monad (void)
+import Control.Applicative ( (<$>) )
+import Control.Exception
 
 import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
                                   hRange, hAuthorization)
 import Codec.Binary.Base64.String (encode)
 import Data.CaseInsensitive (CI(..))
+import Data.Maybe (fromMaybe)
 import Text.Regex.TDFA ((=~))
 import qualified Data.ByteString.Char8 as BS
 import Network.Wai.Middleware.Cors (cors)
+import System.Process (readProcess)
 
-import Middleware(clientErrors, withSavepoint, authenticated, Environment(..))
+import App (app, sqlErrHandler, isSqlError)
-
+import Config (AppConfig(..), corsPolicy)
-import Dbapi (app, corsPolicy, AppConfig(..))
+import Middleware
-import PgQuery(addUser)
+-- import Auth (addUser)
 
 isLeft :: Either a b -> Bool
 isLeft (Left _ ) = True
@@ -30,43 +38,40 @@ isLeft _ = False
 cfg :: AppConfig
 cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10
 
-openConnection :: IO Connection
+testSettings :: SessionSettings
-openConnection = connectPostgreSQL' $ configDbUri cfg
+testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30
 
-withDatabaseConnection :: (Connection -> IO ()) -> IO ()
+pgSettings :: Postgres
-withDatabaseConnection = bracket openConnection disconnect
+pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test"
 
-loadFixture :: String -> Connection -> IO ()
+withApp :: ActionWith Application -> IO ()
-loadFixture name conn = do
+withApp perform =
-  sql <- readFile $ "test/fixtures/" ++ name ++ ".sql"
+  perform $ middle $ \req resp ->
-  runRaw conn sql
+    H.session pgSettings testSettings $ do
+      session' <- flip runReaderT <$> ask
+      liftIO $ resp =<< catchJust isSqlError
+          (session' $ authenticated (cs $ configAnonRole cfg) app req)
+          sqlErrHandler
 
-dbWithSchema :: ActionWith Connection -> IO ()
+  where middle = cors corsPolicy
-dbWithSchema action = withDatabaseConnection $ \c -> do
-  runRaw c "begin;"
-  action c
-  rollback c
 
-withUser :: BS.ByteString -> BS.ByteString -> BS.ByteString ->
-            ActionWith Connection -> ActionWith Connection
-withUser name pass role action conn = do
-  addUser name pass role conn
-  finally (action conn) $ do
-    _ <- run conn "delete from dbapi.auth where id=?" [toSql name]
-    runRaw conn "commit"
 
-withApp :: ActionWith Application -> ActionWith Connection
+resetDb :: IO ()
-withApp action conn = do
+resetDb = do
-  runRaw conn "begin;"
+  H.session pgSettings testSettings $
-  action $ cors corsPolicy $ authenticated "dbapi_anonymous" app conn
+    H.tx Nothing $ do
-  rollback conn
+      H.unit [H.q| drop schema if exists "1" cascade |]
+      H.unit [H.q| drop schema if exists private cascade |]
+      H.unit [H.q| drop schema if exists dbapi cascade |]
+
+  loadFixture "roles"
+  loadFixture "schema"
+
+
+loadFixture :: FilePath -> IO()
+loadFixture name =
+  void $ readProcess "psql" ["-U", "dbapi_test", "-d", "dbapi_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []
 
-appWithFixture :: ActionWith Application -> IO ()
-appWithFixture action = withDatabaseConnection $ \c -> do
-  runRaw c "begin;"
-  action $ cors corsPolicy . clientErrors  $
-    (authenticated "dbapi_anonymous" . withSavepoint Test) app c
-  rollback c
 
 rangeHdrs :: ByteRange -> [Header]
 rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]
@@ -79,8 +84,8 @@ matchHeader name valRegex headers =
   maybe False (=~ valRegex) $ lookup name headers
 
 authHeader :: String -> String -> Header
-authHeader user pass =
+authHeader u p =
-  (hAuthorization, cs $ "Basic " ++ encode (user ++ ":" ++ pass))
+  (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
 
 -- for hspec-wai
 pending_ :: WaiSession ()

test/TestTypes.hs

@@ -1,18 +1,16 @@
 module TestTypes (
   IncPK(..)
 , CompoundPK(..)
-, incFromList
+-- , incFromList
-, compoundFromList
+-- , compoundFromList
 ) where
 
 import qualified Data.Aeson as JSON
 import Data.Aeson ((.:))
-import Data.Maybe (fromJust)
+-- import Data.Maybe (fromJust)
 import Control.Applicative ((<$>), (<*>))
 import Control.Monad (mzero)
 
-import Database.HDBC (SqlValue, fromSql)
-
 data IncPK = IncPK {
   incId :: Int
 , incNullableStr :: Maybe String
@@ -28,12 +26,12 @@ instance JSON.FromJSON IncPK where
     r .: "inserted_at"
   parseJSON _ = mzero
 
-incFromList :: [(String, SqlValue)] -> IncPK
+-- incFromList :: [(String, SqlValue)] -> IncPK
-incFromList row = IncPK
+-- incFromList row = IncPK
-  (fromSql . fromJust $ lookup "id" row)
+--   (fromSql . fromJust $ lookup "id" row)
-  (fromSql . fromJust $ lookup "nullable_string" row)
+--   (fromSql . fromJust $ lookup "nullable_string" row)
-  (fromSql . fromJust $ lookup "non_nullable_string" row)
+--   (fromSql . fromJust $ lookup "non_nullable_string" row)
-  (fromSql . fromJust $ lookup "inserted_at" row)
+--   (fromSql . fromJust $ lookup "inserted_at" row)
 
 data CompoundPK = CompoundPK {
   compoundK1 :: Int
@@ -48,8 +46,8 @@ instance JSON.FromJSON CompoundPK where
     r .: "extra"
   parseJSON _ = mzero
 
-compoundFromList :: [(String, SqlValue)] -> CompoundPK
+-- compoundFromList :: [(String, SqlValue)] -> CompoundPK
-compoundFromList row = CompoundPK
+-- compoundFromList row = CompoundPK
-  (fromSql . fromJust $ lookup "k1" row)
+--   (fromSql . fromJust $ lookup "k1" row)
-  (fromSql . fromJust $ lookup "k2" row)
+--   (fromSql . fromJust $ lookup "k2" row)
-  (fromSql . fromJust $ lookup "extra" row)
+--   (fromSql . fromJust $ lookup "extra" row)

test/fixtures/roles.sql

@@ -11,7 +11,6 @@ BEGIN
 END;
 $$;
 
-select pg_temp.create_role_if_not_exists('dbapi_anonymous', 'with nologin');
+select pg_temp.create_role_if_not_exists('dbapi_anonymous', 'with nologin') as a
-select pg_temp.create_role_if_not_exists('test_default_role', 'with nologin');
+     , pg_temp.create_role_if_not_exists('test_default_role', 'with nologin') as b
-
+     , pg_temp.create_role_if_not_exists('dbapi_test_author', 'with nologin') into temp shh;
-select pg_temp.create_role_if_not_exists('dbapi_test_author', 'with nologin');

test/fixtures/schema.sql

@@ -741,6 +741,11 @@ GRANT ALL ON TABLE compound_pk TO dbapi_test;
 GRANT ALL ON TABLE compound_pk TO dbapi_anonymous;
 
 
+REVOKE ALL ON TABLE has_fk FROM PUBLIC;
+REVOKE ALL ON TABLE has_fk FROM dbapi_test;
+GRANT ALL ON TABLE has_fk TO dbapi_test;
+GRANT ALL ON TABLE has_fk TO dbapi_anonymous;
+
 --
 -- TOC entry 2328 (class 0 OID 0)
 -- Dependencies: 197