packages feed

mangopay 1.5.1 → 1.6.0

raw patch · 10 files changed

+243/−100 lines, 10 files

Files

mangopay.cabal view
@@ -1,5 +1,5 @@ name:           mangopay-version:        1.5.1+version:        1.6.0 cabal-version:  >= 1.8 build-type:     Simple author:         JP Moresmau <jpmoresmau@gmail.com>
src/Web/MangoPay.hs view
@@ -19,6 +19,7 @@         ,CardExpiration(..)         ,readCardExpiration         ,writeCardExpiration+        ,KindOfAuthentication(..)                  -- access         ,createCredentialsSecret@@ -28,6 +29,8 @@         -- Users         ,NaturalUser(..)         ,IncomeRange(..)+        ,incomeBounds+        ,incomeRange         ,NaturalUserID         ,LegalUser(..)         ,LegalUserType(..)@@ -67,6 +70,8 @@         ,EventType(..)         ,EventSearchParams(..)         ,searchEvents+        ,searchAllEvents+        ,checkEvent         ,HookStatus(..)         ,HookValidity(..)         ,HookID@@ -85,6 +90,7 @@         ,storeDocument         ,fetchDocument         ,storePage+        ,getKindOfAuthentication                  -- Accounts         ,BankAccount(..)
src/Web/MangoPay/Documents.hs view
@@ -7,7 +7,7 @@ import Web.MangoPay.Types import Web.MangoPay.Users -import Data.Text+import Data.Text hiding (any) import Data.Typeable (Typeable) import Data.Aeson import Data.Time.Clock.POSIX (POSIXTime)@@ -111,3 +111,35 @@                          v .:? "RefusedReasonType" <*>                          v .:? "RefusedReasonMessage"         parseJSON _=fail "Document"+++-- | Do we have a validated document of the given type?+hasValidatedDocument+  :: DocumentType+     -- ^ The document type.+  -> [Document]+     -- ^ The documents we know about.+  -> Bool+hasValidatedDocument dtype = any (\d -> dtype == dType d && Just VALIDATED == dStatus d)+++-- | Calculate the MangoPay authentication level.+-- <http://docs.mangopay.com/api-references/kyc-rules/>+getKindOfAuthentication+  :: Either NaturalUser LegalUser+  -> [Document]+  -> KindOfAuthentication+getKindOfAuthentication _ [] = Light+getKindOfAuthentication (Left nu) docs =+  case (uAddress nu,uOccupation nu,uIncomeRange nu,hasValidatedDocument IDENTITY_PROOF docs) of+    (Just _,Just _, Just _,True) -> if hasValidatedDocument ADDRESS_PROOF docs+      then Strong+      else Regular+    _ -> Light+getKindOfAuthentication (Right lu) docs=+  case (lHeadquartersAddress lu,lLegalRepresentativeEmail lu,lLegalRepresentativeAddress lu,+    hasValidatedDocument ARTICLES_OF_ASSOCIATION docs,+    hasValidatedDocument REGISTRATION_PROOF docs,+    hasValidatedDocument SHAREHOLDER_DECLARATION docs) of+    (Just _, Just _, Just _, True, True, True) -> Regular+    _ -> Light
src/Web/MangoPay/Events.hs view
@@ -19,16 +19,35 @@ import Control.Monad (join) import qualified Data.ByteString.Char8 as BS --- | create or edit a natural user-searchEvents ::  (MPUsableMonad m) => EventSearchParams -> AccessToken -> MangoPayT m  [Event]+-- | search events, returns a paginated list+searchEvents ::  (MPUsableMonad m) => EventSearchParams -> AccessToken -> MangoPayT m  (PagedList Event) searchEvents esp at=do         url<-getClientURL "/events"         req<-getGetRequest url (Just at) esp-        getJSONResponse req+        getJSONList req ++-- | search events, returns the full result+searchAllEvents ::  (MPUsableMonad m) => EventSearchParams -> AccessToken -> MangoPayT m  [Event]+searchAllEvents esp at=getAll (\p -> searchEvents esp{espPagination=p}) at+++-- | Check if an event came from MangoPay.  Since notifications+-- are not authenticated, you're advised to always check if the+-- event really comes from MangoPay (cf.+-- <https://mangopay.desk.com/customer/portal/questions/6493147>).+checkEvent :: (MPUsableMonad m) => Event -> AccessToken ->  MangoPayT m Bool+checkEvent evt at= do+  -- documentation doesn't say it, but tests show dates are inclusive+  let dt = Just $ eDate evt+  let esp = EventSearchParams (Just $ eEventType evt) dt dt Nothing+  evts <- searchAllEvents esp at+  return $ evt `elem` evts++ -- | create or edit a hook storeHook ::  (MPUsableMonad m) => Hook -> AccessToken -> MangoPayT m Hook-storeHook h at= +storeHook h at=         case hId h of                 Nothing-> do                         url<-getClientURL "/hooks"@@ -37,20 +56,20 @@                         url<-getClientURLMultiple ["/hooks/",i]                         let Object m=toJSON h                         putExchange url (Just at) (Object $ HM.delete "EventType" m)-                + -- | fetch a wallet from its ID fetchHook :: (MPUsableMonad m) => HookID -> AccessToken -> MangoPayT m Hook fetchHook wid at=do         url<-getClientURLMultiple ["/hooks/",wid]         req<-getGetRequest url (Just at) ([]::HT.Query)-        getJSONResponse req +        getJSONResponse req --- | list all wallets for a given user   +-- | list all wallets for a given user listHooks :: (MPUsableMonad m) =>  Maybe Pagination -> AccessToken -> MangoPayT m (PagedList Hook) listHooks mp at=do         url<-getClientURL "/hooks"         req<-getGetRequest url (Just at) (paginationAttributes mp)-        getJSONList req +        getJSONList req  -- | Event type data EventType=@@ -90,7 +109,7 @@         parseJSON (String s)=pure $ read $ unpack s         parseJSON _ =fail "EventType" --- | search parameters for events        +-- | search parameters for events data EventSearchParams=EventSearchParams{         espEventType :: Maybe EventType         ,espBeforeDate :: Maybe POSIXTime@@ -98,17 +117,17 @@         ,espPagination :: Maybe Pagination         }         deriving (Show,Eq,Ord,Typeable)- + instance Default EventSearchParams where   def=EventSearchParams Nothing Nothing Nothing Nothing-  + instance HT.QueryLike EventSearchParams where-  toQuery (EventSearchParams et bd ad p)=filter (isJust .snd) +  toQuery (EventSearchParams et bd ad p)=filter (isJust .snd)     ["eventtype" ?+ et     ,"beforeDate" ?+ bd     ,"afterDate" ?+ ad-   ] ++ paginationAttributes p -        +   ] ++ paginationAttributes p+ --instance ToJSON EventSearchParams where --        toJSON esp=object $ ["eventtype" .= espEventType esp, --                "beforeDate" .= espBeforeDate esp, "afterDate" .= espAfterDate esp]@@ -121,12 +140,12 @@         ,eDate :: POSIXTime         }         deriving (Show,Eq,Ord,Typeable)- --- | to json as per MangoPay format        ++-- | to json as per MangoPay format instance ToJSON Event where         toJSON e=object ["ResourceId"  .= eResourceId e,"EventType" .= eEventType e,"Date" .= eDate e] --- | from json as per MangoPay format +-- | from json as per MangoPay format instance FromJSON Event where         parseJSON (Object v) =Event <$>                          v .: "ResourceId" <*>@@ -136,59 +155,59 @@  -- | parse an event from the query string -- the MangoPay is not very clear on notifications, but see v1 <http://docs.mangopay.com/v1-api-references/notifications/>--- v2 works the same, the event is passed via parameters of the query string   +-- v2 works the same, the event is passed via parameters of the query string eventFromQueryString :: HT.Query -> Maybe Event eventFromQueryString q=do   rid<-fmap TE.decodeUtf8 $ join $ findAssoc q "RessourceId" -- yes, two ss here   et<-join $ fmap (maybeRead . BS.unpack) $ join $ findAssoc q "EventType"   d<-fmap fromIntegral $ join $ fmap ((maybeRead :: String -> Maybe Integer). BS.unpack) $ join $ findAssoc q "Date"   return $ Event rid et d-                 + -- | parse an event from the query string represented as Text -- the MangoPay is not very clear on notifications, but see v1 <http://docs.mangopay.com/v1-api-references/notifications/>--- v2 works the same, the event is passed via parameters of the query string   +-- v2 works the same, the event is passed via parameters of the query string eventFromQueryStringT :: [(Text, Text)] -> Maybe Event eventFromQueryStringT q=do   rid<- findAssoc q "RessourceId" -- yes, two ss here   et<-join $ fmap (maybeRead . unpack) $ findAssoc q "EventType"   d<-fmap fromIntegral $ join $ fmap ((maybeRead :: String -> Maybe Integer). unpack) $ findAssoc q "Date"-  return $ Event rid et d  +  return $ Event rid et d --- | status of notification hook                       +-- | status of notification hook data HookStatus=Enabled | Disabled        deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable)-     + -- | to json as per MangoPay format instance ToJSON HookStatus  where     toJSON Enabled="ENABLED"     toJSON Disabled="DISABLED"- + -- | from json as per MangoPay format instance FromJSON HookStatus where-    parseJSON (String "ENABLED") =pure Enabled                  -    parseJSON (String "DISABLED") =pure Disabled            -    parseJSON _= fail "HookStatus"      +    parseJSON (String "ENABLED") =pure Enabled+    parseJSON (String "DISABLED") =pure Disabled+    parseJSON _= fail "HookStatus" --- | validity of notification hook                   +-- | validity of notification hook data HookValidity=Valid | Invalid        deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable)-     + -- | to json as per MangoPay format instance ToJSON HookValidity  where     toJSON Valid="VALID"     toJSON Invalid="INVALID"- + -- | from json as per MangoPay format instance FromJSON HookValidity where-    parseJSON (String "VALID") =pure Valid                  -    parseJSON (String "INVALID") =pure Invalid            -    parseJSON _= fail "HookValidity"   - --- | id for hook   -type HookID=Text   +    parseJSON (String "VALID") =pure Valid+    parseJSON (String "INVALID") =pure Invalid+    parseJSON _= fail "HookValidity" --- | a notification hook    +-- | id for hook+type HookID=Text++-- | a notification hook data Hook=Hook {         hId :: Maybe HookID -- ^ The Id of the hook details         ,hCreationDate :: Maybe POSIXTime@@ -197,14 +216,14 @@         ,hStatus :: HookStatus         ,hValidity :: Maybe HookValidity         ,hEventType :: EventType-        }              +        }         deriving (Show,Eq,Ord,Typeable)-  --- | to json as per MangoPay format        ++-- | to json as per MangoPay format instance ToJSON Hook where         toJSON h=object ["Tag"  .= hTag h,"EventType" .= hEventType h,"Url" .= hUrl h,"Status" .= hStatus h] --- | from json as per MangoPay format +-- | from json as per MangoPay format instance FromJSON Hook where         parseJSON (Object v) =Hook <$>                          v .: "Id" <*>@@ -213,5 +232,5 @@                          v .: "Url" <*>                          v .: "Status" <*>                          v .: "Validity" <*>-                         v .: "EventType" -        parseJSON _=fail "Hook"        +                         v .: "EventType"+        parseJSON _=fail "Hook"
src/Web/MangoPay/Types.hs view
@@ -175,6 +175,86 @@   }   deriving (Show,Read,Eq,Ord,Typeable) ++-- | currency amount +data Amount=Amount {+        aCurrency :: Currency+        ,aAmount :: Integer -- ^ all amounts should be in cents!+        }+        deriving (Show,Read,Eq,Ord,Typeable)+ +-- | to json as per MangoPay format        +instance ToJSON Amount where+        toJSON b=object ["Currency"  .= aCurrency b,"Amount" .= aAmount b]++-- | from json as per MangoPay format +instance FromJSON Amount where+        parseJSON (Object v) =Amount <$>+                         v .: "Currency" <*>+                         v .: "Amount" +        parseJSON _=fail "Amount"+        +-- | supported income ranges+data IncomeRange=IncomeRange1 | IncomeRange2 | IncomeRange3 | IncomeRange4 | IncomeRange5 | IncomeRange6+      deriving (Show,Read,Eq,Ord,Bounded, Enum, Typeable)   +++-- | to json as per MangoPay format+-- the samples do show string format when writing, integer format when reading...+instance ToJSON IncomeRange  where+    toJSON IncomeRange1="1"+    toJSON IncomeRange2="2"+    toJSON IncomeRange3="3"+    toJSON IncomeRange4="4"+    toJSON IncomeRange5="5"+    toJSON IncomeRange6="6"+ +-- | from json as per MangoPay format+-- the samples do show string format when writing, integer format when reading...+instance FromJSON IncomeRange where+    parseJSON (String "1") =pure IncomeRange1                  +    parseJSON (String "2") =pure IncomeRange2 +    parseJSON (String "3") =pure IncomeRange3  +    parseJSON (String "4") =pure IncomeRange4  +    parseJSON (String "5") =pure IncomeRange5  +    parseJSON (String "6") =pure IncomeRange6                 +    parseJSON (Number 1) =pure IncomeRange1                  +    parseJSON (Number 2) =pure IncomeRange2 +    parseJSON (Number 3) =pure IncomeRange3  +    parseJSON (Number 4) =pure IncomeRange4  +    parseJSON (Number 5) =pure IncomeRange5  +    parseJSON (Number 6) =pure IncomeRange6    +    parseJSON _= fail "IncomeRange"  ++-- | bounds in euros for income range+incomeBounds :: IncomeRange -> (Amount,Amount)+incomeBounds IncomeRange1 = (kEuros 0,kEuros 18)+incomeBounds IncomeRange2 = (kEuros 18,kEuros 30)+incomeBounds IncomeRange3 = (kEuros 30,kEuros 50)+incomeBounds IncomeRange4 = (kEuros 50,kEuros 80)+incomeBounds IncomeRange5 = (kEuros 80,kEuros 120)+incomeBounds IncomeRange6 = (kEuros 120,kEuros (-1))+  ++-- | get Income Range for given Euro amount+incomeRange :: Amount -> IncomeRange+incomeRange (Amount "EUR" cents) +  | cents < kCents 18  = IncomeRange1+  | cents < kCents 30  = IncomeRange2+  | cents < kCents 50  = IncomeRange3+  | cents < kCents 80  = IncomeRange4+  | cents < kCents 120 = IncomeRange5+  | otherwise          = IncomeRange6+incomeRange (Amount _ _) = error "Amount should be given in euros"+++-- | convert a amount of kilo-euros in an amount+kEuros :: Integer -> Amount+kEuros  = Amount "EUR" . kCents -- amount is in cents++kCents :: Integer -> Integer+kCents ke = ke * 1000 * 100+ -- | read Card Expiration from text representation (MMYY) readCardExpiration :: T.Reader CardExpiration readCardExpiration t |@@ -207,6 +287,23 @@   fromString s     | Right (ce,"")<-readCardExpiration $ fromString s=ce   fromString _=error "CardExpiration"+++-- | the kind of authentication data the user has provided+data KindOfAuthentication = +    Light+  | Regular+  | Strong+    deriving (Eq, Ord, Show, Read, Bounded, Enum, Typeable)+++instance ToJSON KindOfAuthentication where+        toJSON =toJSON . show++instance FromJSON KindOfAuthentication where+        parseJSON (String s)=pure $ read $ unpack s+        parseJSON _ =fail "KindOfAuthentication"+  -- | a structure holding the information of an API call data CallRecord a = CallRecord {
src/Web/MangoPay/Users.hs view
@@ -88,36 +88,7 @@ -- | User ID type NaturalUserID = Text --- | supported income ranges-data IncomeRange=IncomeRange1 | IncomeRange2 | IncomeRange3 | IncomeRange4 | IncomeRange5 | IncomeRange6-      deriving (Show,Read,Eq,Ord,Bounded, Enum, Typeable)   ---- | to json as per MangoPay format--- the samples do show string format when writing, integer format when reading...-instance ToJSON IncomeRange  where-    toJSON IncomeRange1="1"-    toJSON IncomeRange2="2"-    toJSON IncomeRange3="3"-    toJSON IncomeRange4="4"-    toJSON IncomeRange5="5"-    toJSON IncomeRange6="6"- --- | from json as per MangoPay format--- the samples do show string format when writing, integer format when reading...-instance FromJSON IncomeRange where-    parseJSON (String "1") =pure IncomeRange1                  -    parseJSON (String "2") =pure IncomeRange2 -    parseJSON (String "3") =pure IncomeRange3  -    parseJSON (String "4") =pure IncomeRange4  -    parseJSON (String "5") =pure IncomeRange5  -    parseJSON (String "6") =pure IncomeRange6                 -    parseJSON (Number 1) =pure IncomeRange1                  -    parseJSON (Number 2) =pure IncomeRange2 -    parseJSON (Number 3) =pure IncomeRange3  -    parseJSON (Number 4) =pure IncomeRange4  -    parseJSON (Number 5) =pure IncomeRange5  -    parseJSON (Number 6) =pure IncomeRange6    -    parseJSON _= fail "IncomeRange"    +    -- | a natural user -- <http://docs.mangopay.com/api-references/users/natural-users/>
src/Web/MangoPay/Wallets.hs view
@@ -69,23 +69,6 @@         req<-getGetRequest url (Just at) (paginationAttributes mp)         getJSONList req  --- | currency amount -data Amount=Amount {-        aCurrency :: Currency-        ,aAmount :: Integer -- ^ all amounts should be in cents!-        }-        deriving (Show,Read,Eq,Ord,Typeable)- --- | to json as per MangoPay format        -instance ToJSON Amount where-        toJSON b=object ["Currency"  .= aCurrency b,"Amount" .= aAmount b]---- | from json as per MangoPay format -instance FromJSON Amount where-        parseJSON (Object v) =Amount <$>-                         v .: "Currency" <*>-                         v .: "Amount" -        parseJSON _=fail "Amount"  -- | ID of a wallet type WalletID=Text
test/Web/MangoPay/DocumentsTest.hs view
@@ -13,16 +13,18 @@  -- | test document API test_Document :: Assertion-test_Document=do+test_Document = do   usL<-testMP $ listUsers (Just $ Pagination 1 1)   assertEqual 1 (length $ plData usL)   let uid=urId $ head $ plData usL+  euser <- testMP $ getUser uid   let d=Document Nothing Nothing Nothing IDENTITY_PROOF (Just CREATED) Nothing Nothing   testEventTypes [KYC_CREATED,KYC_VALIDATION_ASKED] $ do     d2<-testMP $ storeDocument uid d     assertBool (isJust $ dId d2)     assertBool (isJust $ dCreationDate d2)     assertEqual IDENTITY_PROOF (dType d2)+    assertEqual Light $ getKindOfAuthentication euser [d2]     tf<-BS.readFile "data/test.jpg"     -- document has to be in CREATED status     testMP $ storePage uid (fromJust $ dId d2) tf@@ -33,3 +35,12 @@     assertEqual (Just VALIDATION_ASKED) (dStatus d4)     return $ dId d2   ++-- | test type of authentication+test_KindOfAuthentication :: Assertion+test_KindOfAuthentication = do+  usL<-testMP $ listUsers (Just $ Pagination 1 1)+  assertEqual 1 (length $ plData usL)+  let uid=urId $ head $ plData usL+  euser <- testMP $ getUser uid+  assertEqual Light $ getKindOfAuthentication euser []
test/Web/MangoPay/SimpleTest.hs view
@@ -26,4 +26,23 @@   assertEqual "1503" $ writeCardExpiration ce2   let ce3 = CardExpiration 10 2034   assertEqual "1034" $ writeCardExpiration ce3+   +-- | test income ranges+test_IncomeRanges :: Assertion+test_IncomeRanges = mapM_ testIncomeRange [minBound .. maxBound]++-- | test one income range+testIncomeRange :: IncomeRange -> Assertion+testIncomeRange ir=do+  let (Amount c1 a1,Amount c2 a2) = incomeBounds ir+  assertEqual "EUR" c1+  assertEqual "EUR" c2+  if a2 > (-1)+    then do +      let mid = div (a1+a2) 2+      assertEqual ir $ incomeRange (Amount c1 mid)+    else do+      assertEqual IncomeRange6 ir+      let mid = a1 * 2+      assertEqual ir $ incomeRange (Amount c1 mid)
test/Web/MangoPay/TestUtils.hs view
@@ -35,6 +35,7 @@ import qualified Data.ByteString as BS import qualified Network.HTTP.Types as HT import Data.Conduit (($$+-))+import Data.Monoid ((<>))  -- | a test card testCardInfo1 :: CardInfo@@ -137,7 +138,7 @@ -- | assert that we find an event for the given resource id and event type testSearchEvent :: Maybe Text -> EventType -> Assertion testSearchEvent tid evtT=do-  es<-testMP $ searchEvents (def{espEventType=Just evtT})+  es<-testMP $ searchAllEvents (def{espEventType=Just evtT})   assertBool (not $ null es)   assertBool (any ((tid ==) . Just . eResourceId) es) @@ -145,7 +146,7 @@ createHook :: EventType -> Assertion createHook evtT= do     hook<-liftM tsHookEndPoint $ readIORef testState-    h<-testMP $ storeHook (Hook Nothing Nothing Nothing (hepUrl hook) Enabled Nothing evtT)+    h<-testMP $ storeHook (Hook Nothing Nothing Nothing (hepUrl hook <> "/mphook") Enabled Nothing evtT)     assertBool (isJust $ hId h)     h2<-testMP $ fetchHook (fromJust $ hId h)     assertEqual (hId h) (hId h2)@@ -165,6 +166,7 @@ data EventResult = Timeout -- ^ didn't receive all expected events   | EventsOK -- ^ OK: everything expected received, nothing unexpected   | ExtraEvent Event -- ^ unexpected+  | UncheckedEvent Event -- ^ event not found in MangoPay   | UnhandledNotification String -- ^ notification we couldn't parse   deriving (Show,Eq,Ord,Typeable) @@ -183,11 +185,14 @@           (Nothing,_)->do -- no event yet              threadDelay 1000000              waitForEvent rc fs (del-1)-          (Just (Right evt),_)-> -- an event, does it match-                case Data.List.foldl' (match1 evt) ([],False) fs of-                  (_,False)->return $ ExtraEvent evt -- doesn't match-                  (fs2,_)-> waitForEvent rc fs2 del -- matched, either we have more to do or we need to check no unexpected event was found-+          (Just (Right evt),_)-> do -- an event, does it match+                ok <- testMP $ checkEvent evt+                if ok +                  then +                    case Data.List.foldl' (match1 evt) ([],False) fs of+                      (_,False)->return $ ExtraEvent evt -- doesn't match+                      (fs2,_)-> waitForEvent rc fs2 del -- matched, either we have more to do or we need to check no unexpected event was found+                  else  return $ UncheckedEvent evt   where     -- | match the first event function and return all the non matching function, and a flag indicating if we matched     match1 :: Event -> ([Event -> Bool],Bool) -> (Event -> Bool) -> ([Event -> Bool],Bool)