@@ -0,0 +1,361 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DerivingStrategies #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE StandaloneDeriving #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+
7+module Data.CreditCard
8+ ( -- * Types
9+ CreditCardDate(..)
10+ , ccdYear
11+ , ccdMonth
12+ , cardExpirationDay
13+ , CreditCardNumber(..)
14+ , _CreditCardNumber
15+ , CreditCardPAN(..)
16+ , mkCreditCardPan
17+ , panTrailingDigits
18+ , CreditCardSecurity(..)
19+ , parseCreditCardSecurity
20+ , CreditCard(..)
21+ , ccNumber
22+ , ccHolderName
23+ , ccSecurity
24+ , ccExpirationDate
25+ , ccZipCode
26+ , ZipCode(..)
27+ , _ZipCode
28+ , CreditCardType(..)
29+ , _Visa
30+ , _MasterCard
31+ , _AmericanExpress
32+ , _DiscoverCard
33+ , _DinersClub
34+ , _JCB
35+ , CreditCardError(..)
36+ , _UnknownCardNumber
37+ , _InvalidCardNumber
38+ -- * functions
39+ , parseCardNumber
40+ , renderCardNumber
41+ , apiCreditCardNumber
42+ , formatExpiryDate
43+ , parseExpirationDate
44+ , creditCardType
45+ , guessCreditCardType
46+ , guessPANCardType
47+ , getLuhnDigit
48+ , checkLuhnDigit
49+ , isValidCCNumber
50+ ) where
51+
52+import Control.Lens hiding (elements)
53+
54+import Control.Monad (guard)
55+import Data.Aeson as Aeson
56+import Data.Aeson.Inflections (defaultFieldLabelModifier)
57+import Data.Aeson.Types (withText)
58+import Data.Char (isDigit)
59+import Data.Digit
60+import Data.Either (isRight)
61+import Data.Foldable as F
62+import Data.Ix
63+import Data.List as L
64+import Data.List.NonEmpty (NonEmpty)
65+import 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
71+import Data.Semigroup
72+import Data.Text (Text)
73+import qualified Data.Text as T
74+import Data.Time
75+#ifndef ghcjs_HOST_OS
76+import Database.PostgreSQL.Simple.FromField
77+import Database.PostgreSQL.Simple.ToField
78+#endif
79+import Formatting as F
80+import GHC.Generics (Generic)
81+import Numeric.Natural
82+import Test.QuickCheck.Arbitrary
83+import Test.QuickCheck.Gen
84+
85+
86+newtype ZipCode = ZipCode
87+ { unZipCode :: Text }
88+ deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema)
89+
90+makePrisms ''ZipCode
91+
92+data CreditCardDate = CreditCardDate
93+ { _ccdYear :: Int
94+ -- ^ Full year with century, e.g. 2000, 2017, 2020 ...
95+ , _ccdMonth :: Int
96+ -- ^ Month number in range [1..12]
97+ } deriving (Eq, Show, Generic)
98+
99+instance ToSchema CreditCardDate where
100+ declareNamedSchema _ = declareNamedSchema (Proxy @Text)
101+
102+makeLenses ''CreditCardDate
103+
104+formatExpiryDate :: 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)
110+
111+-- NOTE: This function is supposed to be called 'parseExpiryDate',
112+-- but we already have a function with the same name in b2b/api
113+-- that works slightly differently, i.e. it parses the date in
114+-- MM/YY format, not MMYY. Therefore _expiration_, not _expiry_ for now.
115+parseExpirationDate :: Text -> Maybe CreditCardDate
116+parseExpirationDate txt = do
117+ guard (T.length txt == 4)
118+ [monthTxt, yearTxt] <- case T.chunksOf 2 txt of
119+ [m,y] -> Just [m,y]
120+ _ -> Nothing
121+ month <- preview (_DigitsText . to digitsToNum) monthTxt
122+ guard (inRange (1,12) month)
123+ year <- (+2000) <$> preview (_DigitsText . to digitsToNum) yearTxt
124+ -- Look, I know this code might very well survive after 2100.
125+ -- But I'll probably be dead by then, so I don't care.
126+ guard (inRange (2000,2099) year)
127+ pure (CreditCardDate year month)
128+
129+instance FromJSON CreditCardDate where
130+ parseJSON = withText "CreditCardDate" $ \s ->
131+ case parseExpirationDate s of
132+ Just d -> pure d
133+ Nothing -> fail "Cannot parse Credit Card Date"
134+
135+instance ToJSON CreditCardDate where
136+ toJSON = toJSON . formatExpiryDate
137+
138+instance Arbitrary CreditCardDate where
139+ arbitrary = CreditCardDate <$> year <*> month
140+ where
141+ month = choose (1,12)
142+ year = choose (2000,2099)
143+
144+-- | Takes exact day when CC expires (the last day of expiration
145+-- month)
146+cardExpirationDay :: CreditCardDate -> Day
147+cardExpirationDay ccd = fromGregorian year month day
148+ where
149+ year = ccd ^. ccdYear . to fromIntegral
150+ month = ccd ^. ccdMonth
151+ day = gregorianMonthLength year month
152+
153+newtype CreditCardNumber = CreditCardNumber
154+ { unCreditCardNumber :: NonEmpty Digit }
155+ deriving (Eq, Generic)
156+
157+instance ToSchema CreditCardNumber where
158+ declareNamedSchema _ = declareNamedSchema (Proxy @Text)
159+
160+makePrisms ''CreditCardNumber
161+
162+renderCardNumber :: CreditCardNumber -> Text
163+renderCardNumber = view (_CreditCardNumber . re _DigitsText)
164+
165+parseCardNumber :: Text -> Maybe CreditCardNumber
166+parseCardNumber = preview (_DigitsText . from _CreditCardNumber)
167+
168+apiCreditCardNumber :: Prism' Text CreditCardNumber
169+apiCreditCardNumber = prism' renderCardNumber parseCardNumber
170+
171+instance FromJSON CreditCardNumber where
172+ parseJSON = withText "CreditCardNumber" $ \s ->
173+ case parseCardNumber s of
174+ Just c -> pure c
175+ Nothing -> fail "Cannot parse Credit Card Number"
176+
177+instance ToJSON CreditCardNumber where
178+ toJSON = toJSON . renderCardNumber
179+
180+-- | This instance specifically hides CC number replacing it with PAN.
181+-- For example, 1234567890123456 becomes 1234********3456.
182+instance Show CreditCardNumber where
183+ show = show . mkCreditCardPan
184+
185+instance Arbitrary CreditCardNumber where
186+ arbitrary = CreditCardNumber . NE.fromList <$> listOf1 arbitrary
187+
188+-- | Credit card with '*' character instead of digits except first and
189+-- last 4 digits. It is safe to store this in DB and in logs
190+newtype CreditCardPAN = CreditCardPAN
191+ { unCreditCardPAN :: Text
192+ } deriving (Eq, Ord)
193+ deriving newtype (Show)
194+
195+panTrailingDigits :: CreditCardPAN -> Text
196+panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt
197+
198+-- | Create a bogus card number from PAN.
199+-- This may not seem terribly useful on its own,
200+-- but this allows to reuse some functions working
201+-- 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")
210+
211+#ifndef ghcjs_HOST_OS
212+deriving instance FromField CreditCardPAN
213+deriving instance ToField CreditCardPAN
214+#endif
215+
216+mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
217+mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
218+ where
219+ ntext = renderCardNumber n
220+ firstDigits = T.take 4 ntext
221+ lastDigits = T.reverse $ T.take 4 $ T.reverse ntext
222+ stars = T.pack $ L.replicate (T.length ntext - 8) '*'
223+
224+newtype CreditCardSecurity = CreditCardSecurity
225+ { unCCSecurity :: Text }
226+ deriving (Eq, Ord, Generic)
227+ deriving newtype (ToJSON, FromJSON, ToSchema)
228+
229+instance Arbitrary CreditCardSecurity where
230+ arbitrary = CreditCardSecurity . T.pack . concatMap (show :: Int -> String)
231+ <$> sequence (replicate 3 (choose (0, 9)))
232+
233+-- | Show instance for 'CreditCardSecurity' doesn't actually show
234+-- anything. It replaces all characters with '*'.
235+instance Show CreditCardSecurity where
236+ show (CreditCardSecurity t) = show $ T.map (const '*') t
237+
238+makePrisms ''CreditCardSecurity
239+
240+-- | Parse and validate credit card security code.
241+-- The code must be a three-digit sequence.
242+parseCreditCardSecurity :: Text -> Maybe CreditCardSecurity
243+parseCreditCardSecurity txt
244+ | isValid = pure $ CreditCardSecurity txt
245+ | otherwise = Nothing
246+ where
247+ isValid = and
248+ [ T.length txt == 3
249+ , T.all isDigit txt ]
250+
251+data CreditCard = CreditCard
252+ { _ccNumber :: !(CreditCardNumber)
253+ , _ccHolderName :: !(Text)
254+ , _ccSecurity :: !(Maybe CreditCardSecurity)
255+ , _ccExpirationDate :: !(CreditCardDate)
256+ , _ccZipCode :: !(Maybe ZipCode)
257+ } 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 }
264+
265+instance FromJSON CreditCard where
266+ parseJSON =
267+ genericParseJSON defaultOptions
268+ { Aeson.fieldLabelModifier = defaultFieldLabelModifier }
269+instance ToJSON CreditCard where
270+ toJSON =
271+ genericToJSON defaultOptions
272+ { Aeson.fieldLabelModifier = defaultFieldLabelModifier }
273+
274+instance Arbitrary CreditCard where
275+ arbitrary =
276+ CreditCard <$> arbitrary <*> cardholder <*> security <*> arbitrary <*> zipc
277+ where
278+ cardholder = elements ["Mr Cardholder", "Mrs Cardholder"]
279+ security = elements [Nothing, pure $ CreditCardSecurity "1337"]
280+ zipc = elements [Nothing, pure $ ZipCode "12345"]
281+
282+makeLenses ''CreditCard
283+
284+data CreditCardType
285+ = Visa
286+ | MasterCard
287+ | AmericanExpress
288+ | DiscoverCard
289+ | DinersClub
290+ | JCB
291+ deriving (Eq, Show)
292+
293+makePrisms ''CreditCardType
294+
295+data CreditCardError
296+ = UnknownCardNumber
297+ | InvalidCardNumber
298+ deriving (Eq, Show)
299+
300+makePrisms ''CreditCardError
301+
302+getDigits :: Natural -> [Natural]
303+getDigits = F.toList . fmap digitToNum . unDigits . natToDigits
304+
305+-- | Calculate luhn checksum digit
306+getLuhnDigit :: [Digit] -> Digit
307+getLuhnDigit n = digitFromNumMod10 (total * 9)
308+ where
309+ total = sum $ L.map multEven $ L.zip [0..] $ L.reverse n
310+ multEven (i :: Int, digitToNum -> a)
311+ | even i = sum $ getDigits (a * 2)
312+ | otherwise = a
313+
314+-- | Checks luhn checksum of card number
315+checkLuhnDigit :: CreditCardNumber -> Bool
316+checkLuhnDigit (CreditCardNumber n) =
317+ NE.last n == getLuhnDigit (NE.init n)
318+
319+-- | Determines credit card by it's number
320+guessCreditCardType :: CreditCardNumber -> Maybe CreditCardType
321+guessCreditCardType n
322+ | isMasterCard = Just MasterCard
323+ | isAmEx = Just AmericanExpress
324+ | isDiscoverCard = Just DiscoverCard
325+ | isDinersClub = Just DinersClub
326+ | isJCB = Just JCB
327+ | isVisa = Just Visa -- NOTE: starts with just 4? realy?
328+ | otherwise = Nothing
329+ where
330+ isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])
331+ isMasterCard = (inRange (51, 55) (firstDigits 2)) && (digitsLength == 16)
332+ 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)
336+ && (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)
346+ digitsLength = L.length $ n ^. _CreditCardNumber
347+ firstDigits x = poly10 @Integer $ L.take x
348+ $ n ^.. _CreditCardNumber . folded . to digitToNum
349+
350+creditCardType :: CreditCardNumber -> Either CreditCardError CreditCardType
351+creditCardType n = case checkLuhnDigit n of
352+ True -> case guessCreditCardType n of
353+ Nothing -> Left UnknownCardNumber
354+ Just t -> Right t
355+ False -> Left InvalidCardNumber
356+
357+isValidCCNumber :: CreditCardNumber -> Bool
358+isValidCCNumber = isRight . creditCardType
359+
360+guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
361+guessPANCardType = guessCreditCardType . panToBogusNumber