mangopay 1.2 → 1.3

raw patch · 9 files changed

+72/−67 lines, 9 files

Files

• mangopay.cabal +1/−1
• src/Web/MangoPay.hs +1/−2
• src/Web/MangoPay/Cards.hs +7/−53
• src/Web/MangoPay/Monad.hs +2/−0
• test/Web/MangoPay/CardsTest.hs +1/−1
• test/Web/MangoPay/PayinsTest.hs +2/−2
• test/Web/MangoPay/RefundsTest.hs +3/−3
• test/Web/MangoPay/TestUtils.hs +54/−4
• test/Web/MangoPay/WalletsTest.hs +1/−1

@@ -1,5 +1,5 @@ name:           mangopay-version:        1.2+version:        1.3 cabal-version:  >= 1.8 build-type:     Simple author:         JP Moresmau <jpmoresmau@gmail.com>

@@ -15,6 +15,7 @@         ,Pagination(..)         ,PagedList(..)         ,MPUsableMonad+        ,ToHtQuery(..)                  -- access         ,createCredentialsSecret@@ -120,8 +121,6 @@         ,CardValidity(..)         ,mkCardRegistration         ,storeCardRegistration-        ,registerCard-        ,fullRegistration         ,fetchCard         ,listCards         

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, PatternGuards, ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables,OverloadedStrings, FlexibleContexts, FlexibleInstances,ConstraintKinds #-} -- | handle cards module Web.MangoPay.Cards where @@ -7,38 +7,19 @@ import Web.MangoPay.Types import Web.MangoPay.Users -import Data.Conduit import Data.Text import Data.Typeable (Typeable) import Data.Aeson-import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)+import Data.Time.Clock.POSIX (POSIXTime) import Control.Applicative import qualified Network.HTTP.Types as HT -import qualified Network.HTTP.Conduit as H-import Control.Monad.IO.Class (liftIO)-import qualified Data.Conduit.List as EL (consume)-import qualified Data.Text.Encoding as TE-import qualified Data.ByteString as BS- import qualified Data.HashMap.Lazy as HM-import Control.Exception.Base (throw)  -- | card registration ID type CardRegistrationID=Text --- | perform the full registration of a card-fullRegistration :: (MPUsableMonad m) => AnyUserID -> Currency -> CardInfo -> AccessToken -> MangoPayT m CardRegistration-fullRegistration uid currency cardInfo at=do-  -- create registration-  let cr1=mkCardRegistration uid currency-  cr2<-storeCardRegistration cr1 at-  -- register it-  cr3<-registerCard cardInfo cr2-  -- save registered version-  storeCardRegistration cr3 at-  -+  -- | create or edit a card registration storeCardRegistration ::  (MPUsableMonad m) => CardRegistration -> AccessToken -> MangoPayT m CardRegistration storeCardRegistration cr at= @@ -58,35 +39,7 @@   ,ciCSC :: Text   } deriving (Show,Read,Eq,Ord,Typeable) --- | register a card with the registration URL-registerCard :: (MPUsableMonad m) => CardInfo -> CardRegistration -> MangoPayT m CardRegistration-registerCard ci cr |-  Just url <- crCardRegistrationURL cr,-  Just pre <- crPreregistrationData cr,-  Just ak <- crAccessKey cr=do-    req <-liftIO $ H.parseUrl $ unpack url  -    mgr<-getManager-    let b=HT.renderQuery False $ HT.toQuery [-            "accessKeyRef" ?+ ak-            ,"data" ?+ pre-            ,"cardNumber" ?+ ciNumber ci-            ,"cardExpirationDate" ?+ ciExpire ci-            ,"cardCvx" ?+ ciCSC ci]-    let req'=req {H.method=HT.methodPost-         , H.requestHeaders=[("content-type","application/x-www-form-urlencoded")]-         , H.requestBody=H.RequestBodyBS b}             -    res<- H.http req' mgr-    reg <- H.responseBody res $$+- EL.consume-    let t=TE.decodeUtf8 $ BS.concat reg-    if "data=" `isPrefixOf` t -      then return cr{crRegistrationData=Just t}-      else do-        pt<-liftIO getPOSIXTime-        throw $ MpAppException $ MpError "" "RegistrationError" t $ Just pt            -registerCard _ _=do-  pt<-liftIO getPOSIXTime-  throw $ MpAppException $ MpError "" "IllegalState" "CardRegistration not ready" $ Just pt            -                + -- | helper function to create a new card registration mkCardRegistration :: AnyUserID -> Currency -> CardRegistration mkCardRegistration uid currency=CardRegistration Nothing Nothing Nothing uid currency Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing@@ -112,7 +65,8 @@  -- | to json as per MangoPay format         instance ToJSON CardRegistration where-        toJSON cr=object ["Tag" .= crTag cr,"UserId" .= crUserId cr+        toJSON cr=object ["Id".= crId cr -- ^ we store the ID, because in the registration workflow we may need to hang on to the registration object for a while, so let's use JSON serialization to keep it!+          , "Tag" .= crTag cr,"UserId" .= crUserId cr           ,"Currency" .= crCurrency cr,"RegistrationData" .= crRegistrationData cr           ,"CardRegistrationURL" .= crCardRegistrationURL cr] @@ -120,7 +74,7 @@ instance FromJSON CardRegistration where         parseJSON (Object v) =CardRegistration <$>                          v .: "Id" <*>-                         v .: "CreationDate" <*>+                         v .:? "CreationDate" <*>                          v .:? "Tag" <*>                          v .: "UserId" <*>                          v .: "Currency" <*>

