b5ef718...master · typeable/credit-card

git.iko.soy/typeable/credit-card

on master help sign in

Setup.hsdeleted−2

since splitsnapshots

unifiedsplit

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

credit-card.cabal+15−3

@@ -23,15 +23,17 @@ library

23 , QuickCheck

24 , aeson

25 , aeson-inflections >= 0.1

26+ , binary

26 , digit

27 , digit

27− , formatting

28 , lens

29− , openapi3

30 , text

29 , text

31 , time

30 , time

32− if !impl(ghcjs) && flag(postgres)

31+ if !(impl(ghcjs) || arch(javascript) || arch(wasm32)) && flag(postgres)

33 build-depends: postgresql-simple

32 build-depends: postgresql-simple

34 cpp-options: -DUSE_POSTGRES

33 cpp-options: -DUSE_POSTGRES

34+ if !(impl(ghcjs) || arch(javascript) || arch(wasm32))

35+ build-depends: openapi3

36+ cpp-options: -DBACKEND

35 if flag(store)

37 if flag(store)

36 build-depends:

38 build-depends:

37 store

39 store

@@ -43,6 +45,11 @@ library

43 , ScopedTypeVariables

45 , ScopedTypeVariables

44 , TypeApplications

46 , TypeApplications

45 , ViewPatterns

47 , ViewPatterns

48+ ghc-options:

49+ -Wall

50+ if impl(ghc >= 8.10)

51+ ghc-options: -Wunused-packages

52+ -Wunused-packages

47test-suite spec

54test-suite spec

48 type: exitcode-stdio-1.0

55 type: exitcode-stdio-1.0

@@ -58,3 +65,8 @@ test-suite spec

58 other-modules: CreditCardSpec

65 other-modules: CreditCardSpec

59 default-extensions: ScopedTypeVariables

66 default-extensions: ScopedTypeVariables

60 , OverloadedStrings

67 , OverloadedStrings

68+ ghc-options:

69+ -Wall

70+ if impl(ghc >= 8.10)

71+ ghc-options: -Wunused-packages

72+ -Wunused-packages

src/Data/CreditCard.hs+111−60

@@ -1,8 +1,10 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DerivingStrategies #-}

