postgrest (empty) → 0.2.5.0
raw patch · 15 files changed
+1329/−0 lines, 15 filesdep +HTTPdep +QuickCheckdep +Ranged-setssetup-changed
Dependencies added: HTTP, QuickCheck, Ranged-sets, aeson, base, base64-string, bcrypt, blaze-builder, bytestring, case-insensitive, containers, convertible, hasql, hasql-backend, hasql-postgres, hspec, hspec-wai, hspec-wai-json, http-media, http-types, mtl, network, network-uri, optparse-applicative, parsec, process, regex-base, regex-tdfa, regex-tdfa-text, resource-pool, scientific, split, string-conversions, stringsearch, text, time, transformers, unordered-containers, vector, wai, wai-cors, wai-extra, wai-middleware-static, warp
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- postgrest.cabal +93/−0
- src/App.hs +266/−0
- src/Auth.hs +69/−0
- src/Config.hs +54/−0
- src/Main.hs +64/−0
- src/Middleware.hs +76/−0
- src/PgError.hs +86/−0
- src/PgQuery.hs +234/−0
- src/PgStructure.hs +188/−0
- src/RangeQuery.hs +58/−0
- test/Main.hs +9/−0
- test/Spec.hs +1/−0
- test/SpecHelper.hs +109/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Joe Nelson++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ postgrest.cabal view
@@ -0,0 +1,93 @@+name: postgrest+description: Reads the schema of a PostgreSQL database and creates RESTful routes+ for the tables and views, supporting all HTTP verbs that security+ permits.+version: 0.2.5.0+synopsis: REST API for any Postgres database+license: MIT+license-file: LICENSE+author: Joe Nelson, Adam Baker+homepage: https://github.com/begriffs/postgrest+maintainer: cred+github@begriffs.com+category: Web+build-type: Simple+cabal-version: >=1.10++executable postgrest+ main-is: Main.hs+ ghc-options: -Wall -W -O2+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ other-extensions: QuasiQuotes+ build-depends: base >=4.6 && <5+ , hasql == 0.4.*, hasql-backend+ , hasql-postgres == 0.8.*+ , warp >= 3.0.2, wai >= 3.0.1+ , wai-extra, wai-cors+ , wai-middleware-static >= 0.6.0+ , HTTP, convertible, http-types+ , case-insensitive+ , scientific, time+ , aeson, network >= 2.6+ , bytestring, text, split, string-conversions+ , stringsearch, parsec+ , containers, unordered-containers+ , optparse-applicative >= 0.9.1 && < 0.10+ , regex-base, regex-tdfa+ , regex-tdfa-text+ , Ranged-sets+ , transformers+ , bcrypt, base64-string+ , network-uri >= 2.6+ , resource-pool+ , blaze-builder+ , vector+ , mtl+ Other-Modules: App+ , Auth+ , Config+ , PgStructure+ , PgQuery+ , PgError+ , RangeQuery+ , Middleware+ hs-source-dirs: src++Test-Suite spec+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ default-extensions: OverloadedStrings+ other-extensions: QuasiQuotes+ Hs-Source-Dirs: test, src+ ghc-options: -Wall -W -Werror+ Main-Is: Main.hs+ Other-Modules: App, Auth, Config, Spec, SpecHelper+ Build-Depends: base, hspec >= 2.1.2, QuickCheck+ , hspec-wai >= 0.5.0, hspec-wai-json+ , hasql == 0.4.*, hasql-backend+ , hasql-postgres == 0.8.*+ , warp >= 3.0.2, wai >= 3.0.1+ , HTTP, convertible+ , case-insensitive+ , wai-extra, wai-cors, containers+ , wai-middleware-static >= 0.6.0+ , http-types, scientific, time+ , bytestring, aeson, network >= 2.6+ , text, optparse-applicative+ , stringsearch, parsec+ , unordered-containers+ , regex-base+ , string-conversions+ , http-media, regex-tdfa+ , regex-tdfa-text+ , Ranged-sets+ , transformers+ , bcrypt+ , base64-string+ , split+ , network-uri >= 2.6+ , resource-pool+ , blaze-builder+ , vector+ , mtl+ , process
+ src/App.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE FlexibleContexts #-}+module App (app, sqlError, isSqlError) where++import Control.Monad (join)+import Control.Arrow ((***))+import Control.Applicative++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 qualified Data.Set as S+import qualified Data.ByteString.Lazy as BL++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.Monoid+import qualified Hasql as H+import qualified Hasql.Postgres as H++import Auth+import PgQuery+import RangeQuery+import PgStructure+import PgError+import Text.Parsec hiding (Column)++app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response+app reqBody req =+ case (path, verb) of+ ([], _) -> do+ body <- encode <$> tables (cs schema)+ return $ responseLBS status200 [jsonH] $ cs body++ ([table], "OPTIONS") -> do+ let t = QualifiedTable schema (cs table)+ 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.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)++ (["postgrest", "users"], "POST") -> do+ let user = decode reqBody :: Maybe AuthUser++ case user of+ Nothing -> return $ responseLBS status400 [jsonH] $+ encode . object $ [("message", String "Failed to parse user.")]+ Just u -> do+ _ <- addUser (cs $ userId u)+ (cs $ userPass u) (cs $ userRole u)+ return $ responseLBS status201+ [ jsonH+ , (hLocation, "/postgrest/users?id=eq." <> cs (userId u))+ ] ""++ ([table], "POST") ->+ handleJsonObj reqBody $ \obj -> 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 reqBody $ \obj -> 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 reqBody $ \obj -> do+ let qt = QualifiedTable schema (cs table)+ H.unit+ $ coerce+ $ whereT qq+ $ update qt (map cs $ keys obj) (elems obj)+ return $ responseLBS status204 [ jsonH ] ""++ ([table], "DELETE") -> do+ let qt = QualifiedTable schema (cs table)+ let del = coerce $ countT+ . returningStarT+ . whereT qq+ $ deleteFrom qt+ row <- H.single del+ let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row+ return $ if deletedCount == 0+ then responseLBS status404 [] ""+ else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] ""++ (_, _) ->+ 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+ coerce (q, args, All b) = (q, args, b)+++isSqlError :: H.Error -> Maybe H.Error+isSqlError = Just++sqlError :: H.Error -> Response+sqlError err =+ let inside = case err of+ H.CantConnect _ ->+ "Message: \"Cannot connect to postgres server\""+ H.ConnectionLost t -> t+ H.ErroneousResult t -> t+ H.UnexpectedResult t -> t+ H.UnparsableTemplate t -> t+ H.UnparsableRow t -> t+ H.NotInTransaction -> "An operation which requires a"+ <> "database transaction was executed without one" in+ either+ (\hint ->+ responseLBS status500+ [(hContentType, "application/json")]+ (cs . encode . object $ [+ ("message", String $+ "Failed to parse exception:" <> inside)+ , ("hint", String . cs . show $ hint)]))+ (\msg ->+ responseLBS (httpStatus msg)+ [(hContentType, "application/json")]+ (encode msg))+ (parse message "" inside)+++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 :: BL.ByteString -> (Object -> H.Tx H.Postgres s Response)+ -> H.Tx H.Postgres s Response+handleJsonObj reqBody handler = do+ let p = eitherDecode reqBody+ case p of+ Left err ->+ return $ responseLBS status400 [jsonH] jErr+ where+ jErr = encode . object $+ [("message", String $ "Failed to parse JSON payload. " <> cs err)]+ Right (Object o) -> handler o+ Right _ ->+ return $ responseLBS status400 [jsonH] jErr+ where+ jErr = encode . object $+ [("message", String "Expecting a JSON object")]++data TableOptions = TableOptions {+ tblOptcolumns :: [Column]+, tblOptpkey :: [Text]+}++instance ToJSON TableOptions where+ toJSON t = object [+ "columns" .= tblOptcolumns t+ , "pkey" .= tblOptpkey t ]
+ src/Auth.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}+module Auth where++import Data.Aeson+import Control.Monad (mzero)+import Control.Applicative ( (<*>), (<$>) )+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)++import System.IO.Unsafe++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.Tx H.Postgres s ()+addUser identity pass role = do+ let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)+ H.unit $+ [H.q|insert into postgrest.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 postgrest.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 view
@@ -0,0 +1,54 @@+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 {+ configDbName :: String+ , configDbPort :: Int+ , configDbUser :: String+ , configDbPass :: String+ , configDbHost :: String++ , configPort :: Int+ , configAnonRole :: String+ , configSecure :: Bool+ , configPool :: Int+ }++argParser :: Parser AppConfig+argParser = AppConfig+ <$> strOption (long "db-name" <> short 'd' <> help "name of database")+ <*> option (long "db-port" <> short 'P' <> value 5432 <> help "postgres server port")+ <*> strOption (long "db-user" <> short 'U' <> help "postgres authenticator role")+ <*> strOption (long "db-pass" <> value "" <> help "password for authenticator role")+ <*> strOption (long "db-host" <> short 'h' <> value "localhost" <> help "postgres server hostname")++ <*> option (long "port" <> short 'p' <> value 3000 <> help "port number on which to run HTTP server")+ <*> strOption (long "anonymous" <> short 'a' <> help "postgres role to use for non-authenticated requests")+ <*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS")+ <*> option (long "db-pool" <> 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/Main.hs view
@@ -0,0 +1,64 @@+module Main where++import Paths_postgrest (version)++import App+import Middleware++import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Exception+import Data.String.Conversions (cs)+import Network.Wai (strictRequestBody)+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 Data.List (intercalate)+import Data.Version (versionBranch)+import qualified Hasql as H+import qualified Hasql.Postgres as H+import Options.Applicative hiding (columns)++import Config (AppConfig(..), argParser, corsPolicy)++main :: IO ()+main = do+ conf <- execParser (info (helper <*> argParser) describe)+ let port = configPort conf++ unless (configSecure conf) $+ putStrLn "WARNING, running in insecure mode, auth will be in plaintext"+ Prelude.putStrLn $ "Listening on port " +++ (show $ configPort conf :: String)++ let pgSettings = H.ParamSettings (cs $ configDbHost conf)+ (fromIntegral $ configDbPort conf)+ (cs $ configDbUser conf)+ (cs $ configDbPass conf)+ (cs $ configDbName conf)++ sessSettings <- maybe (fail "Improper session settings") return $+ H.sessionSettings (fromIntegral $ configPool conf) 30++ let appSettings = setPort port+ . setServerName (cs $ "postgrest/" <> prettyVersion)+ $ defaultSettings+ middle =+ (if configSecure conf then redirectInsecure else id)+ . gzip def . cors corsPolicy+ . staticPolicy (only [("favicon.ico", "static/favicon.ico")])+ anonRole = cs $ configAnonRole conf+ currRole = cs $ configDbUser conf++ H.session pgSettings sessSettings $ H.sessionUnlifter >>= \unlift ->+ liftIO $ runSettings appSettings $ middle $ \req respond -> do+ body <- strictRequestBody req+ respond =<< catchJust isSqlError+ (unlift $ H.tx Nothing+ $ authenticated currRole anonRole (app body) req)+ (return . sqlError)++ where+ describe = progDesc "create a REST API to an existing Postgres database"+ prettyVersion = intercalate "." $ map show $ versionBranch version
+ src/Middleware.hs view
@@ -0,0 +1,76 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Middleware where++import Data.Maybe (fromMaybe)+import Data.Monoid (mconcat)+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 Network.HTTP.Types.Header (hLocation, hAuthorization)+import Network.HTTP.Types (RequestHeaders)+import Network.HTTP.Types.Status (status400, status401, status301)+import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,+ rawQueryString, isSecure, Request(..), Response)+import Network.URI (URI(..), parseURI)++import Auth (LoginAttempt(..), signInRole, setRole, resetRole)+import Codec.Binary.Base64.String (decode)++authenticated :: forall s. Text -> Text ->+ (Request -> H.Tx H.Postgres s Response) ->+ Request -> H.Tx H.Postgres s Response+authenticated currentRole anon app req = do+ attempt <- httpRequesterRole (requestHeaders req)+ case attempt of+ MalformedAuth ->+ return $ responseLBS status400 [] "Malformed basic auth header"+ LoginFailed ->+ return $ responseLBS status401 [] "Invalid username or password"+ LoginSuccess role -> if role /= currentRole then runInRole role else app req+ NoCredentials -> if anon /= currentRole then runInRole anon else app req++ where+ httpRequesterRole :: RequestHeaders -> H.Tx H.Postgres s LoginAttempt+ httpRequesterRole hdrs = do+ let auth = fromMaybe "" $ lookup hAuthorization hdrs+ case split (==' ') (cs auth) of+ ("Basic" : b64 : _) ->+ case split (==':') (cs . decode . cs $ b64) of+ (u:p:_) -> signInRole u p+ _ -> return MalformedAuth+ _ -> return NoCredentials++ runInRole :: Text -> H.Tx H.Postgres s Response+ runInRole r = do+ setRole r+ res <- app req+ resetRole+ return res+++redirectInsecure :: Application -> Application+redirectInsecure app req respond = do+ let hdrs = requestHeaders req+ host = lookup "host" hdrs+ uriM = parseURI . cs =<< mconcat [+ Just "https://",+ host,+ Just $ rawPathInfo req,+ Just $ rawQueryString req]+ isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"++ if not (isSecure req || isHerokuSecure)+ then case uriM of+ Just uri ->+ respond $ responseLBS status301 [+ (hLocation, cs . show $ uri { uriScheme = "https:" })+ ] ""+ Nothing ->+ respond $ responseLBS status400 [] "SSL is required"+ else app req respond
+ src/PgError.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++module PgError (Message(..), message, httpStatus) where++import Text.Parsec+import Text.Parsec.Text+import qualified Data.Map as M+import Text.Regex.TDFA.Text ()+import Data.Text hiding (drop, concat, head)+import Data.Aeson+import Data.Maybe+import Control.Monad (void)++import Data.String.Conversions (cs)+import Data.CaseInsensitive (CI, mk)++import Network.HTTP.Types.Status++data Message = Message {+ msgStatus :: Maybe Text+ , msgCode :: Text+ , msgText :: Maybe Text+ , msgHint :: Maybe Text+} deriving (Show, Eq)++message :: Parser Message+message = do+ ps <- sepBy valPair (char ';')+ let m = M.fromList ps+ return $ Message+ (M.lookup "status" m)+ (fromMaybe "" $ M.lookup "code" m)+ (M.lookup "message" m)+ (M.lookup "hint" m)++valPair :: Parser (CI Text, Text)+valPair = do+ _ <- spaces+ name <- many1 letter+ _ <- char ':'+ spaces+ _ <- many $ char '"'+ val <- manyTill anyChar $+ try+ (void $ many (char '"') >> (+ (void . lookAhead $ (char ';'))+ <|> ((optional $ char '.') >> eof)+ ))+ return (mk (cs name), cs val)+++instance ToJSON Message where+ toJSON t = object [+ "message" .= msgText t+ , "code" .= msgCode t+ , "status" .= msgStatus t+ , "hint" .= msgHint t+ ]++httpStatus :: Message -> Status+httpStatus m =+ let code = cs $ msgCode m :: String in+ case code of+ '0' : '8' : _ -> status503 -- pg connection err+ '0' : '9' : _ -> status500 -- triggered action exception+ '0' : 'L' : _ -> status403 -- invalid grantor+ '0' : 'P' : _ -> status403 -- invalid role specification+ '2' : '5' : _ -> status500 -- invalid tx state+ '2' : '8' : _ -> status403 -- invalid auth specification+ '2' : 'D' : _ -> status500 -- invalid tx termination+ '3' : '8' : _ -> status500 -- external routine exception+ '3' : '9' : _ -> status500 -- external routine invocation+ '3' : 'B' : _ -> status500 -- savepoint exception+ '4' : '0' : _ -> status500 -- tx rollback+ '5' : '3' : _ -> status503 -- insufficient resources+ '5' : '4' : _ -> status413 -- too complex+ '5' : '5' : _ -> status500 -- obj not on prereq state+ '5' : '7' : _ -> status500 -- operator intervention+ '5' : '8' : _ -> status500 -- system error+ 'F' : '0' : _ -> status500 -- conf file error+ 'H' : 'V' : _ -> status500 -- foreign data wrapper error+ 'P' : '0' : _ -> status500 -- PL/pgSQL Error+ 'X' : 'X' : _ -> status500 -- internal Error+ "42P01" -> status404 -- undefined table+ "42501" -> status404 -- insufficient privilege+ _ -> status400
+ src/PgQuery.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module PgQuery where++import RangeQuery++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 qualified Data.ByteString.Char8 as BS+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 Data.Scientific (isInteger, formatScientific, FPFormat(..))++type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All)++type StatementT = DynamicSQL -> DynamicSQL++data QualifiedTable = QualifiedTable {+ qtSchema :: Text+, qtName :: Text+} deriving (Show)++data OrderTerm = OrderTerm {+ 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++whereT :: Net.Query -> StatementT+whereT params q =+ if L.null cols+ 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+ )++countT :: StatementT+countT (sql, params, pre) =+ ("WITH qqq AS (" <> sql <> ") SELECT count(1) FROM qqq"+ , params+ , pre)++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)++returningStarT :: StatementT+returningStarT (sql, params, pre) =+ (sql <> " RETURNING *", params, pre)++deleteFrom :: QualifiedTable -> DynamicSQL+deleteFrom t =+ ("delete 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+ ((<> "::unknown") . pgFmtLit . unquoted)+ vals)+ ) <> ") returning row_to_json(" <> fromQt t <> ".*)"+ , []+ , 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+ ((<> "::unknown") . pgFmtLit . unquoted)+ vals)+ )+ , []+ , mempty+ )++update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL+update t cols vals =+ ("update " <> fromQt t <> " set (" <>+ cs (intercalate ", " (map pgFmtIdent cols)) <>+ ") = (" <>+ cs (+ intercalate ", " (map+ ((<> "::unknown") . pgFmtLit . unquoted)+ vals)+ ) <> ")"+ , []+ , mempty+ )++wherePred :: Net.QueryItem -> DynamicSQL+wherePred (col, predicate) =+ (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ", [], mempty)++ where+ opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate+ value = intercalate "." rest+ op = case opCode of+ "eq" -> "="+ "gt" -> ">"+ "lt" -> "<"+ "gte" -> ">="+ "lte" -> "<="+ "neq" -> "<>"+ _ -> "="++orderParse :: Net.Query -> [OrderTerm]+orderParse q =+ mapMaybe orderParseTerm . split (==',') $ cs order+ where+ order = fromMaybe "" $ join (lookup "order" q)++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++commaq :: DynamicSQL+commaq = (", ", [], mempty)++andq :: DynamicSQL+andq = (" and ", [], mempty)++pgFmtIdent :: Text -> Text+pgFmtIdent x =+ let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in+ if escaped =~ danger+ then "\"" <> escaped <> "\""+ else escaped++ where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: Text++pgFmtLit :: Text -> Text+pgFmtLit x =+ let trimmed = trimNullChars x+ escaped = "'" <> replace "'" "''" trimmed <> "'"+ slashed = replace "\\" "\\\\" escaped in+ cs $ if escaped =~ ("\\\\" :: Text)+ then "E" <> slashed+ else slashed++trimNullChars :: Text -> Text+trimNullChars = Data.Text.takeWhile (/= '\x0')++fromQt :: QualifiedTable -> BS.ByteString+fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)++unquoted :: JSON.Value -> Text+unquoted (JSON.String t) = t+unquoted (JSON.Number n) =+ cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n+unquoted (JSON.Bool b) = cs . show $ b+unquoted _ = ""++pgParam :: JSON.Value -> H.StatementArgument H.Postgres+pgParam (JSON.Number n) = H.renderValue+ (cs $ formatScientific Fixed+ (if isInteger n then Just 0 else Nothing) n :: Text)+pgParam (JSON.String s) = H.renderValue s+pgParam (JSON.Bool b) = H.renderValue $+ if b then "t" else "f" :: Text+pgParam JSON.Null = H.renderValue (Nothing :: Maybe Text)+pgParam (JSON.Object o) = H.renderValue $ JSON.encode o+pgParam (JSON.Array a) = H.renderValue $ JSON.encode a
+ src/PgStructure.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances,+ MultiParamTypeClasses, ScopedTypeVariables #-}+module PgStructure where++import PgQuery (QualifiedTable(..))+import Data.Functor ( (<$>) )+import Data.Text hiding (foldl, map, zipWith, concat)+import Data.Aeson+import Data.Functor.Identity+import qualified Data.Vector as V+import Data.String.Conversions (cs)++import Control.Applicative ( (<*>) )++import qualified Data.List as L+import qualified Data.Map as Map++import qualified Hasql as H+import qualified Hasql.Backend as H+import qualified Hasql.Postgres as H++foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map 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+, tableName :: Text+, tableInsertable :: Bool+} deriving (Show)++data ForeignKey = ForeignKey {+ fkTable::Text, fkCol::Text+} deriving (Eq, Show)++data Column = Column {+ colSchema :: Text+, colTable :: Text+, colName :: Text+, colPosition :: Int+, colNullable :: Bool+, colType :: Text+, colUpdatable :: Bool+, colMaxLen :: Maybe Int+, colPrecision :: Maybe Int+, colDefault :: Maybe Text+, colEnum :: [Text]+, colFK :: Maybe ForeignKey+} deriving (Show)++instance H.RowParser H.Postgres Column where+ parseRow r =+ let schema = H.parseResult $ r V.! 0+ table = H.parseResult $ r V.! 1+ name = H.parseResult $ r V.! 2+ position = H.parseResult $ r V.! 3+ nullable = 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+ , "nullable" .= colNullable c+ , "type" .= colType c+ , "updatable" .= colUpdatable c+ , "maxLen" .= colMaxLen c+ , "precision" .= colPrecision c+ , "references".= colFK c+ , "default" .= colDefault c+ , "enum" .= colEnum c ]++instance ToJSON ForeignKey where+ toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]++instance ToJSON Table where+ toJSON v = object [+ "schema" .= tableSchema v+ , "name" .= tableName v+ , "insertable" .= tableInsertable v ]
+ src/RangeQuery.hs view
@@ -0,0 +1,58 @@+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++import Data.String.Conversions (cs)+import Text.Regex.TDFA ((=~))+import Text.Read (readMaybe)++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++rangeLeq :: Int -> NonnegRange+rangeLeq n =+ Range BoundaryBelowAll (BoundaryAbove n)
+ test/Main.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE QuasiQuotes #-}+module Main where++import Test.Hspec+import SpecHelper+import Spec++main :: IO ()+main = resetDb >> hspec spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ test/SpecHelper.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}++module SpecHelper where++import Network.Wai+import Test.Hspec+import Test.Hspec.Wai++import Hasql as H+import Hasql.Postgres as H++import Data.String.Conversions (cs)+import Data.Monoid+-- import Control.Exception.Base (bracket, finally)+import Control.Monad (void)+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 App (app, sqlError, isSqlError)+import Config (AppConfig(..), corsPolicy)+import Middleware+-- import Auth (addUser)++isLeft :: Either a b -> Bool+isLeft (Left _ ) = True+isLeft _ = False++cfg :: AppConfig+cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10++testSettings :: SessionSettings+testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30++pgSettings :: Postgres+pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test"++withApp :: ActionWith Application -> IO ()+withApp perform =+ let anonRole = cs $ configAnonRole cfg+ currRole = cs $ configDbUser cfg in+ perform $ middle $ \req resp ->+ H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift ->+ liftIO $ do+ body <- strictRequestBody req+ resp =<< catchJust isSqlError+ (unlift $ H.tx Nothing+ $ authenticated currRole anonRole (app body) req)+ (return . sqlError)++ where middle = cors corsPolicy+++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 postgrest cascade |]++ loadFixture "roles"+ loadFixture "schema"+++loadFixture :: FilePath -> IO()+loadFixture name =+ void $ readProcess "psql" ["-U", "postgrest_test", "-d", "postgrest_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []+++rangeHdrs :: ByteRange -> [Header]+rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]++rangeUnit :: Header+rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items")++matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool+matchHeader name valRegex headers =+ maybe False (=~ valRegex) $ lookup name headers++authHeader :: String -> String -> Header+authHeader u p =+ (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))++clearTable :: BS.ByteString -> IO ()+clearTable table = H.session pgSettings testSettings $ H.tx Nothing $+ H.unit ("delete from \"1\"."<>table, [], True)++createItems :: Int -> IO ()+createItems n = H.session pgSettings testSettings $ H.tx Nothing txn+ where+ txn = sequence_ $ map H.unit stmts+ stmts = map [H.q|insert into "1".items (id) values (?)|] [1..n]++-- for hspec-wai+pending_ :: WaiSession ()+pending_ = liftIO Test.Hspec.pending++-- for hspec-wai+pendingWith_ :: String -> WaiSession ()+pendingWith_ = liftIO . Test.Hspec.pendingWith