monzo (empty) → 0.4.0.0
raw patch · 11 files changed
+1239/−0 lines, 11 filesdep +aesondep +authenticate-oauthdep +basesetup-changed
Dependencies added: aeson, authenticate-oauth, base, bytestring, containers, hspec, http-client, http-client-tls, monzo, mtl, network, servant, servant-client, servant-server, text, time, timerep, transformers, unordered-containers, wai, warp
Files
- LICENSE +20/−0
- README.md +10/−0
- Setup.hs +2/−0
- examples/Example.hs +68/−0
- monzo.cabal +130/−0
- src/Monzo.hs +42/−0
- src/Monzo/API.hs +263/−0
- src/Monzo/Types.hs +585/−0
- test/Monzo/MonzoSpec.hs +30/−0
- test/Monzo/Server.hs +88/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Michael B. Gale + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,10 @@+# Haskell bindings for the Monzo API + +[](https://hackage.haskell.org/package/monzo) +[](https://travis-ci.org/mbg/monzo) + +## Getting started + +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 Monzo.hs` (if not). Then load the example into the REPL with `:l examples/Example.hs`. Finally, invoke the example with `withMonzo token foo`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ examples/Example.hs view
@@ -0,0 +1,68 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Monzo 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 Monzo + +-------------------------------------------------------------------------------- + +token :: String +token = head $ lines $ unsafePerformIO $ readFile "token.txt" + +-------------------------------------------------------------------------------- + +printAccount :: Account -> Monzo () +printAccount Account{..} = liftIO $ do + putStr accountDescription + putStrLn $ " (" ++ accountID ++ ")" + putStr "Created: " + print (timestamp accountCreated) + +printBalance :: Balance -> Monzo () +printBalance Balance{..} = liftIO $ do + putStr "Balance: " + print balanceValue + putStr "Currency: " + putStrLn balanceCurrency + putStr "Spent today: " + print balanceSpentToday + +printTransaction :: Transaction -> Monzo () +printTransaction t@Transaction{..} = liftIO $ do + print t + +foo :: Monzo () +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-} + +--------------------------------------------------------------------------------
+ monzo.cabal view
@@ -0,0 +1,130 @@+-- Initial mondo.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: monzo + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.4.0.0 + +-- A short (one-line) description of the package. +synopsis: Haskell bindings for the Monzo API + +-- A longer description of the package. +description: Provides Haskell bindings for the Monzo API. + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Michael B. Gale + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: michael.gale@cl.cam.ac.uk + +-- A copyright notice. +-- copyright: + +category: Web + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: README.md, + examples/Example.hs + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/mbg/monzo + +library + -- Modules exported by the library. + exposed-modules: Monzo, + Monzo.API + + -- Modules included in this library but not exported. + other-modules: Monzo.Types + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.9, + aeson >=0.11, + servant >=0.6, + servant-client >=0.6, + transformers >=0.4, + http-client >= 0.4, + http-client-tls >= 0.2, + authenticate-oauth >=1.5, + bytestring >=0.10, + mtl, + text >= 1.2, + containers, + time >=1.5, + timerep >=2.0, + unordered-containers >=0.2 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + + default-extensions: TypeOperators, + DataKinds, + DeriveGeneric, + OverloadedStrings, + ScopedTypeVariables, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances, + TypeFamilies, + RecordWildCards, + PolyKinds, + GADTs, + ImpredicativeTypes + +test-suite spec + type: exitcode-stdio-1.0 + + main-is: Spec.hs + + other-modules: Monzo.MonzoSpec, + Monzo.Server + + build-depends: base >=4.8 && <4.9, + monzo == 0.4.*, + 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/Monzo.hs view
@@ -0,0 +1,42 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Mondo API -- +-- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- +-------------------------------------------------------------------------------- + +module Monzo ( + module Monzo.Types, + + Monzo, + + withMonzo, + withMonzoAt, + + listAccounts, + getBalance, + getTransaction, + listTransactions, + annotateTransaction, + createFeedItem, + registerWebhook, + listWebhooks, + deleteWebhook, + uploadAttachment, + registerAttachment, + removeAttachment +) where + +-------------------------------------------------------------------------------- + +import Web.Authenticate.OAuth + +import Monzo.Types +import Monzo.API + +-------------------------------------------------------------------------------- + +monzoAuth :: OAuth +monzoAuth = newOAuth { + oauthServerName = "https://auth.getmondo.co.uk/" +} + +--------------------------------------------------------------------------------
+ src/Monzo/API.hs view
@@ -0,0 +1,263 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Monzo API -- +-- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- +-------------------------------------------------------------------------------- + +module Monzo.API ( + MonzoAuth, + + TransactionsAPI, + FeedAPI, + WebhooksAPI, + AttachmentsAPI, + MonzoAPI, + + monzoAPI, + + Monzo, + + withMonzo, + withMonzoAt, + + listAccounts, + getBalance, + getTransaction, + listTransactions, + annotateTransaction, + createFeedItem, + registerWebhook, + listWebhooks, + deleteWebhook, + uploadAttachment, + registerAttachment, + removeAttachment +) where + +-------------------------------------------------------------------------------- + +import GHC.TypeLits + +import qualified Data.ByteString.Internal as BS +import Data.Proxy +import Data.Monoid ((<>)) + +import Control.Monad.Trans +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader + +import Network.HTTP.Client (Manager, newManager) +import Network.HTTP.Client.TLS + +import Servant.API hiding (addHeader) +import Servant.Common.Req (Req(..), addHeader) +import Servant.Client + +import Monzo.Types + +-------------------------------------------------------------------------------- + +data MonzoAuth + +instance HasClient api => HasClient (MonzoAuth :> api) where + type Client (MonzoAuth :> api) = String -> Client api + + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy api) (monzoAuthReq val req) + +monzoAuthReq :: String -> Req -> Req +monzoAuthReq 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 Monzo's transactions API. +type TransactionsAPI = + Capture "transaction_id" TransactionID :> + QueryParam "expand[]" String :> + MonzoAuth :> + Get '[JSON] TransactionResponse + :<|> QueryParam "account_id" AccountID :> + MonzoAuth :> + Paginated Get '[JSON] Transactions + :<|> Capture "transaction_id" TransactionID :> + ReqBody '[FormUrlEncoded] Metadata :> + MonzoAuth :> + Patch '[JSON] TransactionResponse + +-- | A type representing Monzo's feed API. +type FeedAPI = + ReqBody '[FormUrlEncoded] (FeedItem BasicItem) :> + MonzoAuth :> + Post '[JSON] Empty + +-- | A type representing Monzo's webhooks API. +type WebhooksAPI = + ReqBody '[FormUrlEncoded] Webhook :> + MonzoAuth :> + Post '[JSON] Webhook + :<|> QueryParam "account_id" AccountID :> + MonzoAuth :> + Get '[JSON] Webhooks + :<|> Capture "webhook_id" WebhookID :> + MonzoAuth :> + Delete '[JSON] Empty + +-- | A type representing Monzo's attachments API. +type AttachmentsAPI = + "upload" :> + ReqBody '[FormUrlEncoded] FileUploadReq :> + MonzoAuth :> + Post '[JSON] FileUploadRes + :<|> "register" :> + ReqBody '[FormUrlEncoded] Attachment :> + MonzoAuth :> + Post '[JSON] Attachment + :<|> "deregister" :> + ReqBody '[FormUrlEncoded] AttachmentID :> + MonzoAuth :> + Post '[JSON] Empty + +-- | A type representing the Monzo API. +type MonzoAPI = + "accounts" :> MonzoAuth :> Get '[JSON] AccountsResponse + :<|> "balance" :> QueryParam "account_id" AccountID :> MonzoAuth :> Get '[JSON] Balance + :<|> "transactions" :> TransactionsAPI + :<|> "feed" :> FeedAPI + :<|> "webhooks" :> WebhooksAPI + :<|> "attachment" :> AttachmentsAPI + +-- | `MonzoAPI` serves as a proxy value for the `MonzoAPI` type. +monzoAPI :: Proxy MonzoAPI +monzoAPI = Proxy + +-- | The URL of the Monzo API. +monzoURL :: BaseUrl +monzoURL = BaseUrl Https "api.getmondo.co.uk" 443 "/" + +-------------------------------------------------------------------------------- + +-- | The type of computations which interact with Monzo's API. +type Monzo = ReaderT String (ReaderT Manager (ReaderT BaseUrl (ExceptT ServantError IO))) + +-- | `withMonzo token f` runs a computation `f` which interacts with the Monzo +-- API and is authenticated by an OAuth token `token`. +withMonzo :: String -> Monzo a -> IO (Either ServantError a) +withMonzo = withMonzoAt monzoURL + +-- | `withMonzoAt baseurl token f` runs a computation `f` which interacts with +-- the Monzo API and is authenticated by an OAuth token `token`, assuming +-- that the Monzo API can be found at `baseurl`. +withMonzoAt :: BaseUrl -> String -> Monzo a -> IO (Either ServantError a) +withMonzoAt url tkn m = do + manager <- newManager tlsManagerSettings + runExceptT (runReaderT (runReaderT (runReaderT m tkn) manager) url) + +-- | `credential` retrieves the OAuth token used to make API requests. +credential :: Monzo String +credential = ask + +-- | `manager` retrives the HTTP client used to make API requests. +manager :: Monzo Manager +manager = lift ask + +-- | `baseurl` retrives the URL at which the API is located. +baseurl :: Monzo BaseUrl +baseurl = lift $ lift ask + +-------------------------------------------------------------------------------- + +accountsGET + :<|> balanceGET + :<|> transactionAPI + :<|> feedAPI + :<|> webHookAPI + :<|> attachmentAPI = client monzoAPI + +transactionGET + :<|> transactionsGET + :<|> transactionPATCH = transactionAPI + +feedItemPOST = feedAPI + +webHookPOST + :<|> webHookGET + :<|> webHookDELETE = webHookAPI + +uploadPOST + :<|> registerAttachmentPOST + :<|> removeAttachmentPOST = attachmentAPI + +-- | `handleAPI f` retrieves the implicit parameters from a `Monzo a` +-- computation and passes them on explicitly to `f`. +handleAPI :: (String -> Manager -> BaseUrl -> ExceptT ServantError IO a) -> Monzo a +handleAPI api = do + mgr <- manager + url <- baseurl + tkn <- credential + lift $ lift $ lift $ api tkn mgr url + +-- | `listAccounts` lists all of the current user's accounts. +listAccounts :: Monzo [Account] +listAccounts = accounts <$> handleAPI accountsGET + +-- | `getBalance acc` returns `acc`'s current balance. +getBalance :: Account -> Monzo 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 -> Monzo Transaction +getTransaction Transaction{..} expandMerchant = + transaction <$> handleAPI (transactionGET transactionID ex) + where + ex = if expandMerchant then Just "merchant" else Nothing + +-- | `listTransactions acc opts` lists all transactions for `acc`. +listTransactions :: Account -> PageOptions -> Monzo [Transaction] +listTransactions Account{..} opts = transactions <$> handleAPI (\tkn -> + transactionsGET (Just accountID) tkn + (limit opts) (since opts) (Timestamp <$> before opts)) + +-- | `annotateTransaction trans metadata` annotates `trans` with some metadata. +annotateTransaction :: Transaction -> Metadata -> Monzo Transaction +annotateTransaction Transaction{..} meta = transaction <$> + handleAPI (transactionPATCH transactionID meta) + +-- | `createFeedItem item` creates a new feed item. +createFeedItem :: FeedItem BasicItem -> Monzo () +createFeedItem item = toUnit <$> handleAPI (feedItemPOST item) + +-- | `registerWebhook webhook` registers `webhook`. +registerWebhook :: Webhook -> Monzo Webhook +registerWebhook hook = handleAPI $ webHookPOST hook + +-- | `listWebhooks account` lists all webhooks for `account`. +listWebhooks :: Account -> Monzo Webhooks +listWebhooks Account{..} = handleAPI $ webHookGET (Just accountID) + +-- `deleteWebhook webhook` removes `webhook`. +deleteWebhook :: WebhookID -> Monzo () +deleteWebhook hookID = toUnit <$> handleAPI (webHookDELETE hookID) + +-- `uploadAttachment req` makes a request to upload an attachment. +uploadAttachment :: FileUploadReq -> Monzo FileUploadRes +uploadAttachment req = handleAPI $ uploadPOST req + +-- `registerAttachment attachment` registers `attachment` for its transaction. +registerAttachment :: Attachment -> Monzo Attachment +registerAttachment att = handleAPI $ registerAttachmentPOST att + +-- | `removeAttachment attachment` deletes `attachment` from its transaction. +removeAttachment :: AttachmentID -> Monzo () +removeAttachment attID = toUnit <$> handleAPI (removeAttachmentPOST attID) + +--------------------------------------------------------------------------------
+ src/Monzo/Types.hs view
@@ -0,0 +1,585 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Monzo API -- +-- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- +-------------------------------------------------------------------------------- + +module Monzo.Types where + +-------------------------------------------------------------------------------- + +import GHC.Generics + +import Control.Monad (mzero) + +import Data.Aeson +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 ((<>)) + +import Servant.API + +-------------------------------------------------------------------------------- + +-- | 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 + parseJSON val + | val == emptyObject = pure Empty + | otherwise = mzero + +instance ToJSON Empty where + toJSON Empty = object [] + +toUnit :: Empty -> () +toUnit _ = () + +-------------------------------------------------------------------------------- + +-- | The type of account IDs. +type AccountID = String + +-- | The type of transaction IDs. +type TransactionID = String + +-- | The type of webhook IDs. +type WebhookID = String + +-- | The type of attachment IDs. +newtype AttachmentID = AttID T.Text + deriving Show + +instance FromJSON AttachmentID where + 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 { + accounts :: [Account] +} deriving (Show, Generic) + +instance FromJSON AccountsResponse +instance ToJSON AccountsResponse + +data Account = Account { + accountID :: AccountID, + accountDescription :: String, + accountCreated :: Timestamp +} deriving (Eq, Show, Generic) + +instance FromJSON Account where + parseJSON (Object v) = + Account <$> v .: "id" + <*> v .: "description" + <*> v .: "created" + parseJSON _ = mzero + +instance ToJSON Account where + toJSON Account{..} = + object [ "id" .= accountID + , "description" .= accountDescription + , "created" .= accountCreated + ] + +data Balance = Balance { + balanceValue :: Integer, + balanceCurrency :: String, + balanceSpentToday :: Integer +} deriving (Eq, Show, Generic) + +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. +data DeclineReason + = InsufficientFunds + | CardInactive + | CardBlocked + | Other + deriving Show + +instance FromJSON DeclineReason where + parseJSON (String "INSUFFICIENT_FUNDS") = pure InsufficientFunds + parseJSON (String "CARD_INACTIVE") = pure CardInactive + parseJSON (String "CARD_BLOCKED") = pure CardBlocked + 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 :: Double, + addrLongitude :: Double, + addrPostcode :: String, + addrRegion :: String +} deriving Show + +instance FromJSON Address where + parseJSON (Object v) = + Address <$> v .: "address" + <*> v .: "city" + <*> v .: "country" + <*> v .: "latitude" + <*> v .: "longitude" + <*> v .: "postcode" + <*> 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, + merchantGroupID :: Maybe String, + merchantID :: String, + merchantLogo :: Maybe String, + merchantEmoji :: Maybe String, + merchantName :: Maybe String, + 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" + <*> v .: "id" + <*> 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 :: 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) = + Transaction <$> v .: "account_balance" + <*> v .: "amount" + <*> v .: "created" + <*> v .: "currency" + <*> v .: "description" + <*> v .: "id" + <*> v .:? "decline_reason" + <*> v .: "is_load" + <*> v .:? "settled" + <*> v .:? "category" + <*> v .:?? "merchant" + <*> v .: "metadata" + 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 + = BasicItem + +instance Show FeedItemType where + show BasicItem = "basic" + +instance Read FeedItemType where + readsPrec _ "basic" = [(BasicItem, "")] + +instance ToJSON FeedItemType where + toJSON BasicItem = String "basic" + +data FeedItemParams (k :: FeedItemType) + = BasicFeedItem { + itemTitle :: String, + itemImageURL :: String, + itemBody :: Maybe String, + itemBackgroundColour :: Maybe String, + itemTitleColour :: Maybe String, + itemBodyColour :: Maybe String + } + +newBasicFeedItem :: String -> String -> FeedItemParams BasicItem +newBasicFeedItem title url = BasicFeedItem { + itemTitle = title, + itemImageURL = url, + itemBody = Nothing, + itemBackgroundColour = Nothing, + itemTitleColour = Nothing, + itemBodyColour = Nothing +} + +instance ToFormUrlEncoded (FeedItemParams k) where + toFormUrlEncoded BasicFeedItem{..} = + [ ( "params[title]" , T.pack itemTitle ) + , ( "params[image_url]", T.pack itemImageURL ) + ] + +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 k, + itemURL :: Maybe String +} + +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 { + webhooks :: [Webhook] +} deriving (Show, Generic) + +instance FromJSON Webhooks +instance ToJSON Webhooks + +data Webhook = Webhook { + webhookAccountID :: AccountID, + webhookURL :: String, + webhookID :: Maybe WebhookID +} deriving Show + +instance FromJSON Webhook where + parseJSON (Object v) = + Webhook <$> v .: "account_id" + <*> v .: "url" + <*> 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 { + uploadFileName :: String, + uploadFileType :: String +} + +instance ToFormUrlEncoded FileUploadReq where + toFormUrlEncoded req = + [ ( "file_name", T.pack $ uploadFileName req ) + , ( "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 +} + +instance FromJSON FileUploadRes where + parseJSON (Object v) = + FileUploadRes <$> v .: "file_url" + <*> v .: "upload_url" + parseJSON _ = mzero + +instance ToJSON FileUploadRes where + toJSON FileUploadRes{..} = + object [ "file_url" .= uploadURL + , "upload_url" .= uploadPostURL + ] + +-------------------------------------------------------------------------------- + +-- | Transaction attachments. +data Attachment = Attachment { + attachmentTransaction :: TransactionID, + attachmentFileType :: String, + attachmentURL :: String, + attachmentID :: Maybe AttachmentID, + attachmentUserID :: Maybe String, + attachmentCreated :: Maybe String +} deriving Show + +instance FromJSON Attachment where + parseJSON (Object v) = + Attachment <$> v .: "external_id" + <*> v .: "file_type" + <*> v .: "file_url" + <*> v .: "id" + <*> v .: "user_id" + <*> 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/Monzo/MonzoSpec.hs view
@@ -0,0 +1,30 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Monzo API -- +-- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- +-------------------------------------------------------------------------------- + +module Monzo.MonzoSpec where + +-------------------------------------------------------------------------------- + +import Control.Arrow (left) + +import Test.Hspec + +import Monzo +import Monzo.Server + +-------------------------------------------------------------------------------- + +monzoTest baseUrl m = left show <$> withMonzoAt baseUrl "" m + +spec :: Spec +spec = describe "Monzo" $ beforeAll (startWaiApp server) $ afterAll endWaiApp $ do + + it "Monzo.listAccounts" $ \(_, baseUrl) -> + monzoTest baseUrl listAccounts `shouldReturn` Right [acc] + + it "Monzo.getBalance" $ \(_, baseUrl) -> + monzoTest baseUrl (getBalance acc) `shouldReturn` Right balance + +--------------------------------------------------------------------------------
+ test/Monzo/Server.hs view
@@ -0,0 +1,88 @@+-------------------------------------------------------------------------------- +-- Haskell bindings for the Monzo API -- +-- Written by Michael B. Gale (michael.gale@cl.cam.ac.uk) -- +-------------------------------------------------------------------------------- + +module Monzo.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 Monzo +import Monzo.API + +-------------------------------------------------------------------------------- + +instance HasServer api ctx => HasServer (MonzoAuth :> api) ctx where + type ServerT (MonzoAuth :> 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 MonzoAPI +handler = return (AccountsResponse [acc]) + :<|> (\acc -> return balance) + :<|> undefined + +server :: Application +server = serve monzoAPI 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 #-}