diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 89e2ccb6f..61a335aa0 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -76,7 +76,8 @@ import PostgREST.Request.ApiRequest (Action (..), Target (..)) import PostgREST.Request.Preferences (PreferCount (..), PreferParameters (..), - PreferRepresentation (..)) + PreferRepresentation (..), + toAppliedHeader) import PostgREST.Request.Types (ReadRequest, fstFieldNames) import PostgREST.Version (prettyVersion) import PostgREST.Workers (connectionWorker, listener) @@ -322,7 +323,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do , if null pkCols && isNothing iOnConflict then Nothing else - (\x -> ("Preference-Applied", BS.pack $ show x)) <$> iPreferResolution + toAppliedHeader <$> iPreferResolution ] failNotSingular iAcceptContentType resQueryTotal $ diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 8f3f256a9..dbd1bd009 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -23,7 +23,6 @@ import qualified Hasql.DynamicStatements.Snippet as SQL hiding (sql) import qualified Hasql.DynamicStatements.Statement as SQL import qualified Hasql.Transaction as SQL -import qualified Network.HTTP.Types.Header as HTTP import qualified Network.Wai as Wai import qualified Network.Wai.Logger as Wai import qualified Network.Wai.Middleware.Cors as Wai @@ -182,10 +181,10 @@ optionalRollback AppConfig{..} ApiRequest{..} transaction = do preferenceApplied | shouldCommit = addHeadersIfNotIncluded - [(HTTP.hPreferenceApplied, BS.pack (show Commit))] + [toAppliedHeader Commit] | shouldRollback = addHeadersIfNotIncluded - [(HTTP.hPreferenceApplied, BS.pack (show Rollback))] + [toAppliedHeader Rollback] | otherwise = identity diff --git a/src/PostgREST/Request/ApiRequest.hs b/src/PostgREST/Request/ApiRequest.hs index c2e691ba3..334c686b6 100644 --- a/src/PostgREST/Request/ApiRequest.hs +++ b/src/PostgREST/Request/ApiRequest.hs @@ -3,7 +3,6 @@ Module : PostgREST.Request.ApiRequest Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. -} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -67,6 +66,7 @@ import PostgREST.Request.Preferences (PreferCount (..), PreferTransaction (..)) import qualified PostgREST.ContentType as ContentType +import qualified PostgREST.Request.Preferences as Preferences import Protolude hiding (head, toS) import Protolude.Conv (toS) @@ -195,20 +195,11 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody , iRange = ranges , iTopLevelRange = topLevelRange , iPayload = relevantPayload - , iPreferRepresentation = representation - , iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject - | hasPrefer (show MultipleObjects) -> Just MultipleObjects - | otherwise -> Nothing - , iPreferCount = if | hasPrefer (show ExactCount) -> Just ExactCount - | hasPrefer (show PlannedCount) -> Just PlannedCount - | hasPrefer (show EstimatedCount) -> Just EstimatedCount - | otherwise -> Nothing - , iPreferResolution = if | hasPrefer (show MergeDuplicates) -> Just MergeDuplicates - | hasPrefer (show IgnoreDuplicates) -> Just IgnoreDuplicates - | otherwise -> Nothing - , iPreferTransaction = if | hasPrefer (show Commit) -> Just Commit - | hasPrefer (show Rollback) -> Just Rollback - | otherwise -> Nothing + , iPreferRepresentation = preferRepresentation + , iPreferParameters = preferParameters + , iPreferCount = preferCount + , iPreferResolution = preferResolution + , iPreferTransaction = preferTransaction , iFilters = filters , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ] , iSelect = toS <$> join (lookup "select" qParams) @@ -325,7 +316,7 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody target = let callFindProc procSch procNam = findProc - (QualifiedIdentifier procSch procNam) payloadColumns (hasPrefer (show SingleObject)) (dbProcs dbStructure) + (QualifiedIdentifier procSch procNam) payloadColumns (preferParameters == Just SingleObject) (dbProcs dbStructure) contentType (action == ActionInvoke InvPost) in case path of @@ -359,16 +350,7 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody hdrs = requestHeaders req qParams = [(toS k, v)|(k,v) <- qString] lookupHeader = flip lookup hdrs - hasPrefer :: Text -> Bool - hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs - where - split :: BS.ByteString -> [Text] - split = map T.strip . T.split (==',') . toS - representation - | hasPrefer (show Full) = Full - | hasPrefer (show None) = None - | hasPrefer (show HeadersOnly) = HeadersOnly - | otherwise = None + Preferences.Preferences{..} = Preferences.fromHeaders hdrs auth = fromMaybe "" $ lookupHeader hAuthorization tokenStr = case T.split (== ' ') (toS auth) of ("Bearer" : t : _) -> t diff --git a/src/PostgREST/Request/Preferences.hs b/src/PostgREST/Request/Preferences.hs index 0e4dc1d82..2562adaf2 100644 --- a/src/PostgREST/Request/Preferences.hs +++ b/src/PostgREST/Request/Preferences.hs @@ -1,16 +1,69 @@ -module PostgREST.Request.Preferences where +module PostgREST.Request.Preferences + ( Preferences(..) + , PreferCount(..) + , PreferParameters(..) + , PreferRepresentation(..) + , PreferResolution(..) + , PreferTransaction(..) + , fromHeaders + , ToAppliedHeader(..) + ) where + +import qualified Data.ByteString as BS +import qualified Network.HTTP.Types.Header as HTTP +import qualified Data.Map as Map -import GHC.Show import Protolude +data Preferences + = Preferences + { preferResolution :: Maybe PreferResolution + , preferRepresentation :: PreferRepresentation + , preferParameters :: Maybe PreferParameters + , preferCount :: Maybe PreferCount + , preferTransaction :: Maybe PreferTransaction + } + +fromHeaders :: [HTTP.Header] -> Preferences +fromHeaders headers = + Preferences + { preferResolution = parsePrefs [MergeDuplicates, IgnoreDuplicates] + , preferRepresentation = fromMaybe None $ parsePrefs [Full, None, HeadersOnly] + , preferParameters = parsePrefs [SingleObject, MultipleObjects] + , preferCount = parsePrefs [ExactCount, PlannedCount, EstimatedCount] + , preferTransaction = parsePrefs [Commit, Rollback] + } + where + prefHeaders = filter ((==) HTTP.hPrefer . fst) headers + prefs = fmap strip . concatMap (BS.split comma . snd) $ prefHeaders + comma = fromIntegral (ord ',') + strip = BS.dropWhile (space ==) . BS.dropWhileEnd (space ==) + space = fromIntegral (ord ' ') + + parsePrefs :: ToHeaderValue a => [a] -> Maybe a + parsePrefs vals = + head $ mapMaybe (flip Map.lookup $ prefMap vals) prefs + + prefMap :: ToHeaderValue a => [a] -> Map.Map ByteString a + prefMap = Map.fromList . fmap (\pref -> (toHeaderValue pref, pref)) + +class ToHeaderValue a where + toHeaderValue :: a -> ByteString + +class ToHeaderValue a => ToAppliedHeader a where + toAppliedHeader :: a -> HTTP.Header + toAppliedHeader x = (HTTP.hPreferenceApplied, toHeaderValue x) + data PreferResolution = MergeDuplicates | IgnoreDuplicates -instance Show PreferResolution where - show MergeDuplicates = "resolution=merge-duplicates" - show IgnoreDuplicates = "resolution=ignore-duplicates" +instance ToHeaderValue PreferResolution where + toHeaderValue MergeDuplicates = "resolution=merge-duplicates" + toHeaderValue IgnoreDuplicates = "resolution=ignore-duplicates" + +instance ToAppliedHeader PreferResolution -- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2 data PreferRepresentation @@ -19,36 +72,38 @@ data PreferRepresentation | None -- ^ Return nothing from the mutated data. deriving Eq -instance Show PreferRepresentation where - show Full = "return=representation" - show None = "return=minimal" - show HeadersOnly = "return=headers-only" +instance ToHeaderValue PreferRepresentation where + toHeaderValue Full = "return=representation" + toHeaderValue None = "return=minimal" + toHeaderValue HeadersOnly = "return=headers-only" data PreferParameters = SingleObject -- ^ Pass all parameters as a single json object to a stored procedure | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure deriving Eq -instance Show PreferParameters where - show SingleObject = "params=single-object" - show MultipleObjects = "params=multiple-objects" +instance ToHeaderValue PreferParameters where + toHeaderValue SingleObject = "params=single-object" + toHeaderValue MultipleObjects = "params=multiple-objects" data PreferCount = ExactCount -- ^ exact count(slower) | PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}. | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count. - deriving Eq + deriving Eq -instance Show PreferCount where - show ExactCount = "count=exact" - show PlannedCount = "count=planned" - show EstimatedCount = "count=estimated" +instance ToHeaderValue PreferCount where + toHeaderValue ExactCount = "count=exact" + toHeaderValue PlannedCount = "count=planned" + toHeaderValue EstimatedCount = "count=estimated" data PreferTransaction - = Commit -- Commit transaction - the default. - | Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests. + = Commit -- ^ Commit transaction - the default. + | Rollback -- ^ Rollback transaction after sending the response - does not persist changes, e.g. for running tests. deriving Eq -instance Show PreferTransaction where - show Commit = "tx=commit" - show Rollback = "tx=rollback" +instance ToHeaderValue PreferTransaction where + toHeaderValue Commit = "tx=commit" + toHeaderValue Rollback = "tx=rollback" + +instance ToAppliedHeader PreferTransaction