module Web.JonathansCard
(
Balance(..)
, Change(..)
, balances
, latest
, changes
, UTCTime
) where
import Control.Monad ( ap, liftM )
import Data.ByteString.Char8 ( ByteString, unpack )
import Data.Time.Clock ( UTCTime )
import Data.Time.Format ( parseTime )
import Network.HTTP ( Header(Header), HeaderName(..), Request(Request)
, RequestMethod(GET), getResponseBody, simpleHTTP
, catchIO
)
import Network.URI ( URI(URI), URIAuth(URIAuth) )
import System.Locale ( defaultTimeLocale )
import Text.JSON ( JSON(..), JSObject(..), JSValue(..), Result
, decode, resultToEither, valFromObj
)
data Balance = Balance
{ balAmount :: Double
, balBalanceId :: Int
, balCreated :: Maybe UTCTime
, balMessage :: String
} deriving Show
data Change = Change
{ chgBalance :: Double
, chgCreated :: Maybe UTCTime
, chgDelta :: Double
} deriving Show
balances :: IO (Either String [Balance])
balances = apiCall "balances" "balances" "balances"
latest :: IO (Either String Balance)
latest = apiCall "latest" "balance" "latest balance"
changes :: IO (Either String [Change])
changes = apiCall "changes" "changes" "changes"
apiCall :: JSON a => String -> String -> String -> IO (Either String a)
apiCall endpoint parent errObject = flip catchIO (\_ -> err) $ do
rsp <- (decode . unpack) `liftM` request endpoint
return . resultToEither $ valFromObj parent =<< rsp
where err = return . Left $ "Unable to retrieve " ++ errObject ++ "."
request :: String -> IO ByteString
request p = (simpleHTTP $ prepRq p) >>= getResponseBody
prepRq :: String -> Request ByteString
prepRq p = Request (url p) GET headers ""
where
headers = [ Header HdrAccept "application/json"
, Header HdrUserAgent "JonathansCard/0.1 haskell"
]
url :: String -> URI
url p = URI "http:" uriAuth ("/card/api/" ++ p) "" ""
where uriAuth = Just $ URIAuth "" "jonathanstark.com" ":80"
get :: JSON a => JSObject JSValue -> String -> Result a
get = flip valFromObj
getTime :: String -> Maybe UTCTime
getTime = parseTime defaultTimeLocale "%Y-%m-%dT%X%z"
instance JSON Balance where
readJSON (JSObject rsp) = do
Balance `liftM` (read `liftM` get rsp "amount")
`ap` (read `liftM` get rsp "balance_id")
`ap` (getTime `liftM` get rsp "created_at")
`ap` get rsp "message"
readJSON _ = undefined
showJSON = undefined
instance JSON Change where
readJSON (JSObject rsp) = do
Change `liftM` (read `liftM` get rsp "balance")
`ap` (getTime `liftM` get rsp "created_at")
`ap` (read `liftM` get rsp "delta")
readJSON _ = undefined
showJSON = undefined