jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor: Remove GHC.Show instances in Preferences module

Browse Source
This commit is contained in:
monacoremo
2021-11-09 19:13:52 +01:00
committed by Remo
parent 40f9a6068a
commit 038d84b62d
4 changed files with 90 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+3 -2
View File
@@ -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 $
src/PostgREST/Middleware.hs
+2 -3
View File
@@ -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
src/PostgREST/Request/ApiRequest.hs
+8 -26
View File
@@ -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
src/PostgREST/Request/Preferences.hs
+77 -22
View File
@@ -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