3{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE StandaloneDeriving #-}

3{-# LANGUAGE StandaloneDeriving #-}

4+{-# LANGUAGE DerivingVia #-}

5{-# LANGUAGE TemplateHaskell #-}

6+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

7+{-# HLINT ignore "Use ||" #-}

7module Data.CreditCard

9module Data.CreditCard

8 ( -- * Types

10 ( -- * Types

@@ -52,9 +54,10 @@ module Data.CreditCard

53import Control.Lens hiding (elements)

55import Control.Lens hiding (elements)

55−import Control.Monad (guard, (<=<))

57+import Control.Monad (guard, (<=<), replicateM)

56import Data.Aeson as Aeson

58import Data.Aeson as Aeson

57import Data.Aeson.Inflections (defaultFieldLabelModifier)

59import Data.Aeson.Inflections (defaultFieldLabelModifier)

60+import Data.Binary (Binary)

58import Data.Char (isDigit)

61import Data.Char (isDigit)

59import Data.Digit

62import Data.Digit

60import Data.Either (isRight)

63import Data.Either (isRight)

@@ -63,21 +66,20 @@ import Data.Ix

63import Data.List as L

66import Data.List as L

64import Data.List.NonEmpty (NonEmpty)

67import Data.List.NonEmpty (NonEmpty)

65import qualified Data.List.NonEmpty as NE

68import qualified Data.List.NonEmpty as NE

66−import Data.OpenApi as OpenApi

67− ( ToSchema(..), SchemaOptions(..), defaultSchemaOptions

68− , genericDeclareNamedSchema)

69−import Data.Proxy

70import Data.Semigroup

69import Data.Semigroup

71import Data.Text (Text)

70import Data.Text (Text)

72import qualified Data.Text as T

71import qualified Data.Text as T

73import Data.Time

72import 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)

75#ifdef USE_POSTGRES

78#ifdef USE_POSTGRES

76import Database.PostgreSQL.Simple.FromField

79import Database.PostgreSQL.Simple.FromField

77import Database.PostgreSQL.Simple.ToField

80import Database.PostgreSQL.Simple.ToField

78#endif

81#endif

79#endif

82#endif

80−import Formatting as F

81import GHC.Generics (Generic)

83import GHC.Generics (Generic)

82import Numeric.Natural

84import Numeric.Natural

83import Test.QuickCheck.Arbitrary

85import Test.QuickCheck.Arbitrary

@@ -91,7 +93,11 @@ import qualified Data.Store.Internal

91newtype ZipCode = ZipCode

93newtype ZipCode = ZipCode

92 { unZipCode :: Text }

94 { unZipCode :: Text }

93 deriving stock (Show, Eq, Generic)

95 deriving stock (Show, Eq, Generic)

96+#ifdef BACKEND

94 deriving newtype (ToJSON, FromJSON, ToSchema)

97 deriving newtype (ToJSON, FromJSON, ToSchema)

98+#else

99+ deriving newtype (ToJSON, FromJSON)

100+#endif

95#ifdef USE_STORE

101#ifdef USE_STORE

96 deriving anyclass Data.Store.Store

102 deriving anyclass Data.Store.Store

97#endif

103#endif

@@ -108,17 +114,12 @@ data CreditCardDate = CreditCardDate

108 deriving anyclass Data.Store.Store

114 deriving anyclass Data.Store.Store

109#endif

115#endif

110

116

111−instance ToSchema CreditCardDate where

112− declareNamedSchema _ = declareNamedSchema (Proxy @Text)

113−

114makeLenses ''CreditCardDate

117makeLenses ''CreditCardDate

115

118

116formatExpiryDate :: CreditCardDate -> Text

119formatExpiryDate :: CreditCardDate -> Text

117−formatExpiryDate ccd =

120+formatExpiryDate ccd = s2 (ccd ^. ccdMonth) <> s2 (ccd ^. ccdYear - 2000)

118− F.sformat

121+ where

119− (F.left 2 '0' F.% F.left 2 '0')

122+ s2 = T.justifyRight 2 '0' . T.pack . show

120− (F.sformat F.int $ ccd ^. ccdMonth)

121− (F.sformat F.int $ ccd ^. ccdYear - 2000)

122

123

123-- NOTE: This function is supposed to be called 'parseExpiryDate',

124-- NOTE: This function is supposed to be called 'parseExpiryDate',

124-- but we already have a function with the same name in b2b/api

125-- but we already have a function with the same name in b2b/api

@@ -166,10 +167,6 @@ newtype CreditCardNumber = CreditCardNumber

166 { unCreditCardNumber :: NonEmpty Digit }

167 { unCreditCardNumber :: NonEmpty Digit }

167 deriving (Eq, Generic)

168 deriving (Eq, Generic)

168

169

169−

170−instance ToSchema CreditCardNumber where

171− declareNamedSchema _ = declareNamedSchema (Proxy @Text)

172−

173makePrisms ''CreditCardNumber

170makePrisms ''CreditCardNumber

174

171

175renderCardNumber :: CreditCardNumber -> Text

172renderCardNumber :: CreditCardNumber -> Text

@@ -212,7 +209,7 @@ instance Arbitrary CreditCardNumber where

212newtype CreditCardPAN = CreditCardPAN

209newtype CreditCardPAN = CreditCardPAN

213 { unCreditCardPAN :: Text

210 { unCreditCardPAN :: Text

214 } deriving (Eq, Ord)

211 } deriving (Eq, Ord)

215− deriving newtype (Show)

212+ deriving newtype (Show, FromJSON, ToJSON)

216

213

217panTrailingDigits :: CreditCardPAN -> Text

214panTrailingDigits :: CreditCardPAN -> Text

218panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt

215panTrailingDigits (CreditCardPAN txt) = T.takeEnd 4 txt

@@ -228,12 +225,6 @@ panToBogusNumber (CreditCardPAN txt) = do

228 let middle = NE.fromList $ replicate (T.length txt - 8) D0

225 let middle = NE.fromList $ replicate (T.length txt - 8) D0

229 return $ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]

226 return $ CreditCardNumber $ sconcat $ NE.fromList [leading, middle, trailing]

230

227

231−#ifndef ghcjs_HOST_OS

232−#ifdef USE_POSTGRES

233−deriving instance FromField CreditCardPAN

234−deriving instance ToField CreditCardPAN

235−#endif

236−#endif

237

228

238mkCreditCardPan :: CreditCardNumber -> CreditCardPAN

229mkCreditCardPan :: CreditCardNumber -> CreditCardPAN

239mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits

230mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits

@@ -246,14 +237,18 @@ mkCreditCardPan n = CreditCardPAN $ firstDigits <> stars <> lastDigits

246newtype CreditCardSecurity = CreditCardSecurity

237newtype CreditCardSecurity = CreditCardSecurity

247 { unCCSecurity :: Text }

238 { unCCSecurity :: Text }

248 deriving (Eq, Ord, Generic)

239 deriving (Eq, Ord, Generic)

240+#ifdef BACKEND

249 deriving newtype (ToJSON, FromJSON, ToSchema)

241 deriving newtype (ToJSON, FromJSON, ToSchema)

242+#else

243+ deriving newtype (ToJSON, FromJSON)

244+#endif

250#ifdef USE_STORE

245#ifdef USE_STORE

251 deriving anyclass Data.Store.Store

246 deriving anyclass Data.Store.Store

252#endif

247#endif

253

248

254instance Arbitrary CreditCardSecurity where

249instance Arbitrary CreditCardSecurity where

255 arbitrary = CreditCardSecurity . T.pack . concatMap (show :: Int -> String)

250 arbitrary = CreditCardSecurity . T.pack . concatMap (show :: Int -> String)

256− <$> sequence (replicate 3 (choose (0, 9)))

251+ <$> replicateM 3 (choose (0, 9))

257

252

258-- | Show instance for 'CreditCardSecurity' doesn't actually show

253-- | Show instance for 'CreditCardSecurity' doesn't actually show

259-- anything. It replaces all characters with '*'.

254-- anything. It replaces all characters with '*'.

@@ -269,27 +264,19 @@ parseCreditCardSecurity txt

269 | isValid = pure $ CreditCardSecurity txt

264 | isValid = pure $ CreditCardSecurity txt

270 | otherwise = Nothing

265 | otherwise = Nothing

271 where

266 where

272− isValid = and

273− [ (3, 4) `inRange` T.length txt

267+ isValid = (3, 4) `inRange` T.length txt && T.all isDigit txt

274− , T.all isDigit txt ]

275

268

276data CreditCard = CreditCard

269data CreditCard = CreditCard

277− { _ccNumber :: !(CreditCardNumber)

270+ { _ccNumber :: !CreditCardNumber

278− , _ccHolderName :: !(Text)

271+ , _ccHolderName :: !Text

279 , _ccSecurity :: !(Maybe CreditCardSecurity)

272 , _ccSecurity :: !(Maybe CreditCardSecurity)

280− , _ccExpirationDate :: !(CreditCardDate)

273+ , _ccExpirationDate :: !CreditCardDate

281 , _ccZipCode :: !(Maybe ZipCode)

274 , _ccZipCode :: !(Maybe ZipCode)

282 } deriving (Eq, Generic, Show)

275 } deriving (Eq, Generic, Show)

283#ifdef USE_STORE

276#ifdef USE_STORE

284 deriving anyclass Data.Store.Store

277 deriving anyclass Data.Store.Store

285#endif

278#endif

286

279

287−instance ToSchema CreditCard where

288− declareNamedSchema p = genericDeclareNamedSchema opts p

289− where

290− opts = defaultSchemaOptions

291− { OpenApi.fieldLabelModifier = defaultFieldLabelModifier }

292−

293instance FromJSON CreditCard where

280instance FromJSON CreditCard where

294 parseJSON =

281 parseJSON =

295 genericParseJSON defaultOptions

282 genericParseJSON defaultOptions

@@ -317,10 +304,23 @@ data CreditCardType

317 | DinersClub

304 | DinersClub

318 | JCB

305 | JCB

319 | UnionPay

306 | UnionPay

320− deriving (Eq, Show)

307+ deriving (Eq, Show, Generic, Enum, Bounded)

308+

309+instance Binary CreditCardType

321

310

322makePrisms ''CreditCardType

311makePrisms ''CreditCardType

323

312

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+

324data CreditCardError

325 = UnknownCardNumber

326 | InvalidCardNumber

@@ -335,8 +335,8 @@ getDigits = F.toList . fmap digitToNum . unDigits . natToDigits

335getLuhnDigit :: [Digit] -> Digit

336getLuhnDigit n = digitFromNumMod10 (total * 9)

337 where

338− total = sum $ L.map multEven $ L.zip [0..] $ L.reverse n

338+ total = sum $ L.zipWith multEven [0..] $ L.reverse n

339− multEven (i :: Int, digitToNum -> a)

339+ multEven (i :: Int) (digitToNum -> a)

340 | even i = sum $ getDigits (a * 2)

341 | otherwise = a

342

@@ -358,35 +358,86 @@ guessCreditCardType n

358 | otherwise = Nothing

359 where

360 isVisa = (4 == firstDigits 1) && (digitsLength `elem` [13,16,19])

361+ isMasterCard = or

361− isMasterCard = (inRange (51, 55) (firstDigits 2)) && (digitsLength == 16)

362+ [ inRange (51, 55) (firstDigits 2) && (digitsLength == 16)

363+ , inRange (2221, 2720) (firstDigits 4) && (digitsLength == 16)]

362 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)

364 isAmEx = (firstDigits 2 `elem` [34, 37]) && (digitsLength == 15)

363− isUnionPay = (firstDigits 2 `elem` [60, 62]) && (digitsLength `elem` [16,17,18,19])

365+ isUnionPay = (firstDigits 2 == 62) && (digitsLength `elem` [16,17,18,19])

364− isDiscoverCard =

366+ isDiscoverCard = or

367+ [ firstDigits 4 == 6011

365− (firstDigits 4 == 6011 || inRange (644, 649) (firstDigits 3)

368+ , inRange (644, 649) (firstDigits 3)

366− || inRange (622126, 622925) (firstDigits 6) || firstDigits 2 == 65)

369+ , inRange (622126, 622925) (firstDigits 6)

370+ , firstDigits 2 == 65]

367 && (digitsLength `elem` [16, 19])

371 && (digitsLength `elem` [16, 19])

368− isDinersClub =

372+ isDinersClub = or

369− ((inRange (300, 305) (firstDigits 3) || firstDigits 3 == 309

373+ [ inRange (300, 305) (firstDigits 3) && digitsLength == 14

374+ , firstDigits 3 == 309 && digitsLength == 14

375+ , firstDigits 2 == 36 && digitsLength == 14

370− || firstDigits 2 == 36 || inRange (38, 39) (firstDigits 2))

376+ , inRange (38, 39) (firstDigits 2) && digitsLength == 14

371− && digitsLength == 14)

372− || (firstDigits 2 `elem` [54, 55] && digitsLength == 16)

377+ , firstDigits 2 `elem` [54, 55] && digitsLength == 16]

373− isJCB =

378+ isJCB = or

374− (inRange (3528, 3589) (firstDigits 4) && digitsLength `elem` [15, 16])

379+ [ inRange (3528, 3589) (firstDigits 4) && digitsLength `elem` [15, 16]

375− || (firstDigits 4 `elem` [1800, 2131] && digitsLength == 15)

380+ , firstDigits 4 `elem` [1800, 2131] && digitsLength == 15

376− || (firstDigits 6 == 357266 && digitsLength == 19)

381+ , firstDigits 6 == 357266 && digitsLength == 19]

377 digitsLength = L.length $ n ^. _CreditCardNumber

382 digitsLength = L.length $ n ^. _CreditCardNumber

378 firstDigits x = poly10 @Integer $ L.take x

383 firstDigits x = poly10 @Integer $ L.take x

379 $ n ^.. _CreditCardNumber . folded . to digitToNum

384 $ n ^.. _CreditCardNumber . folded . to digitToNum

380

385

381creditCardType :: CreditCardNumber -> Either CreditCardError CreditCardType

386creditCardType :: CreditCardNumber -> Either CreditCardError CreditCardType

382−creditCardType n = case checkLuhnDigit n of

387+creditCardType n

383− True -> case guessCreditCardType n of

388+ | checkLuhnDigit n = case guessCreditCardType n of

384 Nothing -> Left UnknownCardNumber

389 Nothing -> Left UnknownCardNumber

385 Just t -> Right t

390 Just t -> Right t

386− False -> Left InvalidCardNumber

391+ | otherwise = Left InvalidCardNumber

387

392

388isValidCCNumber :: CreditCardNumber -> Bool

393isValidCCNumber :: CreditCardNumber -> Bool

389isValidCCNumber = isRight . creditCardType

394isValidCCNumber = isRight . creditCardType

390

395

391guessPANCardType :: CreditCardPAN -> Maybe CreditCardType

396guessPANCardType :: CreditCardPAN -> Maybe CreditCardType

392guessPANCardType = guessCreditCardType <=< panToBogusNumber

397guessPANCardType = 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

stack.yamldeleted−37

@@ -1,37 +0,0 @@

1−resolver: lts-19.0

2−

3−packages:

4−- .

5−extra-deps:

6−- git: https://github.com/typeable/aeson-inflections

7− commit: 66ac49cc1e468f36bf9d6c78b73bdabcfca0855d

8−- git: https://github.com/typeable/digit.git

9− commit: e03f087c90c9228a9ae52a0e516eba22589eef94

10−- git: https://github.com/typeable/missing-lens.git

11− commit: 328659fdda8fd7ec509abfab6298775062fc2926

12−nix:

13− packages: [postgresql_14]

14−

15−# Override default flag values for local packages and extra-deps

16−# flags: {}

17−

18−# Extra package databases containing global packages

19−# extra-package-dbs: []

20−

21−# Control whether we use the GHC we find on the path

22−# system-ghc: true

23−#

24−# Require a specific version of stack, using version ranges

25−# require-stack-version: -any # Default

26−# require-stack-version: ">=2.7"

27−#

28−# Override the architecture used by stack, especially useful on Windows

29−# arch: i386

30−# arch: x86_64

31−#

32−# Extra directories used by stack for building

33−# extra-include-dirs: [/path/to/dir]

34−# extra-lib-dirs: [/path/to/dir]

35−#

36−# Allow a newer minor version of GHC than the snapshot specifies

37−# compiler-check: newer-minor