@@ -0,0 +1,361 @@
2+{-# LANGUAGE DerivingStrategies #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE StandaloneDeriving #-}
5+{-# LANGUAGE TemplateHaskell #-}
13+ , CreditCardNumber(..)
18+ , CreditCardSecurity(..)
19+ , parseCreditCardSecurity
35+ , CreditCardError(..)
41+ , apiCreditCardNumber
43+ , parseExpirationDate
45+ , guessCreditCardType
52+import Control.Lens hiding (elements)
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)
60+import Data.Either (isRight)
61+import Data.Foldable as F
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)
72+import Data.Text (Text)
73+import qualified Data.Text as T
76+import Database.PostgreSQL.Simple.FromField
77+import Database.PostgreSQL.Simple.ToField
79+import Formatting as F
80+import GHC.Generics (Generic)
81+import Numeric.Natural
82+import Test.QuickCheck.Arbitrary
83+import Test.QuickCheck.Gen
86+newtype ZipCode = ZipCode
87+ { unZipCode :: Text }
88+ deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema)
92+data CreditCardDate = CreditCardDate
94+ -- ^ Full year with century, e.g. 2000, 2017, 2020 ...
96+ -- ^ Month number in range [1..12]
97+ } deriving (Eq, Show, Generic)
99+instance ToSchema CreditCardDate where
100+ declareNamedSchema _ = declareNamedSchema (Proxy @Text)
102+makeLenses ''CreditCardDate
104+formatExpiryDate :: CreditCardDate -> Text
105+formatExpiryDate ccd =
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)
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
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)
129+instance FromJSON CreditCardDate where
130+ parseJSON = withText "CreditCardDate" $ \s ->
131+ case parseExpirationDate s of
133+ Nothing -> fail "Cannot parse Credit Card Date"
135+instance ToJSON CreditCardDate where
136+ toJSON = toJSON . formatExpiryDate
138+instance Arbitrary CreditCardDate where
139+ arbitrary = CreditCardDate <$> year <*> month
141+ month = choose (1,12)
142+ year = choose (2000,2099)
144+-- | Takes exact day when CC expires (the last day of expiration
146+cardExpirationDay :: CreditCardDate -> Day
147+cardExpirationDay ccd = fromGregorian year month day
149+ year = ccd ^. ccdYear . to fromIntegral
150+ month = ccd ^. ccdMonth
151+ day = gregorianMonthLength year month
153+newtype CreditCardNumber = CreditCardNumber
154+ { unCreditCardNumber :: NonEmpty Digit }
155+ deriving (Eq, Generic)
157+instance ToSchema CreditCardNumber where
158+ declareNamedSchema _ = declareNamedSchema (Proxy @Text)
160+makePrisms ''CreditCardNumber
162+renderCardNumber :: CreditCardNumber -> Text
163+renderCardNumber = view (_CreditCardNumber . re _DigitsText)
165+parseCardNumber :: Text -> Maybe CreditCardNumber
166+parseCardNumber = preview (_DigitsText . from _CreditCardNumber)
168+apiCreditCardNumber :: Prism' Text CreditCardNumber
169+apiCreditCardNumber = prism' renderCardNumber parseCardNumber
171+instance FromJSON CreditCardNumber where
172+ parseJSON = withText "CreditCardNumber" $ \s ->
173+ case parseCardNumber s of
175+ Nothing -> fail "Cannot parse Credit Card Number"
177+instance ToJSON CreditCardNumber where
178+ toJSON = toJSON . renderCardNumber
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
185+instance Arbitrary CreditCardNumber where
186+ arbitrary = CreditCardNumber . NE.fromList <$> listOf1 arbitrary
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)
195+panTrailingDigits :: CreditCardPAN -> Text
196+panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt
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
202+panToBogusNumber :: CreditCardPAN -> CreditCardNumber
203+panToBogusNumber (CreditCardPAN txt) =
204+ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]
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")
211+#ifndef ghcjs_HOST_OS
212+deriving instance FromField CreditCardPAN
213+deriving instance ToField CreditCardPAN
216+mkCreditCardPan :: CreditCardNumber -> CreditCardPAN
217+mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits
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) '*'
224+newtype CreditCardSecurity = CreditCardSecurity
225+ { unCCSecurity :: Text }
226+ deriving (Eq, Ord, Generic)
227+ deriving newtype (ToJSON, FromJSON, ToSchema)
229+instance Arbitrary CreditCardSecurity where
230+ arbitrary = CreditCardSecurity . T.pack . concatMap (show :: Int -> String)
231+ <$> sequence (replicate 3 (choose (0, 9)))
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
238+makePrisms ''CreditCardSecurity
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
249+ , T.all isDigit txt ]
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)
259+instance ToSchema CreditCard where
260+ declareNamedSchema p = genericDeclareNamedSchema opts p
262+ opts = defaultSchemaOptions
263+ { OpenApi.fieldLabelModifier = defaultFieldLabelModifier }
265+instance FromJSON CreditCard where
267+ genericParseJSON defaultOptions
268+ { Aeson.fieldLabelModifier = defaultFieldLabelModifier }
269+instance ToJSON CreditCard where
271+ genericToJSON defaultOptions
272+ { Aeson.fieldLabelModifier = defaultFieldLabelModifier }
274+instance Arbitrary CreditCard where
276+ CreditCard <$> arbitrary <*> cardholder <*> security <*> arbitrary <*> zipc
278+ cardholder = elements ["Mr Cardholder", "Mrs Cardholder"]
279+ security = elements [Nothing, pure $ CreditCardSecurity "1337"]
280+ zipc = elements [Nothing, pure $ ZipCode "12345"]
282+makeLenses ''CreditCard
293+makePrisms ''CreditCardType
300+makePrisms ''CreditCardError
302+getDigits :: Natural -> [Natural]
303+getDigits = F.toList . fmap digitToNum . unDigits . natToDigits
305+-- | Calculate luhn checksum digit
306+getLuhnDigit :: [Digit] -> Digit
307+getLuhnDigit n = digitFromNumMod10 (total * 9)
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)
314+-- | Checks luhn checksum of card number
315+checkLuhnDigit :: CreditCardNumber -> Bool
316+checkLuhnDigit (CreditCardNumber n) =
317+ NE.last n == getLuhnDigit (NE.init n)
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
327+ | isVisa = Just Visa -- NOTE: starts with just 4? realy?
328+ | otherwise = Nothing
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)
334+ (firstDigits 4 == 6011 || inRange (644, 649) (firstDigits 3)
335+ || inRange (622126, 622925) (firstDigits 6) || firstDigits 2 == 65)
336+ && (digitsLength `elem` [16, 19])
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)
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
350+creditCardType :: CreditCardNumber -> Either CreditCardError CreditCardType
351+creditCardType n = case checkLuhnDigit n of
352+ True -> case guessCreditCardType n of
353+ Nothing -> Left UnknownCardNumber
355+ False -> Left InvalidCardNumber
357+isValidCCNumber :: CreditCardNumber -> Bool
358+isValidCCNumber = isRight . creditCardType
360+guessPANCardType :: CreditCardPAN -> Maybe CreditCardType
361+guessPANCardType = guessCreditCardType . panToBogusNumber