Add LenientData

src/Web/HttpApiData.hs

@@ -35,6 +35,9 @@ module Web.HttpApiData (
   parseBoundedEnumOfI,
   parseBoundedTextData,
 
+  -- * Lenient data
+  LenientData (..),
+
   -- * Other helpers
   showTextData,
   readTextData,

src/Web/Internal/HttpApiData.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -11,6 +12,7 @@ module Web.Internal.HttpApiData where
 
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative
+import Data.Foldable (Foldable(foldMap))
 import Data.Traversable (Traversable(traverse))
 #endif
 
@@ -48,6 +50,8 @@ import TextShow (TextShow, showt)
 
 import qualified Data.UUID.Types as UUID
 
+import Data.Typeable (Typeable)
+
 -- $setup
 -- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
 -- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
@@ -586,3 +590,23 @@ instance ToHttpApiData UUID.UUID where
 instance FromHttpApiData UUID.UUID where
     parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText
     parseHeader   = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes
+
+
+-- | Lenient parameters. 'FromHttpApiData' combinators always return `Right`.
+newtype LenientData a = LenientData { getLenientData :: Either Text a }
+    deriving (Eq, Ord, Show, Read, Typeable)
+
+instance Functor LenientData where
+    fmap f (LenientData x) = LenientData (fmap f x)
+
+instance Foldable LenientData where
+    foldMap _ (LenientData (Left _))  = mempty
+    foldMap f (LenientData (Right x)) = f x
+
+instance Traversable LenientData where
+    traverse f (LenientData x) = fmap LenientData (traverse f x)
+
+instance FromHttpApiData a => FromHttpApiData (LenientData a) where
+    parseUrlPiece   = Right . LenientData . parseUrlPiece
+    parseHeader     = Right . LenientData . parseHeader
+    parseQueryParam = Right . LenientData . parseQueryParam