diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs deleted file mode 100644 --- a/src/App.hs +++ /dev/null @@ -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 ] diff --git a/src/Auth.hs b/src/Auth.hs deleted file mode 100644 --- a/src/Auth.hs +++ /dev/null @@ -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 diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -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 -> [] diff --git a/src/Error.hs b/src/Error.hs deleted file mode 100644 --- a/src/Error.hs +++ /dev/null @@ -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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 diff --git a/src/Middleware.hs b/src/Middleware.hs deleted file mode 100644 --- a/src/Middleware.hs +++ /dev/null @@ -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 diff --git a/src/PgQuery.hs b/src/PgQuery.hs deleted file mode 100644 --- a/src/PgQuery.hs +++ /dev/null @@ -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 diff --git a/src/PgStructure.hs b/src/PgStructure.hs deleted file mode 100644 --- a/src/PgStructure.hs +++ /dev/null @@ -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 ] diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/App.hs @@ -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 ] diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Auth.hs @@ -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)] + } diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Config.hs @@ -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 -> [] diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Error.hs @@ -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 diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Main.hs @@ -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 diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Middleware.hs @@ -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 diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/PgQuery.hs @@ -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 diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/PgStructure.hs @@ -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 ] diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/RangeQuery.hs @@ -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) diff --git a/src/RangeQuery.hs b/src/RangeQuery.hs deleted file mode 100644 --- a/src/RangeQuery.hs +++ /dev/null @@ -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) diff --git a/src/Types.hs b/src/Types.hs deleted file mode 100644 --- a/src/Types.hs +++ /dev/null @@ -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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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