git.iko.soy/typeable/credit-card
on master help sign in
Merge pull request #4 from typeable/add-union-pay
fca6e5aVille Tirronen
credit-card.cabal+1
compare with master
unifiedsplit
@@ -31,6 +31,7 @@ library
31 , time
31 , time
32 if !impl(ghcjs) && flag(postgres)
32 if !impl(ghcjs) && flag(postgres)
33 build-depends: postgresql-simple
33 build-depends: postgresql-simple
34+ cpp-options: -DUSE_POSTGRES
34 if flag(store)
35 if flag(store)
35 build-depends:
36 build-depends:
36 store
37 store
src/Data/CreditCard.hs+49−8
@@ -2,6 +2,7 @@
2{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE StandaloneDeriving #-}
5+{-# LANGUAGE DerivingVia #-}
5{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TemplateHaskell #-}
6
7
7module Data.CreditCard
8module Data.CreditCard
@@ -32,6 +33,7 @@ module Data.CreditCard
32 , _DiscoverCard
33 , _DiscoverCard
33 , _DinersClub
34 , _DinersClub
34 , _JCB
35 , _JCB
36+ , _UnionPay
35 , CreditCardError(..)
37 , CreditCardError(..)
36 , _UnknownCardNumber
38 , _UnknownCardNumber
37 , _InvalidCardNumber
39 , _InvalidCardNumber
@@ -62,7 +64,6 @@ import Data.Ix
62import Data.List as L
64import Data.List as L
63import Data.List.NonEmpty (NonEmpty)
65import Data.List.NonEmpty (NonEmpty)
64import qualified Data.List.NonEmpty as NE
66import qualified Data.List.NonEmpty as NE
65−import Data.Maybe (fromMaybe)
66import Data.OpenApi as OpenApi
67import Data.OpenApi as OpenApi
67 ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions
68 ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions
68 , genericDeclareNamedSchema)
69 , genericDeclareNamedSchema)
@@ -228,12 +229,6 @@ panToBogusNumber (CreditCardPAN txt) = do
228 let middle = NE.fromList $ replicate (T.length txt - 8) D0
229 let middle = NE.fromList $ replicate (T.length txt - 8) D0
229 return $ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
230 return $ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
230
231
231−#ifndef ghcjs_HOST_OS
232−#ifdef USE_CASSAVA
233−deriving instance FromField CreditCardPAN
234−deriving instance ToField CreditCardPAN
235−#endif
236−#endif
237
232
238mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
233mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
239mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
234mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
@@ -316,10 +311,25 @@ data CreditCardType
316 | DiscoverCard
311 | DiscoverCard
317 | DinersClub
312 | DinersClub
318 | JCB
313 | JCB
314+ | UnionPay
319− deriving (Eq, Show)
315+ deriving (Eq, Show, Generic, Enum, Bounded)
320
316
321makePrisms ''CreditCardType
317makePrisms ''CreditCardType
322
318
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+
323data CreditCardError
333data CreditCardError
324 = UnknownCardNumber
334 = UnknownCardNumber
325 | InvalidCardNumber
335 | InvalidCardNumber
@@ -353,11 +363,13 @@ guessCreditCardType n
353 | isDinersClub = Just DinersClub
363 | isDinersClub = Just DinersClub
354 | isJCB = Just JCB
364 | isJCB = Just JCB
355 | isVisa = Just Visa -- NOTE: starts with just 4? realy?
365 | isVisa = Just Visa -- NOTE: starts with just 4? realy?
366+ | isUnionPay = Just UnionPay
356 | otherwise = Nothing
367 | otherwise = Nothing
357 where
368 where
358 isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])
369 isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])
359 isMasterCard = (inRange (51, 55) (firstDigits 2)) && (digitsLength == 16)
370 isMasterCard = (inRange (51, 55) (firstDigits 2)) && (digitsLength == 16)
360 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)
371 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)
372+ isUnionPay = (firstDigits 2 `elem` [62]) && (digitsLength `elem` [16,17,18,19])
361 isDiscoverCard =
373 isDiscoverCard =
362 (firstDigits 4 == 6011 || inRange (644, 649) (firstDigits 3)
374 (firstDigits 4 == 6011 || inRange (644, 649) (firstDigits 3)
363 || inRange (622126, 622925) (firstDigits 6) || firstDigits 2 == 65)
375 || inRange (622126, 622925) (firstDigits 6) || firstDigits 2 == 65)
@@ -387,3 +399,32 @@ isValidCCNumber = isRight . creditCardType
387
399
388guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
400guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
389guessPANCardType = guessCreditCardType <=< panToBogusNumber
401guessPANCardType = 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
stack.yaml+2
@@ -9,6 +9,8 @@ extra-deps:
9 commit: e03f087c90c9228a9ae52a0e516eba22589eef94
9 commit: e03f087c90c9228a9ae52a0e516eba22589eef94
10- git: https://github.com/typeable/missing-lens.git
10- git: https://github.com/typeable/missing-lens.git
11 commit: 328659fdda8fd7ec509abfab6298775062fc2926
11 commit: 328659fdda8fd7ec509abfab6298775062fc2926
12+nix:
13+ packages: [postgresql_14]
12
14
13# Override default flag values for local packages and extra-deps
15# Override default flag values for local packages and extra-deps
14# flags: {}
16# flags: {}