diff --git a/mangopay.cabal b/mangopay.cabal --- a/mangopay.cabal +++ b/mangopay.cabal @@ -1,5 +1,5 @@ name: mangopay -version: 1.9.1 +version: 1.9.2 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau @@ -55,6 +55,12 @@ , template-haskell , country-codes == 0.1.* + -- Needed for TestUtils + , blaze-builder + , HUnit >= 1.2.5 + , wai >= 3.0 && < 3.1 + , warp >= 3.0 && < 3.1 + if flag(conduit11) build-depends: conduit == 1.1.* @@ -76,7 +82,8 @@ Web.MangoPay.Cards, Web.MangoPay.Refunds, Web.MangoPay.Payouts, - Web.MangoPay.Accounts + Web.MangoPay.Accounts, + Web.MangoPay.TestUtils if flag(debug) cpp-options: -DDEBUG @@ -100,25 +107,21 @@ ghc-options: -Wall -rtsopts -threaded build-depends: base, aeson, attoparsec, base16-bytestring, - base64-bytestring, bytestring, case-insensitive, conduit, - data-default, http-conduit, http-types, lifted-base, - monad-control, monad-logger, resourcet, template-haskell, - text, time, transformers, transformers-base, - unordered-containers, utf8-string, vector, country-codes - , blaze-builder + base64-bytestring, blaze-builder, bytestring, + case-insensitive, conduit, data-default, http-conduit, + http-types, HUnit, lifted-base, monad-control, monad-logger, + resourcet, template-haskell, text, time, transformers, + transformers-base, unordered-containers, utf8-string, + vector, wai, warp, country-codes + , HTF > 0.9 - , HUnit >= 1.2.5 - , wai >= 3.0 && < 3.1 - , warp >= 3.0 && < 3.1 if flag(conduit11) build-depends: conduit-extra else build-depends: attoparsec-conduit other-modules: Web.MangoPay.UsersTest, - Web.MangoPay.TestUtils, Web.MangoPay.WalletsTest, - Web.MangoPay.AccessTest, Web.MangoPay.DocumentsTest, Web.MangoPay.PayinsTest, Web.MangoPay.CardsTest, diff --git a/src/Web/MangoPay/TestUtils.hs b/src/Web/MangoPay/TestUtils.hs new file mode 100644 --- /dev/null +++ b/src/Web/MangoPay/TestUtils.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, + OverloadedStrings, PatternGuards, RankNTypes, TemplateHaskell #-} +module Web.MangoPay.TestUtils + ( -- * Initialization + withMangoPayTestUtils + + -- * Test helpers + , testCardInfo1 + , testMP + , testEventTypes + , testEventTypes' + + -- ** Credit card registration + , unsafeFullRegistration + , unsafeRegisterCard + + -- ** Tear down + , ensureNoEvents + ) where + +import Blaze.ByteString.Builder (copyByteString) +import Control.Applicative +import Control.Concurrent (forkIO, killThread, ThreadId, threadDelay) +import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) +import Control.Exception (bracket) +import Control.Monad (void, liftM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (LoggingT, runStdoutLoggingT, logDebugS, logWarnS) +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Data.Conduit (($$+-)) +import Data.Default (def) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) +import Data.Typeable (Typeable) +import Network.HTTP.Types (status200) +import Network.Wai.Handler.Warp +import System.IO.Unsafe (unsafePerformIO) +import Test.HUnit + +import Web.MangoPay + +import qualified Data.ByteString.Lazy as BSL +import qualified Network.HTTP.Conduit as H +import qualified Data.Aeson as A +import qualified Data.Conduit.List as EL +import qualified Data.IORef as I +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString as BS +import qualified Network.HTTP.Types as HT +import qualified Network.Wai as W + + +---------------------------------------------------------------------- + + +-- | A test card. +testCardInfo1 :: CardInfo +testCardInfo1 = CardInfo "4970100000000154" "1220" "123" + + +-- | Test MangoPay API call, logging in with the client +-- credentials. Expects a file called @client.test.conf@ +-- containing the JSON of client credentials in the current +-- directory. +testMP :: (AccessToken -> MangoPayT (LoggingT (ResourceT IO)) b) -> IO b +testMP f = do + ior <- I.readIORef testState + let mgr = tsManager ior + at = tsAccessToken ior + cred = tsCredentials ior + runResourceT $ runStdoutLoggingT $ runMangoPayT cred mgr Sandbox $ f at + + +-- | Test an event, checking the resource id and the event type. +testEvent :: Maybe Text -> EventType -> Event -> Bool +testEvent tid et evt = + tid == Just (eResourceId evt) && + et == eEventType evt + +-- | Run the given test, then check that we've received events +-- of the given types which reference resource id returned by the +-- test. +testEventTypes :: [EventType] -> IO (Maybe Text) -> Assertion +testEventTypes evtTs = void . testEventTypes' evtTs + + +-- | Same as 'testEventTypes', but also return the resource id. +testEventTypes' :: [EventType] -> IO (Maybe Text) -> IO (Maybe Text) +testEventTypes' evtTs ops = do + res <- liftM tsReceivedEvents $ I.readIORef testState + a <- ops + er <- waitForEvent res ((,) a <$> evtTs) 5 + assertEqual "testEventTypes'" EventsOK er + return a + + +-------------------------------------------------------------------------------- + + +-- | Result of waiting for an event. +data EventResult = + Timeout [(Maybe Text, EventType)] -- ^ Didn't receive all expected events within the timeout. + | EventsOK -- ^ OK: everything expected received, nothing unexpected. + | ExtraEvent Event -- ^ Unexpected extra event found. + | UncheckedEvent Event -- ^ Event not found in MangoPay (cf. 'checkEvent'). + | UnhandledNotification String -- ^ Notification we couldn't parse (cf. 'eventFromQueryString'). + deriving (Show, Eq, Ord, Typeable) + + +-- | Wait until we receive all the expected events, and only the +-- expected events, for a maximum number of seconds. +waitForEvent + :: ReceivedEvents + -> [(Maybe Text, EventType)] -- ^ (Resource id, event type) expected. + -> Integer -- ^ Timeout in seconds. + -> IO EventResult +waitForEvent _ fs del | del <= 0 = return (Timeout fs) +waitForEvent rc fs del = do + mevt <- popReceivedEvent rc + case (mevt, fs) of + (Nothing, []) -> return EventsOK -- Nothing left to process. + (Just (Left er), _) -> return er -- some notification we didn't understand + (Just (Right evt), []) -> return $ ExtraEvent evt -- an event that doesn't match + (Nothing, _) -> do -- no event yet + threadDelay 1000000 + waitForEvent rc fs (del-1) + (Just (Right evt), _) -> do -- an event, does it match + ok <- testMP $ checkEvent evt + if ok + then case findMatch evt fs of + Nothing -> return $ ExtraEvent evt -- doesn't match + Just 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 + findMatch evt = go id + where + go unmatched (g@(r,t):gs) + | testEvent r t evt = Just (unmatched gs) + | otherwise = go (unmatched . (g:)) gs + go _ [] = Nothing + + +-- | Get one received event (and remove it from the underlying +-- storage). +popReceivedEvent :: ReceivedEvents -> IO (Maybe (Either EventResult Event)) +popReceivedEvent (ReceivedEvents mv) = do + evts <- takeMVar mv + case evts of + [] -> do + putMVar mv [] + return Nothing + (e:es) -> do + putMVar mv es + return $ Just e + + +-- | Get all received events (and remove them from the underlying +-- storage). Useful after running all tests to ensure that all +-- events were processed. +popReceivedEvents :: ReceivedEvents -> IO [Either EventResult Event] +popReceivedEvents (ReceivedEvents mv) = do + evts <- takeMVar mv + putMVar mv [] + return evts + + +-- | Wait for the given number of seconds and check if any +-- MangoPay event has arrived. Fails if so. Use this function +-- at the end of your test run to ensure that you're aware of +-- every MangoPay event. +ensureNoEvents :: Int -> Assertion +ensureNoEvents seconds = do + -- Wait in case events still arrive. + threadDelay $ seconds * 1000000 + res <- tsReceivedEvents <$> I.readIORef testState + evts <- popReceivedEvents res + assertEqual "ensureNoEvents" [] evts + + +---------------------------------------------------------------------- + + +-- | The test state as a top level global variable +-- () +-- since HTF does not let us thread a parameter through tests. +testState :: I.IORef TestState +testState = unsafePerformIO (I.newIORef $ TestState zero zero zero zero zero) + where zero = error "testState has not been initialized yet" +{-# NOINLINE testState #-} + + +-- | The test state we keep over all tests. +data TestState = + TestState + { tsAccessToken :: AccessToken -- ^ The access token if we're logged in. + , tsCredentials :: Credentials -- ^ The credentials. + , tsManager :: H.Manager -- ^ The HTTP manager. + , tsHookEndPoint :: HookEndPoint -- ^ The end point for notifications. + , tsReceivedEvents :: ReceivedEvents -- ^ The received events. + } + + +-- | Get the HTTP manager used by the tests. +getTestHttpManager :: IO H.Manager +getTestHttpManager = tsManager <$> I.readIORef testState + + +-- | (Internal) The events received via the notification hook. +-- Uses an @MVar@ for storing events. +newtype ReceivedEvents = ReceivedEvents (MVar [Either EventResult Event]) + + +-- | (Internal) Create a new 'ReceivedEvents'. +newReceivedEvents :: IO ReceivedEvents +newReceivedEvents = ReceivedEvents <$> newMVar [] + + +---------------------------------------------------------------------- + + +-- | Creates and initializes the MangoPay infrastructure needed +-- to use the test helpers from this module. Tears down the +-- server at the end. +-- +-- You may want to use 'ensureNoEvents' at the end of your action +-- before tearing down the server. +-- +-- This module uses global, shared state. You have to wrap your +-- entire test suite with this function, and you can't use +-- 'withMangoPayTests' more than once. +-- +-- Reads two files from the current directory: +-- +-- * @client.test.conf@ (can be generated by mangopay-passphrase). +-- +-- * @hook.test.conf@, json file containing object with "Url" +-- and "Port" fields. The first is the URL used to access this +-- server's root, while the second is the port this server +-- should listen to. +withMangoPayTestUtils + :: IO a + -- ^ Action to run while being able to use functions from + -- this module. + -> IO a +withMangoPayTestUtils act = + H.withManager $ \mgr -> liftIO $ do + hook <- getHookEndPoint + res <- newReceivedEvents + -- Initial state. + I.modifyIORef testState $ \ts -> + ts { tsManager = mgr + , tsHookEndPoint = hook + , tsReceivedEvents = res } + bracket + (startHTTPServer hook res) + killThread + (const $ initializeTestState >> act) + + +---------------------------------------------------------------------- + + +-- | (Internal) Read end point information from @hook.test.conf@ +-- in current folder. +getHookEndPoint :: IO HookEndPoint +getHookEndPoint = do + js <- BSL.readFile "hook.test.conf" + let Just mhook = A.decode js + return mhook + + +-- | (Internal) Simple configuration to tell the tests what +-- endpoint to use for notifications. +data HookEndPoint = + HookEndPoint + { hepUrl :: Text + , hepPort :: Int + } deriving (Show, Read, Eq, Ord, Typeable) + +instance A.ToJSON HookEndPoint where + toJSON h = + A.object + [ "Url" A..= hepUrl h + , "Port" A..= hepPort h ] + +instance A.FromJSON HookEndPoint where + parseJSON (A.Object v) = + HookEndPoint + <$> v A..: "Url" + <*> v A..: "Port" + parseJSON _ = fail "HookEndPoint" + + + +---------------------------------------------------------------------- + + +-- | Start a HTTP server listening on the given port. If the +-- path info is "mphook", then we'll push the received event to +-- the given 'ReceivedEvents'. +startHTTPServer :: HookEndPoint -> ReceivedEvents -> IO ThreadId +startHTTPServer hook revts = forkIO $ run (hepPort hook) app + where + app req respond = runStdoutLoggingT (checkAndPushEvent req) >> respond noop + checkAndPushEvent req + | dropWhile T.null (W.pathInfo req) == ["mphook"] = do + liftIO $ pushReceivedEvent revts toPush + $(logDebugS) src (T.pack toLog) + | otherwise = + $(logWarnS) src $ T.pack $ concat + [ "Received HTTP request for path " + , show (W.pathInfo req) + , ", ignoring." ] + where + (toPush, toLog) = + case eventFromQueryString qs of + Just evt -> (Right evt, "Received event:" ++ show evt) + Nothing -> ( Left $ UnhandledNotification $ show qs + , "Could not parse event " ++ show qs ) + where qs = W.queryString req + noop = + W.responseBuilder status200 [("Content-Type", "text/plain")] $ + copyByteString "noop" + src = "mangopay-testutils" + + + +-- | (Internal) Add a new event. +pushReceivedEvent :: ReceivedEvents -> Either EventResult Event -> IO () +pushReceivedEvent (ReceivedEvents mv) evt = do + evts' <- takeMVar mv + -- we're getting events in duplicate ??? + let ns = if evt `Prelude.elem` evts' then evts' else evt:evts' + putMVar mv ns + + +---------------------------------------------------------------------- + + +-- | Initialize credentials, access token and hooks. +-- +-- Takes the name/email from @client.test.conf@ in the current directory +-- (this file can be generated by mangopay-passphrase), +-- generates a new id/name, keeps the same email and generates a new secret +-- saves the secret to use in other tests. +initializeTestState :: IO () +initializeTestState = do + mgr <- getTestHttpManager + creds <- createCredentials mgr + at <- createAccessToken mgr creds + I.modifyIORef testState $ \ts -> + ts { tsCredentials = creds + , tsAccessToken = toAccessToken at } + listenForAll + + +-- | (Internal) Add the current time as a suffix to the client id +-- and name of the credentials. +addCredsSuffix :: Credentials -> POSIXTime -> Credentials +addCredsSuffix creds ct = + creds + { cClientSecret = Nothing + , cClientId = T.append (cClientId creds) suff + , cName = T.append (cName creds) suff } + where suff = + T.pack $ + reverse $ take (20 - clidlen) $ reverse $ + show (round ct :: Integer) + clidlen = T.length $ cClientId creds + + +-- | (Internal) Create new 'Credentials' using the ones at +-- @client.test.conf@ and 'addCredsSuffix'. +createCredentials :: H.Manager -> IO Credentials +createCredentials mgr = do + Just origCreds <- A.decode <$> BSL.readFile "client.test.conf" + suffixedCreds <- addCredsSuffix origCreds <$> getPOSIXTime + createdCreds <- + runResourceT $ + runStdoutLoggingT $ + runMangoPayT suffixedCreds mgr Sandbox createCredentialsSecret + assertBool "createCredentials/has secret" (isJust $ cClientSecret createdCreds) + return createdCreds + + +-- | (Internal) Create access token from the 'Credentials'. +createAccessToken :: H.Manager -> Credentials -> IO OAuthToken +createAccessToken mgr creds = + let Just secret = cClientSecret creds + in runResourceT $ + runStdoutLoggingT $ + runMangoPayT creds mgr Sandbox $ + oauthLogin (cClientId creds) secret + + +-- | (Internal) Listen for all event types. +listenForAll :: IO () +listenForAll = mapM_ listenFor [minBound .. maxBound] + + +-- | (Internal) Create a hook for a given event type. +listenFor :: EventType -> IO () +listenFor evtT = do + hook <- liftM tsHookEndPoint $ I.readIORef testState + h <- testMP $ createHook (Hook Nothing Nothing Nothing (hepUrl hook <> "/mphook") Enabled Nothing evtT) + h2 <- testMP $ let Just id_ = hId h in fetchHook id_ + assertEqual "listenFor/id" (hId h) (hId h2) + assertEqual "listenFor/valid" (Just Valid) (hValidity h) + + +---------------------------------------------------------------------- + + +-- | Perform the full registration of a card. +-- +-- This function is UNSAFE, because if you use this, YOU handle +-- 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 <- createCardRegistration cr1 at + -- Register it. + cr3 <- liftIO $ unsafeRegisterCard cardInfo cr2 + -- Save registered version. + modifyCardRegistration cr3 at + + +-- | Register a card with the registration URL. +-- +-- This function is UNSAFE, because if you use this, YOU handle +-- the user's credit card details so you need to be PCI +-- compliant! +-- +-- XXX This is not working anymore. +unsafeRegisterCard :: CardInfo -> CardRegistration -> IO CardRegistration + +unsafeRegisterCard ci cr@(CardRegistration + { crCardRegistrationURL = Just url + , crPreregistrationData = Just pre + , crAccessKey = Just ak }) = do + mgr <- getTestHttpManager + req <- H.parseUrl $ T.unpack url + let b = + HT.renderQuery False $ HT.toQuery + [ "accessKeyRef" ?+ ak + , "data" ?+ pre + , "cardNumber" ?+ ciNumber ci + , "cardExpirationDate" ?+ (writeCardExpiration $ ciExpire ci) + , "cardCvx" ?+ ciCSC ci ] + 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 + ("unsafeRegisterCard/\"data=\" prefix of " ++ show t) + ("data=" `T.isPrefixOf` t) + return cr { crRegistrationData = Just t } +unsafeRegisterCard _ _ = do + assertFailure "CardRegistration not ready" + error "never here" diff --git a/test/Web/MangoPay/AccessTest.hs b/test/Web/MangoPay/AccessTest.hs deleted file mode 100644 --- a/test/Web/MangoPay/AccessTest.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -F -pgmF htfpp #-} --- | test access functions that can be tested -module Web.MangoPay.AccessTest where - - -import Web.MangoPay hiding (createHook) -import Web.MangoPay.TestUtils - -import Test.Framework -import Test.HUnit (Assertion) -import Data.Aeson -import qualified Data.Text as T -import Data.Maybe (fromJust, isJust) -import Data.ByteString.Lazy as BS -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.IORef (modifyIORef,readIORef) -import Control.Monad (liftM) -import Control.Monad.Trans.Resource (runResourceT) -import Control.Monad.Logger - --- | Take the name/email from client.conf in the current directory --- (this file can be generated by mangopay-passphrase) --- generates a new id/name, keeps the same email and generates a new secret --- saves the secret to use in other tests -test_CreateCredentials :: Assertion -test_CreateCredentials=do - js<-BS.readFile "client.conf" - let mcred=decode js - assertBool (isJust mcred) - ct<-getPOSIXTime - -- max 20 characters in ClientId - let suff=T.take 20 $ T.pack $ show $ round ct - let creds=(fromJust mcred) - let newCreds=creds{cClientSecret=Nothing, - cClientId=T.append (cClientId creds) suff, - cName=T.append (cName creds) suff} - mgr<-liftM tsManager $ readIORef testState - creds2<-runResourceT $ runStdoutLoggingT $ runMangoPayT newCreds mgr Sandbox createCredentialsSecret - assertBool (isJust $ cClientSecret creds2) - let s=fromJust $ cClientSecret creds2 - -- login once with our new credentials - oat<-runResourceT $ runStdoutLoggingT $ runMangoPayT creds2 mgr Sandbox $ - oauthLogin (cClientId creds2) s - -- store access token and credentials - modifyIORef testState (\ts->ts{tsAccessToken=toAccessToken oat,tsCredentials=creds2}) - -- create hooks for all event types - mapM_ createHook [minBound .. maxBound] diff --git a/test/Web/MangoPay/TestUtils.hs b/test/Web/MangoPay/TestUtils.hs deleted file mode 100644 --- a/test/Web/MangoPay/TestUtils.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, FlexibleContexts, - OverloadedStrings, PatternGuards, RankNTypes #-} -{-# OPTIONS_GHC -F -pgmF htfpp #-} -module Web.MangoPay.TestUtils where - -import Web.MangoPay - -import qualified Data.ByteString.Lazy as BSL hiding (map,any,null) -import Network.HTTP.Conduit as H -import Data.Maybe -import Test.Framework - -import Network.Wai as W -import Network.Wai.Handler.Warp -import Network.HTTP.Types (status200) -import Blaze.ByteString.Builder (copyByteString) -import Data.Aeson as A -import Control.Concurrent (forkIO, ThreadId, threadDelay) -import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) -import Control.Monad (when, void, liftM) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (ResourceT, runResourceT) - -import Data.Text as T (Text, unpack, isPrefixOf) -import Data.List -import Data.Typeable -import Control.Applicative -import Test.HUnit (Assertion) -import Data.Default (def) -import Data.IORef -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 (($$+-)) -import Data.Monoid ((<>)) - --- | a test card -testCardInfo1 :: CardInfo -testCardInfo1 = CardInfo "4970100000000154" "1220" "123" - --- | test MangoPay API call, logging in with the client credentials --- expects a file called client.test.conf containing the JSON of client credentials --- in the current directory -testMP :: forall b. - (AccessToken -> MangoPayT (LoggingT (ResourceT IO)) b) - -> IO b -testMP f= do - ior<-readIORef testState - let mgr=tsManager ior - let at=tsAccessToken ior - let cred=tsCredentials ior - runResourceT $ runStdoutLoggingT $ runMangoPayT cred mgr Sandbox $ f at - --- | the test state as a top level global variable --- --- since HTF does not let us thread a parameter through tests -testState :: IORef TestState -{-# NOINLINE testState #-} -testState = unsafePerformIO (newIORef $ TestState zero zero zero zero zero) - where zero=error "testState has not been initialized yet" - - --- | the test state we keep over all tests -data TestState=TestState { - tsAccessToken :: AccessToken -- ^ the access token if we're logged in - ,tsCredentials :: Credentials -- ^ the credentials - ,tsManager :: H.Manager -- ^ the http manager - ,tsHookEndPoint :: HookEndPoint -- ^ the end point for notifications - ,tsReceivedEvents :: ReceivedEvents -- ^ the received events - } - - --- | read end point information from hook.test.conf in current folder -getHookEndPoint :: IO HookEndPoint -getHookEndPoint = do - js<-BSL.readFile "hook.test.conf" - let mhook=decode js - assertBool (isJust mhook) - return $ fromJust mhook - --- | simple configuration to tell the tests what endpoint to use for notifications -data HookEndPoint = HookEndPoint{ - hepUrl :: Text - ,hepPort :: Int - } deriving (Show,Read,Eq,Ord,Typeable) - --- | to json -instance ToJSON HookEndPoint where - toJSON h=object ["Url" .= hepUrl h,"Port" .= hepPort h] - --- | from json -instance FromJSON HookEndPoint where - parseJSON (Object v) =HookEndPoint <$> - v .: "Url" <*> - v .: "Port" - parseJSON _=fail "HookEndPoint" - - --- | the events received via the notification hook --- uses a MVar for storing events -data ReceivedEvents=ReceivedEvents{ - events::MVar [Either EventResult Event] - } - --- | creates the new ReceivedEvents -newReceivedEvents :: IO ReceivedEvents -newReceivedEvents=do - mv<-newMVar [] - return $ ReceivedEvents mv - --- | test an event, checking the resource id and the event type -testEvent :: Maybe Text -> EventType -> Event -> Bool -testEvent tid et evt= tid == (Just $ eResourceId evt) - && et == eEventType evt - --- | check that we're receiving events of the given type with the resource id returned by the passed test -testEventTypes :: [EventType] - -> IO (Maybe Text) - -> Assertion -testEventTypes evtTs =void . testEventTypes' evtTs - --- | check that we're receiving events of the given type with the resource id returned by the passed test --- returns the result of the inner test -testEventTypes' :: [EventType] - -> IO (Maybe Text) - -> IO (Maybe Text) -testEventTypes' evtTs ops=do - res<-liftM tsReceivedEvents $ readIORef testState - a<-ops - mapM_ (testSearchEvent a) evtTs - er<-waitForEvent res (map (testEvent a) evtTs) 5 - assertEqual EventsOK er - return a - --- | 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 $ searchAllEvents (def{espEventType=Just evtT}) - assertBool (not $ null es) - assertBool (any ((tid ==) . Just . eResourceId) es) - --- | create a hook for a given event type -createHook :: EventType -> Assertion -createHook evtT= do - hook<-liftM tsHookEndPoint $ readIORef testState - h<-testMP $ Web.MangoPay.createHook (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) - assertEqual (Just Valid) (hValidity h) - --- | run a test with the notification server running -testEvents :: IO a -- ^ the test, returning a value - -> [a -> Event -> Bool] -- ^ the test on the events, taking into account the returned value - -> Assertion -testEvents ops tests=do - res<-liftM tsReceivedEvents $ readIORef testState - a<-ops - er<-waitForEvent res (map ($ a) tests) 5 - assertEqual EventsOK er - --- | result of waiting for event -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) - --- | wait till we receive all the expected events, and none other, for a maximum number of seconds -waitForEvent :: ReceivedEvents - -> [Event -> Bool] -- ^ function on the expected event - -> Integer -- ^ delay in seconds - -> IO EventResult -waitForEvent _ _ del | del<=0=return Timeout -waitForEvent rc fs del=do - mevt<-popReceivedEvent rc - case (mevt,fs) of - (Nothing,[])->return EventsOK -- nothing left to process - (Just (Left er),_)->return er -- some notification we didn't understand - (Just (Right evt),[])->return $ ExtraEvent evt -- an event that doesn't match - (Nothing,_)->do -- no event yet - threadDelay 1000000 - waitForEvent rc fs (del-1) - (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) - match1 evt (nfs,False) f - | f evt=(nfs,True) - | otherwise=(f:nfs,False) - match1 _ (nfs,True) f=(f:nfs,True) - --- | get one received event (and remove it from the underlying storage) -popReceivedEvent :: ReceivedEvents -> IO (Maybe (Either EventResult Event)) -popReceivedEvent (ReceivedEvents mv)=do - evts<-takeMVar mv - case evts of - []->do - putMVar mv [] - return Nothing - (e:es)->do - putMVar mv es - return $ Just e - --- | get all received events (and remove them from the underlying storage) -popReceivedEvents :: ReceivedEvents -> IO [Either EventResult Event] -popReceivedEvents (ReceivedEvents mv)=do - evts<-takeMVar mv - putMVar mv [] - return evts - --- | add a new event -pushReceivedEvent :: ReceivedEvents -> Either EventResult Event -> IO () -pushReceivedEvent (ReceivedEvents mv) evt=do - evts' <-takeMVar mv - -- we're getting events in duplicate ??? - let ns = if evt `Prelude.elem` evts' then evts' else evt:evts' - putMVar mv ns - --- | start a HTTP server listening on the given port --- if the path info is "mphook", then we'll push the received event -startHTTPServer :: Port -> ReceivedEvents -> IO ThreadId -startHTTPServer p revts= - forkIO $ run p app - where - app req respond = do - when (pathInfo req == ["mphook"]) $ do - let mevt=eventFromQueryString $ W.queryString req - liftIO $ case mevt of - Just evt->do - pushReceivedEvent revts $ Right evt - putStrLn $ "Received event:" ++ show evt - Nothing->pushReceivedEvent revts $ Left $ UnhandledNotification $ show $ W.queryString req - respond $ 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<-createCardRegistration cr1 at - -- register it - cr3<-liftIO $ unsafeRegisterCard cardInfo cr2 - -- save registered version - modifyCardRegistration 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" ?+ (writeCardExpiration $ 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" diff --git a/test/mangopay-tests.hs b/test/mangopay-tests.hs --- a/test/mangopay-tests.hs +++ b/test/mangopay-tests.hs @@ -4,9 +4,10 @@ import Test.Framework +import Test.HUnit (Assertion) +-- Order matters! import {-@ HTF_TESTS @-} Web.MangoPay.SimpleTest -import {-@ HTF_TESTS @-} Web.MangoPay.AccessTest import {-@ HTF_TESTS @-} Web.MangoPay.UsersTest import {-@ HTF_TESTS @-} Web.MangoPay.WalletsTest import {-@ HTF_TESTS @-} Web.MangoPay.DocumentsTest @@ -18,33 +19,14 @@ import Web.MangoPay.TestUtils -import Control.Exception (bracket) -import Network.HTTP.Conduit as H -import Control.Concurrent (killThread, threadDelay) -import Control.Monad.IO.Class (liftIO) -import Data.IORef (modifyIORef, readIORef) -import Test.HUnit (Assertion) -import Control.Monad (liftM) --- | test entry point -main :: IO() -main = H.withManager (\mgr->liftIO $ do - hook<-getHookEndPoint - res<-newReceivedEvents - -- initial state - modifyIORef testState (\ts->ts{tsManager=mgr,tsHookEndPoint=hook,tsReceivedEvents=res}) - bracket - (startHTTPServer (hepPort hook) res) - killThread - (\_->htfMain $ htf_importedTests ++ [htf_thisModulesTests]) - ) +-- | Test entry point. +main :: IO () +main = + withMangoPayTestUtils $ + htfMain $ htf_importedTests ++ [htf_thisModulesTests] --- | 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 - evts<-popReceivedEvents res - assertEqual [] evts +-- | Test there are no unprocessed events. +test_Final :: Assertion +test_Final = ensureNoEvents 5