mangopay 1.6.0 → 1.6.1
raw patch · 5 files changed
+117/−100 lines, 5 files
Files
- mangopay.cabal +1/−1
- src/Web/MangoPay.hs +1/−0
- src/Web/MangoPay/Users.hs +104/−91
- test/Web/MangoPay/UsersTest.hs +7/−4
- test/mangopay-tests.hs +4/−4
mangopay.cabal view
@@ -1,5 +1,5 @@ name: mangopay-version: 1.6.0+version: 1.6.1 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau <jpmoresmau@gmail.com>
src/Web/MangoPay.hs view
@@ -44,6 +44,7 @@ ,fetchLegalUser ,getUser ,listUsers+ ,getExistingUserID -- Wallets ,Wallet(..)
src/Web/MangoPay/Users.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings, FlexibleContexts, FlexibleInstances, ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts,+ FlexibleInstances, OverloadedStrings, PatternGuards,+ ScopedTypeVariables #-} -- | handle users module Web.MangoPay.Users where @@ -16,56 +18,68 @@ -- | create or edit a natural user storeNaturalUser :: (MPUsableMonad m) => NaturalUser -> AccessToken -> MangoPayT m NaturalUser-storeNaturalUser u at= +storeNaturalUser u at= case uId u of Nothing-> do url<-getClientURL "/users/natural"- postExchange url (Just at) u + postExchange url (Just at) u Just i-> do url<-getClientURLMultiple ["/users/natural/",i]- putExchange url (Just at) u{uProofOfIdentity=Nothing,uProofOfAddress=Nothing} - + putExchange url (Just at) u{uProofOfIdentity=Nothing,uProofOfAddress=Nothing} + -- | fetch a natural user from her ID fetchNaturalUser :: (MPUsableMonad m) => NaturalUserID -> AccessToken -> MangoPayT m NaturalUser fetchNaturalUser uid at=do url<-getClientURLMultiple ["/users/natural/",uid] req<-getGetRequest url (Just at) ([]::HT.Query)- getJSONResponse req + getJSONResponse req + -- | create or edit a natural user storeLegalUser :: (MPUsableMonad m) => LegalUser -> AccessToken -> MangoPayT m LegalUser-storeLegalUser u at= +storeLegalUser u at = case lId u of Nothing-> do url<-getClientURL "/users/legal"- postExchange url (Just at) u + postExchange url (Just at) u Just i-> do url<-getClientURLMultiple ["/users/legal/",i] putExchange url (Just at) u- + -- | fetch a natural user from her ID fetchLegalUser :: (MPUsableMonad m) => LegalUserID -> AccessToken -> MangoPayT m LegalUser-fetchLegalUser uid at=do- url<-getClientURLMultiple ["/users/legal/",uid]- req<-getGetRequest url (Just at) ([]::HT.Query)- getJSONResponse req +fetchLegalUser uid at = do+ url <- getClientURLMultiple ["/users/legal/",uid]+ req <- getGetRequest url (Just at) ([]::HT.Query)+ getJSONResponse req + -- | get a user, natural or legal getUser :: (MPUsableMonad m) => AnyUserID -> AccessToken -> MangoPayT m (Either NaturalUser LegalUser)-getUser uid at=do- url<-getClientURLMultiple ["/users/",uid]- req<-getGetRequest url (Just at) ([]::HT.Query)+getUser uid at = do+ url <- getClientURLMultiple ["/users/",uid]+ req <- getGetRequest url (Just at) ([]::HT.Query) getJSONResponse req + -- | list all user references listUsers :: (MPUsableMonad m) => Maybe Pagination -> AccessToken -> MangoPayT m (PagedList UserRef)-listUsers mp at=do- url<-getClientURL "/users/"- req<-getGetRequest url (Just at) (paginationAttributes mp)- getJSONList req +listUsers mp at = do+ url <- getClientURL "/users/"+ req <- getGetRequest url (Just at) (paginationAttributes mp)+ getJSONList req ++-- | Convenience function to extract the user ID of an EXISTING user (one with an id).+getExistingUserID+ :: Either NaturalUser LegalUser+ -> AnyUserID+getExistingUserID u | Just uid <- either uId lId u = uid+getExistingUserID _ = error $ "Web.MangoPay.Users.getExistingUserID: Nothing"++ instance FromJSON (Either NaturalUser LegalUser) where parseJSON o@(Object v)=do pt::PersonType<-v .: "PersonType"@@ -79,7 +93,7 @@ --deleteNaturalUser uid at=do -- url<-getClientURL (TE.encodeUtf8 $ Data.Text.concat ["/users/natural/",uid]) -- req<-getDeleteRequest url (Just at) ([]::HT.Query)--- _::Object<- getJSONResponse req +-- _::Object<- getJSONResponse req -- return () -- | ID for any kind of user@@ -88,33 +102,32 @@ -- | User ID type NaturalUserID = Text - -- | a natural user -- <http://docs.mangopay.com/api-references/users/natural-users/> data NaturalUser=NaturalUser {- uId :: Maybe NaturalUserID -- ^ The Id of the object- ,uCreationDate :: Maybe POSIXTime -- ^ The creation date of the user object- ,uEmail :: Text -- ^ User’s e-mail- ,uFirstName :: Text -- ^ User’s firstname- ,uLastName :: Text -- ^ User’s lastname- ,uAddress :: Maybe Text -- ^ User’s address- ,uBirthday :: POSIXTime -- ^ User’s birthdate- ,uNationality :: CountryCode -- ^ User’s Nationality+ uId :: Maybe NaturalUserID -- ^ The Id of the object+ ,uCreationDate :: Maybe POSIXTime -- ^ The creation date of the user object+ ,uEmail :: Text -- ^ User’s e-mail+ ,uFirstName :: Text -- ^ User’s firstname+ ,uLastName :: Text -- ^ User’s lastname+ ,uAddress :: Maybe Text -- ^ User’s address+ ,uBirthday :: POSIXTime -- ^ User’s birthdate+ ,uNationality :: CountryCode -- ^ User’s Nationality ,uCountryOfResidence:: CountryCode -- ^User’s country of residence- ,uOccupation :: Maybe Text -- ^User’s occupation (ie. Work)- ,uIncomeRange :: Maybe IncomeRange -- ^ User’s income range- ,uTag :: Maybe Text -- ^ Custom data- ,uProofOfIdentity :: Maybe Text -- ^ - ,uProofOfAddress :: Maybe Text -- ^ + ,uOccupation :: Maybe Text -- ^User’s occupation (ie. Work)+ ,uIncomeRange :: Maybe IncomeRange -- ^ User’s income range+ ,uTag :: Maybe Text -- ^ Custom data+ ,uProofOfIdentity :: Maybe Text -- ^+ ,uProofOfAddress :: Maybe Text -- ^ } deriving (Show,Eq,Ord,Typeable)- --- | to json as per MangoPay format ++-- | to json as per MangoPay format instance ToJSON NaturalUser where toJSON u=object ["Tag" .= uTag u,"Email" .= uEmail u,"FirstName".= uFirstName u,"LastName" .= uLastName u,"Address" .= uAddress u, "Birthday" .= uBirthday u ,"Nationality" .= uNationality u,"CountryOfResidence" .= uCountryOfResidence u,"Occupation" .= uOccupation u, "IncomeRange" .= uIncomeRange u,"ProofOfIdentity" .= uProofOfIdentity u- ,"ProofOfAddress" .= uProofOfAddress u,"PersonType" .= Natural] + ,"ProofOfAddress" .= uProofOfAddress u,"PersonType" .= Natural] -- | from json as per MangoPay format instance FromJSON NaturalUser where@@ -132,56 +145,56 @@ v .:? "IncomeRange" <*> v .:? "Tag" <*> v .:? "ProofOfIdentity" <*>- v .:? "ProofOfAddress" - parseJSON _= fail "NaturalUser" + v .:? "ProofOfAddress"+ parseJSON _= fail "NaturalUser" -- | User ID type LegalUserID = Text- --- | the type of legal user ++-- | the type of legal user data LegalUserType = Business | Organization- deriving (Show,Read,Eq,Ord,Enum,Bounded,Typeable) - + deriving (Show,Read,Eq,Ord,Enum,Bounded,Typeable)+ -- | to json as per MangoPay format instance ToJSON LegalUserType where toJSON Business="BUSINESS" toJSON Organization="ORGANIZATION"- + -- | from json as per MangoPay format instance FromJSON LegalUserType where- parseJSON (String "BUSINESS") =pure Business - parseJSON (String "ORGANIZATION") =pure Organization - parseJSON _= fail "LegalUserType" - + parseJSON (String "BUSINESS") =pure Business+ parseJSON (String "ORGANIZATION") =pure Organization+ parseJSON _= fail "LegalUserType"+ -- | a legal user--- <http://docs.mangopay.com/api-references/users/legal-users/> +-- <http://docs.mangopay.com/api-references/users/legal-users/> data LegalUser=LegalUser {- lId :: Maybe Text -- ^ The Id of the object- ,lCreationDate :: Maybe POSIXTime -- ^ The creation date of the user object- ,lEmail :: Text -- ^ The email of the company or the organization- ,lName :: Text -- ^ The name of the company or the organization- ,lLegalPersonType :: LegalUserType -- ^ The type of the legal user (‘BUSINESS’ or ’ORGANIZATION’)- ,lHeadquartersAddress :: Maybe Text -- ^ The address of the company’s headquarters- ,lLegalRepresentativeFirstName :: Text -- ^ The firstname of the company’s Legal representative person- ,lLegalRepresentativeLastName :: Text -- ^ The lastname of the company’s Legal representative person- ,lLegalRepresentativeAddress :: Maybe Text -- ^ The address of the company’s Legal representative person- ,lLegalRepresentativeEmail :: Maybe Text -- ^ The email of the company’s Legal representative person- ,lLegalRepresentativeBirthday :: POSIXTime -- ^ The birthdate of the company’s Legal representative person- ,lLegalRepresentativeNationality :: CountryCode -- ^ the nationality of the company’s Legal representative person+ lId :: Maybe Text -- ^ The Id of the object+ ,lCreationDate :: Maybe POSIXTime -- ^ The creation date of the user object+ ,lEmail :: Text -- ^ The email of the company or the organization+ ,lName :: Text -- ^ The name of the company or the organization+ ,lLegalPersonType :: LegalUserType -- ^ The type of the legal user (‘BUSINESS’ or ’ORGANIZATION’)+ ,lHeadquartersAddress :: Maybe Text -- ^ The address of the company’s headquarters+ ,lLegalRepresentativeFirstName :: Text -- ^ The firstname of the company’s Legal representative person+ ,lLegalRepresentativeLastName :: Text -- ^ The lastname of the company’s Legal representative person+ ,lLegalRepresentativeAddress :: Maybe Text -- ^ The address of the company’s Legal representative person+ ,lLegalRepresentativeEmail :: Maybe Text -- ^ The email of the company’s Legal representative person+ ,lLegalRepresentativeBirthday :: POSIXTime -- ^ The birthdate of the company’s Legal representative person+ ,lLegalRepresentativeNationality :: CountryCode -- ^ the nationality of the company’s Legal representative person ,lLegalRepresentativeCountryOfResidence :: CountryCode -- ^ The country of residence of the company’s Legal representative person- ,lStatute :: Maybe Text -- ^ The business statute of the company- ,lTag :: Maybe Text -- ^ Custom data- ,lProofOfRegistration :: Maybe Text -- ^ The proof of registration of the company- ,lShareholderDeclaration :: Maybe Text -- ^ The shareholder declaration of the company+ ,lStatute :: Maybe Text -- ^ The business statute of the company+ ,lTag :: Maybe Text -- ^ Custom data+ ,lProofOfRegistration :: Maybe Text -- ^ The proof of registration of the company+ ,lShareholderDeclaration :: Maybe Text -- ^ The shareholder declaration of the company } deriving (Show,Eq,Ord,Typeable)- --- | to json as per MangoPay format ++-- | to json as per MangoPay format instance ToJSON LegalUser where toJSON u=object ["Tag" .= lTag u,"Email" .= lEmail u,"Name".= lName u,"LegalPersonType" .= lLegalPersonType u,"HeadquartersAddress" .= lHeadquartersAddress u, "LegalRepresentativeFirstName" .= lLegalRepresentativeFirstName u ,"LegalRepresentativeLastName" .= lLegalRepresentativeLastName u,"LegalRepresentativeAddress" .= lLegalRepresentativeAddress u,"LegalRepresentativeEmail" .= lLegalRepresentativeEmail u, "LegalRepresentativeBirthday" .= lLegalRepresentativeBirthday u,"LegalRepresentativeNationality" .= lLegalRepresentativeNationality u- ,"LegalRepresentativeCountryOfResidence" .= lLegalRepresentativeCountryOfResidence u,"Statute" .= lStatute u,"ProofOfRegistration" .=lProofOfRegistration u,"ShareholderDeclaration" .=lShareholderDeclaration u,"PersonType" .= Legal] - + ,"LegalRepresentativeCountryOfResidence" .= lLegalRepresentativeCountryOfResidence u,"Statute" .= lStatute u,"ProofOfRegistration" .=lProofOfRegistration u,"ShareholderDeclaration" .=lShareholderDeclaration u,"PersonType" .= Legal]+ -- | from json as per MangoPay format instance FromJSON LegalUser where parseJSON (Object v) =LegalUser <$>@@ -201,40 +214,40 @@ v .:? "Statute" <*> v .:? "Tag" <*> v .:? "ProofOfRegistration" <*>- v .:? "ShareholderDeclaration" - parseJSON _= fail "NaturalUser" - --- | Type of user. + v .:? "ShareholderDeclaration"+ parseJSON _= fail "NaturalUser"++-- | Type of user. data PersonType = Natural | Legal deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable)- + -- | to json as per MangoPay format instance ToJSON PersonType where toJSON Natural="NATURAL" toJSON Legal="LEGAL"- + -- | from json as per MangoPay format instance FromJSON PersonType where- parseJSON (String "NATURAL") =pure Natural - parseJSON (String "LEGAL") =pure Legal - parseJSON _= fail "PersonType" - + parseJSON (String "NATURAL") =pure Natural+ parseJSON (String "LEGAL") =pure Legal+ parseJSON _= fail "PersonType"+ -- | a short user reference data UserRef=UserRef {- urId :: AnyUserID+ urId :: AnyUserID , urCreationDate :: POSIXTime- , urPersonType :: PersonType- , urEmail :: Text- , urTag :: Maybe Text- } + , urPersonType :: PersonType+ , urEmail :: Text+ , urTag :: Maybe Text+ } deriving (Show,Eq,Ord,Typeable)- --- | to json as per MangoPay format ++-- | to json as per MangoPay format instance ToJSON UserRef where toJSON ur=object [ "PersonType" .= urPersonType ur, "Email" .= urEmail ur,"Id" .= urId ur, "Tag" .= urTag ur,"CreationDate" .= urCreationDate ur]- - ++ -- | from json as per MangoPay format instance FromJSON UserRef where parseJSON (Object v) =UserRef <$>@@ -242,6 +255,6 @@ v .: "CreationDate"<*> v .: "PersonType" <*> v .: "Email" <*>- v .:? "Tag" + v .:? "Tag" parseJSON _=fail "UserRef"- +
test/Web/MangoPay/UsersTest.hs view
@@ -12,8 +12,8 @@ import Data.CountryCodes (CountryCode(FR)) testNaturalUser :: NaturalUser-testNaturalUser=NaturalUser Nothing Nothing "jpmoresmau@gmail.com" "JP" "Moresmau" Nothing 11111 FR FR - (Just "Haskell contractor") (Just IncomeRange2) Nothing Nothing Nothing +testNaturalUser=NaturalUser Nothing Nothing "jpmoresmau@gmail.com" "JP" "Moresmau" Nothing 11111 FR FR+ (Just "Haskell contractor") (Just IncomeRange2) Nothing Nothing Nothing test_NaturalUser :: Assertion test_NaturalUser = do@@ -30,11 +30,12 @@ assertEqual (Left ue) eu usL<-testMP $ listUsers (Just $ Pagination 1 100) assertEqual 1 (length $ filter (((fromJust $ uId u)==) . urId) $ plData usL)+ assertEqual (fromJust $ uId u) (getExistingUserID $ Left u) testLegalUser :: LegalUser testLegalUser = LegalUser Nothing Nothing "jpmoresmau@gmail.com" "JP Moresmau" Business Nothing "JP" "Moresmau" (Just "my house") Nothing 222222 FR FR Nothing Nothing Nothing Nothing- + test_LegalUser :: Assertion test_LegalUser = do l<-testMP $ storeLegalUser testLegalUser@@ -53,7 +54,8 @@ assertEqual (Right le) el usL<-testMP $ listUsers (Just $ Pagination 1 100) assertEqual 1 (length $ filter (((fromJust $ lId l)==) . urId) $ plData usL)- + assertEqual (fromJust $ lId l) (getExistingUserID $ Right l)+ test_PaginationUsers :: Assertion test_PaginationUsers = do usL<-testMP $ listUsers (Just $ Pagination 1 1)@@ -67,3 +69,4 @@ assertEqual 1 (plPageCount usL2) us<-testMP $ getAll listUsers assertEqual 2 (length us)+
test/mangopay-tests.hs view
@@ -33,18 +33,18 @@ res<-newReceivedEvents -- initial state modifyIORef testState (\ts->ts{tsManager=mgr,tsHookEndPoint=hook,tsReceivedEvents=res})- bracket + bracket (startHTTPServer (hepPort hook) res) killThread (\_->htfMain $ htf_importedTests ++ [htf_thisModulesTests]) ) --- | test there are no unprocessed events +-- | test there are no unprocessed events test_Final :: Assertion test_Final=do -- wait in case events still arrive threadDelay $ 5 * 1000000- res<-liftM tsReceivedEvents $ readIORef testState + res<-liftM tsReceivedEvents $ readIORef testState evts<-popReceivedEvents res assertEqual [] evts- +