@@ -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
@@ -52,9 +54,10 @@ module Data.CreditCard
5254
5355import Control.Lens hiding (elements)
5456
55−import Control.Monad (guard, (<=<))
57+import Control.Monad (guard, (<=<), replicateM)
5658import Data.Aeson as Aeson
5759import Data.Aeson.Inflections (defaultFieldLabelModifier)
60+import Data.Binary (Binary)
5861import Data.Char (isDigit)
5962import Data.Digit
6063import Data.Either (isRight)
@@ -63,21 +66,20 @@ import Data.Ix
6366import Data.List as L
6467import Data.List.NonEmpty (NonEmpty)
6568import qualified Data.List.NonEmpty as NE
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)
7578#ifdef USE_POSTGRES
7679import Database.PostgreSQL.Simple.FromField
7780import Database.PostgreSQL.Simple.ToField
7881#endif
7982#endif
80−import Formatting as F
8183import GHC.Generics (Generic)
8284import Numeric.Natural
8385import Test.QuickCheck.Arbitrary
@@ -91,7 +93,11 @@ import qualified Data.Store.Internal
9193newtype ZipCode = ZipCode
9294 { unZipCode :: Text }
9395 deriving stock (Show, Eq, Generic)
96+#ifdef BACKEND
9497 deriving newtype (ToJSON, FromJSON, ToSchema)
98+#else
99+ deriving newtype (ToJSON, FromJSON)
100+#endif
95101#ifdef USE_STORE
96102 deriving anyclass Data.Store.Store
97103#endif
@@ -108,17 +114,12 @@ data CreditCardDate = CreditCardDate
108114 deriving anyclass Data.Store.Store
109115#endif
110116
111−instance ToSchema CreditCardDate where
112− declareNamedSchema _ = declareNamedSchema (Proxy @Text)
113−
114117makeLenses ''CreditCardDate
115118
116119formatExpiryDate :: CreditCardDate -> Text
117−formatExpiryDate ccd =
118− F.sformat
119− (F.left 2 '0' F.% F.left 2 '0')
120− (F.sformat F.int $ ccd ^. ccdMonth)
121− (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
122123
123124-- NOTE: This function is supposed to be called 'parseExpiryDate',
124125-- but we already have a function with the same name in b2b/api
@@ -166,10 +167,6 @@ newtype CreditCardNumber = CreditCardNumber
166167 { unCreditCardNumber :: NonEmpty Digit }
167168 deriving (Eq, Generic)
168169
169−
170−instance ToSchema CreditCardNumber where
171− declareNamedSchema _ = declareNamedSchema (Proxy @Text)
172−
173170makePrisms ''CreditCardNumber
174171
175172renderCardNumber :: CreditCardNumber -> Text
@@ -212,7 +209,7 @@ instance Arbitrary CreditCardNumber where
212209newtype CreditCardPAN = CreditCardPAN
213210 { unCreditCardPAN :: Text
214211 } deriving (Eq, Ord)
215− deriving newtype (Show)
212+ deriving newtype (Show, FromJSON, ToJSON)
216213
217214panTrailingDigits :: CreditCardPAN -> Text
218215panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt
@@ -228,12 +225,6 @@ panToBogusNumber (CreditCardPAN txt) = do
228225 let middle = NE.fromList $ replicate (T.length txt - 8) D0
229226 return $ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
230227
231−#ifndef ghcjs_HOST_OS
232−#ifdef USE_POSTGRES
233−deriving instance FromField CreditCardPAN
234−deriving instance ToField CreditCardPAN
235−#endif
236−#endif
237228
238229mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
239230mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
@@ -246,14 +237,18 @@ mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
246237newtype CreditCardSecurity = CreditCardSecurity
247238 { unCCSecurity :: Text }
248239 deriving (Eq, Ord, Generic)
240+#ifdef BACKEND
249241 deriving newtype (ToJSON, FromJSON, ToSchema)
242+#else
243+ deriving newtype (ToJSON, FromJSON)
244+#endif
250245#ifdef USE_STORE
251246 deriving anyclass Data.Store.Store
252247#endif
253248
254249instance Arbitrary CreditCardSecurity where
255250 arbitrary = CreditCardSecurity . T.pack . concatMap (show :: Int -> String)
256− <$> sequence (replicate 3 (choose (0, 9)))
251+ <$> replicateM 3 (choose (0, 9))
257252
258253-- | Show instance for 'CreditCardSecurity' doesn't actually show
259254-- anything. It replaces all characters with '*'.
@@ -269,27 +264,19 @@ parseCreditCardSecurity txt
269264 | isValid = pure $ CreditCardSecurity txt
270265 | otherwise = Nothing
271266 where
272− isValid = and
273− [ (3, 4) `inRange` T.length txt
274− , T.all isDigit txt ]
267+ isValid = (3, 4) `inRange` T.length txt && T.all isDigit txt
275268
276269data CreditCard = CreditCard
277− { _ccNumber :: !(CreditCardNumber)
278− , _ccHolderName :: !(Text)
270+ { _ccNumber :: !CreditCardNumber
271+ , _ccHolderName :: !Text
279272 , _ccSecurity :: !(Maybe CreditCardSecurity)
280− , _ccExpirationDate :: !(CreditCardDate)
273+ , _ccExpirationDate :: !CreditCardDate
281274 , _ccZipCode :: !(Maybe ZipCode)
282275 } deriving (Eq, Generic, Show)
283276#ifdef USE_STORE
284277 deriving anyclass Data.Store.Store
285278#endif
286279
287−instance ToSchema CreditCard where
288− declareNamedSchema p = genericDeclareNamedSchema opts p
289− where
290− opts = defaultSchemaOptions
291− { OpenApi.fieldLabelModifier = defaultFieldLabelModifier }
292−
293280instance FromJSON CreditCard where
294281 parseJSON =
295282 genericParseJSON defaultOptions
@@ -317,10 +304,23 @@ data CreditCardType
317304 | DinersClub
318305 | JCB
319306 | UnionPay
320− deriving (Eq, Show)
307+ deriving (Eq, Show, Generic, Enum, Bounded)
308+
309+instance Binary CreditCardType
321310
322311makePrisms ''CreditCardType
323312
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+
324324data CreditCardError
325325 = UnknownCardNumber
326326 | InvalidCardNumber
@@ -335,8 +335,8 @@ getDigits = F.toList . fmap digitToNum . unDigits . natToDigits
335335getLuhnDigit :: [Digit] -> Digit
336336getLuhnDigit n = digitFromNumMod10 (total * 9)
337337 where
338− total = sum $ L.map multEven $ L.zip [0..] $ L.reverse n
339− multEven (i :: Int, digitToNum -> a)
338+ total = sum $ L.zipWith multEven [0..] $ L.reverse n
339+ multEven (i :: Int) (digitToNum -> a)
340340 | even i = sum $ getDigits (a * 2)
341341 | otherwise = a
342342
@@ -358,35 +358,86 @@ guessCreditCardType n
358358 | otherwise = Nothing
359359 where
360360 isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])
361− 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)]
362364 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)
363− isUnionPay = (firstDigits 2 `elem` [60, 62]) && (digitsLength `elem` [16,17,18,19])
364− isDiscoverCard =
365− (firstDigits 4 == 6011 || inRange (644, 649) (firstDigits 3)
366− || 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]
367371 && (digitsLength `elem` [16, 19])
368− isDinersClub =
369− ((inRange (300, 305) (firstDigits 3) || firstDigits 3 == 309
370− || firstDigits 2 == 36 || inRange (38, 39) (firstDigits 2))
371− && digitsLength == 14)
372− || (firstDigits 2 `elem` [54, 55] && digitsLength == 16)
373− isJCB =
374− (inRange (3528, 3589) (firstDigits 4) && digitsLength `elem` [15, 16])
375− || (firstDigits 4 `elem` [1800, 2131] && digitsLength == 15)
376− || (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]
377382 digitsLength = L.length $ n ^. _CreditCardNumber
378383 firstDigits x = poly10 @Integer $ L.take x
379384 $ n ^.. _CreditCardNumber . folded . to digitToNum
380385
381386creditCardType :: CreditCardNumber -> Either CreditCardError CreditCardType
382−creditCardType n = case checkLuhnDigit n of
383− True -> case guessCreditCardType n of
387+creditCardType n
388+ | checkLuhnDigit n = case guessCreditCardType n of
384389 Nothing -> Left UnknownCardNumber
385390 Just t -> Right t
386− False -> Left InvalidCardNumber
391+ | otherwise = Left InvalidCardNumber
387392
388393isValidCCNumber :: CreditCardNumber -> Bool
389394isValidCCNumber = isRight . creditCardType
390395
391396guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
392397guessPANCardType = 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