diff --git a/CHANGELOG.md b/CHANGELOG.md index e57d5f6df..40d968830 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ This project adheres to [Semantic Versioning](http://semver.org/). ### Fixed - Prevent role from being changed twice - @begriffs +- Use read-only transaction for read requests - @ruslantalpa ## [0.3.1.1] - 2016-03-28 diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 2c0b84aaf..6517e8d05 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -1,26 +1,31 @@ module PostgREST.ApiRequest where -import qualified Data.Aeson as JSON -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.Csv as CSV -import Data.List (find) -import qualified Data.HashMap.Strict as M -import qualified Data.Set as S -import Data.Maybe (fromMaybe, isJust, isNothing, - listToMaybe, fromJust) -import Control.Monad (join) -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) -import qualified Data.Text as T -import qualified Data.Vector as V -import Network.Wai (Request (..)) -import Network.Wai.Parse (parseHttpAccept) -import PostgREST.RangeQuery (NonnegRange, rangeRequested) -import PostgREST.Types (QualifiedIdentifier (..), - Schema, Payload(..), - UniformObjects(..)) -import Data.Ranged.Ranges (singletonRange) +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Csv as CSV +import Data.List (find, sortBy) +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S +import Data.Maybe (fromMaybe, isJust, isNothing, + listToMaybe, fromJust) +import Control.Arrow ((***)) +import Control.Monad (join) +import Data.Monoid ((<>)) +import Data.Ord (comparing) +import Data.String.Conversions (cs) +import qualified Data.Text as T +import qualified Data.Vector as V +import Network.HTTP.Base (urlEncodeVars) +import Network.HTTP.Types.Header (hAuthorization) +import Network.HTTP.Types.URI (parseSimpleQuery) +import Network.Wai (Request (..)) +import Network.Wai.Parse (parseHttpAccept) +import PostgREST.RangeQuery (NonnegRange, rangeRequested) +import PostgREST.Types (QualifiedIdentifier (..), + Schema, Payload(..), + UniformObjects(..)) +import Data.Ranged.Ranges (singletonRange) type RequestBody = BL.ByteString @@ -52,11 +57,11 @@ instance Show ContentType where if it is an action we are able to perform. -} data ApiRequest = ApiRequest { - -- | Set to Nothing for unknown HTTP verbs + -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST iAction :: Action - -- | Set to Nothing for malformed range + -- | Requested range of rows within response , iRange :: NonnegRange - -- | Set to Nothing for strangely nested urls + -- | The target, be it calling a proc or accessing a table , iTarget :: Target -- | The content type the client most desires (or JSON if undecided) , iAccepts :: Either BS.ByteString ContentType @@ -74,6 +79,10 @@ data ApiRequest = ApiRequest { , iSelect :: String -- | &order parameter , iOrder :: Maybe String + -- | Alphabetized (canonical) request query string for response URLs + , iCanonicalQS :: String + -- | JSON Web Token + , iJWT :: T.Text } -- | Examines HTTP request and translates it into user intent. @@ -136,6 +145,12 @@ userApiRequest schema req reqBody = then "*" else fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams , iOrder = join $ lookup "order" qParams + , iCanonicalQS = urlEncodeVars + . sortBy (comparing fst) + . map (join (***) cs) + . parseSimpleQuery + $ rawQueryString req + , iJWT = tokenStr } where @@ -155,6 +170,10 @@ userApiRequest schema req reqBody = | hasPrefer "return=representation" = Full | hasPrefer "return=minimal" = None | otherwise = HeadersOnly + auth = fromMaybe "" $ lookupHeader hAuthorization + tokenStr = case T.split (== ' ') (cs auth) of + ("Bearer" : t : _) -> t + _ -> "" -- PRIVATE --------------------------------------------------------------- diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 752bcc3c3..be620e865 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -7,12 +7,9 @@ module PostgREST.App ( ) where import Control.Applicative -import Control.Arrow ((***)) -import Control.Monad (join) import Data.Bifunctor (first) -import Data.List (find, sortBy, delete) +import Data.List (find, delete) import Data.Maybe (isJust, fromMaybe, fromJust, mapMaybe) -import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) import Data.String.Conversions (cs) import Data.Text (Text, replace, strip) @@ -24,10 +21,8 @@ import qualified Hasql.Transaction as HT import Text.Parsec.Error import Text.ParserCombinators.Parsec (parse) -import Network.HTTP.Base (urlEncodeVars) import Network.HTTP.Types.Header import Network.HTTP.Types.Status -import Network.HTTP.Types.URI (parseSimpleQuery) import Network.Wai import Network.Wai.Middleware.RequestLogger (logStdout) @@ -72,13 +67,22 @@ postgrest conf dbStructure pool = time <- getPOSIXTime body <- strictRequestBody req - let handleReq = runWithClaims conf time (app dbStructure conf body) req + let schema = cs $ configSchema conf + apiRequest = userApiRequest schema req body + handleReq = runWithClaims conf time (app dbStructure conf) apiRequest + txMode = transactionMode $ iAction apiRequest + resp <- either pgErrResponse id <$> P.use pool - (HT.run handleReq HT.ReadCommitted HT.Write) + (HT.run handleReq HT.ReadCommitted txMode) respond resp -app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Transaction Response -app dbStructure conf reqBody req = +transactionMode :: Action -> H.Mode +transactionMode ActionRead = HT.Read +transactionMode ActionInfo = HT.Read +transactionMode _ = HT.Write + +app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response +app dbStructure conf apiRequest = let -- TODO: blow up for Left values (there is a middleware that checks the headers) contentType = either (const ApplicationJSON) id (iAccepts apiRequest) @@ -102,11 +106,7 @@ app dbStructure conf reqBody req = else responseLBS status200 [contentTypeH] (cs body) else do let (status, contentRange) = rangeHeader queryTotal tableTotal - canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? - . sortBy (comparing fst) - . map (join (***) cs) - . parseSimpleQuery - $ rawQueryString req + canonical = iCanonicalQS apiRequest return $ responseLBS status [contentTypeH, contentRange, ("Content-Location", @@ -210,7 +210,6 @@ app dbStructure conf reqBody req = allPrKeys = dbPrimaryKeys dbStructure allOrigins = ("Access-Control-Allow-Origin", "*") :: Header schema = cs $ configSchema conf - apiRequest = userApiRequest schema req reqBody shouldCount = iPreferCount apiRequest range = restrictRange (configMaxRows conf) $ iRange apiRequest readDbRequest = DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index cd76fa2bb..1281e48b5 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -5,13 +5,12 @@ module PostgREST.Middleware where import Data.Aeson (Value (..)) import qualified Data.HashMap.Strict as M -import Data.Maybe (fromMaybe) import Data.String.Conversions (cs) import Data.Text import Data.Time.Clock (NominalDiffTime) import qualified Hasql.Transaction as H -import Network.HTTP.Types.Header (hAccept, hAuthorization) +import Network.HTTP.Types.Header (hAccept) import Network.HTTP.Types.Status (status400, status415) import Network.Wai (Application, Request (..), Response, requestHeaders) @@ -19,7 +18,7 @@ import Network.Wai.Middleware.Cors (cors) import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Static (only, staticPolicy) -import PostgREST.ApiRequest (pickContentType) +import PostgREST.ApiRequest (ApiRequest(..), pickContentType) import PostgREST.Auth (jwtClaims, claimsToSQL) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) @@ -27,26 +26,21 @@ import PostgREST.Error (errResponse) import Prelude hiding (concat, null) runWithClaims :: AppConfig -> NominalDiffTime -> - (Request -> H.Transaction Response) -> - Request -> H.Transaction Response + (ApiRequest -> H.Transaction Response) -> + ApiRequest -> H.Transaction Response runWithClaims conf time app req = do - let tokenStr = case split (== ' ') (cs auth) of - ("Bearer" : t : _) -> t - _ -> "" - eClaims = jwtClaims jwtSecret tokenStr time + let eClaims = jwtClaims jwtSecret (iJWT req) time case eClaims of Left e -> clientErr e Right claims -> - if M.null claims && not (null tokenStr) + if M.null claims && not (null $ iJWT req) then clientErr "Invalid JWT" else do -- role claim defaults to anon if not specified in jwt H.sql . mconcat . claimsToSQL $ M.union claims (M.singleton "role" anon) app req where - hdrs = requestHeaders req jwtSecret = configJwtSecret conf - auth = fromMaybe "" $ lookup hAuthorization hdrs anon = String . cs $ configAnonRole conf clientErr = return . errResponse status400