diff --git a/mangopay.cabal b/mangopay.cabal --- a/mangopay.cabal +++ b/mangopay.cabal @@ -1,5 +1,5 @@ name: mangopay -version: 1.5.1 +version: 1.6.0 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau diff --git a/src/Web/MangoPay.hs b/src/Web/MangoPay.hs --- a/src/Web/MangoPay.hs +++ b/src/Web/MangoPay.hs @@ -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(..) diff --git a/src/Web/MangoPay/Documents.hs b/src/Web/MangoPay/Documents.hs --- a/src/Web/MangoPay/Documents.hs +++ b/src/Web/MangoPay/Documents.hs @@ -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. +-- +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 diff --git a/src/Web/MangoPay/Events.hs b/src/Web/MangoPay/Events.hs --- a/src/Web/MangoPay/Events.hs +++ b/src/Web/MangoPay/Events.hs @@ -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. +-- ). +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 --- 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 --- 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" diff --git a/src/Web/MangoPay/Types.hs b/src/Web/MangoPay/Types.hs --- a/src/Web/MangoPay/Types.hs +++ b/src/Web/MangoPay/Types.hs @@ -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 { diff --git a/src/Web/MangoPay/Users.hs b/src/Web/MangoPay/Users.hs --- a/src/Web/MangoPay/Users.hs +++ b/src/Web/MangoPay/Users.hs @@ -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 -- diff --git a/src/Web/MangoPay/Wallets.hs b/src/Web/MangoPay/Wallets.hs --- a/src/Web/MangoPay/Wallets.hs +++ b/src/Web/MangoPay/Wallets.hs @@ -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 diff --git a/test/Web/MangoPay/DocumentsTest.hs b/test/Web/MangoPay/DocumentsTest.hs --- a/test/Web/MangoPay/DocumentsTest.hs +++ b/test/Web/MangoPay/DocumentsTest.hs @@ -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 [] diff --git a/test/Web/MangoPay/SimpleTest.hs b/test/Web/MangoPay/SimpleTest.hs --- a/test/Web/MangoPay/SimpleTest.hs +++ b/test/Web/MangoPay/SimpleTest.hs @@ -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) diff --git a/test/Web/MangoPay/TestUtils.hs b/test/Web/MangoPay/TestUtils.hs --- a/test/Web/MangoPay/TestUtils.hs +++ b/test/Web/MangoPay/TestUtils.hs @@ -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)