postgrest 0.2.8.0 → 0.2.9.1
raw patch · 21 files changed
+1306/−1231 lines, 21 filesdep +jwtdep +postgrestdep ~hasqldep ~hasql-postgres
Dependencies added: jwt, postgrest
Dependency ranges changed: hasql, hasql-postgres
Files
- postgrest.cabal +73/−26
- src/App.hs +0/−277
- src/Auth.hs +0/−71
- src/Config.hs +0/−60
- src/Error.hs +0/−71
- src/Main.hs +0/−71
- src/Middleware.hs +0/−76
- src/PgQuery.hs +0/−282
- src/PgStructure.hs +0/−172
- src/PostgREST/App.hs +315/−0
- src/PostgREST/Auth.hs +91/−0
- src/PostgREST/Config.hs +64/−0
- src/PostgREST/Error.hs +71/−0
- src/PostgREST/Main.hs +71/−0
- src/PostgREST/Middleware.hs +84/−0
- src/PostgREST/PgQuery.hs +290/−0
- src/PostgREST/PgStructure.hs +175/−0
- src/PostgREST/RangeQuery.hs +60/−0
- src/RangeQuery.hs +0/−58
- src/Types.hs +0/−57
- test/SpecHelper.hs +12/−10
postgrest.cabal view
@@ -2,7 +2,7 @@ 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.8.0+version: 0.2.9.1 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE@@ -12,15 +12,59 @@ category: Web build-type: Simple cabal-version: >=1.10+source-repository head+ type: git+ location: git://github.com/begriffs/postgrest.git +Flag CI+ Description: No warnings allowed in continuous integration+ Manual: True+ Default: False+ executable postgrest- main-is: Main.hs- ghc-options: -Wall -W -O2+ main-is: PostgREST/Main.hs+ default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes default-language: Haskell2010+ build-depends: base >=4.6 && <5+ , postgrest+ , hasql == 0.7.3.1, hasql-backend == 0.4.1+ , hasql-postgres == 0.10.3.1+ , 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+ , containers, unordered-containers+ , optparse-applicative == 0.11.*+ , regex-base, regex-tdfa+ , regex-tdfa-text+ , Ranged-sets+ , transformers, MissingH+ , bcrypt >= 0.0.6, base64-string+ , network-uri >= 2.6+ , resource-pool+ , blaze-builder+ , vector+ , mtl+ , cassava+ , jwt+ hs-source-dirs: src++library+ if flag(ci)+ ghc-options: -Wall -W -Werror+ else+ ghc-options: -Wall -W -O2++ default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes build-depends: base >=4.6 && <5- , hasql == 0.7.3, hasql-backend == 0.4.1- , hasql-postgres == 0.10.3+ , hasql == 0.7.3.1, hasql-backend == 0.4.1+ , hasql-postgres == 0.10.3.1 , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0@@ -43,15 +87,15 @@ , vector , mtl , cassava- Other-Modules: App- , Auth- , Config- , Error- , Middleware- , PgQuery- , PgStructure- , RangeQuery- , Types+ , jwt+ Exposed-Modules: PostgREST.App+ , PostgREST.Auth+ , PostgREST.Config+ , PostgREST.Error+ , PostgREST.Middleware+ , PostgREST.PgQuery+ , PostgREST.PgStructure+ , PostgREST.RangeQuery hs-source-dirs: src Test-Suite spec@@ -59,23 +103,25 @@ Default-Language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes Hs-Source-Dirs: test, src- ghc-options: -Wall -W -Werror+ if flag(ci)+ ghc-options: -Wall -W -Werror+ else+ ghc-options: -Wall -W -O2 Main-Is: Main.hs- Other-Modules: App- , Auth- , Config- , Error- , Middleware- , PgQuery- , PgStructure- , RangeQuery- , Types+ Other-Modules: PostgREST.App+ , PostgREST.Auth+ , PostgREST.Config+ , PostgREST.Error+ , PostgREST.Middleware+ , PostgREST.PgQuery+ , PostgREST.PgStructure+ , PostgREST.RangeQuery , Spec , SpecHelper Build-Depends: base, hspec >= 2.1.2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json- , hasql == 0.7.3, hasql-backend == 0.4.1- , hasql-postgres == 0.10.3+ , hasql == 0.7.3.1, hasql-backend == 0.4.1+ , hasql-postgres == 0.10.3.1 , warp, wai , packdeps, hlint , HTTP, convertible@@ -102,3 +148,4 @@ , cassava , process , heredoc+ , jwt
− src/App.hs
@@ -1,277 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module App (app, sqlError, isSqlError) where--import Control.Monad (join)-import Control.Arrow ((***), second)-import Control.Applicative--import Data.Text hiding (map)-import Data.Maybe (fromMaybe, mapMaybe)-import Text.Regex.TDFA ((=~))-import Data.Ord (comparing)-import Data.Ranged.Ranges (emptyRange)-import qualified Data.HashMap.Strict as M-import Data.String.Conversions (cs)-import Data.CaseInsensitive (original)-import Data.List (sortBy)-import Data.Functor.Identity-import qualified Data.Set as S-import qualified Data.ByteString.Lazy as BL-import qualified Blaze.ByteString.Builder as BB-import qualified Data.Csv as CSV--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 Network.Wai.Internal (Response(..))--import Data.Aeson-import Data.Monoid-import qualified Data.Vector as V-import qualified Hasql as H-import qualified Hasql.Backend as B-import qualified Hasql.Postgres as P--import Auth-import PgQuery-import RangeQuery-import PgStructure--app :: Text -> BL.ByteString -> Request -> H.Tx P.Postgres s Response-app v1schema 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 = B.Stmt "select " V.empty True <>- parentheticT (- whereT qq $ countRows qt- ) <> commaq <> (- asJsonWithCount- . limitT range- . orderT (orderParse qq)- . whereT qq- $ selectStar qt- )- row <- H.maybeEx 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") -> do- let qt = QualifiedTable schema (cs table)- echoRequested = lookup "Prefer" hdrs == Just "return=representation"- parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))- parsed = if lookup "Content-Type" hdrs == Just "text/csv"- then do- rows <- CSV.decode CSV.NoHeader reqBody- if V.null rows then Left "CSV requires header"- else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))- else eitherDecode reqBody >>= \val ->- case val of- Object obj -> Right . second V.singleton . V.unzip . V.fromList $- M.toList obj- _ -> Left "Expecting single JSON object or CSV rows"- case parsed of- Left err -> return $ responseLBS status400 [] $- encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]- Right toBeInserted -> do- rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted- let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows- primaryKeys <- primaryKeyColumns qt- let responses = flip map inserted $ \obj -> do- let primaries =- if Prelude.null primaryKeys- then obj- else M.filterWithKey (const . (`elem` primaryKeys)) obj- let params = urlEncodeVars- $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))- $ sortBy (comparing fst) $ M.toList primaries- responseLBS status201- [ jsonH- , (hLocation, "/" <> cs table <> "?" <> cs params)- ] $ if echoRequested then encode obj else ""- return $ multipart status201 responses-- ([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 $ M.keys obj- if S.fromList tableCols == S.fromList cols- then do- let vals = M.elems obj- H.unitEx $ 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.unitEx- $ whereT qq- $ update qt (map cs $ M.keys obj) (M.elems obj)- return $ responseLBS status204 [ jsonH ] ""-- ([table], "DELETE") -> do- let qt = QualifiedTable schema (cs table)- let del = countT- . returningStarT- . whereT qq- $ deleteFrom qt- row <- H.maybeEx 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 v1schema hdrs- range = rangeRequested hdrs- allOrigins = ("Access-Control-Allow-Origin", "*") :: Header--sqlError :: t-sqlError = undefined--isSqlError :: t-isSqlError = undefined--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 :: Text -> RequestHeaders -> Text-requestedSchema v1schema hdrs =- case verStr of- Just [[_, ver]] -> if ver == "1" then v1schema else ver- _ -> v1schema-- 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 P.Postgres s Response)- -> H.Tx P.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")]--parseCsvCell :: BL.ByteString -> Value-parseCsvCell s = if s == "NULL" then Null else String $ cs s--multipart :: Status -> [Response] -> Response-multipart _ [] = responseLBS status204 [] ""-multipart _ [r] = r-multipart s rs =- responseLBS s [(hContentType, "multipart/mixed; boundary=\"postgrest_boundary\"")] $- BL.intercalate "\n--postgrest_boundary\n" (map renderResponseBody rs)-- where- renderHeader :: Header -> BL.ByteString- renderHeader (k, v) = cs (original k) <> ": " <> cs v-- renderResponseBody :: Response -> BL.ByteString- renderResponseBody (ResponseBuilder _ headers b) =- BL.intercalate "\n" (map renderHeader headers)- <> "\n\n" <> BB.toLazyByteString b- renderResponseBody _ = error- "Unable to create multipart response from non-ResponseBuilder"--data TableOptions = TableOptions {- tblOptcolumns :: [Column]-, tblOptpkey :: [Text]-}--instance ToJSON TableOptions where- toJSON t = object [- "columns" .= tblOptcolumns t- , "pkey" .= tblOptpkey t ]
− src/Auth.hs
@@ -1,71 +0,0 @@-{-# 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 Data.Vector as V-import qualified Hasql as H-import qualified Hasql.Backend as B-import qualified Hasql.Postgres as P-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 P.Postgres s ()-setRole role = H.unitEx $ B.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True--resetRole :: H.Tx P.Postgres s ()-resetRole = H.unitEx [H.stmt|reset role|]--addUser :: Text -> Text -> Text -> H.Tx P.Postgres s ()-addUser identity pass role = do- let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)- H.unitEx $- [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]- identity (cs hashed :: Text) role--signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt-signInRole user pass = do- u <- H.maybeEx $ [H.stmt|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
@@ -1,60 +0,0 @@-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- , configV1Schema :: String- }--argParser :: Parser AppConfig-argParser = AppConfig- <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database")- <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault)- <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role")- <*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role")- <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault)-- <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault)- <*> 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 auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault)- <*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault)--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- , corsExposedHeaders = Just [- "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"- , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"- ]- }- 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/Error.hs
@@ -1,71 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}--module Error (PgError, errResponse) where--import qualified Hasql as H-import qualified Hasql.Postgres as P-import qualified Network.HTTP.Types.Status as HT-import qualified Data.Aeson as JSON-import qualified Data.Text as T-import Data.Aeson ((.=))-import Data.String.Conversions (cs)-import Data.String.Utils(replace)-import Network.Wai(Response, responseLBS)-import Network.HTTP.Types.Header--type PgError = H.SessionError P.Postgres--errResponse :: PgError -> Response-errResponse e = responseLBS (httpStatus e)- [(hContentType, "application/json")] (JSON.encode e)--instance JSON.ToJSON PgError where- toJSON (H.TxError (P.ErroneousResult c m d h)) = JSON.object [- "code" .= (cs c::T.Text),- "message" .= (cs m::T.Text),- "details" .= (fmap cs d::Maybe T.Text),- "hint" .= (fmap cs h::Maybe T.Text)]- toJSON (H.TxError (P.NoResult d)) = JSON.object [- "message" .= ("No response from server"::T.Text),- "details" .= (fmap cs d::Maybe T.Text)]- toJSON (H.TxError (P.UnexpectedResult m)) = JSON.object ["message" .= m]- toJSON (H.TxError P.NotInTransaction) = JSON.object [- "message" .= ("Not in transaction"::T.Text)]- toJSON (H.CxError (P.CantConnect d)) = JSON.object [- "message" .= ("Can't connect to the database"::T.Text),- "details" .= (fmap cs d::Maybe T.Text)]- toJSON (H.CxError (P.UnsupportedVersion v)) = JSON.object [- "message" .= ("Postgres version "++version++" is not supported") ]- where version = replace "0" "." (show v)- toJSON (H.ResultError m) = JSON.object ["message" .= m]--httpStatus :: PgError -> HT.Status-httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =- let code = cs codeBS in- case code of- '0':'8':_ -> HT.status503 -- pg connection err- '0':'9':_ -> HT.status500 -- triggered action exception- '0':'L':_ -> HT.status403 -- invalid grantor- '0':'P':_ -> HT.status403 -- invalid role specification- '2':'5':_ -> HT.status500 -- invalid tx state- '2':'8':_ -> HT.status403 -- invalid auth specification- '2':'D':_ -> HT.status500 -- invalid tx termination- '3':'8':_ -> HT.status500 -- external routine exception- '3':'9':_ -> HT.status500 -- external routine invocation- '3':'B':_ -> HT.status500 -- savepoint exception- '4':'0':_ -> HT.status500 -- tx rollback- '5':'3':_ -> HT.status503 -- insufficient resources- '5':'4':_ -> HT.status413 -- too complex- '5':'5':_ -> HT.status500 -- obj not on prereq state- '5':'7':_ -> HT.status500 -- operator intervention- '5':'8':_ -> HT.status500 -- system error- 'F':'0':_ -> HT.status500 -- conf file error- 'H':'V':_ -> HT.status500 -- foreign data wrapper error- 'P':'0':_ -> HT.status500 -- PL/pgSQL Error- 'X':'X':_ -> HT.status500 -- internal Error- "42P01" -> HT.status404 -- undefined table- "42501" -> HT.status404 -- insufficient privilege- _ -> HT.status400-httpStatus (H.TxError (P.NoResult _)) = HT.status503-httpStatus _ = HT.status500
− src/Main.hs
@@ -1,71 +0,0 @@-module Main where--import Paths_postgrest (version)--import App-import Middleware-import Error(errResponse)--import Control.Monad (unless)-import Control.Monad.IO.Class (liftIO)-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 Network.Wai.Middleware.RequestLogger (logStdout)-import Data.List (intercalate)-import Data.Version (versionBranch)-import qualified Hasql as H-import qualified Hasql.Postgres as P-import Options.Applicative hiding (columns)--import Config (AppConfig(..), argParser, corsPolicy)--main :: IO ()-main = do- let opts = info (helper <*> argParser) $- fullDesc- <> progDesc (- "PostgREST "- <> prettyVersion- <> " / create a REST API to an existing Postgres database"- )- parserPrefs = prefs showHelpOnError- conf <- customExecParser parserPrefs opts- 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 = P.ParamSettings (cs $ configDbHost conf)- (fromIntegral $ configDbPort conf)- (cs $ configDbUser conf)- (cs $ configDbPass conf)- (cs $ configDbName conf)- appSettings = setPort port- . setServerName (cs $ "postgrest/" <> prettyVersion)- $ defaultSettings- middle = logStdout- . (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-- poolSettings <- maybe (fail "Improper session settings") return $- H.poolSettings (fromIntegral $ configPool conf) 30- pool :: H.Pool P.Postgres- <- H.acquirePool pgSettings poolSettings-- runSettings appSettings $ middle $ \req respond -> do- body <- strictRequestBody req- resOrError <- liftIO $ H.session pool $ H.tx Nothing $- authenticated currRole anonRole (app (cs $ configV1Schema conf) body) req- either (respond . errResponse) respond resOrError-- where- prettyVersion = intercalate "." $ map show $ versionBranch version
− src/Middleware.hs
@@ -1,76 +0,0 @@-{-# 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 P-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 P.Postgres s Response) ->- Request -> H.Tx P.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 P.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 P.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/PgQuery.hs
@@ -1,282 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module PgQuery where--import RangeQuery--import qualified Hasql as H-import qualified Hasql.Postgres as P-import qualified Hasql.Backend as B--import qualified Data.Text as T-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.Vector (empty)-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 qualified Data.Vector as V-import Data.Scientific (isInteger, formatScientific, FPFormat(..))--type PStmt = H.Stmt P.Postgres-instance Monoid PStmt where- mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =- B.Stmt (query <> query') (params <> params') (prep && prep')- mempty = B.Stmt "" empty True-type StatementT = PStmt -> PStmt--data QualifiedTable = QualifiedTable {- qtSchema :: T.Text-, qtName :: T.Text-} deriving (Show)--data OrderTerm = OrderTerm {- otTerm :: T.Text-, otDirection :: BS.ByteString-, otNullOrder :: Maybe BS.ByteString-}--limitT :: Maybe NonnegRange -> StatementT-limitT r q =- q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True- 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 <> B.Stmt " where " empty True <> 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 <> B.Stmt " order by " empty True <> clause- where- clause = mconcat $ L.intersperse commaq (map queryTerm ts)- queryTerm :: OrderTerm -> PStmt- queryTerm t = B.Stmt- (" " <> cs (pgFmtIdent $ otTerm t) <> " "- <> cs (otDirection t) <> " "- <> maybe "" cs (otNullOrder t) <> " ")- empty True--parentheticT :: StatementT-parentheticT s =- s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }--iffNotT :: PStmt -> StatementT-iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =- B.Stmt- ("WITH aaa AS (" <> aq <> " returning *) " <>- bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")- (ap <> bp)- (apre && bpre)--countT :: StatementT-countT s =- s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" }--countRows :: QualifiedTable -> PStmt-countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True--asJsonWithCount :: StatementT-asJsonWithCount s = s { B.stmtTemplate =- "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("- <> B.stmtTemplate s <> ") t" }--asJsonRow :: StatementT-asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }--selectStar :: QualifiedTable -> PStmt-selectStar t = B.Stmt ("select * from " <> fromQt t) empty True--returningStarT :: StatementT-returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }--deleteFrom :: QualifiedTable -> PStmt-deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True--insertInto :: QualifiedTable- -> V.Vector T.Text- -> V.Vector (V.Vector JSON.Value)- -> PStmt-insertInto t cols vals- | V.null cols = B.Stmt ("insert into " <> fromQt t <> " default values returning *") empty True- | otherwise = B.Stmt- ("insert into " <> fromQt t <> " (" <>- T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <>- ") values "- <> T.intercalate ", "- (V.toList $ V.map (\v -> "("- <> T.intercalate ", " (V.toList $ V.map insertableValue v)- <> ")"- ) vals- )- <> " returning row_to_json(" <> fromQt t <> ".*)")- empty True--insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt-insertSelect t [] _ = B.Stmt- ("insert into " <> fromQt t <> " default values returning *") empty True-insertSelect t cols vals = B.Stmt- ("insert into " <> fromQt t <> " ("- <> T.intercalate ", " (map pgFmtIdent cols)- <> ") select "- <> T.intercalate ", " (map insertableValue vals))- empty True--update :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt-update t cols vals = B.Stmt- ("update " <> fromQt t <> " set ("- <> T.intercalate ", " (map pgFmtIdent cols)- <> ") = ("- <> T.intercalate ", " (map insertableValue vals)- <> ")")- empty True--wherePred :: Net.QueryItem -> PStmt-wherePred (col, predicate) =- B.Stmt (" " <> pgFmtJsonbPath (cs col) <> " " <> op <> " " <>- if opCode `elem` ["is","isnot"] then whiteList value- else cs sqlValue)- empty True-- where- opCode:rest = T.split (=='.') $ cs $ fromMaybe "." predicate- value = T.intercalate "." rest- whiteList val = fromMaybe (cs (pgFmtLit val) <> "::unknown ")- (L.find ((==) . T.toLower $ val)- ["null","true","false"])- star c = if c == '*' then '%' else c- unknownLiteral = (<> "::unknown ") . pgFmtLit-- sqlValue = case opCode of- "like" -> unknownLiteral $ T.map star value- "ilike" -> unknownLiteral $ T.map star value- "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "- _ -> unknownLiteral value-- op = case opCode of- "eq" -> "="- "gt" -> ">"- "lt" -> "<"- "gte" -> ">="- "lte" -> "<="- "neq" -> "<>"- "like"-> "like"- "ilike"-> "ilike"- "in" -> "in"- "is" -> "is"- "isnot" -> "is not"- _ -> "="--orderParse :: Net.Query -> [OrderTerm]-orderParse q =- mapMaybe orderParseTerm . T.split (==',') $ cs order- where- order = fromMaybe "" $ join (lookup "order" q)--orderParseTerm :: T.Text -> Maybe OrderTerm-orderParseTerm s =- case T.split (=='.') s of- (c:d:nls) ->- if d `elem` ["asc", "desc"]- then Just $ OrderTerm c- ( if d == "asc" then "asc" else "desc" )- ( case nls of- [n] -> if | n == "nullsfirst" -> Just "nulls first"- | n == "nullslast" -> Just "nulls last"- | otherwise -> Nothing- _ -> Nothing- )- else Nothing- _ -> Nothing--commaq :: PStmt-commaq = B.Stmt ", " empty True--andq :: PStmt-andq = B.Stmt " and " empty True--data JsonbPath =- ColIdentifier T.Text- | KeyIdentifier T.Text- | SingleArrow JsonbPath JsonbPath- | DoubleArrow JsonbPath JsonbPath- deriving (Show)--parseJsonbPath :: T.Text -> Maybe JsonbPath-parseJsonbPath p =- case T.splitOn "->>" p of- [a,b] ->- let i:is = T.splitOn "->" a in- Just $ DoubleArrow- (foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is))- (KeyIdentifier b)- _ -> Nothing--pgFmtJsonbPath :: T.Text -> T.Text-pgFmtJsonbPath p =- pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)- where- pgFmtJsonbPath' (ColIdentifier i) = pgFmtIdent i- pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i- pgFmtJsonbPath' (SingleArrow a b) =- pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b- pgFmtJsonbPath' (DoubleArrow a b) =- pgFmtJsonbPath' a <> "->>" <> pgFmtJsonbPath' b--pgFmtIdent :: T.Text -> T.Text-pgFmtIdent x =- let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in- if escaped =~ danger- then "\"" <> escaped <> "\""- else escaped-- where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: T.Text--pgFmtLit :: T.Text -> T.Text-pgFmtLit x =- let trimmed = trimNullChars x- escaped = "'" <> T.replace "'" "''" trimmed <> "'"- slashed = T.replace "\\" "\\\\" escaped in- cs $ if escaped =~ ("\\\\" :: T.Text)- then "E" <> slashed- else slashed--trimNullChars :: T.Text -> T.Text-trimNullChars = T.takeWhile (/= '\x0')--fromQt :: QualifiedTable -> T.Text-fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)--unquoted :: JSON.Value -> T.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 _ = ""--insertableText :: T.Text -> T.Text-insertableText = (<> "::unknown") . pgFmtLit--insertableValue :: JSON.Value -> T.Text-insertableValue JSON.Null = "null"-insertableValue v = insertableText $ unquoted v--paramFilter :: JSON.Value -> T.Text-paramFilter JSON.Null = "is.null"-paramFilter v = "eq." <> unquoted v
− src/PgStructure.hs
@@ -1,172 +0,0 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances,- MultiParamTypeClasses, ScopedTypeVariables #-}-module PgStructure where--import PgQuery (QualifiedTable(..))-import Data.Text hiding (foldl, map, zipWith, concat)-import Data.Aeson-import Data.Functor.Identity-import Data.String.Conversions (cs)-import Data.Maybe (fromMaybe)-import Control.Applicative ( (<$>) )--import qualified Data.Map as Map--import qualified Hasql as H-import qualified Hasql.Postgres as P--foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)-foreignKeys table = do- r <- H.listEx $ [H.stmt|- 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 :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey- addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m---tables :: Text -> H.Tx P.Postgres s [Table]-tables schema = do- rows <- H.listEx $- [H.stmt|- select table_schema, table_name,- is_insertable_into- from information_schema.tables- where table_schema = ?- order by table_name- |] schema- return $ map tableFromRow rows---columns :: QualifiedTable -> H.Tx P.Postgres s [Column]-columns table = do- cols <- H.listEx $ [H.stmt|- 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 (addFK fks . columnFromRow) cols-- where- addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks }---primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text]-primaryKeyColumns table = do- r <- H.listEx $ [H.stmt|- 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---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)--tableFromRow :: (Text, Text, Text) -> Table-tableFromRow (s, n, i) = Table s n (toBool i)--columnFromRow :: (Text, Text, Text,- Int, Text, Text,- Text, Maybe Int, Maybe Int,- Maybe Text, Maybe Text)- -> Column-columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =- Column s t n pos (toBool nul) typ (toBool u) l p d (parseEnum e) Nothing-- where- parseEnum :: Maybe Text -> [Text]- parseEnum str = fromMaybe [] $ split (==',') <$> str---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/PostgREST/App.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE FlexibleContexts #-}+module PostgREST.App (app, sqlError, isSqlError) where++import Control.Monad (join)+import Control.Arrow ((***), second)+import Control.Applicative++import Data.Text hiding (map)+import Data.Maybe (fromMaybe, mapMaybe)+import Text.Regex.TDFA ((=~))+import Data.Ord (comparing)+import Data.Ranged.Ranges (emptyRange)+import qualified Data.HashMap.Strict as M+import Data.String.Conversions (cs)+import Data.CaseInsensitive (original)+import Data.List (sortBy)+import Data.Functor.Identity+import qualified Data.Set as S+import qualified Data.ByteString.Lazy as BL+import qualified Blaze.ByteString.Builder as BB+import qualified Data.Csv as CSV++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 Network.Wai.Internal (Response(..))++import Data.Aeson+import Data.Monoid+import qualified Data.Vector as V+import qualified Hasql as H+import qualified Hasql.Backend as B+import qualified Hasql.Postgres as P++import PostgREST.Config (AppConfig(..))+import PostgREST.Auth+import PostgREST.PgQuery+import PostgREST.RangeQuery+import PostgREST.PgStructure++import Prelude++app :: AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response+app conf 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 = B.Stmt "select " V.empty True <>+ parentheticT (+ whereT qq $ countRows qt+ ) <> commaq <> (+ asJsonWithCount+ . limitT range+ . orderT (orderParse qq)+ . whereT qq+ $ selectStar qt+ )+ row <- H.maybeEx 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))+ ] ""++ (["postgrest", "tokens"], "POST") ->+ case jwtSecret of+ "secret" -> return $ responseLBS status500 [jsonH] $+ encode . object $ [("message", String "JWT Secret is set as \"secret\" which is an unsafe default.")]+ _ -> 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+ setRole authenticator+ login <- signInRole (cs $ userId u)+ (cs $ userPass u)+ case login of+ LoginSuccess role ->+ return $ responseLBS status201 [ jsonH ] $+ encode . object $ [("token", String $ tokenJWT jwtSecret (cs $ userId u) role)]+ _ -> return $ responseLBS status401 [jsonH] $+ encode . object $ [("message", String "Failed authentication.")]++ ([table], "POST") -> do+ let qt = QualifiedTable schema (cs table)+ echoRequested = lookup "Prefer" hdrs == Just "return=representation"+ parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))+ parsed = if lookup "Content-Type" hdrs == Just "text/csv"+ then do+ rows <- CSV.decode CSV.NoHeader reqBody+ if V.null rows then Left "CSV requires header"+ else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))+ else eitherDecode reqBody >>= \val ->+ case val of+ Object obj -> Right . second V.singleton . V.unzip . V.fromList $+ M.toList obj+ _ -> Left "Expecting single JSON object or CSV rows"+ case parsed of+ Left err -> return $ responseLBS status400 [] $+ encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]+ Right toBeInserted -> do+ rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted+ let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows+ primaryKeys <- primaryKeyColumns qt+ let responses = flip map inserted $ \obj -> do+ let primaries =+ if Prelude.null primaryKeys+ then obj+ else M.filterWithKey (const . (`elem` primaryKeys)) obj+ let params = urlEncodeVars+ $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))+ $ sortBy (comparing fst) $ M.toList primaries+ responseLBS status201+ [ jsonH+ , (hLocation, "/" <> cs table <> "?" <> cs params)+ ] $ if echoRequested then encode obj else ""+ return $ multipart status201 responses++ ([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 $ M.keys obj+ if S.fromList tableCols == S.fromList cols+ then do+ let vals = M.elems obj+ H.unitEx $ 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)+ up = returningStarT+ . whereT qq+ $ update qt (map cs $ M.keys obj) (M.elems obj)+ patch = withT up "t" $ B.Stmt+ "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying"+ V.empty True++ row <- H.maybeEx patch+ let (queryTotal, body) =+ fromMaybe (0 :: Int, Just "" :: Maybe Text) row+ r = contentRangeH 0 (queryTotal-1) queryTotal+ echoRequested = lookup "Prefer" hdrs == Just "return=representation"+ s = case () of _ | queryTotal == 0 -> status404+ | echoRequested -> status200+ | otherwise -> status204+ return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""++ ([table], "DELETE") -> do+ let qt = QualifiedTable schema (cs table)+ let del = countT+ . returningStarT+ . whereT qq+ $ deleteFrom qt+ row <- H.maybeEx 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 (cs $ configV1Schema conf) hdrs+ authenticator = cs $ configDbUser conf+ jwtSecret = cs $ configJwtSecret conf+ range = rangeRequested hdrs+ allOrigins = ("Access-Control-Allow-Origin", "*") :: Header++sqlError :: t+sqlError = undefined++isSqlError :: t+isSqlError = undefined++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 :: Text -> RequestHeaders -> Text+requestedSchema v1schema hdrs =+ case verStr of+ Just [[_, ver]] -> if ver == "1" then v1schema else ver+ _ -> v1schema++ 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 P.Postgres s Response)+ -> H.Tx P.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")]++parseCsvCell :: BL.ByteString -> Value+parseCsvCell s = if s == "NULL" then Null else String $ cs s++multipart :: Status -> [Response] -> Response+multipart _ [] = responseLBS status204 [] ""+multipart _ [r] = r+multipart s rs =+ responseLBS s [(hContentType, "multipart/mixed; boundary=\"postgrest_boundary\"")] $+ BL.intercalate "\n--postgrest_boundary\n" (map renderResponseBody rs)++ where+ renderHeader :: Header -> BL.ByteString+ renderHeader (k, v) = cs (original k) <> ": " <> cs v++ renderResponseBody :: Response -> BL.ByteString+ renderResponseBody (ResponseBuilder _ headers b) =+ BL.intercalate "\n" (map renderHeader headers)+ <> "\n\n" <> BB.toLazyByteString b+ renderResponseBody _ = error+ "Unable to create multipart response from non-ResponseBuilder"++data TableOptions = TableOptions {+ tblOptcolumns :: [Column]+, tblOptpkey :: [Text]+}++instance ToJSON TableOptions where+ toJSON t = object [+ "columns" .= tblOptcolumns t+ , "pkey" .= tblOptpkey t ]
+ src/PostgREST/Auth.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}+module PostgREST.Auth where++import Data.Aeson+import Control.Monad (mzero)+import Control.Applicative+import Crypto.BCrypt+import Data.Text+import Data.Monoid+import Data.Map+import qualified Data.Vector as V+import qualified Hasql as H+import qualified Hasql.Backend as B+import qualified Hasql.Postgres as P+import qualified Web.JWT as JWT+import Data.String.Conversions (cs)+import PostgREST.PgQuery (pgFmtLit)++import Prelude++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 P.Postgres s ()+setRole role = H.unitEx $ B.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True++resetRole :: H.Tx P.Postgres s ()+resetRole = H.unitEx [H.stmt|reset role|]++addUser :: Text -> Text -> Text -> H.Tx P.Postgres s ()+addUser identity pass role = do+ let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)+ H.unitEx $+ [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]+ identity (cs hashed :: Text) role++signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt+signInRole user pass = do+ u <- H.maybeEx $ [H.stmt|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++signInWithJWT :: Text -> Text -> LoginAttempt+signInWithJWT secret input = case maybeRole of+ Just (Just (String role)) -> LoginSuccess $ cs role+ _ -> LoginFailed+ where + maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value)+ claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded+ decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input+ +tokenJWT :: Text -> Text -> Text -> Text+tokenJWT secret uid role = JWT.encodeSigned JWT.HS256 (JWT.secret secret) claimsSet+ where+ claimsSet = JWT.def {+ JWT.unregisteredClaims = Data.Map.fromList [("id", String uid), ("role", String role)]+ }
+ src/PostgREST/Config.hs view
@@ -0,0 +1,64 @@+module PostgREST.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(..))+import Prelude++data AppConfig = AppConfig {+ configDbName :: String+ , configDbPort :: Int+ , configDbUser :: String+ , configDbPass :: String+ , configDbHost :: String++ , configPort :: Int+ , configAnonRole :: String+ , configSecure :: Bool+ , configPool :: Int+ , configV1Schema :: String+ + , configJwtSecret :: String+ }++argParser :: Parser AppConfig+argParser = AppConfig+ <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database")+ <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault)+ <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role")+ <*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role")+ <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault)++ <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault)+ <*> 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 auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault)+ <*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault)+ <*> strOption (long "jwt-secret" <> metavar "SECRET" <> value "secret" <> help "Secret used to encrypt and decrypt JWT tokens)" <> showDefault)++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+ , corsExposedHeaders = Just [+ "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"+ , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"+ ]+ }+ 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/PostgREST/Error.hs view
@@ -0,0 +1,71 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}++module PostgREST.Error (PgError, errResponse) where++import qualified Hasql as H+import qualified Hasql.Postgres as P+import qualified Network.HTTP.Types.Status as HT+import qualified Data.Aeson as JSON+import qualified Data.Text as T+import Data.Aeson ((.=))+import Data.String.Conversions (cs)+import Data.String.Utils(replace)+import Network.Wai(Response, responseLBS)+import Network.HTTP.Types.Header++type PgError = H.SessionError P.Postgres++errResponse :: PgError -> Response+errResponse e = responseLBS (httpStatus e)+ [(hContentType, "application/json")] (JSON.encode e)++instance JSON.ToJSON PgError where+ toJSON (H.TxError (P.ErroneousResult c m d h)) = JSON.object [+ "code" .= (cs c::T.Text),+ "message" .= (cs m::T.Text),+ "details" .= (fmap cs d::Maybe T.Text),+ "hint" .= (fmap cs h::Maybe T.Text)]+ toJSON (H.TxError (P.NoResult d)) = JSON.object [+ "message" .= ("No response from server"::T.Text),+ "details" .= (fmap cs d::Maybe T.Text)]+ toJSON (H.TxError (P.UnexpectedResult m)) = JSON.object ["message" .= m]+ toJSON (H.TxError P.NotInTransaction) = JSON.object [+ "message" .= ("Not in transaction"::T.Text)]+ toJSON (H.CxError (P.CantConnect d)) = JSON.object [+ "message" .= ("Can't connect to the database"::T.Text),+ "details" .= (fmap cs d::Maybe T.Text)]+ toJSON (H.CxError (P.UnsupportedVersion v)) = JSON.object [+ "message" .= ("Postgres version "++version++" is not supported") ]+ where version = replace "0" "." (show v)+ toJSON (H.ResultError m) = JSON.object ["message" .= m]++httpStatus :: PgError -> HT.Status+httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =+ let code = cs codeBS in+ case code of+ '0':'8':_ -> HT.status503 -- pg connection err+ '0':'9':_ -> HT.status500 -- triggered action exception+ '0':'L':_ -> HT.status403 -- invalid grantor+ '0':'P':_ -> HT.status403 -- invalid role specification+ '2':'5':_ -> HT.status500 -- invalid tx state+ '2':'8':_ -> HT.status403 -- invalid auth specification+ '2':'D':_ -> HT.status500 -- invalid tx termination+ '3':'8':_ -> HT.status500 -- external routine exception+ '3':'9':_ -> HT.status500 -- external routine invocation+ '3':'B':_ -> HT.status500 -- savepoint exception+ '4':'0':_ -> HT.status500 -- tx rollback+ '5':'3':_ -> HT.status503 -- insufficient resources+ '5':'4':_ -> HT.status413 -- too complex+ '5':'5':_ -> HT.status500 -- obj not on prereq state+ '5':'7':_ -> HT.status500 -- operator intervention+ '5':'8':_ -> HT.status500 -- system error+ 'F':'0':_ -> HT.status500 -- conf file error+ 'H':'V':_ -> HT.status500 -- foreign data wrapper error+ 'P':'0':_ -> HT.status500 -- PL/pgSQL Error+ 'X':'X':_ -> HT.status500 -- internal Error+ "42P01" -> HT.status404 -- undefined table+ "42501" -> HT.status404 -- insufficient privilege+ _ -> HT.status400+httpStatus (H.TxError (P.NoResult _)) = HT.status503+httpStatus _ = HT.status500
+ src/PostgREST/Main.hs view
@@ -0,0 +1,71 @@+module Main where++import Paths_postgrest (version)++import PostgREST.App+import PostgREST.Middleware+import PostgREST.Error(errResponse)++import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+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 Network.Wai.Middleware.RequestLogger (logStdout)+import Data.List (intercalate)+import Data.Version (versionBranch)+import qualified Hasql as H+import qualified Hasql.Postgres as P+import Options.Applicative hiding (columns)++import PostgREST.Config (AppConfig(..), argParser, corsPolicy)++main :: IO ()+main = do+ let opts = info (helper <*> argParser) $+ fullDesc+ <> progDesc (+ "PostgREST "+ <> prettyVersion+ <> " / create a REST API to an existing Postgres database"+ )+ parserPrefs = prefs showHelpOnError+ conf <- customExecParser parserPrefs opts+ let port = configPort conf++ unless (configSecure conf) $+ putStrLn "WARNING, running in insecure mode, auth will be in plaintext"+ unless ("secret" /= configJwtSecret conf) $+ putStrLn "WARNING, running in insecure mode, JWT secret is the default value"+ Prelude.putStrLn $ "Listening on port " +++ (show $ configPort conf :: String)++ let pgSettings = P.ParamSettings (cs $ configDbHost conf)+ (fromIntegral $ configDbPort conf)+ (cs $ configDbUser conf)+ (cs $ configDbPass conf)+ (cs $ configDbName conf)+ appSettings = setPort port+ . setServerName (cs $ "postgrest/" <> prettyVersion)+ $ defaultSettings+ middle = logStdout+ . (if configSecure conf then redirectInsecure else id)+ . gzip def . cors corsPolicy+ . staticPolicy (only [("favicon.ico", "static/favicon.ico")])++ poolSettings <- maybe (fail "Improper session settings") return $+ H.poolSettings (fromIntegral $ configPool conf) 30+ pool :: H.Pool P.Postgres+ <- H.acquirePool pgSettings poolSettings++ runSettings appSettings $ middle $ \req respond -> do+ body <- strictRequestBody req+ resOrError <- liftIO $ H.session pool $ H.tx Nothing $+ authenticated conf (app conf body) req+ either (respond . errResponse) respond resOrError++ where+ prettyVersion = intercalate "." $ map show $ versionBranch version
+ src/PostgREST/Middleware.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}++module PostgREST.Middleware where++import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Text+-- import Data.Pool(withResource, Pool)++import qualified Hasql as H+import qualified Hasql.Postgres as P+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 PostgREST.Config (AppConfig(..))+import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, resetRole)+import Codec.Binary.Base64.String (decode)++import Prelude++authenticated :: forall s. AppConfig ->+ (Request -> H.Tx P.Postgres s Response) ->+ Request -> H.Tx P.Postgres s Response+authenticated conf 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+ jwtSecret = cs $ configJwtSecret conf+ currentRole = cs $ configDbUser conf+ anon = cs $ configAnonRole conf+ httpRequesterRole :: RequestHeaders -> H.Tx P.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+ ("Bearer" : jwt : _) ->+ return $ signInWithJWT jwtSecret jwt+ _ -> return NoCredentials++ runInRole :: Text -> H.Tx P.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/PostgREST/PgQuery.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module PostgREST.PgQuery where++import PostgREST.RangeQuery++import qualified Hasql as H+import qualified Hasql.Postgres as P+import qualified Hasql.Backend as B++import qualified Data.Text as T+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.Vector (empty)+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 qualified Data.Vector as V+import Data.Scientific (isInteger, formatScientific, FPFormat(..))++import Prelude++type PStmt = H.Stmt P.Postgres+instance Monoid PStmt where+ mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =+ B.Stmt (query <> query') (params <> params') (prep && prep')+ mempty = B.Stmt "" empty True+type StatementT = PStmt -> PStmt++data QualifiedTable = QualifiedTable {+ qtSchema :: T.Text+, qtName :: T.Text+} deriving (Show)++data OrderTerm = OrderTerm {+ otTerm :: T.Text+, otDirection :: BS.ByteString+, otNullOrder :: Maybe BS.ByteString+}++limitT :: Maybe NonnegRange -> StatementT+limitT r q =+ q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True+ 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 <> B.Stmt " where " empty True <> conjunction+ where+ cols = [ col | col <- params, fst col `notElem` ["order"] ]+ conjunction = mconcat $ L.intersperse andq (map wherePred cols)++withT :: PStmt -> T.Text -> StatementT+withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =+ B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq <> " from " <> v)+ (ep <> wp)+ (epre && wpre)++orderT :: [OrderTerm] -> StatementT+orderT ts q =+ if L.null ts+ then q+ else q <> B.Stmt " order by " empty True <> clause+ where+ clause = mconcat $ L.intersperse commaq (map queryTerm ts)+ queryTerm :: OrderTerm -> PStmt+ queryTerm t = B.Stmt+ (" " <> cs (pgFmtIdent $ otTerm t) <> " "+ <> cs (otDirection t) <> " "+ <> maybe "" cs (otNullOrder t) <> " ")+ empty True++parentheticT :: StatementT+parentheticT s =+ s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }++iffNotT :: PStmt -> StatementT+iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =+ B.Stmt+ ("WITH aaa AS (" <> aq <> " returning *) " <>+ bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")+ (ap <> bp)+ (apre && bpre)++countT :: StatementT+countT s =+ s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" }++countRows :: QualifiedTable -> PStmt+countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True++asJsonWithCount :: StatementT+asJsonWithCount s = s { B.stmtTemplate =+ "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("+ <> B.stmtTemplate s <> ") t" }++asJsonRow :: StatementT+asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }++selectStar :: QualifiedTable -> PStmt+selectStar t = B.Stmt ("select * from " <> fromQt t) empty True++returningStarT :: StatementT+returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }++deleteFrom :: QualifiedTable -> PStmt+deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True++insertInto :: QualifiedTable+ -> V.Vector T.Text+ -> V.Vector (V.Vector JSON.Value)+ -> PStmt+insertInto t cols vals+ | V.null cols = B.Stmt ("insert into " <> fromQt t <> " default values returning *") empty True+ | otherwise = B.Stmt+ ("insert into " <> fromQt t <> " (" <>+ T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <>+ ") values "+ <> T.intercalate ", "+ (V.toList $ V.map (\v -> "("+ <> T.intercalate ", " (V.toList $ V.map insertableValue v)+ <> ")"+ ) vals+ )+ <> " returning row_to_json(" <> fromQt t <> ".*)")+ empty True++insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt+insertSelect t [] _ = B.Stmt+ ("insert into " <> fromQt t <> " default values returning *") empty True+insertSelect t cols vals = B.Stmt+ ("insert into " <> fromQt t <> " ("+ <> T.intercalate ", " (map pgFmtIdent cols)+ <> ") select "+ <> T.intercalate ", " (map insertableValue vals))+ empty True++update :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt+update t cols vals = B.Stmt+ ("update " <> fromQt t <> " set ("+ <> T.intercalate ", " (map pgFmtIdent cols)+ <> ") = ("+ <> T.intercalate ", " (map insertableValue vals)+ <> ")")+ empty True++wherePred :: Net.QueryItem -> PStmt+wherePred (col, predicate) =+ B.Stmt (" " <> pgFmtJsonbPath (cs col) <> " " <> op <> " " <>+ if opCode `elem` ["is","isnot"] then whiteList value+ else cs sqlValue)+ empty True++ where+ opCode:rest = T.split (=='.') $ cs $ fromMaybe "." predicate+ value = T.intercalate "." rest+ whiteList val = fromMaybe (cs (pgFmtLit val) <> "::unknown ")+ (L.find ((==) . T.toLower $ val)+ ["null","true","false"])+ star c = if c == '*' then '%' else c+ unknownLiteral = (<> "::unknown ") . pgFmtLit++ sqlValue = case opCode of+ "like" -> unknownLiteral $ T.map star value+ "ilike" -> unknownLiteral $ T.map star value+ "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "+ _ -> unknownLiteral value++ op = case opCode of+ "eq" -> "="+ "gt" -> ">"+ "lt" -> "<"+ "gte" -> ">="+ "lte" -> "<="+ "neq" -> "<>"+ "like"-> "like"+ "ilike"-> "ilike"+ "in" -> "in"+ "is" -> "is"+ "isnot" -> "is not"+ _ -> "="++orderParse :: Net.Query -> [OrderTerm]+orderParse q =+ mapMaybe orderParseTerm . T.split (==',') $ cs order+ where+ order = fromMaybe "" $ join (lookup "order" q)++orderParseTerm :: T.Text -> Maybe OrderTerm+orderParseTerm s =+ case T.split (=='.') s of+ (c:d:nls) ->+ if d `elem` ["asc", "desc"]+ then Just $ OrderTerm c+ ( if d == "asc" then "asc" else "desc" )+ ( case nls of+ [n] -> if | n == "nullsfirst" -> Just "nulls first"+ | n == "nullslast" -> Just "nulls last"+ | otherwise -> Nothing+ _ -> Nothing+ )+ else Nothing+ _ -> Nothing++commaq :: PStmt+commaq = B.Stmt ", " empty True++andq :: PStmt+andq = B.Stmt " and " empty True++data JsonbPath =+ ColIdentifier T.Text+ | KeyIdentifier T.Text+ | SingleArrow JsonbPath JsonbPath+ | DoubleArrow JsonbPath JsonbPath+ deriving (Show)++parseJsonbPath :: T.Text -> Maybe JsonbPath+parseJsonbPath p =+ case T.splitOn "->>" p of+ [a,b] ->+ let i:is = T.splitOn "->" a in+ Just $ DoubleArrow+ (foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is))+ (KeyIdentifier b)+ _ -> Nothing++pgFmtJsonbPath :: T.Text -> T.Text+pgFmtJsonbPath p =+ pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)+ where+ pgFmtJsonbPath' (ColIdentifier i) = pgFmtIdent i+ pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i+ pgFmtJsonbPath' (SingleArrow a b) =+ pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b+ pgFmtJsonbPath' (DoubleArrow a b) =+ pgFmtJsonbPath' a <> "->>" <> pgFmtJsonbPath' b++pgFmtIdent :: T.Text -> T.Text+pgFmtIdent x =+ let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in+ if escaped =~ danger+ then "\"" <> escaped <> "\""+ else escaped++ where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: T.Text++pgFmtLit :: T.Text -> T.Text+pgFmtLit x =+ let trimmed = trimNullChars x+ escaped = "'" <> T.replace "'" "''" trimmed <> "'"+ slashed = T.replace "\\" "\\\\" escaped in+ cs $ if escaped =~ ("\\\\" :: T.Text)+ then "E" <> slashed+ else slashed++trimNullChars :: T.Text -> T.Text+trimNullChars = T.takeWhile (/= '\x0')++fromQt :: QualifiedTable -> T.Text+fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)++unquoted :: JSON.Value -> T.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 v = cs $ JSON.encode v++insertableText :: T.Text -> T.Text+insertableText = (<> "::unknown") . pgFmtLit++insertableValue :: JSON.Value -> T.Text+insertableValue JSON.Null = "null"+insertableValue v = insertableText $ unquoted v++paramFilter :: JSON.Value -> T.Text+paramFilter JSON.Null = "is.null"+paramFilter v = "eq." <> unquoted v
+ src/PostgREST/PgStructure.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances,+ MultiParamTypeClasses, ScopedTypeVariables,+ FlexibleContexts #-}+module PostgREST.PgStructure where++import PostgREST.PgQuery (QualifiedTable(..))+import Data.Text hiding (foldl, map, zipWith, concat)+import Data.Aeson+import Data.Functor.Identity+import Data.String.Conversions (cs)+import Data.Maybe (fromMaybe)+import Control.Applicative++import qualified Data.Map as Map++import qualified Hasql as H+import qualified Hasql.Postgres as P++import Prelude++foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)+foreignKeys table = do+ r <- H.listEx $ [H.stmt|+ 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 :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey+ addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m+++tables :: Text -> H.Tx P.Postgres s [Table]+tables schema = do+ rows <- H.listEx $+ [H.stmt|+ select table_schema, table_name,+ is_insertable_into+ from information_schema.tables+ where table_schema = ?+ order by table_name+ |] schema+ return $ map tableFromRow rows+++columns :: QualifiedTable -> H.Tx P.Postgres s [Column]+columns table = do+ cols <- H.listEx $ [H.stmt|+ 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 (addFK fks . columnFromRow) cols++ where+ addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks }+++primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text]+primaryKeyColumns table = do+ r <- H.listEx $ [H.stmt|+ 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+++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)++tableFromRow :: (Text, Text, Text) -> Table+tableFromRow (s, n, i) = Table s n (toBool i)++columnFromRow :: (Text, Text, Text,+ Int, Text, Text,+ Text, Maybe Int, Maybe Int,+ Maybe Text, Maybe Text)+ -> Column+columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =+ Column s t n pos (toBool nul) typ (toBool u) l p d (parseEnum e) Nothing++ where+ parseEnum :: Maybe Text -> [Text]+ parseEnum str = fromMaybe [] $ split (==',') <$> str+++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/PostgREST/RangeQuery.hs view
@@ -0,0 +1,60 @@+module PostgREST.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)++import Prelude++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)
− src/RangeQuery.hs
@@ -1,58 +0,0 @@-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)
− src/Types.hs
@@ -1,57 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Types where--import qualified Data.Aeson as JSON-import Data.Aeson.Types (Parser)--import Data.Scientific (floatingOrInteger)-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- parseJSON (JSON.Number n) = return $ either toSql iToSql (floatingOrInteger n :: Either Double Int)- parseJSON (JSON.String s) = return $ toSql s- parseJSON (JSON.Bool b) = return $ toSql b- parseJSON JSON.Null = return SqlNull- parseJSON (JSON.Object o) = return . toSql $ JSON.encode o- parseJSON (JSON.Array a) = return . toSql $ JSON.encode a--instance JSON.ToJSON SqlValue where- toJSON (SqlString s) = JSON.toJSON s- toJSON (SqlByteString s) = JSON.toJSON $ decodeUtf8 s- toJSON (SqlWord32 w) = JSON.toJSON w- toJSON (SqlWord64 w) = JSON.toJSON w- toJSON (SqlInt32 i) = JSON.toJSON i- toJSON (SqlInt64 i) = JSON.toJSON i- toJSON (SqlInteger i) = JSON.toJSON i- toJSON (SqlChar c) = JSON.toJSON c- toJSON (SqlBool b) = JSON.toJSON b- toJSON (SqlDouble n) = JSON.toJSON n- toJSON (SqlRational n) = JSON.toJSON n- toJSON (SqlLocalDate d) = JSON.toJSON $ showGregorian d- toJSON (SqlLocalTimeOfDay t) = JSON.toJSON $ show t- toJSON (SqlLocalTime t) = JSON.toJSON $ show t- toJSON SqlNull = JSON.Null- toJSON x = JSON.toJSON $ show x---newtype SqlRow = SqlRow {getRow :: [(Text, SqlValue)] } deriving (Show)--sqlRowColumns :: SqlRow -> [Text]-sqlRowColumns = map fst . getRow--sqlRowValues :: SqlRow -> [SqlValue]-sqlRowValues = map snd . getRow--instance JSON.FromJSON SqlRow where- parseJSON (JSON.Object m) = foldlWithKey' add (return $ SqlRow []) m- where- add :: Parser SqlRow -> Text -> JSON.Value -> Parser SqlRow- add parser k v = do- SqlRow l <- parser- sqlV <- JSON.parseJSON v- return . SqlRow $ (k, sqlV) : l- parseJSON _ = mzero
test/SpecHelper.hs view
@@ -26,17 +26,17 @@ import qualified Data.Aeson.Types as J -import App (app)-import Config (AppConfig(..), corsPolicy)-import Middleware-import Error(errResponse)+import PostgREST.App (app)+import PostgREST.Config (AppConfig(..), corsPolicy)+import PostgREST.Middleware+import PostgREST.Error(errResponse) 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 "1"+cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1" "safe" testPoolOpts :: PoolSettings testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30@@ -50,15 +50,13 @@ withApp :: ActionWith Application -> IO () withApp perform = do- let anonRole = cs $ configAnonRole cfg- currRole = cs $ configDbUser cfg pool :: H.Pool P.Postgres <- H.acquirePool pgSettings testPoolOpts perform $ middle $ \req resp -> do body <- strictRequestBody req result <- liftIO $ H.session pool $ H.tx Nothing- $ authenticated currRole anonRole (app (cs $ configV1Schema cfg) body) req+ $ authenticated cfg (app cfg body) req either (resp . errResponse) resp result where middle = cors corsPolicy@@ -93,9 +91,13 @@ matchHeader name valRegex headers = maybe False (=~ valRegex) $ lookup name headers -authHeader :: String -> String -> Header-authHeader u p =+authHeaderBasic :: String -> String -> Header+authHeaderBasic u p = (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))+ +authHeaderJWT :: String -> Header+authHeaderJWT token =+ (hAuthorization, cs $ "Bearer " ++ token) testPool :: IO(H.Pool P.Postgres) testPool = H.acquirePool pgSettings testPoolOpts