@@ -1,8 +1,10 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DerivingStrategies #-}
32{-# LANGUAGE OverloadedStrings #-}
43{-# LANGUAGE StandaloneDeriving #-}
4+{-# LANGUAGE DerivingVia #-}
55{-# LANGUAGE TemplateHaskell #-}
6+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
7+{-# HLINT ignore "Use ||" #-}
68
79module Data.CreditCard
810 ( -- * Types
@@ -32,6 +34,7 @@ module Data.CreditCard
3234 , _DiscoverCard
3335 , _DinersClub
3436 , _JCB
37+ , _UnionPay
3538 , CreditCardError(..)
3639 , _UnknownCardNumber
3740 , _InvalidCardNumber
@@ -51,10 +54,10 @@ module Data.CreditCard
5154
5255import Control.Lens hiding (elements)
5356
54−import Control.Monad (guard)
57+import Control.Monad (guard, (<=<), replicateM)
5558import Data.Aeson as Aeson
5659import Data.Aeson.Inflections (defaultFieldLabelModifier)
57−import Data.Aeson.Types (withText)
60+import Data.Binary (Binary)
5861import Data.Char (isDigit)
5962import Data.Digit
6063import Data.Either (isRight)
@@ -63,29 +66,41 @@ import Data.Ix
6366import Data.List as L
6467import Data.List.NonEmpty (NonEmpty)
6568import qualified Data.List.NonEmpty as NE
66−import Data.Maybe (fromMaybe)
67−import Data.OpenApi as OpenApi
68− ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions
69− , genericDeclareNamedSchema)
70−import Data.Proxy
7169import Data.Semigroup
7270import Data.Text (Text)
7371import qualified Data.Text as T
7472import Data.Time
75−#ifndef ghcjs_HOST_OS
73+#ifdef BACKEND
74+import Data.Proxy
75+import Data.OpenApi as OpenApi
76+ ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions
77+ , genericDeclareNamedSchema)
78+#ifdef USE_POSTGRES
7679import Database.PostgreSQL.Simple.FromField
7780import Database.PostgreSQL.Simple.ToField
7881#endif
79−import Formatting as F
82+#endif
8083import GHC.Generics (Generic)
8184import Numeric.Natural
8285import Test.QuickCheck.Arbitrary
8386import Test.QuickCheck.Gen
87+#ifdef USE_STORE
88+import qualified Data.Store
89+import qualified Data.Store.Internal
90+#endif
8491
8592
8693newtype ZipCode = ZipCode
8794 { unZipCode :: Text }
88− deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema)
95+ deriving stock (Show, Eq, Generic)
96+#ifdef BACKEND
97+ deriving newtype (ToJSON, FromJSON, ToSchema)
98+#else
99+ deriving newtype (ToJSON, FromJSON)
100+#endif
101+#ifdef USE_STORE
102+ deriving anyclass Data.Store.Store
103+#endif
89104
90105makePrisms ''ZipCode
91106
@@ -95,18 +110,16 @@ data CreditCardDate = CreditCardDate
95110 , _ccdMonth :: Int
96111 -- ^ Month number in range [1..12]
97112 } deriving (Eq, Show, Generic)
98−
99−instance ToSchema CreditCardDate where
100− declareNamedSchema _ = declareNamedSchema (Proxy @Text)
113+#ifdef USE_STORE
114+ deriving anyclass Data.Store.Store
115+#endif
101116
102117makeLenses ''CreditCardDate
103118
104119formatExpiryDate :: CreditCardDate -> Text
105−formatExpiryDate ccd =
106− F.sformat
107− (F.left 2 '0' F.% F.left 2 '0')
108− (F.sformat F.int $ ccd ^. ccdMonth)
109− (F.sformat F.int $ ccd ^. ccdYear - 2000)
120+formatExpiryDate ccd = s2 (ccd ^. ccdMonth) <> s2 (ccd ^. ccdYear - 2000)
121+ where
122+ s2 = T.justifyRight 2 '0' . T.pack . show
110123
111124-- NOTE: This function is supposed to be called 'parseExpiryDate',
112125-- but we already have a function with the same name in b2b/api
@@ -154,9 +167,6 @@ newtype CreditCardNumber = CreditCardNumber
154167 { unCreditCardNumber :: NonEmpty Digit }
155168 deriving (Eq, Generic)
156169
157−instance ToSchema CreditCardNumber where
158− declareNamedSchema _ = declareNamedSchema (Proxy @Text)
159−
160170makePrisms ''CreditCardNumber
161171
162172renderCardNumber :: CreditCardNumber -> Text
@@ -168,6 +178,15 @@ parseCardNumber = preview (_DigitsText . from _CreditCardNumber)
168178apiCreditCardNumber :: Prism' Text CreditCardNumber
169179apiCreditCardNumber = prism' renderCardNumber parseCardNumber
170180
181+#ifdef USE_STORE
182+instance Data.Store.Store CreditCardNumber where
183+ poke = Data.Store.poke . renderCardNumber
184+ peek = do
185+ maybeNumber <- parseCardNumber <$> Data.Store.peek
186+ maybe (fail "invalid stored credit card number") pure maybeNumber
187+ size = Data.Store.VarSize (Data.Store.Internal.getSize . renderCardNumber)
188+#endif
189+
171190instance FromJSON CreditCardNumber where
172191 parseJSON = withText "CreditCardNumber" $ \s ->
173192 case parseCardNumber s of
@@ -190,7 +209,7 @@ instance Arbitrary CreditCardNumber where
190209newtype CreditCardPAN = CreditCardPAN
191210 { unCreditCardPAN :: Text
192211 } deriving (Eq, Ord)
193− deriving newtype (Show)
212+ deriving newtype (Show, FromJSON, ToJSON)
194213
195214panTrailingDigits :: CreditCardPAN -> Text
196215panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt
@@ -199,19 +218,13 @@ panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt
199218-- This may not seem terribly useful on its own,
200219-- but this allows to reuse some functions working
201220-- with CC numbers.
202−panToBogusNumber :: CreditCardPAN -> CreditCardNumber
203−panToBogusNumber (CreditCardPAN txt) =
204− CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
205− where
206− leading = check $ preview _DigitsText $ T.take 4 txt
207− middle = NE.fromList $ replicate (T.length txt - 8) D0
208− trailing = check $ preview _DigitsText $ T.takeEnd 4 txt
209− check = fromMaybe (error "Failed to parse PAN back to digits")
221+panToBogusNumber :: CreditCardPAN -> Maybe CreditCardNumber
222+panToBogusNumber (CreditCardPAN txt) = do
223+ leading <- preview _DigitsText $ T.take 4 txt
224+ trailing <- preview _DigitsText $ T.takeEnd 4 txt
225+ let middle = NE.fromList $ replicate (T.length txt - 8) D0
226+ return $ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
210227
211−#ifndef ghcjs_HOST_OS
212−deriving instance FromField CreditCardPAN
213−deriving instance ToField CreditCardPAN
214−#endif
215228
216229mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
217230mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
@@ -224,11 +237,18 @@ mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
224237newtype CreditCardSecurity = CreditCardSecurity
225238 { unCCSecurity :: Text }
226239 deriving (Eq, Ord, Generic)
240+#ifdef BACKEND
227241 deriving newtype (ToJSON, FromJSON, ToSchema)
242+#else
243+ deriving newtype (ToJSON, FromJSON)
244+#endif
245+#ifdef USE_STORE
246+ deriving anyclass Data.Store.Store
247+#endif
228248
229249instance Arbitrary CreditCardSecurity where
230250 arbitrary = CreditCardSecurity . T.pack . concatMap (show :: Int -> String)
231− <$> sequence (replicate 3 (choose (0, 9)))
251+ <$> replicateM 3 (choose (0, 9))
232252
233253-- | Show instance for 'CreditCardSecurity' doesn't actually show
234254-- anything. It replaces all characters with '*'.
@@ -244,23 +264,18 @@ parseCreditCardSecurity txt
244264 | isValid = pure $ CreditCardSecurity txt
245265 | otherwise = Nothing
246266 where
247− isValid = and
248− [ T.length txt == 3
249− , T.all isDigit txt ]
267+ isValid = (3, 4) `inRange` T.length txt && T.all isDigit txt
250268
251269data CreditCard = CreditCard
252− { _ccNumber :: !(CreditCardNumber)
253− , _ccHolderName :: !(Text)
270+ { _ccNumber :: !CreditCardNumber
271+ , _ccHolderName :: !Text
254272 , _ccSecurity :: !(Maybe CreditCardSecurity)
255− , _ccExpirationDate :: !(CreditCardDate)
273+ , _ccExpirationDate :: !CreditCardDate
256274 , _ccZipCode :: !(Maybe ZipCode)
257275 } deriving (Eq, Generic, Show)
258−
259−instance ToSchema CreditCard where
260− declareNamedSchema p = genericDeclareNamedSchema opts p
261− where
262− opts = defaultSchemaOptions
263− { OpenApi.fieldLabelModifier = defaultFieldLabelModifier }
276+#ifdef USE_STORE
277+ deriving anyclass Data.Store.Store
278+#endif
264279
265280instance FromJSON CreditCard where
266281 parseJSON =
@@ -288,10 +303,24 @@ data CreditCardType
288303 | DiscoverCard
289304 | DinersClub
290305 | JCB
291− deriving (Eq, Show)
306+ | UnionPay
307+ deriving (Eq, Show, Generic, Enum, Bounded)
308+
309+instance Binary CreditCardType
292310
293311makePrisms ''CreditCardType
294312
313+instance Arbitrary CreditCardType where
314+ arbitrary = elements [minBound..maxBound]
315+
316+instance FromJSON CreditCardType where
317+ parseJSON =
318+ genericParseJSON defaultOptions
319+
320+instance ToJSON CreditCardType where
321+ toJSON =
322+ genericToJSON defaultOptions
323+
295324data CreditCardError
296325 = UnknownCardNumber
297326 | InvalidCardNumber
@@ -306,8 +335,8 @@ getDigits = F.toList . fmap digitToNum . unDigits . natToDigits
306335getLuhnDigit :: [Digit] -> Digit
307336getLuhnDigit n = digitFromNumMod10 (total * 9)
308337 where
309− total = sum $ L.map multEven $ L.zip [0..] $ L.reverse n
310− multEven (i :: Int, digitToNum -> a)
338+ total = sum $ L.zipWith multEven [0..] $ L.reverse n
339+ multEven (i :: Int) (digitToNum -> a)
311340 | even i = sum $ getDigits (a * 2)
312341 | otherwise = a
313342
@@ -325,37 +354,90 @@ guessCreditCardType n
325354 | isDinersClub = Just DinersClub
326355 | isJCB = Just JCB
327356 | isVisa = Just Visa -- NOTE: starts with just 4? realy?
357+ | isUnionPay = Just UnionPay
328358 | otherwise = Nothing
329359 where
330360 isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])
331− isMasterCard = (inRange (51, 55) (firstDigits 2)) && (digitsLength == 16)
361+ isMasterCard = or
362+ [ inRange (51, 55) (firstDigits 2) && (digitsLength == 16)
363+ , inRange (2221, 2720) (firstDigits 4) && (digitsLength == 16)]
332364 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)
333− isDiscoverCard =
334− (firstDigits 4 == 6011 || inRange (644, 649) (firstDigits 3)
335− || inRange (622126, 622925) (firstDigits 6) || firstDigits 2 == 65)
365+ isUnionPay = (firstDigits 2 == 62) && (digitsLength `elem` [16,17,18,19])
366+ isDiscoverCard = or
367+ [ firstDigits 4 == 6011
368+ , inRange (644, 649) (firstDigits 3)
369+ , inRange (622126, 622925) (firstDigits 6)
370+ , firstDigits 2 == 65]
336371 && (digitsLength `elem` [16, 19])
337− isDinersClub =
338− ((inRange (300, 305) (firstDigits 3) || firstDigits 3 == 309
339− || firstDigits 2 == 36 || inRange (38, 39) (firstDigits 2))
340− && digitsLength == 14)
341− || (firstDigits 2 `elem` [54, 55] && digitsLength == 16)
342− isJCB =
343− (inRange (3528, 3589) (firstDigits 4) && digitsLength `elem` [15, 16])
344− || (firstDigits 4 `elem` [1800, 2131] && digitsLength == 15)
345− || (firstDigits 6 == 357266 && digitsLength == 19)
372+ isDinersClub = or
373+ [ inRange (300, 305) (firstDigits 3) && digitsLength == 14
374+ , firstDigits 3 == 309 && digitsLength == 14
375+ , firstDigits 2 == 36 && digitsLength == 14
376+ , inRange (38, 39) (firstDigits 2) && digitsLength == 14
377+ , firstDigits 2 `elem` [54, 55] && digitsLength == 16]
378+ isJCB = or
379+ [ inRange (3528, 3589) (firstDigits 4) && digitsLength `elem` [15, 16]
380+ , firstDigits 4 `elem` [1800, 2131] && digitsLength == 15
381+ , firstDigits 6 == 357266 && digitsLength == 19]
346382 digitsLength = L.length $ n ^. _CreditCardNumber
347383 firstDigits x = poly10 @Integer $ L.take x
348384 $ n ^.. _CreditCardNumber . folded . to digitToNum
349385
350386creditCardType :: CreditCardNumber -> Either CreditCardError CreditCardType
351−creditCardType n = case checkLuhnDigit n of
352− True -> case guessCreditCardType n of
387+creditCardType n
388+ | checkLuhnDigit n = case guessCreditCardType n of
353389 Nothing -> Left UnknownCardNumber
354390 Just t -> Right t
355− False -> Left InvalidCardNumber
391+ | otherwise = Left InvalidCardNumber
356392
357393isValidCCNumber :: CreditCardNumber -> Bool
358394isValidCCNumber = isRight . creditCardType
359395
360396guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
361−guessPANCardType = guessCreditCardType . panToBogusNumber
397+guessPANCardType = guessCreditCardType <=< panToBogusNumber
398+
399+#ifdef BACKEND
400+#ifdef USE_POSTGRES
401+deriving instance FromField CreditCardPAN
402+deriving instance ToField CreditCardPAN
403+instance ToField CreditCardType where
404+ toField cardType = toField $ case cardType of
405+ Visa -> "Visa"
406+ MasterCard -> "MasterCard"
407+ AmericanExpress-> "AmericanExpress"
408+ DiscoverCard -> "DiscoverCard"
409+ DinersClub -> "DinersClub"
410+ JCB -> "JCB"
411+ UnionPay -> "UnionPay" :: Text
412+
413+instance FromField CreditCardType where
414+ fromField f mbs = do
415+ txt <- fromField f mbs
416+ case T.unpack txt of
417+ "Visa" -> return Visa
418+ "MasterCard" -> return MasterCard
419+ "AmericanExpress"-> return AmericanExpress
420+ "DiscoverCard" -> return DiscoverCard
421+ "DinersClub" -> return DinersClub
422+ "JCB" -> return JCB
423+ "UnionPay" -> return UnionPay
424+ _ -> returnError ConversionFailed f ("Invalid credit card type: " ++ T.unpack txt)
425+#endif
426+#endif
427+
428+#ifdef BACKEND
429+instance ToSchema CreditCardDate where
430+ declareNamedSchema _ = declareNamedSchema (Proxy @Text)
431+
432+instance ToSchema CreditCardNumber where
433+ declareNamedSchema _ = declareNamedSchema (Proxy @Text)
434+
435+instance ToSchema CreditCard where
436+ declareNamedSchema = genericDeclareNamedSchema opts
437+ where
438+ opts = defaultSchemaOptions
439+ { OpenApi.fieldLabelModifier = defaultFieldLabelModifier }
440+
441+instance ToSchema CreditCardType where
442+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
443+#endif