@@ -41,6 +41,8 @@ import Data.Conduit.Binary (sinkHandle) import System.IO (stdout) import Data.Conduit.Util (zipSinks)+import qualified Data.ByteString.Lazy.Char8 as BSLC+import Control.Monad.IO.Class (liftIO) #endif  -- | put our constraints in one synonym

@@ -27,7 +27,7 @@   assertBool (isJust $ crPreregistrationData cr2)     assertBool (isNothing $ crRegistrationData cr2)     assertBool (isNothing $ crCardId cr2)  -  cr3<-testMP (\_->registerCard testCardInfo1 cr2)+  cr3<-unsafeRegisterCard testCardInfo1 cr2   assertBool (isJust $ crRegistrationData cr3)     cr4<-testMP $ storeCardRegistration cr3   assertBool (isJust $ crCardId cr4)  

@@ -35,7 +35,7 @@   usL<-testMP $ listUsers (Just $ Pagination 1 1)   assertEqual 1 (length $ plData usL)   let uid=urId $ head $ plData usL-  cr<-testMP $ fullRegistration uid "EUR" testCardInfo1+  cr<-testMP $ unsafeFullRegistration uid "EUR" testCardInfo1   assertBool (isJust $ crCardId cr)   let cid=fromJust $ crCardId cr   let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing @@ -60,7 +60,7 @@   usL<-testMP $ listUsers (Just $ Pagination 1 1)   assertEqual 1 (length $ plData usL)   let uid=urId $ head $ plData usL-  cr<-testMP $ fullRegistration uid "EUR" testCardInfo1+  cr<-testMP $ unsafeFullRegistration uid "EUR" testCardInfo1   assertBool (isJust $ crCardId cr)   let cid=fromJust $ crCardId cr   let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing 

@@ -16,7 +16,7 @@   usL<-testMP $ listUsers (Just $ Pagination 1 1)   assertEqual 1 (length $ plData usL)   let uid=urId $ head $ plData usL-  cr<-testMP $ fullRegistration uid "EUR" testCardInfo1+  cr<-testMP $ unsafeFullRegistration uid "EUR" testCardInfo1   assertBool (isJust $ crCardId cr)   let cid=fromJust $ crCardId cr   let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing @@ -47,7 +47,7 @@   usL<-testMP $ listUsers (Just $ Pagination 1 1)   assertEqual 1 (length $ plData usL)   let uid=urId $ head $ plData usL-  cr<-testMP $ fullRegistration uid "EUR" testCardInfo1+  cr<-testMP $ unsafeFullRegistration uid "EUR" testCardInfo1   assertBool (isJust $ crCardId cr)   let cid=fromJust $ crCardId cr   let w=Wallet Nothing Nothing (Just "custom") [uid] "my wallet" "EUR" Nothing @@ -87,7 +87,7 @@         let uw2=fromJust $ wId w2'         assertBool (uw1 /= uw2)         -        cr<-testMP $ fullRegistration uid1 "EUR" testCardInfo1+        cr<-testMP $ unsafeFullRegistration uid1 "EUR" testCardInfo1         assertBool (isJust $ crCardId cr)         let cid=fromJust $ crCardId cr         testEventTypes [PAYIN_NORMAL_CREATED,PAYIN_NORMAL_SUCCEEDED] $ do

