refactor: Remove GHC.Show instances in Preferences module

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 $

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
 

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
+      , iPreferRepresentation = preferRepresentation
-      , iPreferParameters  = if | hasPrefer (show SingleObject)     -> Just SingleObject
+      , iPreferParameters = preferParameters
-                                | hasPrefer (show MultipleObjects)  -> Just MultipleObjects
+      , iPreferCount = preferCount
-                                | otherwise                         -> Nothing
+      , iPreferResolution = preferResolution
-      , iPreferCount       = if | hasPrefer (show ExactCount)       -> Just ExactCount
+      , iPreferTransaction = preferTransaction
-                                | 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
       , 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
+  Preferences.Preferences{..} = Preferences.fromHeaders hdrs
-  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
   auth = fromMaybe "" $ lookupHeader hAuthorization
   tokenStr = case T.split (== ' ') (toS auth) of
     ("Bearer" : t : _) -> t

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
+instance ToHeaderValue PreferResolution where
-  show MergeDuplicates  = "resolution=merge-duplicates"
+  toHeaderValue MergeDuplicates  = "resolution=merge-duplicates"
-  show IgnoreDuplicates = "resolution=ignore-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
+instance ToHeaderValue PreferRepresentation where
-  show Full        = "return=representation"
+  toHeaderValue Full        = "return=representation"
-  show None        = "return=minimal"
+  toHeaderValue None        = "return=minimal"
-  show HeadersOnly = "return=headers-only"
+  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
+instance ToHeaderValue PreferParameters where
-  show SingleObject    = "params=single-object"
+  toHeaderValue SingleObject    = "params=single-object"
-  show MultipleObjects = "params=multiple-objects"
+  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
+instance ToHeaderValue PreferCount where
-  show ExactCount     = "count=exact"
+  toHeaderValue ExactCount     = "count=exact"
-  show PlannedCount   = "count=planned"
+  toHeaderValue PlannedCount   = "count=planned"
-  show EstimatedCount = "count=estimated"
+  toHeaderValue EstimatedCount = "count=estimated"
 
 data PreferTransaction
-  = Commit   -- Commit transaction - the default.
+  = Commit   -- ^ Commit transaction - the default.
-  | Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
+  | Rollback -- ^ Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
   deriving Eq
 
-instance Show PreferTransaction where
+instance ToHeaderValue PreferTransaction where
-  show Commit   = "tx=commit"
+  toHeaderValue Commit   = "tx=commit"
-  show Rollback = "tx=rollback"
+  toHeaderValue Rollback = "tx=rollback"
+
+instance ToAppliedHeader PreferTransaction