module Web.MangoPay.TestUtils
(
withMangoPayTestUtils
, withMangoPayTestUtils'
, testCardInfo1
, testMP
, testEventTypes
, testEventTypes'
, unsafeFullRegistration
, unsafeRegisterCard
, 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.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 Control.Concurrent.Async as AS
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
testCardInfo1 :: CardInfo
testCardInfo1 = CardInfo "4970100000000154" "1220" "123"
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
testEvent :: Maybe Text -> EventType -> Event -> Bool
testEvent tid et evt =
tid == Just (eResourceId evt) &&
et == eEventType evt
testEventTypes :: [EventType] -> IO (Maybe Text) -> Assertion
testEventTypes evtTs = void . testEventTypes' evtTs
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) 20
assertEqual "testEventTypes'" EventsOK er
return a
data EventResult =
Timeout [(Maybe Text, EventType)]
| EventsOK
| ExtraEvent Event
| UncheckedEvent Event
| UnhandledNotification String
deriving (Show, Eq, Ord, Typeable)
waitForEvent
:: ReceivedEvents
-> [(Maybe Text, EventType)]
-> Integer
-> 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
(Just (Left er), _) -> return er
(Just (Right evt), []) -> return $ ExtraEvent evt
(Nothing, _) -> do
threadDelay 1000000
waitForEvent rc fs (del1)
(Just (Right evt), _) -> do
ok <- testMP $ checkEvent evt
if ok
then case findMatch evt fs of
Nothing -> return $ ExtraEvent evt
Just fs2 -> waitForEvent rc fs2 del
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
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
popReceivedEvents :: ReceivedEvents -> IO [Either EventResult Event]
popReceivedEvents (ReceivedEvents mv) = do
evts <- takeMVar mv
putMVar mv []
return evts
ensureNoEvents :: Int -> Assertion
ensureNoEvents seconds = do
threadDelay $ seconds * 1000000
res <- tsReceivedEvents <$> I.readIORef testState
evts <- popReceivedEvents res
assertEqual "ensureNoEvents" [] evts
testState :: I.IORef TestState
testState = unsafePerformIO (I.newIORef $ TestState zero zero zero zero zero)
where zero = error "testState has not been initialized yet"
data TestState =
TestState
{ tsAccessToken :: AccessToken
, tsCredentials :: Credentials
, tsManager :: H.Manager
, tsHookEndPoint :: HookEndPoint
, tsReceivedEvents :: ReceivedEvents
}
getTestHttpManager :: IO H.Manager
getTestHttpManager = tsManager <$> I.readIORef testState
newtype ReceivedEvents = ReceivedEvents (MVar [Either EventResult Event])
newReceivedEvents :: IO ReceivedEvents
newReceivedEvents = ReceivedEvents <$> newMVar []
withMangoPayTestUtils
:: IO a
-> IO a
withMangoPayTestUtils = withMangoPayTestUtils' . const . const
withMangoPayTestUtils'
:: ( Credentials
-> H.Manager
-> IO a )
-> IO a
withMangoPayTestUtils' act =
H.withManager $ \mgr -> liftIO $ do
hook <- getHookEndPoint
res <- newReceivedEvents
I.modifyIORef testState $ \ts ->
ts { tsManager = mgr
, tsHookEndPoint = hook
, tsReceivedEvents = res }
bracket
(startHTTPServer hook res)
killThread
(const $ initializeTestState >>= flip act mgr)
getHookEndPoint :: IO HookEndPoint
getHookEndPoint = do
js <- BSL.readFile "hook.test.conf"
let Just mhook = A.decode js
return mhook
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"
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"
pushReceivedEvent :: ReceivedEvents -> Either EventResult Event -> IO ()
pushReceivedEvent (ReceivedEvents mv) evt = do
evts' <- takeMVar mv
let ns = if evt `Prelude.elem` evts' then evts' else evt:evts'
putMVar mv ns
initializeTestState :: IO Credentials
initializeTestState = do
mgr <- getTestHttpManager
creds <- createCredentials mgr
at <- createAccessToken mgr creds
I.modifyIORef testState $ \ts ->
ts { tsCredentials = creds
, tsAccessToken = toAccessToken at }
listenForAll
return creds
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
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
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
listenForAll :: IO ()
listenForAll = void $ AS.mapConcurrently listenFor [minBound .. maxBound]
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)
unsafeFullRegistration
:: MPUsableMonad m => AnyUserId -> Currency -> CardInfo -> AccessToken -> MangoPayT m CardRegistration
unsafeFullRegistration uid currency cardInfo at = do
let cr1 = mkCardRegistration uid currency
cr2 <- createCardRegistration cr1 at
cr3 <- liftIO $ unsafeRegisterCard cardInfo cr2
modifyCardRegistration cr3 at
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"