diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 149eb2dd3..000000000 --- a/.travis.yml +++ /dev/null @@ -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 diff --git a/README.md b/README.md index 1ad9b7ac6..370ab8a82 100644 --- a/README.md +++ b/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 diff --git a/circle.yml b/circle.yml new file mode 100644 index 000000000..fd146bd94 --- /dev/null +++ b/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 diff --git a/dbapi.cabal b/dbapi.cabal index 1ff77708b..02737d805 100644 --- a/dbapi.cabal +++ b/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 - Other-Modules: Dbapi + , resource-pool + , 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 - Other-Modules: Dbapi, Spec, SpecHelper - Build-Depends: base, hspec2, QuickCheck + Main-Is: Spec.hs + Other-Modules: App, Auth, Config, Spec, SpecHelper + 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 diff --git a/src/App.hs b/src/App.hs new file mode 100644 index 000000000..fa589da77 --- /dev/null +++ b/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 ] diff --git a/src/Auth.hs b/src/Auth.hs new file mode 100644 index 000000000..87add40f0 --- /dev/null +++ b/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 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 000000000..8930dc347 --- /dev/null +++ b/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 -> [] diff --git a/src/Dbapi.hs b/src/Dbapi.hs deleted file mode 100644 index 26e22276a..000000000 --- a/src/Dbapi.hs +++ /dev/null @@ -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) diff --git a/src/Main.hs b/src/Main.hs index 02a759497..890f2a567 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,61 +2,60 @@ module Main where import Paths_dbapi (version) -import Dbapi -import Middleware (inTransaction, authenticated, withSavepoint, clientErrors, - redirectInsecure, withDBConnection, Environment(..)) -import Network.Wai.Handler.Warp hiding (Connection) -import Data.String.Conversions (cs) +import App +import Middleware import Control.Monad (unless) -import Control.Applicative -import Control.Exception(bracket) -import Options.Applicative hiding (columns) -import Network.Wai.Middleware.Gzip (gzip, def) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (runReaderT, ask) +import Control.Exception +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 -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") +import Config (AppConfig(..), argParser, corsPolicy) main :: IO () main = do conf <- execParser (info (helper <*> argParser) describe) - bracket - (createPool (connectPostgreSQL' (configDbUri conf)) - disconnect 1 600 (configPool conf)) - destroyAllResources - (\pool -> do - let port = configPort conf + let port = configPort conf - unless (configSecure conf) $ - putStrLn "WARNING, running in insecure mode, auth will be in plaintext" + unless (configSecure conf) $ + putStrLn "WARNING, running in insecure mode, auth will be in plaintext" - Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) - let settings = setPort port - . setServerName (cs $ "dbapi/" <> prettyVersion) - $ defaultSettings - runSettings settings $ (if configSecure conf then redirectInsecure else id) + Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) + + + let pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test" + + 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 diff --git a/src/Middleware.hs b/src/Middleware.hs index 55b04f836..85529de2d 100644 --- a/src/Middleware.hs +++ b/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 Database.HDBC (runRaw) -import Database.HDBC.PostgreSQL (Connection) -import Database.HDBC.Types (SqlError(..)) +import Data.Text +-- import Data.Pool(withResource, Pool) +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 (finally, throw, catchJust, catch, SomeException, - bracket_) +import Control.Exception (catchJust) -import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization, - hLocation) -import Network.HTTP.Types.Status (status400, status401, status404, status301) +import Network.HTTP.Types.Header (hLocation, hContentType, hAuthorization) +import Network.HTTP.Types (RequestHeaders) +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 -withDBConnection pool app req respond = - withResource pool (\c -> app c req respond) +-- safeAction :: Request -> Bool +-- safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod -safeAction :: Request -> Bool -safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod +-- withSavepoint :: Environment -> (Connection -> Application) -> +-- 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) -> - Connection -> Application -inTransaction env app conn req respond = - 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 +authenticated :: Text -> (Request -> H.Session H.Postgres IO Response) -> + Request -> H.Session H.Postgres IO Response +authenticated anon app req = 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" - LoginSuccess role -> - bracket_ (setRole conn role) (resetRole conn) $ app conn req respond - NoCredentials -> - bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond + return $ responseLBS status401 [] "Invalid username or password" + LoginSuccess role -> runInRole role + NoCredentials -> runInRole anon 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 - (u:p:_) -> signInRole u p conn + case split (==':') (cs . decode . cs $ b64) of + (u:p:_) -> H.tx Nothing $ signInRole u p _ -> return MalformedAuth _ -> return NoCredentials -instance ToJSON SqlError where - toJSON t = object [ - "error" .= object [ - "code" .= seNativeError t - , "message" .= seErrorMsg t - , "state" .= seState t - ] - ] + runInRole :: Text -> H.Session H.Postgres IO Response + runInRole r = do + H.tx Nothing $ setRole r + resp <- app req + H.tx Nothing resetRole + 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" - then responseLBS status404 [] "" - else responseLBS status400 [(hContentType, "application/json")] (encode err) + respond $ + responseLBS status400 [(hContentType, "application/json")] (cs $ show 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) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index f3b193b76..0651029ac 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,242 +1,173 @@ --- {{{ Imports -module PgQuery ( - getRows -, insert -, update -, upsert -, addUser -, signInRole -, setRole -, resetRole -, checkPass -, pgFmtIdent -, pgFmtLit -, RangedResult(..) -, LoginAttempt(..) -, DbRole -) where +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +module PgQuery where -import Data.Text (Text, splitOn, intercalate, replace, takeWhile) -import Data.String.Conversions (cs) -import Data.Functor ( (<$>) ) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid ((<>), mconcat) -import qualified Data.Map as M +import RangeQuery -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 Control.Monad (join) - -import qualified RangeQuery as R +import qualified Network.HTTP.Types.URI as Net 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) -import Database.HDBC.PostgreSQL +type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All) -import qualified Network.HTTP.Types.URI as Net +type StatementT = DynamicSQL -> DynamicSQL -import Types (SqlRow(..), getRow, sqlRowColumns, sqlRowValues) -import Crypto.BCrypt (hashPasswordUsingPolicy, fastBcryptHashingPolicy, validatePassword) - --- }}} - -data RangedResult = RangedResult { - rrFrom :: Int -, rrTo :: Int -, rrTotal :: Int -, rrBody :: BL.ByteString +data QualifiedTable = QualifiedTable { + qtSchema :: Text +, qtName :: Text } 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 -, otColumn :: Text + otTerm :: 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 -wherePred (column, predicate) = - pgFmtIdent (cs column) <> " " <> op <> " " <> pgFmtLit (cs value) +whereT :: Net.Query -> StatementT +whereT params q = + 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 - value = BS.intercalate "." rest + opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate + value = intercalate "." rest op = case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - _ -> "=" - -limitClause :: Maybe R.NonnegRange -> Text -limitClause range = - cs $ " LIMIT " <> limit <> " OFFSET " <> show offset <> " " + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + _ -> "=" +orderParse :: Net.Query -> [OrderTerm] +orderParse q = + mapMaybe orderParseTerm . split (==',') $ cs order where - limit = fromMaybe "ALL" $ show <$> (R.limit =<< range) - offset = fromMaybe 0 $ R.offset <$> range + order = fromMaybe "" $ join (lookup "order" q) -globalAndLimitedCounts :: Schema -> Text -> Net.Query -> Text -globalAndLimitedCounts schema table qq = - " select " - <> "(select count(1) from " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " " - <> whereClause qq - <> "), count(t), " +orderParseTerm :: Text -> Maybe OrderTerm +orderParseTerm s = + case split (=='.') s of + [d,c] -> + if d `elem` ["asc", "desc"] + then Just $ OrderTerm c $ + if d == "asc" then "asc" else "desc" + else Nothing + _ -> Nothing -selectStarClause :: Schema -> Text -> Text -selectStarClause schema table = - " select * from " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " " +commaq :: DynamicSQL +commaq = (", ", [], mempty) -jsonArrayRows :: Text -> Text -jsonArrayRows q = - "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 *" +andq :: DynamicSQL +andq = (" and ", [], mempty) 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 () -setRole conn role = runRaw conn $ "set role " <> cs role +fromQt :: QualifiedTable -> BS.ByteString +fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) -resetRole :: Connection -> IO () -resetRole conn = runRaw conn "reset role" +pgParam :: JSON.Value -> H.StatementArgument H.Postgres +pgParam (JSON.Number n) = H.renderValue n +pgParam (JSON.String s) = H.renderValue s +pgParam (JSON.Bool b) = H.renderValue b +pgParam JSON.Null = H.renderValue (Nothing :: Maybe String) +pgParam (JSON.Object o) = H.renderValue $ JSON.encode o +pgParam (JSON.Array a) = H.renderValue $ JSON.encode a diff --git a/src/PgStructure.hs b/src/PgStructure.hs index e323a1569..cff646428 100644 --- a/src/PgStructure.hs +++ b/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.Aeson as JSON +import qualified Data.List as L import qualified Data.Map as Map -import Database.HDBC hiding (colType, colNullable) -import Database.HDBC.PostgreSQL +import qualified Hasql as H +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 - toJSON c = JSON.object [ +instance H.RowParser H.Postgres Column where + parseRow r = + let schema = H.parseResult $ r V.! 0 + table = H.parseResult $ r V.! 1 + name = H.parseResult $ r V.! 2 + position = H.parseResult $ r V.! 3 + nullable = 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 { - tblOptcolumns :: [Column] -, tblOptpkey :: [Text] -} +instance ToJSON ForeignKey where + toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk] -instance JSON.ToJSON TableOptions where - toJSON t = JSON.object [ - "columns" .= tblOptcolumns t - , "pkey" .= tblOptpkey t ] - -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) +instance ToJSON Table where + toJSON v = object [ + "schema" .= tableSchema v + , "name" .= tableName v + , "insertable" .= tableInsertable v ] diff --git a/src/RangeQuery.hs b/src/RangeQuery.hs index 45b6dfdbc..6eb4bfedf 100644 --- a/src/RangeQuery.hs +++ b/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 diff --git a/src/Types.hs b/src/Types.hs index 0ad9a72ab..27e323357 100644 --- a/src/Types.hs +++ b/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 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index 55e754d9c..f2e4cf38d 100644 --- a/test/Feature/AuthSpec.hs +++ b/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 diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs index 4d25b04aa..33c518cd5 100644 --- a/test/Feature/CorsSpec.hs +++ b/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", "*/*"), diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 8f047dc69..f27223779 100644 --- a/test/Feature/InsertSpec.hs +++ b/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" $ - post "/menagerie" + it "accepts disparate json types" $ do + 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" [] diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 06328b685..1d477b3de 100644 --- a/test/Feature/QuerySpec.hs +++ b/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 diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index 8beba88bb..dc31279da 100644 --- a/test/Feature/RangeSpec.hs +++ b/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" $ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 7ef6471f3..d9393dac9 100644 --- a/test/Feature/StructureSpec.hs +++ b/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"; -uRole = "dbapi_test"} in - around withDatabaseConnection $ - aroundWith (withUser uName uPass uRole) $ aroundWith withApp $ do - describe "GET /" $ +spec = before resetDb $ around withApp $ do + describe "GET /" $ do it "lists views in schema" $ - request methodGet "/" - [("Authorization", "Basic "<>(cs.encode $ cs uName<>":"<>cs uPass))] "" + request methodGet "/" [] "" `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" - [("Authorization", "Basic "<>(cs.encode $ cs uName<>":"<>cs uPass))] "" + request methodOptions "/has_fk" [] "" `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"} } ] diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 index 6a36d32da..000000000 --- a/test/Main.hs +++ /dev/null @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs index b4e92e756..a824f8c30 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1 +1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 65a09bf57..74eb9bfa7 100644 --- a/test/SpecHelper.hs +++ b/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 Database.HDBC.PostgreSQL +import Hasql as H +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 Dbapi (app, corsPolicy, AppConfig(..)) -import PgQuery(addUser) +import App (app, sqlErrHandler, isSqlError) +import Config (AppConfig(..), corsPolicy) +import Middleware +-- 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 -openConnection = connectPostgreSQL' $ configDbUri cfg +testSettings :: SessionSettings +testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30 -withDatabaseConnection :: (Connection -> IO ()) -> IO () -withDatabaseConnection = bracket openConnection disconnect +pgSettings :: Postgres +pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test" -loadFixture :: String -> Connection -> IO () -loadFixture name conn = do - sql <- readFile $ "test/fixtures/" ++ name ++ ".sql" - runRaw conn sql +withApp :: ActionWith Application -> IO () +withApp perform = + perform $ middle $ \req resp -> + 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 () -dbWithSchema action = withDatabaseConnection $ \c -> do - runRaw c "begin;" - action c - rollback c + where middle = cors corsPolicy -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 -withApp action conn = do - runRaw conn "begin;" - action $ cors corsPolicy $ authenticated "dbapi_anonymous" app conn - rollback conn +resetDb :: IO () +resetDb = 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 |] + 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 = - (hAuthorization, cs $ "Basic " ++ encode (user ++ ":" ++ pass)) +authHeader u p = + (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p)) -- for hspec-wai pending_ :: WaiSession () diff --git a/test/TestTypes.hs b/test/TestTypes.hs index 95998406d..e5e02bc87 100644 --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -1,18 +1,16 @@ module TestTypes ( IncPK(..) , CompoundPK(..) -, incFromList -, compoundFromList +-- , incFromList +-- , 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 row = IncPK - (fromSql . fromJust $ lookup "id" row) - (fromSql . fromJust $ lookup "nullable_string" row) - (fromSql . fromJust $ lookup "non_nullable_string" row) - (fromSql . fromJust $ lookup "inserted_at" row) +-- incFromList :: [(String, SqlValue)] -> IncPK +-- incFromList row = IncPK +-- (fromSql . fromJust $ lookup "id" row) +-- (fromSql . fromJust $ lookup "nullable_string" row) +-- (fromSql . fromJust $ lookup "non_nullable_string" 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 row = CompoundPK - (fromSql . fromJust $ lookup "k1" row) - (fromSql . fromJust $ lookup "k2" row) - (fromSql . fromJust $ lookup "extra" row) +-- compoundFromList :: [(String, SqlValue)] -> CompoundPK +-- compoundFromList row = CompoundPK +-- (fromSql . fromJust $ lookup "k1" row) +-- (fromSql . fromJust $ lookup "k2" row) +-- (fromSql . fromJust $ lookup "extra" row) diff --git a/test/Unit/ErrorsSpec.hs b/test/Unit/ErrorsSpec.hx similarity index 100% rename from test/Unit/ErrorsSpec.hs rename to test/Unit/ErrorsSpec.hx diff --git a/test/Unit/PgQuerySpec.hs b/test/Unit/PgQuerySpec.hx similarity index 100% rename from test/Unit/PgQuerySpec.hs rename to test/Unit/PgQuerySpec.hx diff --git a/test/Unit/PgStructureSpec.hs b/test/Unit/PgStructureSpec.hx similarity index 100% rename from test/Unit/PgStructureSpec.hs rename to test/Unit/PgStructureSpec.hx diff --git a/test/fixtures/roles.sql b/test/fixtures/roles.sql index ecc1020a8..db8a90f55 100644 --- a/test/fixtures/roles.sql +++ b/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('test_default_role', 'with nologin'); - -select pg_temp.create_role_if_not_exists('dbapi_test_author', 'with nologin'); +select pg_temp.create_role_if_not_exists('dbapi_anonymous', 'with nologin') as a + , 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; diff --git a/test/fixtures/schema.sql b/test/fixtures/schema.sql index 556fdf802..44a90c2aa 100755 --- a/test/fixtures/schema.sql +++ b/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