@@ -1,10 +1,8 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DerivingStrategies #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE StandaloneDeriving #-}
4−{-# LANGUAGE DerivingVia #-}
55{-# LANGUAGE TemplateHaskell #-}
6−{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
7−{-# HLINT ignore "Use ||" #-}
86
97module Data.CreditCard
108 ( -- * Types
@@ -54,10 +52,9 @@ module Data.CreditCard
5452
5553import Control.Lens hiding (elements)
5654
57−import Control.Monad (guard, (<=<), replicateM)
55+import Control.Monad (guard, (<=<))
5856import Data.Aeson as Aeson
5957import Data.Aeson.Inflections (defaultFieldLabelModifier)
60−import Data.Binary (Binary)
6158import Data.Char (isDigit)
6259import Data.Digit
6360import Data.Either (isRight)
@@ -66,20 +63,21 @@ import Data.Ix
6663import Data.List as L
6764import Data.List.NonEmpty (NonEmpty)
6865import qualified Data.List.NonEmpty as NE
66+import Data.OpenApi as OpenApi
67+ ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions
68+ , genericDeclareNamedSchema)
69+import Data.Proxy
6970import Data.Semigroup
7071import Data.Text (Text)
7172import qualified Data.Text as T
7273import Data.Time
73−#ifdef BACKEND
74−import Data.Proxy
75−import Data.OpenApi as OpenApi
76− ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions
77− , genericDeclareNamedSchema)
74+#ifndef ghcjs_HOST_OS
7875#ifdef USE_POSTGRES
7976import Database.PostgreSQL.Simple.FromField
8077import Database.PostgreSQL.Simple.ToField
8178#endif
8279#endif
80+import Formatting as F
8381import GHC.Generics (Generic)
8482import Numeric.Natural
8583import Test.QuickCheck.Arbitrary
@@ -93,11 +91,7 @@ import qualified Data.Store.Internal
9391newtype ZipCode = ZipCode
9492 { unZipCode :: Text }
9593 deriving stock (Show, Eq, Generic)
96−#ifdef BACKEND
9794 deriving newtype (ToJSON, FromJSON, ToSchema)
98−#else
99− deriving newtype (ToJSON, FromJSON)
100−#endif
10195#ifdef USE_STORE
10296 deriving anyclass Data.Store.Store
10397#endif
@@ -114,12 +108,17 @@ data CreditCardDate = CreditCardDate
114108 deriving anyclass Data.Store.Store
115109#endif
116110
111+instance ToSchema CreditCardDate where
112+ declareNamedSchema _ = declareNamedSchema (Proxy @Text)
113+
117114makeLenses ''CreditCardDate
118115
119116formatExpiryDate :: CreditCardDate -> Text
120−formatExpiryDate ccd = s2 (ccd ^. ccdMonth) <> s2 (ccd ^. ccdYear - 2000)
121− where
122− s2 = T.justifyRight 2 '0' . T.pack . show
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)
123122
124123-- NOTE: This function is supposed to be called 'parseExpiryDate',
125124-- but we already have a function with the same name in b2b/api
@@ -167,6 +166,10 @@ newtype CreditCardNumber = CreditCardNumber
167166 { unCreditCardNumber :: NonEmpty Digit }
168167 deriving (Eq, Generic)
169168
169+
170+instance ToSchema CreditCardNumber where
171+ declareNamedSchema _ = declareNamedSchema (Proxy @Text)
172+
170173makePrisms ''CreditCardNumber
171174
172175renderCardNumber :: CreditCardNumber -> Text
@@ -209,7 +212,7 @@ instance Arbitrary CreditCardNumber where
209212newtype CreditCardPAN = CreditCardPAN
210213 { unCreditCardPAN :: Text
211214 } deriving (Eq, Ord)
212− deriving newtype (Show, FromJSON, ToJSON)
215+ deriving newtype (Show)
213216
214217panTrailingDigits :: CreditCardPAN -> Text
215218panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt
@@ -225,6 +228,12 @@ panToBogusNumber (CreditCardPAN txt) = do
225228 let middle = NE.fromList $ replicate (T.length txt - 8) D0
226229 return $ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
227230
231+#ifndef ghcjs_HOST_OS
232+#ifdef USE_POSTGRES
233+deriving instance FromField CreditCardPAN
234+deriving instance ToField CreditCardPAN
235+#endif
236+#endif
228237
229238mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
230239mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
@@ -237,18 +246,14 @@ mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
237246newtype CreditCardSecurity = CreditCardSecurity
238247 { unCCSecurity :: Text }
239248 deriving (Eq, Ord, Generic)
240−#ifdef BACKEND
241249 deriving newtype (ToJSON, FromJSON, ToSchema)
242−#else
243− deriving newtype (ToJSON, FromJSON)
244−#endif
245250#ifdef USE_STORE
246251 deriving anyclass Data.Store.Store
247252#endif
248253
249254instance Arbitrary CreditCardSecurity where
250255 arbitrary = CreditCardSecurity . T.pack . concatMap (show :: Int -> String)
251− <$> replicateM 3 (choose (0, 9))
256+ <$> sequence (replicate 3 (choose (0, 9)))
252257
253258-- | Show instance for 'CreditCardSecurity' doesn't actually show
254259-- anything. It replaces all characters with '*'.
@@ -264,19 +269,27 @@ parseCreditCardSecurity txt
264269 | isValid = pure $ CreditCardSecurity txt
265270 | otherwise = Nothing
266271 where
267− isValid = (3, 4) `inRange` T.length txt && T.all isDigit txt
272+ isValid = and
273+ [ (3, 4) `inRange` T.length txt
274+ , T.all isDigit txt ]
268275
269276data CreditCard = CreditCard
270− { _ccNumber :: !CreditCardNumber
271− , _ccHolderName :: !Text
277+ { _ccNumber :: !(CreditCardNumber)
278+ , _ccHolderName :: !(Text)
272279 , _ccSecurity :: !(Maybe CreditCardSecurity)
273− , _ccExpirationDate :: !CreditCardDate
280+ , _ccExpirationDate :: !(CreditCardDate)
274281 , _ccZipCode :: !(Maybe ZipCode)
275282 } deriving (Eq, Generic, Show)
276283#ifdef USE_STORE
277284 deriving anyclass Data.Store.Store
278285#endif
279286
287+instance ToSchema CreditCard where
288+ declareNamedSchema p = genericDeclareNamedSchema opts p
289+ where
290+ opts = defaultSchemaOptions
291+ { OpenApi.fieldLabelModifier = defaultFieldLabelModifier }
292+
280293instance FromJSON CreditCard where
281294 parseJSON =
282295 genericParseJSON defaultOptions
@@ -304,23 +317,10 @@ data CreditCardType
304317 | DinersClub
305318 | JCB
306319 | UnionPay
307− deriving (Eq, Show, Generic, Enum, Bounded)
308−
309−instance Binary CreditCardType
320+ deriving (Eq, Show)
310321
311322makePrisms ''CreditCardType
312323
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.zipWith multEven [0..] $ L.reverse n
339− multEven (i :: Int) (digitToNum -> a)
338+ total = sum $ L.map multEven $ L.zip [0..] $ L.reverse n
339+ multEven (i :: Int, digitToNum -> a)
340340 | even i = sum $ getDigits (a * 2)
341341 | otherwise = a
342342
@@ -358,86 +358,35 @@ guessCreditCardType n
358358 | otherwise = Nothing
359359 where
360360 isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])
361− isMasterCard = or
362− [ inRange (51, 55) (firstDigits 2) && (digitsLength == 16)
363− , inRange (2221, 2720) (firstDigits 4) && (digitsLength == 16)]
361+ isMasterCard = (inRange (51, 55) (firstDigits 2)) && (digitsLength == 16)
364362 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)
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]
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)
371367 && (digitsLength `elem` [16, 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]
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)
382377 digitsLength = L.length $ n ^. _CreditCardNumber
383378 firstDigits x = poly10 @Integer $ L.take x
384379 $ n ^.. _CreditCardNumber . folded . to digitToNum
385380
386381creditCardType :: CreditCardNumber -> Either CreditCardError CreditCardType
387−creditCardType n
388− | checkLuhnDigit n = case guessCreditCardType n of
382+creditCardType n = case checkLuhnDigit n of
383+ True -> case guessCreditCardType n of
389384 Nothing -> Left UnknownCardNumber
390385 Just t -> Right t
391− | otherwise = Left InvalidCardNumber
386+ False -> Left InvalidCardNumber
392387
393388isValidCCNumber :: CreditCardNumber -> Bool
394389isValidCCNumber = isRight . creditCardType
395390
396391guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
397392guessPANCardType = 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