@@ -1,10 +1,10 @@-{-# LANGUAGE RankNTypes,OverloadedStrings,DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes,OverloadedStrings,DeriveDataTypeable, ConstraintKinds, FlexibleContexts, PatternGuards #-} {-# OPTIONS_GHC -F -pgmF htfpp #-} module Web.MangoPay.TestUtils where  import Web.MangoPay -import Data.ByteString.Lazy as BS hiding (map,any,null)+import qualified Data.ByteString.Lazy as BSL hiding (map,any,null) import Network.HTTP.Conduit as H import Data.Maybe import Test.Framework@@ -20,7 +20,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (ResourceT, runResourceT) -import Data.Text (Text)+import Data.Text as T (Text, unpack, isPrefixOf)  import Data.List import Data.Typeable import Control.Applicative@@ -30,6 +30,12 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Monad.Logger +import qualified Data.Conduit.List as EL (consume)+import qualified Data.Text.Encoding as TE+import qualified Data.ByteString as BS+import qualified Network.HTTP.Types as HT+import Data.Conduit (($$+-))+ -- | a test card testCardInfo1 :: CardInfo testCardInfo1 = CardInfo "4970100000000154" "1220" "123"@@ -69,7 +75,7 @@ -- | read end point information from hook.test.conf in current folder getHookEndPoint :: IO HookEndPoint getHookEndPoint = do-      js<-BS.readFile "hook.test.conf"+      js<-BSL.readFile "hook.test.conf"       let mhook=decode js       assertBool (isJust mhook)       return $ fromJust mhook@@ -232,3 +238,47 @@                                 print evt                             Nothing->pushReceivedEvent revts $ Left $ UnhandledNotification $ show $ W.queryString req                 return $ W.responseBuilder status200 [("Content-Type", "text/plain")] $ copyByteString "noop"+++-- | perform the full registration of a card+-- this function is UNSAFE, because if you use this, YOU manage the user's credit card details+-- so you need to be PCI compliant!+unsafeFullRegistration :: (MPUsableMonad m) => AnyUserID -> Currency -> CardInfo -> AccessToken -> MangoPayT m CardRegistration+unsafeFullRegistration uid currency cardInfo at=do+  -- create registration+  let cr1=mkCardRegistration uid currency+  cr2<-storeCardRegistration cr1 at+  -- register it+  cr3<-liftIO $ unsafeRegisterCard cardInfo cr2+  -- save registered version+  storeCardRegistration cr3 at++-- | register a card with the registration URL+-- this function is UNSAFE, because if you use this, YOU manage the user's credit card details+-- so you need to be PCI compliant!+unsafeRegisterCard :: CardInfo -> CardRegistration -> IO CardRegistration+unsafeRegisterCard ci cr |+  Just url <- crCardRegistrationURL cr,+  Just pre <- crPreregistrationData cr,+  Just ak <- crAccessKey cr=do+    ior<-readIORef testState+    let mgr=tsManager ior+    req <-H.parseUrl $ T.unpack url  +    let b=HT.renderQuery False $ HT.toQuery [+            "accessKeyRef" ?+ ak+            ,"data" ?+ pre+            ,"cardNumber" ?+ ciNumber ci+            ,"cardExpirationDate" ?+ ciExpire ci+            ,"cardCvx" ?+ ciCSC ci]+    let req'=req {H.method=HT.methodPost+         , H.requestHeaders=[("content-type","application/x-www-form-urlencoded")]+         , H.requestBody=H.RequestBodyBS b}             +    reg<- runResourceT $  do +      res<-H.http req' mgr+      H.responseBody res $$+- EL.consume+    let t=TE.decodeUtf8 $ BS.concat reg+    assertBool $ "data=" `T.isPrefixOf` t +    return cr{crRegistrationData=Just t}+unsafeRegisterCard _ _=assertFailure "CardRegistration not ready" +                                +                

@@ -77,7 +77,7 @@         let uw2=fromJust $ wId w2'         assertBool (uw1 /= uw2)         -        cr<-testMP $ fullRegistration uid1 "EUR" testCardInfo1+        cr<-testMP $ unsafeFullRegistration uid1 "EUR" testCardInfo1         assertBool (isJust $ crCardId cr)         let cid=fromJust $ crCardId cr         testEventTypes [PAYIN_NORMAL_CREATED,PAYIN_NORMAL_SUCCEEDED] $ do