diff --git a/mangopay.cabal b/mangopay.cabal --- a/mangopay.cabal +++ b/mangopay.cabal @@ -1,5 +1,5 @@ name: mangopay -version: 1.6.0 +version: 1.6.1 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 @@ -44,6 +44,7 @@ ,fetchLegalUser ,getUser ,listUsers + ,getExistingUserID -- Wallets ,Wallet(..) 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 @@ -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 -- 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 --- +-- 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" - + diff --git a/test/Web/MangoPay/UsersTest.hs b/test/Web/MangoPay/UsersTest.hs --- a/test/Web/MangoPay/UsersTest.hs +++ b/test/Web/MangoPay/UsersTest.hs @@ -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) + diff --git a/test/mangopay-tests.hs b/test/mangopay-tests.hs --- a/test/mangopay-tests.hs +++ b/test/mangopay-tests.hs @@ -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 - +