@@ -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,9 +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)
60+import Data.Binary (Binary)
5761import Data.Char (isDigit)
5862import Data.Digit
5963import Data.Either (isRight)
@@ -62,29 +66,41 @@ import Data.Ix
6266import Data.List as L
6367import Data.List.NonEmpty (NonEmpty)
6468import qualified Data.List.NonEmpty as NE
65−import Data.Maybe (fromMaybe)
66−import Data.OpenApi as OpenApi
67− ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions
68− , genericDeclareNamedSchema)
69−import Data.Proxy
7069import Data.Semigroup
7170import Data.Text (Text)
7271import qualified Data.Text as T
7372import Data.Time
74−#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
7579import Database.PostgreSQL.Simple.FromField
7680import Database.PostgreSQL.Simple.ToField
7781#endif
78−import Formatting as F
82+#endif
7983import GHC.Generics (Generic)
8084import Numeric.Natural
8185import Test.QuickCheck.Arbitrary
8286import Test.QuickCheck.Gen
87+#ifdef USE_STORE
88+import qualified Data.Store
89+import qualified Data.Store.Internal
90+#endif
8391
8492
8593newtype ZipCode = ZipCode
8694 { unZipCode :: Text }
87− 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
88104
89105makePrisms ''ZipCode
90106
@@ -94,18 +110,16 @@ data CreditCardDate = CreditCardDate
94110 , _ccdMonth :: Int
95111 -- ^ Month number in range [1..12]
96112 } deriving (Eq, Show, Generic)
97−
98−instance ToSchema CreditCardDate where
99− declareNamedSchema _ = declareNamedSchema (Proxy @Text)
113+#ifdef USE_STORE
114+ deriving anyclass Data.Store.Store
115+#endif
100116
101117makeLenses ''CreditCardDate
102118
103119formatExpiryDate :: CreditCardDate -> Text
104−formatExpiryDate ccd =
105− F.sformat
106− (F.left 2 '0' F.% F.left 2 '0')
107− (F.sformat F.int $ ccd ^. ccdMonth)
108− (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
109123
110124-- NOTE: This function is supposed to be called 'parseExpiryDate',
111125-- but we already have a function with the same name in b2b/api
@@ -153,9 +167,6 @@ newtype CreditCardNumber = CreditCardNumber
153167 { unCreditCardNumber :: NonEmpty Digit }
154168 deriving (Eq, Generic)
155169
156−instance ToSchema CreditCardNumber where
157− declareNamedSchema _ = declareNamedSchema (Proxy @Text)
158−
159170makePrisms ''CreditCardNumber
160171
161172renderCardNumber :: CreditCardNumber -> Text
@@ -167,6 +178,15 @@ parseCardNumber = preview (_DigitsText . from _CreditCardNumber)
167178apiCreditCardNumber :: Prism' Text CreditCardNumber
168179apiCreditCardNumber = prism' renderCardNumber parseCardNumber
169180
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+
170190instance FromJSON CreditCardNumber where
171191 parseJSON = withText "CreditCardNumber" $ \s ->
172192 case parseCardNumber s of
@@ -189,7 +209,7 @@ instance Arbitrary CreditCardNumber where
189209newtype CreditCardPAN = CreditCardPAN
190210 { unCreditCardPAN :: Text
191211 } deriving (Eq, Ord)
192− deriving newtype (Show)
212+ deriving newtype (Show, FromJSON, ToJSON)
193213
194214panTrailingDigits :: CreditCardPAN -> Text
195215panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt
@@ -198,19 +218,13 @@ panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt
198218-- This may not seem terribly useful on its own,
199219-- but this allows to reuse some functions working
200220-- with CC numbers.
201−panToBogusNumber :: CreditCardPAN -> CreditCardNumber
202−panToBogusNumber (CreditCardPAN txt) =
203− CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
204− where
205− leading = check $ preview _DigitsText $ T.take 4 txt
206− middle = NE.fromList $ replicate (T.length txt - 8) D0
207− trailing = check $ preview _DigitsText $ T.takeEnd 4 txt
208− 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]
209227
210−#ifndef ghcjs_HOST_OS
211−deriving instance FromField CreditCardPAN
212−deriving instance ToField CreditCardPAN
213−#endif
214228
215229mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
216230mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
@@ -223,11 +237,18 @@ mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
223237newtype CreditCardSecurity = CreditCardSecurity
224238 { unCCSecurity :: Text }
225239 deriving (Eq, Ord, Generic)
240+#ifdef BACKEND
226241 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
227248
228249instance Arbitrary CreditCardSecurity where
229250 arbitrary = CreditCardSecurity . T.pack . concatMap (show :: Int -> String)
230− <$> sequence (replicate 3 (choose (0, 9)))
251+ <$> replicateM 3 (choose (0, 9))
231252
232253-- | Show instance for 'CreditCardSecurity' doesn't actually show
233254-- anything. It replaces all characters with '*'.
@@ -243,23 +264,18 @@ parseCreditCardSecurity txt
243264 | isValid = pure $ CreditCardSecurity txt
244265 | otherwise = Nothing
245266 where
246− isValid = and
247− [ (3, 4) `inRange` T.length txt
248− , T.all isDigit txt ]
267+ isValid = (3, 4) `inRange` T.length txt && T.all isDigit txt
249268
250269data CreditCard = CreditCard
251− { _ccNumber :: !(CreditCardNumber)
252− , _ccHolderName :: !(Text)
270+ { _ccNumber :: !CreditCardNumber
271+ , _ccHolderName :: !Text
253272 , _ccSecurity :: !(Maybe CreditCardSecurity)
254− , _ccExpirationDate :: !(CreditCardDate)
273+ , _ccExpirationDate :: !CreditCardDate
255274 , _ccZipCode :: !(Maybe ZipCode)
256275 } deriving (Eq, Generic, Show)
257−
258−instance ToSchema CreditCard where
259− declareNamedSchema p = genericDeclareNamedSchema opts p
260− where
261− opts = defaultSchemaOptions
262− { OpenApi.fieldLabelModifier = defaultFieldLabelModifier }
276+#ifdef USE_STORE
277+ deriving anyclass Data.Store.Store
278+#endif
263279
264280instance FromJSON CreditCard where
265281 parseJSON =
@@ -287,10 +303,24 @@ data CreditCardType
287303 | DiscoverCard
288304 | DinersClub
289305 | JCB
290− deriving (Eq, Show)
306+ | UnionPay
307+ deriving (Eq, Show, Generic, Enum, Bounded)
308+
309+instance Binary CreditCardType
291310
292311makePrisms ''CreditCardType
293312
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+
294324data CreditCardError
295325 = UnknownCardNumber
296326 | InvalidCardNumber
@@ -305,8 +335,8 @@ getDigits = F.toList . fmap digitToNum . unDigits . natToDigits
305335getLuhnDigit :: [Digit] -> Digit
306336getLuhnDigit n = digitFromNumMod10 (total * 9)
307337 where
308− total = sum $ L.map multEven $ L.zip [0..] $ L.reverse n
309− multEven (i :: Int, digitToNum -> a)
338+ total = sum $ L.zipWith multEven [0..] $ L.reverse n
339+ multEven (i :: Int) (digitToNum -> a)
310340 | even i = sum $ getDigits (a * 2)
311341 | otherwise = a
312342
@@ -324,37 +354,90 @@ guessCreditCardType n
324354 | isDinersClub = Just DinersClub
325355 | isJCB = Just JCB
326356 | isVisa = Just Visa -- NOTE: starts with just 4? realy?
357+ | isUnionPay = Just UnionPay
327358 | otherwise = Nothing
328359 where
329360 isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])
330− 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)]
331364 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)
332− isDiscoverCard =
333− (firstDigits 4 == 6011 || inRange (644, 649) (firstDigits 3)
334− || 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]
335371 && (digitsLength `elem` [16, 19])
336− isDinersClub =
337− ((inRange (300, 305) (firstDigits 3) || firstDigits 3 == 309
338− || firstDigits 2 == 36 || inRange (38, 39) (firstDigits 2))
339− && digitsLength == 14)
340− || (firstDigits 2 `elem` [54, 55] && digitsLength == 16)
341− isJCB =
342− (inRange (3528, 3589) (firstDigits 4) && digitsLength `elem` [15, 16])
343− || (firstDigits 4 `elem` [1800, 2131] && digitsLength == 15)
344− || (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]
345382 digitsLength = L.length $ n ^. _CreditCardNumber
346383 firstDigits x = poly10 @Integer $ L.take x
347384 $ n ^.. _CreditCardNumber . folded . to digitToNum
348385
349386creditCardType :: CreditCardNumber -> Either CreditCardError CreditCardType
350−creditCardType n = case checkLuhnDigit n of
351− True -> case guessCreditCardType n of
387+creditCardType n
388+ | checkLuhnDigit n = case guessCreditCardType n of
352389 Nothing -> Left UnknownCardNumber
353390 Just t -> Right t
354− False -> Left InvalidCardNumber
391+ | otherwise = Left InvalidCardNumber
355392
356393isValidCCNumber :: CreditCardNumber -> Bool
357394isValidCCNumber = isRight . creditCardType
358395
359396guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
360−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