module Web.MangoPay.TestUtils
(
withMangoPayTestUtils
, testCardInfo1
, testMP
, testEventTypes
, testEventTypes'
, unsafeFullRegistration
, unsafeRegisterCard
, ensureNoEvents
, withWorkaroundManager
, newWorkaroundManager
) 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 (MonadIO, liftIO)
import Control.Monad.Trans.Control (MonadBaseControl)
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 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.Connection as Conn
import qualified Network.HTTP.Types as HT
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra as TLSX
import qualified Network.Wai as W
import qualified System.X509 as X509
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
secondsToWaitForEvent :: Integer
secondsToWaitForEvent = 20
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) secondsToWaitForEvent
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
:: ( Credentials
-> AccessToken
-> H.Manager
-> IO a )
-> IO a
withMangoPayTestUtils act =
withWorkaroundManager $ \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 >>= \(creds, at) -> act creds at mgr)
withWorkaroundManager :: (MonadIO m, MonadBaseControl IO m) => (H.Manager -> ResourceT m a) -> m a
withWorkaroundManager act = workaroundSettings >>= flip H.withManagerSettings act
newWorkaroundManager :: MonadIO m => m H.Manager
newWorkaroundManager = liftIO . H.newManager =<< workaroundSettings
workaroundSettings :: MonadIO m => m H.ManagerSettings
workaroundSettings = mkSettings `liftM` liftIO ioActions
where
ioActions =
X509.getSystemCertificateStore
mkParams certStore =
(TLS.defaultParamsClient neverHere neverHere)
{ TLS.clientSupported = def
{ TLS.supportedVersions = noTLS12
, TLS.supportedCiphers = TLSX.ciphersuite_all }
, TLS.clientShared = def
{ TLS.sharedCAStore = certStore }
}
where
noTLS12 = filter (/= TLS.TLS12) (TLS.supportedVersions def)
neverHere :: a
neverHere = error "withWorkaroundManager: never here, TLSSettings/ClientParams"
mkSettings =
flip H.mkManagerSettings Nothing . Conn.TLSSettings . mkParams
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, AccessToken)
initializeTestState = do
mgr <- getTestHttpManager
creds <- createCredentials mgr
at <- toAccessToken <$> createAccessToken mgr creds
I.modifyIORef testState $ \ts ->
ts { tsCredentials = creds
, tsAccessToken = at }
listenForAll
return (creds, at)
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"