mondo 0.2.0.0 → 0.3.0.0
raw patch · 10 files changed
+708/−236 lines, 10 filesdep +hspecdep +mondodep +networkdep ~servantdep ~servant-client
Dependencies added: hspec, mondo, network, servant-server, time, timerep, unordered-containers, wai, warp
Dependency ranges changed: servant, servant-client
Files
- README.md +5/−2
- examples/Example.hs +68/−0
- mondo.cabal +46/−9
- src/Mondo.hs +18/−1
- src/Mondo/API.hs +139/−133
- src/Mondo/Types.hs +313/−51
- test/Example.hs +0/−40
- test/Mondo/MondoSpec.hs +30/−0
- test/Mondo/Server.hs +88/−0
- test/Spec.hs +1/−0
README.md view
@@ -1,7 +1,10 @@ # Haskell bindings for the Mondo API +[](https://hackage.haskell.org/package/mondo) +[](https://travis-ci.org/mbg/mondo) + ## Getting started -There is some example code in `test/Example.hs`. The code assumes that a file named `token.txt` containing a valid OAuth token is in the same folder. +There is some example code in `examples/Example.hs`. The code assumes that a file named `token.txt` containing a valid OAuth token is in the same folder. -To run the example, run `cabal repl` (if using a cabal sandbox) or `ghci Mondo.hs` (if not). Then load the example into the REPL with `:l test/Example.hs`. Finally, invoke the example with `withMondo token foo`. +To run the example, run `cabal repl` (if using a cabal sandbox) or `ghci Mondo.hs` (if not). Then load the example into the REPL with `:l examples/Example.hs`. Finally, invoke the example with `withMondo token foo`.
+ examples/Example.hs view
@@ -0,0 +1,68 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Mondo API -- +-- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- +-------------------------------------------------------------------------------- + +module Example where + +-------------------------------------------------------------------------------- + +import Control.Monad +import Control.Monad.IO.Class + +import System.IO.Unsafe + +import Mondo + +-------------------------------------------------------------------------------- + +token :: String +token = head $ lines $ unsafePerformIO $ readFile "token.txt" + +-------------------------------------------------------------------------------- + +printAccount :: Account -> Mondo () +printAccount Account{..} = liftIO $ do + putStr accountDescription + putStrLn $ " (" ++ accountID ++ ")" + putStr "Created: " + print (timestamp accountCreated) + +printBalance :: Balance -> Mondo () +printBalance Balance{..} = liftIO $ do + putStr "Balance: " + print balanceValue + putStr "Currency: " + putStrLn balanceCurrency + putStr "Spent today: " + print balanceSpentToday + +printTransaction :: Transaction -> Mondo () +printTransaction t@Transaction{..} = liftIO $ do + print t + +foo :: Mondo () +foo = do + -- get a list of accounts; this always returns one account at the moment + [acc] <- listAccounts + printAccount acc + + -- get the current balance of the account + b <- getBalance acc + printBalance b + + -- get up to 100 transactions + ts <- listTransactions acc defaultPageOptions + + -- retrieve more information for each transaction + forM_ ts $ \t -> do + ft <- getTransaction t True + printTransaction ft + + {-createFeedItem $ FeedItem + (accountID acc) + BasicItem + (newBasicFeedItem "Haskell test" "https://www.haskell.org/static/img/logo.png?etag=rJR84DMh") + Nothing-} + +--------------------------------------------------------------------------------
mondo.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.0 +version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: Haskell bindings for the Mondo API @@ -41,7 +41,7 @@ -- Extra files to be distributed with the package, such as examples or a -- README. extra-source-files: README.md, - test/Example.hs + examples/Example.hs -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10 @@ -52,11 +52,11 @@ library -- Modules exported by the library. - exposed-modules: Mondo + exposed-modules: Mondo, + Mondo.API -- Modules included in this library but not exported. - other-modules: Mondo.API, - Mondo.Types + other-modules: Mondo.Types -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -64,8 +64,8 @@ -- Other library packages from which modules are imported. build-depends: base >=4.8 && <4.9, aeson >=0.11, - servant >=0.5, - servant-client >=0.5, + servant >=0.6, + servant-client >=0.6, transformers >=0.4, http-client >= 0.4, http-client-tls >= 0.2, @@ -73,7 +73,10 @@ bytestring >=0.10, mtl, text >= 1.2, - containers + containers, + time >=1.5, + timerep >=2.0, + unordered-containers >=0.2 -- Directories containing source files. hs-source-dirs: src @@ -90,4 +93,38 @@ FlexibleContexts, UndecidableInstances, TypeFamilies, - RecordWildCards + RecordWildCards, + PolyKinds, + GADTs, + ImpredicativeTypes + +test-suite spec + type: exitcode-stdio-1.0 + + main-is: Spec.hs + + other-modules: Mondo.MondoSpec, + Mondo.Server + + build-depends: base >=4.8 && <4.9, + mondo == 0.3.*, + servant >= 0.6, + servant-client >= 0.6, + servant-server >= 0.6, + hspec, + wai >= 3.2, + warp >= 3.2, + transformers >= 0.4, + network >= 2.6, + time >= 1.5, + timerep >= 2.0 + + hs-source-dirs: test + + default-language: Haskell2010 + + default-extensions: MultiParamTypeClasses, + TypeFamilies, + TypeOperators, + FlexibleInstances, + ScopedTypeVariables
src/Mondo.hs view
@@ -5,7 +5,24 @@ module Mondo ( module Mondo.Types, - module Mondo.API + + Mondo, + + withMondo, + withMondoAt, + + listAccounts, + getBalance, + getTransaction, + listTransactions, + annotateTransaction, + createFeedItem, + registerWebhook, + listWebhooks, + deleteWebhook, + uploadAttachment, + registerAttachment, + removeAttachment ) where --------------------------------------------------------------------------------
src/Mondo/API.hs view
@@ -3,13 +3,23 @@ -- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- -------------------------------------------------------------------------------- -{-# LANGUAGE FunctionalDependencies #-} - module Mondo.API ( + MondoAuth, + + TransactionsAPI, + FeedAPI, + WebhooksAPI, + AttachmentsAPI, + MondoAPI, + + mondoAPI, + Mondo, withMondo, - getAccounts, + withMondoAt, + + listAccounts, getBalance, getTransaction, listTransactions, @@ -51,51 +61,80 @@ instance HasClient api => HasClient (MondoAuth :> api) where type Client (MondoAuth :> api) = String -> Client api - clientWithRoute Proxy req url mgr val = - clientWithRoute (Proxy :: Proxy api) (mondoAuthReq val req) url mgr + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy api) (mondoAuthReq val req) mondoAuthReq :: String -> Req -> Req mondoAuthReq token = addHeader "Authorization" ("Bearer " <> token) -------------------------------------------------------------------------------- +-- | Adds pagination options to an API. +type Paginated c cts a = + QueryParam "limit" Int :> + QueryParam "since" Since :> + QueryParam "before" Timestamp :> + c cts a + +-------------------------------------------------------------------------------- + +-- | A type representing Mondo's transactions API. type TransactionsAPI = Capture "transaction_id" TransactionID :> QueryParam "expand[]" String :> + MondoAuth :> Get '[JSON] TransactionResponse :<|> QueryParam "account_id" AccountID :> - Get '[JSON] Transactions + MondoAuth :> + Paginated Get '[JSON] Transactions :<|> Capture "transaction_id" TransactionID :> ReqBody '[FormUrlEncoded] Metadata :> + MondoAuth :> Patch '[JSON] TransactionResponse -- | A type representing Mondo's feed API. type FeedAPI = - ReqBody '[FormUrlEncoded] FeedItem :> Post '[JSON] Empty + ReqBody '[FormUrlEncoded] (FeedItem BasicItem) :> + MondoAuth :> + Post '[JSON] Empty -- | A type representing Mondo's webhooks API. type WebhooksAPI = - ReqBody '[FormUrlEncoded] Webhook :> Post '[JSON] Webhook - :<|> QueryParam "account_id" AccountID :> Get '[JSON] Webhooks - :<|> Capture "webhook_id" WebhookID :> Delete '[JSON] Empty + ReqBody '[FormUrlEncoded] Webhook :> + MondoAuth :> + Post '[JSON] Webhook + :<|> QueryParam "account_id" AccountID :> + MondoAuth :> + Get '[JSON] Webhooks + :<|> Capture "webhook_id" WebhookID :> + MondoAuth :> + Delete '[JSON] Empty -- | A type representing Mondo's attachments API. type AttachmentsAPI = - "upload" :> ReqBody '[FormUrlEncoded] FileUploadReq :> Post '[JSON] FileUploadRes - :<|> "register" :> ReqBody '[FormUrlEncoded] Attachment :> Post '[JSON] Attachment - :<|> "deregister" :> ReqBody '[FormUrlEncoded] AttachmentID :> Post '[JSON] Empty + "upload" :> + ReqBody '[FormUrlEncoded] FileUploadReq :> + MondoAuth :> + Post '[JSON] FileUploadRes + :<|> "register" :> + ReqBody '[FormUrlEncoded] Attachment :> + MondoAuth :> + Post '[JSON] Attachment + :<|> "deregister" :> + ReqBody '[FormUrlEncoded] AttachmentID :> + MondoAuth :> + Post '[JSON] Empty -type AuthAPI = - "accounts" :> Get '[JSON] AccountsResponse - :<|> "balance" :> QueryParam "account_id" AccountID :> Get '[JSON] Balance +-- | A type representing the Mondo API. +type MondoAPI = + "accounts" :> MondoAuth :> Get '[JSON] AccountsResponse + :<|> "balance" :> QueryParam "account_id" AccountID :> MondoAuth :> Get '[JSON] Balance :<|> "transactions" :> TransactionsAPI :<|> "feed" :> FeedAPI :<|> "webhooks" :> WebhooksAPI :<|> "attachment" :> AttachmentsAPI --- | A type representing the Mondo API. -type MondoAPI = MondoAuth :> AuthAPI - +-- | `mondoAPI` serves as a proxy value for the `MondoAPI` type. mondoAPI :: Proxy MondoAPI mondoAPI = Proxy @@ -105,153 +144,120 @@ -------------------------------------------------------------------------------- -type Mondo = ReaderT String (ReaderT Manager (ExceptT ServantError IO)) +-- | The type of computations which interact with Mondo's API. +type Mondo = ReaderT String (ReaderT Manager (ReaderT BaseUrl (ExceptT ServantError IO))) +-- | `withMondo token f` runs a computation `f` which interacts with the Mondo +-- API and is authenticated by an OAuth token `token`. withMondo :: String -> Mondo a -> IO (Either ServantError a) -withMondo tkn m = do +withMondo = withMondoAt mondoURL + +-- | `withMondoAt baseurl token f` runs a computation `f` which interacts with +-- the Mondo API and is authenticated by an OAuth token `token`, assuming +-- that the Mondo API can be found at `baseurl`. +withMondoAt :: BaseUrl -> String -> Mondo a -> IO (Either ServantError a) +withMondoAt url tkn m = do manager <- newManager tlsManagerSettings - runExceptT (runReaderT (runReaderT m tkn) manager) + runExceptT (runReaderT (runReaderT (runReaderT m tkn) manager) url) +-- | `credential` retrieves the OAuth token used to make API requests. credential :: Mondo String credential = ask +-- | `manager` retrives the HTTP client used to make API requests. manager :: Mondo Manager manager = lift ask +-- | `baseurl` retrives the URL at which the API is located. +baseurl :: Mondo BaseUrl +baseurl = lift $ lift ask + -------------------------------------------------------------------------------- -fullApi = client mondoAPI mondoURL +accountsGET + :<|> balanceGET + :<|> transactionAPI + :<|> feedAPI + :<|> webHookAPI + :<|> attachmentAPI = client mondoAPI -transactionsApi :: Manager -> String -> - (TransactionID -> Maybe String -> ExceptT ServantError IO TransactionResponse) - :<|> ((Maybe AccountID -> ExceptT ServantError IO Transactions) - :<|> (TransactionID -> Metadata -> ExceptT ServantError IO TransactionResponse)) -transactionsApi mgr tkn = getNth (Proxy :: Proxy 2) $ fullApi mgr tkn +transactionGET + :<|> transactionsGET + :<|> transactionPATCH = transactionAPI -feedApi mgr tkn = getNth (Proxy :: Proxy 3) $ fullApi mgr tkn -webhooksApi mgr tkn = getNth (Proxy :: Proxy 4) $ fullApi mgr tkn +feedItemPOST = feedAPI -getAccounts :: Mondo AccountsResponse -getAccounts = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 0) $ fullApi mgr tkn - lift $ lift fn +webHookPOST + :<|> webHookGET + :<|> webHookDELETE = webHookAPI -getBalance :: AccountID -> Mondo Balance -getBalance acc = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 1) $ fullApi mgr tkn - lift $ lift $ fn (Just acc) +uploadPOST + :<|> registerAttachmentPOST + :<|> removeAttachmentPOST = attachmentAPI -getTransaction :: TransactionID -> Bool -> Mondo Transaction -getTransaction tr expandMerchant = do +-- | `handleAPI f` retrieves the implicit parameters from a `Mondo a` +-- computation and passes them on explicitly to `f`. +handleAPI :: (String -> Manager -> BaseUrl -> ExceptT ServantError IO a) -> Mondo a +handleAPI api = do mgr <- manager + url <- baseurl tkn <- credential - let - fn = getNth (Proxy :: Proxy 0) $ transactionsApi mgr tkn + lift $ lift $ lift $ api tkn mgr url + +-- | `listAccounts` lists all of the current user's accounts. +listAccounts :: Mondo [Account] +listAccounts = accounts <$> handleAPI accountsGET + +-- | `getBalance acc` returns `acc`'s current balance. +getBalance :: Account -> Mondo Balance +getBalance Account{..} = handleAPI $ balanceGET (Just accountID) + +-- | `getTransaction trans expandMerchant` retrives a transaction `trans` and +-- optionally expands information about the merchant if `expandMerchant` is +-- `True`. +getTransaction :: Transaction -> Bool -> Mondo Transaction +getTransaction Transaction{..} expandMerchant = + transaction <$> handleAPI (transactionGET transactionID ex) + where ex = if expandMerchant then Just "merchant" else Nothing - lift $ lift (transaction <$> fn tr ex) -listTransactions :: AccountID -> Mondo Transactions -listTransactions acc = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 1) $ transactionsApi mgr tkn - lift $ lift $ fn (Just acc) +-- | `listTransactions acc opts` lists all transactions for `acc`. +listTransactions :: Account -> PageOptions -> Mondo [Transaction] +listTransactions Account{..} opts = transactions <$> handleAPI (\tkn -> + transactionsGET (Just accountID) tkn + (limit opts) (since opts) (Timestamp <$> before opts)) -annotateTransaction :: TransactionID -> Metadata -> Mondo Transaction -annotateTransaction tr meta = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 2) $ transactionsApi mgr tkn - lift $ lift (transaction <$> fn tr meta) +-- | `annotateTransaction trans metadata` annotates `trans` with some metadata. +annotateTransaction :: Transaction -> Metadata -> Mondo Transaction +annotateTransaction Transaction{..} meta = transaction <$> + handleAPI (transactionPATCH transactionID meta) --- | `createFeedItem item' creates a new feed item. -createFeedItem :: FeedItem -> Mondo () -createFeedItem item = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 0) $ feedApi mgr tkn - lift $ lift $ toUnit <$> fn item +-- | `createFeedItem item` creates a new feed item. +createFeedItem :: FeedItem BasicItem -> Mondo () +createFeedItem item = toUnit <$> handleAPI (feedItemPOST item) +-- | `registerWebhook webhook` registers `webhook`. registerWebhook :: Webhook -> Mondo Webhook -registerWebhook hook = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 0) $ webhooksApi mgr tkn - lift $ lift $ fn hook +registerWebhook hook = handleAPI $ webHookPOST hook -listWebhooks :: AccountID -> Mondo Webhooks -listWebhooks acc = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 1) $ webhooksApi mgr tkn - lift $ lift $ fn (Just acc) +-- | `listWebhooks account` lists all webhooks for `account`. +listWebhooks :: Account -> Mondo Webhooks +listWebhooks Account{..} = handleAPI $ webHookGET (Just accountID) +-- `deleteWebhook webhook` removes `webhook`. deleteWebhook :: WebhookID -> Mondo () -deleteWebhook hookID = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 2) $ webhooksApi mgr tkn - lift $ lift $ toUnit <$> fn hookID +deleteWebhook hookID = toUnit <$> handleAPI (webHookDELETE hookID) +-- `uploadAttachment req` makes a request to upload an attachment. uploadAttachment :: FileUploadReq -> Mondo FileUploadRes -uploadAttachment req = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 5) $ fullApi mgr tkn - lift $ lift $ fn req +uploadAttachment req = handleAPI $ uploadPOST req +-- `registerAttachment attachment` registers `attachment` for its transaction. registerAttachment :: Attachment -> Mondo Attachment -registerAttachment att = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 6) $ fullApi mgr tkn - lift $ lift $ fn att +registerAttachment att = handleAPI $ registerAttachmentPOST att +-- | `removeAttachment attachment` deletes `attachment` from its transaction. removeAttachment :: AttachmentID -> Mondo () -removeAttachment attID = do - mgr <- manager - tkn <- credential - let - fn = getNth (Proxy :: Proxy 7) $ fullApi mgr tkn - lift $ lift $ toUnit <$> fn attID - --------------------------------------------------------------------------------- - -class GetNth (n :: Nat) a b | n a -> b where - getNth :: Proxy n -> a -> b - -instance x ~ y => GetNth 0 x y where - getNth _ x = x - -instance {-# OVERLAPPING #-} - GetNth 0 (x :<|> y) x where - getNth _ (x :<|> _) = x - -instance - (GetNth (n-1) x y) => GetNth n (a :<|> x) y where - getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n-1)) x - -class GetLast a b | a -> b where - getLast :: a -> b - -instance {-# OVERLAPPING #-} (GetLast b c) => GetLast (a :<|> b) c where - getLast (_ :<|> b) = getLast b - -instance a ~ b => GetLast a b where - getLast a = a +removeAttachment attID = toUnit <$> handleAPI (removeAttachmentPOST attID) --------------------------------------------------------------------------------
src/Mondo/Types.hs view
@@ -12,8 +12,11 @@ import Control.Monad (mzero) import Data.Aeson -import Data.Aeson.Types (emptyObject) +import Data.Aeson.Types (Parser, emptyObject) +import qualified Data.HashMap.Strict as H import qualified Data.Text as T +import Data.Time.LocalTime +import Data.Time.RFC3339 import qualified Data.Map as M import Data.Monoid ((<>)) @@ -21,6 +24,80 @@ -------------------------------------------------------------------------------- +-- | Retrieve the value associated with the given key of an `Object`. The result +-- is `Nothing` if the key is not present or if it is null, or `empty` if the +-- value cannot be converted to the desired type. +(.:??) :: FromJSON a => Object -> T.Text -> Parser (Maybe a) +obj .:?? key = case H.lookup key obj of + Nothing -> pure Nothing + Just Null -> pure Nothing + Just val -> parseJSON val + +-------------------------------------------------------------------------------- + +lookupEither :: (Show a, Eq a) => a -> [(a,b)] -> Either String b +lookupEither x xs = maybe (Left $ "could not find key " <> show x) return (lookup x xs) + +eitherOr :: Eq a => a -> [(a,b)] -> Either String b -> Either String b +eitherOr x xs f = maybe f return (lookup x xs) + +-------------------------------------------------------------------------------- + +-- | An abstract representation of timestamps used by the Mondo API. +newtype Timestamp = Timestamp { timestamp :: ZonedTime } + deriving (Show) + +instance Eq Timestamp where + (Timestamp x) == (Timestamp y) = + zonedTimeToUTC x == zonedTimeToUTC y + +instance ToHttpApiData Timestamp where + toQueryParam (Timestamp time) = formatTimeRFC3339 time + +instance FromHttpApiData Timestamp where + parseQueryParam v = case parseTimeRFC3339 v of + Nothing -> Left "Can't parse time" + Just t -> Right $ Timestamp t + +instance FromJSON Timestamp where + parseJSON (String v) = case parseTimeRFC3339 v of + Nothing -> mzero + Just t -> pure $ Timestamp t + parseJSON _ = mzero + +instance ToJSON Timestamp where + toJSON (Timestamp t) = String (formatTimeRFC3339 t) + +-------------------------------------------------------------------------------- + +data Since = SinceTime Timestamp | SinceID String + +instance ToHttpApiData Since where + toQueryParam (SinceTime time) = toQueryParam time + toQueryParam (SinceID id) = T.pack id + +instance FromHttpApiData Since where + parseQueryParam v = case parseTimeRFC3339 v of + Just t -> Right $ SinceTime $ Timestamp t + Nothing -> Right $ SinceID $ T.unpack v + +-------------------------------------------------------------------------------- + +data PageOptions = PageOptions { + limit :: Maybe Int, + since :: Maybe Since, + before :: Maybe ZonedTime +} + +defaultPageOptions :: PageOptions +defaultPageOptions = PageOptions { + limit = Just 100, + since = Nothing, + before = Nothing +} + +-------------------------------------------------------------------------------- + data Empty = Empty instance FromJSON Empty where @@ -28,11 +105,16 @@ | val == emptyObject = pure Empty | otherwise = mzero +instance ToJSON Empty where + toJSON Empty = object [] + toUnit :: Empty -> () toUnit _ = () +-------------------------------------------------------------------------------- + -- | The type of account IDs. -type AccountID = String +type AccountID = String -- | The type of transaction IDs. type TransactionID = String @@ -48,9 +130,15 @@ parseJSON (String v) = pure $ AttID v parseJSON _ = mzero +instance ToJSON AttachmentID where + toJSON (AttID v) = String v + instance ToFormUrlEncoded AttachmentID where toFormUrlEncoded (AttID v) = [("id", v)] +instance FromFormUrlEncoded AttachmentID where + fromFormUrlEncoded dict = AttID <$> lookupEither "id" dict + -------------------------------------------------------------------------------- data AccountsResponse = AccountsResponse { @@ -58,26 +146,48 @@ } deriving (Show, Generic) instance FromJSON AccountsResponse +instance ToJSON AccountsResponse data Account = Account { - id :: AccountID, - description :: String, - created :: String -} deriving (Show, Generic) + accountID :: AccountID, + accountDescription :: String, + accountCreated :: Timestamp +} deriving (Eq, Show, Generic) -accountID :: Account -> String -accountID (Account x _ _) = x +instance FromJSON Account where + parseJSON (Object v) = + Account <$> v .: "id" + <*> v .: "description" + <*> v .: "created" + parseJSON _ = mzero -instance FromJSON Account +instance ToJSON Account where + toJSON Account{..} = + object [ "id" .= accountID + , "description" .= accountDescription + , "created" .= accountCreated + ] data Balance = Balance { - balance :: Integer, - currency :: String, - spend_today :: Integer -} deriving (Show, Generic) + balanceValue :: Integer, + balanceCurrency :: String, + balanceSpentToday :: Integer +} deriving (Eq, Show, Generic) -instance FromJSON Balance +instance FromJSON Balance where + parseJSON (Object v) = + Balance <$> v .: "balance" + <*> v .: "currency" + <*> v .: "spend_today" + parseJSON _ = mzero +instance ToJSON Balance where + toJSON Balance{..} = + object [ "balance" .= balanceValue + , "currency" .= balanceCurrency + , "spend_today" .= balanceSpentToday + ] + -------------------------------------------------------------------------------- -- | Enumerates reasons which cause transactions to be declined. @@ -95,12 +205,18 @@ parseJSON (String "OTHER") = pure Other parseJSON _ = mzero +instance ToJSON DeclineReason where + toJSON InsufficientFunds = String "INSUFFICIENT_FUNDS" + toJSON CardInactive = String "CARD_INACTIVE" + toJSON CardBlocked = String "CARD_BLOCKED" + toJSON Other = String "OTHER" + data Address = Address { addrAddress :: String, addrCity :: String, addrCountry :: String, - addrLatitude :: String, - addrLongitude :: String, + addrLatitude :: Double, + addrLongitude :: Double, addrPostcode :: String, addrRegion :: String } deriving Show @@ -116,6 +232,17 @@ <*> v .: "region" parseJSON _ = mzero +instance ToJSON Address where + toJSON Address{..} = + object [ "address" .= addrAddress + , "city" .= addrCity + , "country" .= addrCountry + , "latitude" .= addrLatitude + , "longitude" .= addrLongitude + , "postcode" .= addrPostcode + , "region" .= addrRegion + ] + data Merchant = Merchant { merchantAddress :: Maybe Address, merchantCreated :: Maybe String, @@ -127,46 +254,76 @@ merchantCategory :: Maybe String } deriving Show +newMerchant :: String -> Merchant +newMerchant id = Merchant { + merchantAddress = Nothing, + merchantCreated = Nothing, + merchantGroupID = Nothing, + merchantID = id, + merchantLogo = Nothing, + merchantEmoji = Nothing, + merchantName = Nothing, + merchantCategory = Nothing +} + instance FromJSON Merchant where parseJSON (Object v) = - Merchant <$> v .: "address" - <*> v .: "created" - <*> v .: "group_id" + Merchant <$> v .:? "address" + <*> v .:? "created" + <*> v .:? "group_id" <*> v .: "id" - <*> v .: "logo" - <*> v .: "emoji" - <*> v .: "name" - <*> v .: "category" - parseJSON _ = mzero + <*> v .:? "logo" + <*> v .:? "emoji" + <*> v .:? "name" + <*> v .:? "category" + parseJSON (String v) = + pure (newMerchant $ T.unpack v) + parseJSON _ = + fail "Can't parse merchant." +instance ToJSON Merchant where + toJSON Merchant{..} = + object [ "address" .= merchantAddress + , "created" .= merchantCreated + , "group_id" .= merchantGroupID + , "id" .= merchantID + , "logo" .= merchantLogo + , "emoji" .= merchantEmoji + , "name" .= merchantName + , "category" .= merchantCategory + ] + data Transactions = Transactions { transactions :: [Transaction] } deriving (Show, Generic) instance FromJSON Transactions +instance ToJSON Transactions data TransactionResponse = TransactionResponse { transaction :: Transaction } deriving (Show, Generic) instance FromJSON TransactionResponse +instance ToJSON TransactionResponse -- TODO: add metadata -data Transaction = Transaction { - transactionAccountBalance :: Integer, - transactionAmount :: Integer, - transactionCreated :: String, - transactionCurrency :: String, - transactionDescription :: String, - transactionID :: TransactionID, - transactionDeclineReason :: Maybe DeclineReason, - transactionIsLoad :: Bool, - transactionSettled :: Bool, - transactionCategory :: Maybe String, - transactionMerchant :: Merchant, - transactionMetadata :: M.Map String String -} deriving Show +data Transaction + = Transaction { + transactionAccountBalance :: Integer, + transactionAmount :: Integer, + transactionCreated :: Timestamp, + transactionCurrency :: String, + transactionDescription :: String, + transactionID :: TransactionID, + transactionDeclineReason :: Maybe DeclineReason, + transactionIsLoad :: Bool, + transactionSettled :: Maybe Timestamp, + transactionCategory :: Maybe String, + transactionMerchant :: Maybe Merchant, + transactionMetadata :: M.Map String String + } deriving Show instance FromJSON Transaction where parseJSON (Object v) = @@ -176,20 +333,40 @@ <*> v .: "currency" <*> v .: "description" <*> v .: "id" - <*> v .: "decline_reason" + <*> v .:? "decline_reason" <*> v .: "is_load" - <*> v .: "settled" - <*> v .: "category" - <*> v .: "merchant" + <*> v .:? "settled" + <*> v .:? "category" + <*> v .:?? "merchant" <*> v .: "metadata" - parseJSON _ = mzero + parseJSON v = fail "Can't parse transaction." +instance ToJSON Transaction where + toJSON Transaction{..} = + object [ "account_balance" .= transactionAccountBalance + , "amount" .= transactionAmount + , "created" .= transactionCreated + , "currency" .= transactionCurrency + , "description" .= transactionDescription + , "id" .= transactionID + , "decline_reason" .= transactionDeclineReason + , "is_load" .= transactionIsLoad + , "settled" .= transactionSettled + , "category" .= transactionSettled + , "merchant" .= transactionMerchant + , "metadata" .= transactionMetadata + ] + data Metadata = Metadata { metadata :: M.Map String String } instance ToFormUrlEncoded Metadata where toFormUrlEncoded (Metadata d) = [("metadata[" <> T.pack k <> "]", T.pack v) | (k,v) <- M.toList d] +instance FromFormUrlEncoded Metadata where + fromFormUrlEncoded dict = + return $ Metadata $ M.fromList [(T.unpack k, T.unpack v) | (k,v) <- dict] + -------------------------------------------------------------------------------- data FeedItemType @@ -198,10 +375,13 @@ instance Show FeedItemType where show BasicItem = "basic" +instance Read FeedItemType where + readsPrec _ "basic" = [(BasicItem, "")] + instance ToJSON FeedItemType where toJSON BasicItem = String "basic" -data FeedItemParams +data FeedItemParams (k :: FeedItemType) = BasicFeedItem { itemTitle :: String, itemImageURL :: String, @@ -211,7 +391,7 @@ itemBodyColour :: Maybe String } -newBasicFeedItem :: String -> String -> FeedItemParams +newBasicFeedItem :: String -> String -> FeedItemParams BasicItem newBasicFeedItem title url = BasicFeedItem { itemTitle = title, itemImageURL = url, @@ -221,25 +401,52 @@ itemBodyColour = Nothing } -instance ToFormUrlEncoded FeedItemParams where - toFormUrlEncoded (BasicFeedItem {..}) = +instance ToFormUrlEncoded (FeedItemParams k) where + toFormUrlEncoded BasicFeedItem{..} = [ ( "params[title]" , T.pack itemTitle ) , ( "params[image_url]", T.pack itemImageURL ) ] -data FeedItem = FeedItem { +instance FromFormUrlEncoded (FeedItemParams k) where + fromFormUrlEncoded dict = do + title <- lookupEither "params[title]" dict + imageURL <- lookupEither "params[image_url]" dict + + return BasicFeedItem { + itemTitle = T.unpack title, + itemImageURL = T.unpack imageURL, + itemBody = Nothing, + itemBackgroundColour = Nothing, + itemTitleColour = Nothing, + itemBodyColour = Nothing + } + +data FeedItem (k :: FeedItemType) = FeedItem { itemAccountID :: AccountID, itemType :: FeedItemType, - itemParams :: FeedItemParams, + itemParams :: FeedItemParams k, itemURL :: Maybe String } -instance ToFormUrlEncoded FeedItem where +instance ToFormUrlEncoded (FeedItem k) where toFormUrlEncoded item = [ ( "account_id", T.pack $ itemAccountID item ) , ( "type" , T.pack $ show $ itemType item ) ] ++ toFormUrlEncoded (itemParams item) +instance FromFormUrlEncoded (FeedItem k) where + fromFormUrlEncoded dict = do + accountID <- lookupEither "account_id" dict + typ <- lookupEither "type" dict + params <- fromFormUrlEncoded dict + + return FeedItem { + itemAccountID = T.unpack accountID, + itemType = read $ T.unpack typ, + itemParams = params, + itemURL = Nothing + } + -------------------------------------------------------------------------------- data Webhooks = Webhooks { @@ -247,6 +454,7 @@ } deriving (Show, Generic) instance FromJSON Webhooks +instance ToJSON Webhooks data Webhook = Webhook { webhookAccountID :: AccountID, @@ -261,12 +469,29 @@ <*> v .: "id" parseJSON _ = mzero +instance ToJSON Webhook where + toJSON Webhook{..} = + object [ "account_id" .= webhookAccountID + , "url" .= webhookURL + , "id" .= webhookID + ] + instance ToFormUrlEncoded Webhook where toFormUrlEncoded hook = [ ( "account_id", T.pack $ webhookAccountID hook ) , ( "url" , T.pack $ webhookURL hook ) ] +instance FromFormUrlEncoded Webhook where + fromFormUrlEncoded dict = do + acc <- lookupEither "account_id" dict + url <- lookupEither "url" dict + return Webhook { + webhookAccountID = T.unpack acc, + webhookURL = T.unpack url, + webhookID = Nothing + } + -------------------------------------------------------------------------------- data FileUploadReq = FileUploadReq { @@ -280,6 +505,12 @@ , ( "file_type", T.pack $ uploadFileType req ) ] +instance FromFormUrlEncoded FileUploadReq where + fromFormUrlEncoded dict = do + name <- lookupEither "file_name" dict + typ <- lookupEither "file_type" dict + return $ FileUploadReq (T.unpack name) (T.unpack typ) + data FileUploadRes = FileUploadRes { uploadURL :: String, uploadPostURL :: String @@ -288,9 +519,15 @@ instance FromJSON FileUploadRes where parseJSON (Object v) = FileUploadRes <$> v .: "file_url" - <*> v .: "file_type" + <*> v .: "upload_url" parseJSON _ = mzero +instance ToJSON FileUploadRes where + toJSON FileUploadRes{..} = + object [ "file_url" .= uploadURL + , "upload_url" .= uploadPostURL + ] + -------------------------------------------------------------------------------- -- | Transaction attachments. @@ -313,11 +550,36 @@ <*> v .: "created" parseJSON _ = mzero +instance ToJSON Attachment where + toJSON Attachment{..} = + object [ "external_id" .= attachmentTransaction + , "file_type" .= attachmentFileType + , "file_url" .= attachmentURL + , "id" .= attachmentID + , "user_id" .= attachmentUserID + , "created" .= attachmentCreated + ] + instance ToFormUrlEncoded Attachment where toFormUrlEncoded att = [ ( "external_id", T.pack $ attachmentTransaction att ) , ( "file_url", T.pack $ attachmentURL att ) , ( "file_type", T.pack $ attachmentFileType att ) ] + +instance FromFormUrlEncoded Attachment where + fromFormUrlEncoded dict = do + id <- lookupEither "external_id" dict + url <- lookupEither "file_url" dict + typ <- lookupEither "file_type" dict + + return Attachment { + attachmentTransaction = T.unpack id, + attachmentURL = T.unpack url, + attachmentFileType = T.unpack typ, + attachmentID = Nothing, + attachmentUserID = Nothing, + attachmentCreated = Nothing + } --------------------------------------------------------------------------------
− test/Example.hs
@@ -1,40 +0,0 @@--------------------------------------------------------------------------------- --- Haskell bindings for the Mondo API -- --- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- --------------------------------------------------------------------------------- - -module Example where - --------------------------------------------------------------------------------- - -import Control.Monad.IO.Class - -import System.IO.Unsafe - -import Mondo - --------------------------------------------------------------------------------- - -token :: String -token = head $ lines $ unsafePerformIO $ readFile "test/token.txt" - --------------------------------------------------------------------------------- - -foo :: Mondo () -foo = do - AccountsResponse [acc] <- getAccounts - liftIO $ print acc - - r2 <- getBalance (accountID acc) - liftIO $ print r2 - - r3 <- listTransactions (accountID acc) - liftIO $ print r3 - - createFeedItem $ FeedItem - (accountID acc) - BasicItem - (newBasicFeedItem "Haskell test" "https://www.haskell.org/static/img/logo.png?etag=rJR84DMh") - Nothing - ---------------------------------------------------------------------------------
+ test/Mondo/MondoSpec.hs view
@@ -0,0 +1,30 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Mondo API -- +-- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- +-------------------------------------------------------------------------------- + +module Mondo.MondoSpec where + +-------------------------------------------------------------------------------- + +import Control.Arrow (left) + +import Test.Hspec + +import Mondo +import Mondo.Server + +-------------------------------------------------------------------------------- + +mondoTest baseUrl m = left show <$> withMondoAt baseUrl "" m + +spec :: Spec +spec = describe "Mondo" $ beforeAll (startWaiApp server) $ afterAll endWaiApp $ do + + it "Mondo.listAccounts" $ \(_, baseUrl) -> + mondoTest baseUrl listAccounts `shouldReturn` Right [acc] + + it "Mondo.getBalance" $ \(_, baseUrl) -> + mondoTest baseUrl (getBalance acc) `shouldReturn` Right balance + +--------------------------------------------------------------------------------
+ test/Mondo/Server.hs view
@@ -0,0 +1,88 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Mondo API -- +-- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- +-------------------------------------------------------------------------------- + +module Mondo.Server where + +-------------------------------------------------------------------------------- + +import Control.Concurrent +import Control.Monad.Trans.Except + +import Data.Maybe +import Data.Time.LocalTime +import Data.Time.RFC3339 +import Data.Proxy + +import Network.Socket +import Network.Wai +import Network.Wai.Handler.Warp + +import Servant.API +import Servant.Client +import Servant.Server +import Servant.Server.Internal +import Servant.Server.Internal.Router +import Servant.Server.Internal.RoutingApplication + +import Mondo +import Mondo.API + +-------------------------------------------------------------------------------- + +instance HasServer api ctx => HasServer (MondoAuth :> api) ctx where + type ServerT (MondoAuth :> api) m = ServerT api m + + route Proxy = + route (Proxy :: Proxy api) + +-------------------------------------------------------------------------------- + +time :: ZonedTime +time = fromJust $ parseTimeRFC3339 ("2015-11-12T18:37:02Z" :: String) + +acc :: Account +acc = Account { + accountID = "cake_i$_@_1i3", + accountDescription = "Aperture Science", + accountCreated = Timestamp time +} + +balance :: Balance +balance = Balance { + balanceValue = 9001, + balanceCurrency = "GBP", + balanceSpentToday = 108 +} + +-------------------------------------------------------------------------------- + +handler :: Server MondoAPI +handler = return (AccountsResponse [acc]) + :<|> (\acc -> return balance) + :<|> undefined + +server :: Application +server = serve mondoAPI handler + +startWaiApp :: Application -> IO (ThreadId, BaseUrl) +startWaiApp app = do + (port, socket) <- openTestSocket + let settings = setPort port defaultSettings + thread <- forkIO $ runSettingsSocket settings socket app + return (thread, BaseUrl Http "localhost" port "") + +endWaiApp :: (ThreadId, BaseUrl) -> IO () +endWaiApp (thread, _) = killThread thread + +openTestSocket :: IO (Port, Socket) +openTestSocket = do + s <- socket AF_INET Stream defaultProtocol + localhost <- inet_addr "127.0.0.1" + bind s (SockAddrInet aNY_PORT localhost) + listen s 1 + port <- socketPort s + return (fromIntegral port, s) + +--------------------------------------------------------------------------------
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}