mangopay 1.1 → 1.2
raw patch · 6 files changed
+173/−203 lines, 6 filesdep +conduit-extradep ~HUnitdep ~aesondep ~attoparsec
Dependencies added: conduit-extra
Dependency ranges changed: HUnit, aeson, attoparsec, attoparsec-conduit, base, base64-bytestring, blaze-builder, bytestring, case-insensitive, conduit, http-conduit, monad-logger, text, transformers, utf8-string, vector
Files
- mangopay.cabal +38/−62
- src/Web/MangoPay/Documents.hs +10/−14
- src/Web/MangoPay/Monad.hs +57/−58
- src/Web/MangoPay/Types.hs +35/−35
- test/Web/MangoPay/AccessTest.hs +5/−5
- test/Web/MangoPay/TestUtils.hs +28/−29
mangopay.cabal view
@@ -1,5 +1,5 @@ name: mangopay-version: 1.1+version: 1.2 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau <jpmoresmau@gmail.com>@@ -25,33 +25,42 @@ default: False description: Print debugging info. +flag conduit11+ description: conduit >= 1.1+ library hs-source-dirs: src build-depends:- base >= 4 && < 5- , bytestring >= 0.9 && < 0.11- , text == 0.11.*- , transformers >= 0.2 && < 0.4+ base >= 4 && < 5+ , bytestring >= 0.9+ , text >= 0.11+ , transformers >= 0.2 && < 0.4 , transformers-base , monad-control , resourcet- , conduit == 1.0.* , http-types- , http-conduit == 2.0.*+ , http-conduit >= 2.0 && < 2.2 , attoparsec >= 0.10 && < 0.12- , attoparsec-conduit == 1.0.* , aeson >= 0.5 && < 0.8 , time , data-default , lifted-base , unordered-containers , base16-bytestring- , utf8-string >=0.3.7 && <0.4- , base64-bytestring >=1.0.0 && <1.1- , case-insensitive >=1.1.0 && <1.2+ , utf8-string >= 0.3.7+ , base64-bytestring >= 1.0+ , case-insensitive >= 1.1 , monad-logger >= 0.3 && < 0.4 , vector >=0.10.9 && <0.11 , template-haskell+ if flag(conduit11)+ build-depends:+ conduit == 1.1.*+ , conduit-extra == 1.1.*+ else+ build-depends:+ conduit == 1.0.*+ , attoparsec-conduit == 1.0.* ghc-options: -Wall other-modules: Web.MangoPay.Access,@@ -73,30 +82,10 @@ executable mangopay-passphrase build-depends:- base >= 4+ base, aeson, bytestring, http-conduit,+ monad-logger, text, transformers+ , mangopay- , bytestring >= 0.9 && < 0.11- , text == 0.11.*- , transformers >= 0.2 && < 0.4- , transformers-base- , monad-control- , resourcet- , conduit == 1.0.*- , http-types- , http-conduit == 2.0.*- , attoparsec >= 0.10 && < 0.12- , attoparsec-conduit == 1.0.*- , aeson >= 0.5 && < 0.8- , time- , data-default- , lifted-base- , unordered-containers- , base16-bytestring- , utf8-string >=0.3.7 && <0.4- , case-insensitive >=1.1.0 && <1.2- , monad-logger >= 0.3 && < 0.4- , vector >=0.10.9 && <0.11- , template-haskell ghc-options: -Wall -rtsopts hs-source-dirs: exe main-is: Main.hs@@ -108,35 +97,22 @@ main-is: mangopay-tests.hs ghc-options: -Wall -rtsopts -threaded build-depends:- base >= 4, HTF > 0.9- , mangopay- , bytestring >= 0.9 && < 0.11- , text == 0.11.*- , transformers >= 0.2 && < 0.4- , transformers-base- , monad-control- , resourcet- , conduit == 1.0.*- , http-types- , http-conduit == 2.0.*- , attoparsec >= 0.10 && < 0.12- , attoparsec-conduit == 1.0.*- , aeson >= 0.5 && < 0.8- , time- , data-default- , lifted-base- , unordered-containers- , base16-bytestring- , HUnit >=1.2.5 && <1.3- , utf8-string >=0.3.7 && <0.4- , blaze-builder >=0.3.1 && <0.4- , warp+ 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++ , blaze-builder+ , HTF > 0.9+ , HUnit >= 1.2.5 , wai- , base64-bytestring >=1.0.0 && <1.1- , case-insensitive >=1.1.0 && <1.2- , monad-logger >= 0.3 && < 0.4- , vector >=0.10.9 && <0.11- , template-haskell+ , warp+ if flag(conduit11)+ build-depends: conduit-extra+ else+ build-depends: attoparsec-conduit other-modules: Web.MangoPay.UsersTest, Web.MangoPay.TestUtils,
src/Web/MangoPay/Documents.hs view
@@ -15,13 +15,13 @@ import qualified Network.HTTP.Types as HT import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as BS+import qualified Data.ByteString.Base64 as B64 import qualified Data.Text.Encoding as TE -- | create or edit a document storeDocument :: (MPUsableMonad m) => AnyUserID -> Document -> AccessToken -> MangoPayT m Document-storeDocument uid d at= +storeDocument uid d at= case dId d of Nothing-> do url<-getClientURLMultiple ["/users/",uid,"/KYC/documents/"]@@ -29,21 +29,21 @@ Just i-> do url<-getClientURLMultiple ["/users/",uid,"/KYC/documents/",i] putExchange url (Just at) d- + -- | fetch a document from its ID fetchDocument :: (MPUsableMonad m) => AnyUserID -> DocumentID -> AccessToken -> MangoPayT m Document fetchDocument uid did at=do url<-getClientURLMultiple ["/users/",uid,"/KYC/documents/",did] req<-getGetRequest url (Just at) ([]::HT.Query)- getJSONResponse req + getJSONResponse req -- | create a page -- note that per the MangoPay API the document HAS to be in CREATED status -- should we check it here? Since MangoPay returns a 500 Internal Server Error if the document is in another status... storePage :: (MPUsableMonad m) => AnyUserID -> DocumentID -> BS.ByteString -> AccessToken -> MangoPayT m () storePage uid did contents at=do- let val=object ["File" .= TE.decodeLatin1 (BS.encode contents)]+ let val=object ["File" .= TE.decodeUtf8 (B64.encode contents)] url<-getClientURLMultiple ["/users/",uid,"/KYC/documents/",did,"/pages"] postNoReply url (Just at) val @@ -71,7 +71,7 @@ data DocumentStatus=CREATED | VALIDATION_ASKED | VALIDATED- | REFUSED + | REFUSED deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) -- | to json as per MangoPay format@@ -93,14 +93,14 @@ ,dRefusedReasonType :: Maybe Text ,dRefusedReasonMessage :: Maybe Text } deriving (Show,Ord,Eq,Typeable)- - --- | to json as per MangoPay format +++-- | to json as per MangoPay format instance ToJSON Document where toJSON d=object ["Tag" .= dTag d, "Type" .= dType d,"Status" .= dStatus d] --- | from json as per MangoPay format +-- | from json as per MangoPay format instance FromJSON Document where parseJSON (Object v) =Document <$> v .: "Id" <*>@@ -111,7 +111,3 @@ v .:? "RefusedReasonType" <*> v .:? "RefusedReasonMessage" parseJSON _=fail "Document"- - - -
src/Web/MangoPay/Monad.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies,- FlexibleContexts, RankNTypes,CPP,TemplateHaskell #-}+ FlexibleContexts, RankNTypes,CPP,TemplateHaskell, StandaloneDeriving #-} -- | the utility monad and related functions, taking care of the HTTP, JSON, etc. module Web.MangoPay.Monad where import Web.MangoPay.Types -import Control.Applicative +import Control.Applicative import Control.Monad (MonadPlus, liftM, void, join) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Monad.Trans.Control ( MonadTransControl(..), MonadBaseControl(..) , ComposeSt, defaultLiftBaseWith@@ -28,7 +28,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Aeson (json,fromJSON,Result(..),FromJSON, ToJSON,encode) import Data.Conduit.Attoparsec (sinkParser, ParseError) import qualified Data.Text.Encoding as TE@@ -45,15 +44,17 @@ #endif -- | put our constraints in one synonym-type MPUsableMonad m=(MonadBaseControl IO m, C.MonadResource m, MonadLogger m)+type MPUsableMonad m=(MonadBaseControl IO m, R.MonadResource m, MonadLogger m) -- | the mangopay monad transformer -- this encapsulates the data necessary to pass the app credentials, etc newtype MangoPayT m a = Mp { unIs :: ReaderT MpData m a } deriving ( Functor, Applicative, Alternative, Monad , MonadFix, MonadPlus, MonadIO, MonadTrans- , R.MonadThrow, R.MonadActive, R.MonadResource )- + , R.MonadThrow )++deriving instance R.MonadResource m => R.MonadResource (MangoPayT m)+ instance MonadBase b m => MonadBase b (MangoPayT m) where liftBase = lift . liftBase @@ -69,7 +70,7 @@ instance (MonadLogger m) => MonadLogger (MangoPayT m) where monadLoggerLog loc src lvl msg=lift $ monadLoggerLog loc src lvl msg- + -- | Run a computation in the 'MangoPayT' monad transformer with -- your credentials. runMangoPayT :: Credentials -- ^ Your app's credentials.@@ -78,8 +79,8 @@ -> MangoPayT m a -- ^ the action to run -> m a -- ^ the result runMangoPayT creds manager ap (Mp act) =- runReaderT act (MpData creds manager ap) - + runReaderT act (MpData creds manager ap)+ -- | Get the user's credentials. getCreds :: Monad m => MangoPayT m Credentials getCreds = mpCreds `liftM` Mp ask@@ -95,11 +96,11 @@ -> MangoPayT m H.Request -- ^ the properly configured request getPostRequest path mat query=do host<-getHost- let b=HT.renderQuery False $ HT.toQuery query + let b=HT.renderQuery False $ HT.toQuery query #if DEBUG liftIO $ BSC.putStrLn path liftIO $ BSC.putStrLn b-#endif +#endif return $ def { H.secure=True , H.host = host@@ -107,9 +108,9 @@ , H.path = path , H.method=HT.methodPost , H.requestHeaders=[("content-type","application/x-www-form-urlencoded")] ++- case mat of + case mat of Just (AccessToken at)->[("Authorization",at)]- _->[] + _->[] , H.requestBody=H.RequestBodyBS b } @@ -123,7 +124,7 @@ let qs=HT.renderQuery True $ HT.toQuery query #if DEBUG liftIO $ BSC.putStrLn $ BS.append path qs-#endif +#endif return $ def { H.secure=True , H.host = host@@ -133,7 +134,7 @@ , H.queryString=qs , H.requestHeaders=getJSONHeaders mat }- + -- | build a delete request to MangoPay getDeleteRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString -- ^ the url path -> Maybe AccessToken@@ -159,7 +160,7 @@ -- | build a URL for a get operation with a single query getQueryURL :: (Monad m,HT.QueryLike q) => ByteString -- ^ the url path- -> q -- ^ the query parameters + -> q -- ^ the query parameters -> MangoPayT m ByteString -- ^ the URL getQueryURL path query=do host<-getHost@@ -167,9 +168,9 @@ -- | perform a HTTP request and deal with the JSON result -- The logic for errors is as follows: we have several cases:--- If the HTTP request return OK and we can parse the proper result, we return it. --- If we can't parse it into the data type we expect, we throw a MpJSONException: the server returned ok but we can't parse the result. --- If we get an HTTP error code, we try to parse the result and send the proper exception: we have encountered probably a normal error, when the user has filled in incorrect data, etc. +-- If the HTTP request return OK and we can parse the proper result, we return it.+-- If we can't parse it into the data type we expect, we throw a MpJSONException: the server returned ok but we can't parse the result.+-- If we get an HTTP error code, we try to parse the result and send the proper exception: we have encountered probably a normal error, when the user has filled in incorrect data, etc. -- If we can't even parse the result as JSON or if we can't understand the JSON error message, we throw an MpHttpException. mpReq :: forall b (m :: * -> *) wrappedErr c . (MPUsableMonad m,FromJSON b,FromJSON wrappedErr) =>@@ -187,16 +188,16 @@ cookies = H.responseCookieJar res ok=isOkay status err=H.StatusCodeException status headers cookies- mpres<-L.catch (do + mpres<-L.catch (do #if DEBUG (value,_)<-H.responseBody res C.$$+- zipSinks (sinkParser json) (sinkHandle stdout) liftIO $ BSC.putStrLn "" liftIO $ print headers-#else +#else value<-H.responseBody res C.$$+- sinkParser json #endif if ok- then + then -- parse response as the expected value case fromJSON value of Success ot->return $ Right (value,addHeaders headers ot)@@ -206,12 +207,12 @@ case fromJSON value of Success ise-> return $ Left $ MpAppException $ extractError ise _ -> return $ Left $ MpHttpException err $ Just value -- we can't even parse the error, throw the HTTP error inside our error type, but keep the JSON in case a human can make sens of it- ) (\(_::ParseError)->return $ Left $ MpHttpException err Nothing) -- the error body wasn't even json, throw the HTTP error inside our error type + ) (\(_::ParseError)->return $ Left $ MpHttpException err Nothing) -- the error body wasn't even json, throw the HTTP error inside our error type let cr=CallRecord req' mpres -- log call $(logCall) cr return $ recordResult cr- + -- | get a JSON response from a request to MangoPay -- MangoPay returns either a result, or an error getJSONResponse :: forall (m :: * -> *) v.@@ -239,48 +240,48 @@ getI :: CI ByteString -> Maybe Integer getI =join . fmap ((maybeRead :: String -> Maybe Integer). BSC.unpack) . findAssoc headers --- | get all items, hiding the pagination system -getAll :: (MPUsableMonad m,FromJSON v) => - (Maybe Pagination -> AccessToken -> MangoPayT m (PagedList v)) -> AccessToken -> +-- | get all items, hiding the pagination system+getAll :: (MPUsableMonad m,FromJSON v) =>+ (Maybe Pagination -> AccessToken -> MangoPayT m (PagedList v)) -> AccessToken -> MangoPayT m [v] getAll f at=readAll 1 []- where + where readAll p accum=do retL<-f (Just $ Pagination p 100) at let dts=accum ++ plData retL- if plPageCount retL > p + if plPageCount retL > p then readAll (p + 1) dts else return dts- --- | get the headers necessary for a JSON call ++-- | get the headers necessary for a JSON call getJSONHeaders :: Maybe AccessToken -> HT.RequestHeaders getJSONHeaders mat= ("content-type", "application/json") : case mat of Just (AccessToken at) -> [("Authorization", at)]- _ -> [] + _ -> [] --- | send JSON via post, get JSON back +-- | send JSON via post, get JSON back postExchange :: forall (m :: * -> *) v p. (MPUsableMonad m,FromJSON v,ToJSON p) => ByteString -> Maybe AccessToken -> p -> MangoPayT- m v + m v postExchange=jsonExchange HT.methodPost --- | send JSON via post, get JSON back +-- | send JSON via post, get JSON back putExchange :: forall (m :: * -> *) v p. (MPUsableMonad m,FromJSON v,ToJSON p) => ByteString -> Maybe AccessToken -> p -> MangoPayT- m v + m v putExchange=jsonExchange HT.methodPut- --- | send JSON, get JSON back ++-- | send JSON, get JSON back jsonExchange :: forall (m :: * -> *) v p. (MPUsableMonad m,FromJSON v,ToJSON p) => HT.Method@@ -288,23 +289,23 @@ -> Maybe AccessToken -> p -> MangoPayT- m v + m v jsonExchange meth path mat p= getJSONRequest meth path mat p >>= getJSONResponse- --- | get JSON request ++-- | get JSON request getJSONRequest :: forall (m :: * -> *) p. (MPUsableMonad m,ToJSON p) => HT.Method -> ByteString -> Maybe AccessToken -> p- -> MangoPayT m H.Request -- ^ the properly configured request + -> MangoPayT m H.Request -- ^ the properly configured request getJSONRequest meth path mat p= do host<-getHost #if DEBUG liftIO $ BSC.putStrLn path liftIO $ BSLC.putStrLn $ encode p-#endif +#endif return def { H.secure=True , H.host = host@@ -313,41 +314,41 @@ , H.method=meth , H.requestHeaders=getJSONHeaders mat , H.requestBody=H.RequestBodyLBS $ encode p- } - --- | post JSON content and ignore the reply + }++-- | post JSON content and ignore the reply postNoReply :: forall (m :: * -> *) p. (MPUsableMonad m,ToJSON p) => ByteString -> Maybe AccessToken -> p -> MangoPayT- m () + m () postNoReply path mat p= do req<- getJSONRequest HT.methodPost path mat p mgr<-getManager- void $ H.http req mgr - + void $ H.http req mgr+ -- | Get the 'H.Manager'. getManager :: Monad m => MangoPayT m H.Manager getManager = mpManager `liftM` Mp ask -- | Run a 'ResourceT' inside a 'MangoPayT'. runResourceInMp :: (MPUsableMonad m) =>- MangoPayT (C.ResourceT m) a+ MangoPayT (R.ResourceT m) a -> MangoPayT m a-runResourceInMp (Mp inner) = Mp $ ask >>= lift . C.runResourceT . runReaderT inner - +runResourceInMp (Mp inner) = Mp $ ask >>= lift . R.runResourceT . runReaderT inner+ -- | Transform the computation inside a 'MangoPayT'. mapMangoPayT :: (m a -> n b) -> MangoPayT m a -> MangoPayT n b-mapMangoPayT f = Mp . mapReaderT f . unIs - +mapMangoPayT f = Mp . mapReaderT f . unIs+ -- | the data kept through the computations data MpData = MpData { mpCreds::Credentials -- ^ app credentials ,mpManager::H.Manager -- ^ HTTP connection manager ,mpAccessPoint:: AccessPoint -- ^ access point- } + } deriving (Typeable) -- | @True@ if the the 'Status' is ok (i.e. @2XX@).@@ -355,5 +356,3 @@ isOkay status = let sc = HT.statusCode status in 200 <= sc && sc < 300--
src/Web/MangoPay/Types.hs view
@@ -7,7 +7,7 @@ import Control.Exception.Base (Exception,throw) import Data.Text as T hiding (singleton) import Data.Typeable (Typeable)-import Data.ByteString as BS (ByteString,null)+import Data.ByteString as BS (ByteString) import Data.Time.Clock.POSIX (POSIXTime) import Data.Aeson import Data.Default@@ -30,7 +30,7 @@ -- | the MangoPay access point data AccessPoint = Sandbox | Production | Custom ByteString deriving (Show,Read,Eq,Ord,Typeable)- + -- | get the real url for the given access point getAccessPointURL :: AccessPoint -> ByteString getAccessPointURL Sandbox="api.sandbox.mangopay.com"@@ -45,10 +45,10 @@ ,cClientSecret :: Maybe Text -- ^ client secret, maybe be Nothing if we haven't generated it } deriving (Show,Read,Eq,Ord,Typeable)- --- | to json as per MangoPay format ++-- | to json as per MangoPay format instance ToJSON Credentials where- toJSON c=object ["ClientId" .= cClientID c, "Name" .= cName c , "Email" .= cEmail c,"Passphrase" .= cClientSecret c] + toJSON c=object ["ClientId" .= cClientID c, "Name" .= cName c , "Email" .= cEmail c,"Passphrase" .= cClientSecret c] -- | from json as per MangoPay format instance FromJSON Credentials where@@ -57,8 +57,8 @@ v .: "Name" <*> v .: "Email" <*> v .: "Passphrase"- parseJSON _= fail "Credentials" - + parseJSON _= fail "Credentials"+ -- | get client id in ByteString form clientIDBS :: Credentials -> ByteString clientIDBS=TE.encodeUtf8 . cClientID@@ -67,8 +67,8 @@ -- | the access token is simply a Text newtype AccessToken=AccessToken ByteString deriving (Eq, Ord, Read, Show, Typeable)- - ++ -- | the oauth token returned after authentication data OAuthToken = OAuthToken { oaAccessToken :: Text -- ^ the access token@@ -79,28 +79,28 @@ -- | to json as per MangoPay format instance ToJSON OAuthToken where- toJSON oa=object ["access_token" .= oaAccessToken oa, "token_type" .= oaTokenType oa, "expires_in" .= oaExpires oa] + toJSON oa=object ["access_token" .= oaAccessToken oa, "token_type" .= oaTokenType oa, "expires_in" .= oaExpires oa] --- | from json as per MangoPay format +-- | from json as per MangoPay format instance FromJSON OAuthToken where parseJSON (Object v) =OAuthToken <$> v .: "access_token" <*> v .: "token_type" <*>- v .: "expires_in" - parseJSON _= fail "OAuthToken" - --- | build the access token from the OAuthToken + v .: "expires_in"+ parseJSON _= fail "OAuthToken"++-- | build the access token from the OAuthToken toAccessToken :: OAuthToken -> AccessToken toAccessToken oa=AccessToken $ TE.encodeUtf8 $ T.concat [oaTokenType oa, " ",oaAccessToken oa]- + -- | an exception that a call to MangoPay may throw data MpException = MpJSONException String -- ^ JSON parsingError | MpAppException MpError -- ^ application exception | MpHttpException H.HttpException (Maybe Value) -- ^ HTTP level exception, maybe with some JSON payload deriving (Show,Typeable) --- | make our exception type a normal exception -instance Exception MpException +-- | make our exception type a normal exception+instance Exception MpException -- | an error returned to us by MangoPay@@ -111,9 +111,9 @@ ,igeDate :: Maybe POSIXTime } deriving (Show,Eq,Ord,Typeable)- - - +++ -- | from json as per MangoPay format instance FromJSON MpError where parseJSON (Object v) = MpError <$>@@ -122,15 +122,15 @@ v .: "Message" <*> v .: "Date" parseJSON _= fail "MpError"- + instance FromJSON POSIXTime where parseJSON n@(Number _)=(fromIntegral . (round::Double -> Integer)) <$> parseJSON n parseJSON _ = fail "POSIXTime"- + -- | to json as per MangoPay format instance ToJSON POSIXTime where toJSON pt=toJSON (round pt :: Integer)- + -- | Pagination info for searches -- <http://docs.mangopay.com/api-references/pagination/> data Pagination = Pagination {@@ -138,11 +138,11 @@ ,pPerPage :: Integer } deriving (Show,Read,Eq,Ord,Typeable)- + instance Default Pagination where def=Pagination 1 10 --- | get pagination attributes for query +-- | get pagination attributes for query paginationAttributes :: Maybe Pagination -> [(ByteString,Maybe ByteString)] paginationAttributes (Just p)=["page" ?+ pPage p, "per_page" ?+ pPerPage p] paginationAttributes _=[]@@ -198,12 +198,12 @@ recordResult (CallRecord _ (Left err))=throw err recordResult (CallRecord _ (Right (_,a)))=a --- | log a CallRecord +-- | log a CallRecord -- MonadLogger doesn't expose a function with a dynamic log level... logCall :: Q Exp logCall = [|\a -> monadLoggerLog $(qLocation >>= liftLoc) "mangopay" (recordLogLevel a) (recordLogMessage a)|] --- | simple class used to hide the serialization of parameters and simplify the calling code +-- | simple class used to hide the serialization of parameters and simplify the calling code class ToHtQuery a where (?+) :: ByteString -> a -> (ByteString,Maybe ByteString) @@ -215,25 +215,25 @@ instance ToHtQuery Integer where n ?+ d=n ?+ show d- + instance ToHtQuery (Maybe Integer) where n ?+ d=n ?+ fmap show d- + instance ToHtQuery (Maybe POSIXTime) where n ?+ d=n ?+ fmap (show . (round :: POSIXTime -> Integer)) d- + instance ToHtQuery (Maybe T.Text) where n ?+ d=(n,fmap TE.encodeUtf8 d) instance ToHtQuery T.Text where n ?+ d=(n,Just $ TE.encodeUtf8 d)- + instance ToHtQuery (Maybe String) where- n ?+ d=(n,fmap UTF8.fromString d) + n ?+ d=(n,fmap UTF8.fromString d) instance ToHtQuery String where- n ?+ d=(n,Just $ UTF8.fromString d) + n ?+ d=(n,Just $ UTF8.fromString d) -- | find in assoc list findAssoc :: Eq a=> [(a,b)] -> a -> Maybe b@@ -241,4 +241,4 @@ -- | read an object or return Nothing maybeRead :: Read a => String -> Maybe a-maybeRead = fmap fst . listToMaybe . reads +maybeRead = fmap fst . listToMaybe . reads
test/Web/MangoPay/AccessTest.hs view
@@ -16,7 +16,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import Data.IORef (modifyIORef,readIORef) import Control.Monad (liftM)-import Data.Conduit (runResourceT)+import Control.Monad.Trans.Resource (runResourceT) import Control.Monad.Logger -- | Take the name/email from client.conf in the current directory@@ -35,14 +35,14 @@ let newCreds=creds{cClientSecret=Nothing, cClientID=T.append (cClientID creds) suff, cName=T.append (cName creds) suff}- mgr<-liftM tsManager $ readIORef testState + mgr<-liftM tsManager $ readIORef testState creds2<-runResourceT $ runStdoutLoggingT $ runMangoPayT newCreds mgr Sandbox createCredentialsSecret- assertBool (isJust $ cClientSecret creds2) + 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 + 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]
test/Web/MangoPay/TestUtils.hs view
@@ -6,7 +6,6 @@ import Data.ByteString.Lazy as BS hiding (map,any,null) import Network.HTTP.Conduit as H-import Data.Conduit import Data.Maybe import Test.Framework @@ -19,6 +18,7 @@ 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 (Text) import Data.List@@ -26,7 +26,7 @@ import Control.Applicative import Test.HUnit (Assertion) import Data.Default (def)-import Data.IORef +import Data.IORef import System.IO.Unsafe (unsafePerformIO) import Control.Monad.Logger @@ -36,13 +36,13 @@ -- | 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 +-- 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 + ior<-readIORef testState+ let mgr=tsManager ior let at=tsAccessToken ior let cred=tsCredentials ior runResourceT $ runStdoutLoggingT $ runMangoPayT cred mgr Sandbox $ f at@@ -64,13 +64,13 @@ ,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<-BS.readFile "hook.test.conf"- let mhook=decode js + let mhook=decode js assertBool (isJust mhook) return $ fromJust mhook @@ -80,15 +80,15 @@ ,hepPort :: Int } deriving (Show,Read,Eq,Ord,Typeable) --- | to json +-- | to json instance ToJSON HookEndPoint where toJSON h=object ["Url" .= hepUrl h,"Port" .= hepPort h] --- | from json +-- | from json instance FromJSON HookEndPoint where parseJSON (Object v) =HookEndPoint <$> v .: "Url" <*>- v .: "Port" + v .: "Port" parseJSON _=fail "HookEndPoint" @@ -101,23 +101,23 @@ -- | creates the new ReceivedEvents newReceivedEvents :: IO ReceivedEvents newReceivedEvents=do- mv<-newMVar [] + 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) +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] +testEventTypes :: [EventType] -> IO (Maybe Text) -> Assertion-testEventTypes evtTs =void . testEventTypes' evtTs +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] +testEventTypes' :: [EventType] -> IO (Maybe Text) -> IO (Maybe Text) testEventTypes' evtTs ops=do@@ -135,7 +135,7 @@ assertBool (not $ null es) assertBool (any ((tid ==) . Just . eResourceId) es) --- | create a hook for a given event type +-- | create a hook for a given event type createHook :: EventType -> Assertion createHook evtT= do hook<-liftM tsHookEndPoint $ readIORef testState@@ -144,7 +144,7 @@ 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@@ -154,7 +154,7 @@ a<-ops er<-waitForEvent res (map ($ a) tests) 30 assertEqual EventsOK er- + -- | result of waiting for event data EventResult = Timeout -- ^ didn't receive all expected events | EventsOK -- ^ OK: everything expected received, nothing unexpected@@ -163,7 +163,7 @@ deriving (Show,Eq,Ord,Typeable) -- | wait till we receive all the expected events, and none other, for a maximum number of seconds-waitForEvent :: ReceivedEvents +waitForEvent :: ReceivedEvents -> [Event -> Bool] -- ^ function on the expected event -> Integer -- ^ delay in seconds -> IO EventResult@@ -181,8 +181,8 @@ 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- - where ++ 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@@ -190,10 +190,10 @@ | otherwise=(f:nfs,False) match1 _ (nfs,True) f=(f:nfs,True) --- | get one received event (and remove it from the underlying storage) +-- | 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 + evts<-takeMVar mv case evts of []->do putMVar mv []@@ -202,25 +202,25 @@ putMVar mv es return $ Just e --- | get all received events (and remove them from the underlying storage) +-- | get all received events (and remove them from the underlying storage) popReceivedEvents :: ReceivedEvents -> IO [Either EventResult Event] popReceivedEvents (ReceivedEvents mv)=do- evts<-takeMVar mv + 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 + 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 +-- if the path info is "mphook", then we'll push the received event startHTTPServer :: Port -> ReceivedEvents -> IO ThreadId-startHTTPServer p revts= +startHTTPServer p revts= forkIO $ run p app where app req = do@@ -232,4 +232,3 @@ print evt Nothing->pushReceivedEvent revts $ Left $ UnhandledNotification $ show $ W.queryString req return $ W.responseBuilder status200 [("Content-Type", "text/plain")] $ copyByteString "noop"-