@@ -2,6 +2,7 @@
22{-# LANGUAGE DerivingStrategies #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE StandaloneDeriving #-}
5+{-# LANGUAGE DerivingVia #-}
56{-# LANGUAGE TemplateHaskell #-}
67
78module Data.CreditCard
@@ -32,6 +33,7 @@ module Data.CreditCard
3233 , _DiscoverCard
3334 , _DinersClub
3435 , _JCB
36+ , _UnionPay
3537 , CreditCardError(..)
3638 , _UnknownCardNumber
3739 , _InvalidCardNumber
@@ -62,7 +64,6 @@ import Data.Ix
6264import Data.List as L
6365import Data.List.NonEmpty (NonEmpty)
6466import qualified Data.List.NonEmpty as NE
65−import Data.Maybe (fromMaybe)
6667import Data.OpenApi as OpenApi
6768 ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions
6869 , genericDeclareNamedSchema)
@@ -228,12 +229,6 @@ panToBogusNumber (CreditCardPAN txt) = do
228229 let middle = NE.fromList $ replicate (T.length txt - 8) D0
229230 return $ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
230231
231−#ifndef ghcjs_HOST_OS
232−#ifdef USE_CASSAVA
233−deriving instance FromField CreditCardPAN
234−deriving instance ToField CreditCardPAN
235−#endif
236−#endif
237232
238233mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
239234mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
@@ -316,10 +311,25 @@ data CreditCardType
316311 | DiscoverCard
317312 | DinersClub
318313 | JCB
319− deriving (Eq, Show)
314+ | UnionPay
315+ deriving (Eq, Show, Generic, Enum, Bounded)
320316
321317makePrisms ''CreditCardType
322318
319+instance Arbitrary CreditCardType where
320+ arbitrary = elements [minBound..maxBound]
321+
322+instance ToSchema CreditCardType where
323+ declareNamedSchema p = genericDeclareNamedSchema defaultSchemaOptions p
324+
325+instance FromJSON CreditCardType where
326+ parseJSON =
327+ genericParseJSON defaultOptions
328+
329+instance ToJSON CreditCardType where
330+ toJSON =
331+ genericToJSON defaultOptions
332+
323333data CreditCardError
324334 = UnknownCardNumber
325335 | InvalidCardNumber
@@ -353,11 +363,13 @@ guessCreditCardType n
353363 | isDinersClub = Just DinersClub
354364 | isJCB = Just JCB
355365 | isVisa = Just Visa -- NOTE: starts with just 4? realy?
366+ | isUnionPay = Just UnionPay
356367 | otherwise = Nothing
357368 where
358369 isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])
359370 isMasterCard = (inRange (51, 55) (firstDigits 2)) && (digitsLength == 16)
360371 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)
372+ isUnionPay = (firstDigits 2 `elem` [62]) && (digitsLength `elem` [16,17,18,19])
361373 isDiscoverCard =
362374 (firstDigits 4 == 6011 || inRange (644, 649) (firstDigits 3)
363375 || inRange (622126, 622925) (firstDigits 6) || firstDigits 2 == 65)
@@ -387,3 +399,32 @@ isValidCCNumber = isRight . creditCardType
387399
388400guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
389401guessPANCardType = guessCreditCardType <=< panToBogusNumber
402+
403+#ifndef ghcjs_HOST_OS
404+#ifdef USE_POSTGRES
405+deriving instance FromField CreditCardPAN
406+deriving instance ToField CreditCardPAN
407+instance ToField CreditCardType where
408+ toField cardType = toField $ case cardType of
409+ Visa -> "Visa"
410+ MasterCard -> "MasterCard"
411+ AmericanExpress-> "AmericanExpress"
412+ DiscoverCard -> "DiscoverCard"
413+ DinersClub -> "DinersClub"
414+ JCB -> "JCB"
415+ UnionPay -> "UnionPay" :: Text
416+
417+instance FromField CreditCardType where
418+ fromField f mbs = do
419+ txt <- fromField f mbs
420+ case T.unpack txt of
421+ "Visa" -> return Visa
422+ "MasterCard" -> return MasterCard
423+ "AmericanExpress"-> return AmericanExpress
424+ "DiscoverCard" -> return DiscoverCard
425+ "DinersClub" -> return DinersClub
426+ "JCB" -> return JCB
427+ "UnionPay" -> return UnionPay
428+ _ -> returnError ConversionFailed f ("Invalid credit card type: " ++ T.unpack txt)
429+#endif
430+#endif