diff --git a/mangopay.cabal b/mangopay.cabal --- a/mangopay.cabal +++ b/mangopay.cabal @@ -1,5 +1,5 @@ name: mangopay -version: 1.1 +version: 1.2 cabal-version: >= 1.8 build-type: Simple author: JP Moresmau @@ -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, diff --git a/src/Web/MangoPay/Documents.hs b/src/Web/MangoPay/Documents.hs --- a/src/Web/MangoPay/Documents.hs +++ b/src/Web/MangoPay/Documents.hs @@ -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" - - - - diff --git a/src/Web/MangoPay/Monad.hs b/src/Web/MangoPay/Monad.hs --- a/src/Web/MangoPay/Monad.hs +++ b/src/Web/MangoPay/Monad.hs @@ -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 - - diff --git a/src/Web/MangoPay/Types.hs b/src/Web/MangoPay/Types.hs --- a/src/Web/MangoPay/Types.hs +++ b/src/Web/MangoPay/Types.hs @@ -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 -- 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 diff --git a/test/Web/MangoPay/AccessTest.hs b/test/Web/MangoPay/AccessTest.hs --- a/test/Web/MangoPay/AccessTest.hs +++ b/test/Web/MangoPay/AccessTest.hs @@ -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] diff --git a/test/Web/MangoPay/TestUtils.hs b/test/Web/MangoPay/TestUtils.hs --- a/test/Web/MangoPay/TestUtils.hs +++ b/test/Web/MangoPay/TestUtils.hs @@ -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" -