refactor: Use typeclasses in Preferences

src/PostgREST/App.hs

@@ -77,7 +77,7 @@ import PostgREST.Request.ApiRequest      (Action (..),
 import PostgREST.Request.Preferences     (PreferCount (..),
                                           PreferParameters (..),
                                           PreferRepresentation (..),
-                                          resolutionAppliedHeader)
+                                          toAppliedHeader)
 import PostgREST.Request.Types           (ReadRequest, fstFieldNames)
 import PostgREST.Version                 (prettyVersion)
 import PostgREST.Workers                 (connectionWorker, listener)
@@ -323,7 +323,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
         , if null pkCols && isNothing iOnConflict then
             Nothing
           else
-            resolutionAppliedHeader <$> iPreferResolution
+            toAppliedHeader <$> iPreferResolution
         ]
 
   failNotSingular iAcceptContentType resQueryTotal $

src/PostgREST/Middleware.hs

@@ -181,10 +181,10 @@ optionalRollback AppConfig{..} ApiRequest{..} transaction = do
     preferenceApplied
       | shouldCommit =
           addHeadersIfNotIncluded
-            [transactionAppliedHeader Commit]
+            [toAppliedHeader Commit]
       | shouldRollback =
           addHeadersIfNotIncluded
-            [transactionAppliedHeader Rollback]
+            [toAppliedHeader Rollback]
       | otherwise =
           identity
 

src/PostgREST/Request/Preferences.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
 module PostgREST.Request.Preferences
   ( Preferences(..)
   , PreferCount(..)
@@ -7,8 +6,7 @@ module PostgREST.Request.Preferences
   , PreferResolution(..)
   , PreferTransaction(..)
   , fromHeaders
-  , resolutionAppliedHeader
-  , transactionAppliedHeader
+  , ToAppliedHeader(..)
   ) where
 
 import qualified Data.ByteString           as BS
@@ -30,36 +28,42 @@ data Preferences
 fromHeaders :: [HTTP.Header] -> Preferences
 fromHeaders headers =
   Preferences
-    { preferResolution = parsePrefs resolutionStr [MergeDuplicates, IgnoreDuplicates]
-    , preferRepresentation =
-        fromMaybe None $ parsePrefs representationStr [Full, None, HeadersOnly]
-    , preferParameters = parsePrefs parametersStr [SingleObject, MultipleObjects]
-    , preferCount = parsePrefs countStr [ExactCount, PlannedCount, EstimatedCount]
-    , preferTransaction = parsePrefs transactionStr [Commit, Rollback]
+    { 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 toStr vals =
-      head $ mapMaybe (flip Map.lookup $ prefMap toStr vals) prefs
-    prefMap toStr = Map.fromList . fmap (\pref -> (toStr pref, pref))
 
+    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
 
-resolutionAppliedHeader :: PreferResolution -> HTTP.Header
-resolutionAppliedHeader pref =
-  (HTTP.hPreferenceApplied, resolutionStr pref)
+instance ToHeaderValue PreferResolution where
+  toHeaderValue MergeDuplicates  = "resolution=merge-duplicates"
+  toHeaderValue IgnoreDuplicates = "resolution=ignore-duplicates"
 
-resolutionStr :: PreferResolution -> ByteString
-resolutionStr = \case
-  MergeDuplicates  -> "resolution=merge-duplicates"
-  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
@@ -68,44 +72,38 @@ data PreferRepresentation
   | None        -- ^ Return nothing from the mutated data.
   deriving Eq
 
-representationStr :: PreferRepresentation -> ByteString
-representationStr = \case
-  Full        -> "return=representation"
-  None        -> "return=minimal"
-  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
 
-parametersStr :: PreferParameters -> ByteString
-parametersStr = \case
-  SingleObject    -> "params=single-object"
-  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
 
-countStr :: PreferCount -> ByteString
-countStr = \case
-  ExactCount     -> "count=exact"
-  PlannedCount   -> "count=planned"
-  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.
   deriving Eq
 
-transactionStr :: PreferTransaction -> ByteString
-transactionStr = \case
-  Commit   -> "tx=commit"
-  Rollback -> "tx=rollback"
+instance ToHeaderValue PreferTransaction where
+  toHeaderValue Commit   = "tx=commit"
+  toHeaderValue Rollback = "tx=rollback"
 
-transactionAppliedHeader :: PreferTransaction -> HTTP.Header
-transactionAppliedHeader pref =
-  (HTTP.hPreferenceApplied, transactionStr pref)
+instance ToAppliedHeader PreferTransaction