diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Uber.hs b/src/Uber.hs new file mode 100644 --- /dev/null +++ b/src/Uber.hs @@ -0,0 +1,15 @@ +module Uber + ( module Uber.Auth + , module Uber.Client + , module Uber.Contract + , module Uber.Settings + , module WebApi.Contract + , module WebApi.Client + ) where + +import Uber.Auth +import Uber.Client +import Uber.Contract +import Uber.Settings +import WebApi.Contract +import WebApi.Client diff --git a/src/Uber/Auth.hs b/src/Uber/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Auth.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Uber.Auth + ( Token (..) + , ServerToken (..) + , OAuthToken (..) + ) where + +import Data.Monoid ((<>)) +import Data.Text +import GHC.Generics (Generic) +import WebApi + +data AuthHeader = AuthHeader + { authorization :: Text + } deriving Generic + +-- | Data type used to store Server Token +newtype ServerToken = ServerToken Text + deriving Show + +-- | Data type used to store OAuth Token +newtype OAuthToken = OAuthToken Text + deriving Show + +-- | Data type used to store either Server or OAuth token +data Token = Server ServerToken + | OAuth OAuthToken + deriving Show + +class FromToken a where + fromToken :: a -> Text + +instance FromToken ServerToken where + fromToken (ServerToken x) = "Token " <> x + +instance FromToken OAuthToken where + fromToken (OAuthToken x) = "Bearer " <> x + +instance FromToken Token where + fromToken (Server x) = fromToken x + fromToken (OAuth x) = fromToken x + +instance ToHeader AuthHeader +instance ToHeader ServerToken where + toHeader = toHeader . AuthHeader . fromToken +instance ToHeader OAuthToken where + toHeader = toHeader . AuthHeader . fromToken +instance ToHeader Token where + toHeader = toHeader . AuthHeader . fromToken diff --git a/src/Uber/Client.hs b/src/Uber/Client.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Client.hs @@ -0,0 +1,220 @@ +module Uber.Client where + +import Data.Text +import Uber.Auth +import Uber.Contract +import Uber.Settings +import Uber.Types.Product +import Uber.Types.PriceEstimate +import Uber.Types.TimeEstimate +import Uber.Types.History +import Uber.Types.UserInfo +import Uber.Types.RideRequest +import Uber.Types.Misc +import Uber.Types.Reminder +import WebApi + +-- | Returns information about the Uber products offered at a given location +getProducts :: Settings -> LatLng -> IO (Response GET ProductsR) +getProducts settings ll = do + client (addV1 $ toClientSettings settings) $ + Request () ll () () (auth settings) () () + +-- | Returns information aboit a specific Uber product +getProductDetails :: Settings -> ProductId -> IO (Response GET ProductDetailsR) +getProductDetails settings (ProductId pid) = do + client (addV1 $ toClientSettings settings) $ + Request (ProdId $ Field pid) () () () (auth settings) () () + +-- | Returns an estimated price range for each product offered at a given location +getPriceEstimate :: Settings -> PriceEstimateParams -> IO (Response GET PriceEstimateR) +getPriceEstimate settings pp = do + client (addV1 $ toClientSettings settings) $ + Request () pp () () (auth settings) () () + +-- | Returns ETAs for all products offered at a given location +getTimeEstimate :: Settings -> TimeEstimateParams -> IO (Response GET TimeEstimateR) +getTimeEstimate settings tp = do + client (addV1 $ toClientSettings settings) $ + Request () tp () () (auth settings) () () + +-- | Returns data about a user’s activity with Uber +getHistory :: Settings -> HistoryParams -> IO (Response GET HistoryR) +getHistory settings hp = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getHistory: Requires OAuth token" + client (addV12 $ toClientSettings settings) $ + Request () hp () () tkn () () + +-- | Returns information about the Uber user that has authorized with the application +getUserInfo :: Settings -> IO (Response GET UserInfoR) +getUserInfo settings = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getUserInfo: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request () () () () tkn () () + +-- | Requests a ride on behalf of an Uber user +requestARide :: Settings -> RideReqParams -> IO (Response POST RequestRideR) +requestARide settings rp = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "requestARide: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request () () () () tkn () rp + +-- | Returns the real-time details for an ongoing trip +getCurrentRequest :: Settings -> IO (Response GET CurrentRequestR) +getCurrentRequest settings = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getCurrentRequest: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request () () () () tkn () () + +-- | Updates an ongoing request’s destination +updateCurrentRequest :: Settings -> RidePatchParams -> IO (Response PATCH CurrentRequestR) +updateCurrentRequest settings rp = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "updateCurrentRequest: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request () () () () tkn () rp + +-- | Cancels the user's current trip +cancelCurrentRequest :: Settings -> IO (Response DELETE CurrentRequestR) +cancelCurrentRequest settings = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "cancelCurrentRequest: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request () () () () tkn () () + +-- | Gets a ride's estimates given the desired product, start, and end locations +getRideEstimate :: Settings -> RideReqParams -> IO (Response POST RideEstimateR) +getRideEstimate settings rp = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getRideEstimate: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request () () () () tkn () rp + +type RideId = Text +type PlaceId = Text +type ReminderId = Text + +-- | Gets the status of an ongoing or completed trip +getRideStatus :: Settings -> RideId -> IO (Response GET RideR) +getRideStatus settings rid = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getRideStatus: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request rid () () () tkn () () + +-- | Cancels an ongoing Request on behalf of a rider +cancelRide :: Settings -> RideId -> IO (Response GET RideR) +cancelRide settings rid = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "cancelRide: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request rid () () () tkn () () + +-- | Updates an ongoing request’s destination +updateRide :: Settings -> RideId -> RidePatchParams -> IO (Response PATCH RideR) +updateRide settings rid rp = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "updateRide: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request rid () () () tkn () rp + +-- | Gets a map for an accepted Request +getTrackingMap :: Settings -> RideId -> IO (Response GET TrackingMapR) +getTrackingMap settings rid = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getTrackingMap: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request rid () () () tkn () () + +-- | Gets the receipt information of the completed request +getReceipt :: Settings -> RideId -> IO (Response GET ReceiptR) +getReceipt settings rid = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getReceipt: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request rid () () () tkn () () + +-- | Retrieves home and work addresses from an Uber user's profile +getAddress :: Settings -> PlaceId -> IO (Response GET PlaceR) +getAddress settings pid = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getAddress: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request pid () () () tkn () () + +-- | Updates home and work addresses for an Uber user's profile +updateAddress :: Settings -> PlaceId -> Address -> IO (Response PUT PlaceR) +updateAddress settings pid addr = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "updateAddress: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request pid () () () tkn () addr + +-- | Retrievs the list of user’s available payment methods +getPaymentMethods :: Settings -> IO (Response GET PaymentMethodR) +getPaymentMethods settings = do + let tkn = case auth settings of + OAuth tkn -> tkn + _ -> error "getPaymentMethods: Requires OAuth token" + client (addV1 $ toClientSettings settings) $ + Request () () () () tkn () () + +-- | Sets a reminder for a future trip +createReminder :: Settings -> ReminderParams -> IO (Response POST CreateReminderR) +createReminder settings rp = do + let tkn = case auth settings of + Server tkn -> tkn + _ -> error "createReminder: Requires Server token" + client (addV1 $ toClientSettings settings) $ + Request () () () () tkn () rp + +-- | Gets the status of an existing ride reminder +getReminderInfo :: Settings -> ReminderId -> IO (Response GET ReminderR) +getReminderInfo settings rid = do + let tkn = case auth settings of + Server tkn -> tkn + _ -> error "getReminderInfo: Requires Server token" + client (addV1 $ toClientSettings settings) $ + Request rid () () () tkn () () + +-- | Removes any reminder in the pending state from being sent +deleteReminder :: Settings -> ReminderId -> IO (Response DELETE ReminderR) +deleteReminder settings rid = do + let tkn = case auth settings of + Server tkn -> tkn + _ -> error "deleteReminder: Requires Server token" + client (addV1 $ toClientSettings settings) $ + Request rid () () () tkn () () + +-- | Updates an existing reminder +updateReminder :: Settings -> ReminderId -> ReminderPatchParams -> IO (Response PATCH ReminderR) +updateReminder settings rid rp = do + let tkn = case auth settings of + Server tkn -> tkn + _ -> error "updateReminder: Requires Server token" + client (addV1 $ toClientSettings settings) $ + Request rid () () () tkn () rp + +addV1 :: ClientSettings -> ClientSettings +addV1 settings = settings { baseUrl = baseUrl settings ++ "/v1" } + +addV12 :: ClientSettings -> ClientSettings +addV12 settings = settings { baseUrl = baseUrl settings ++ "/v1.2" } diff --git a/src/Uber/Contract.hs b/src/Uber/Contract.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Contract.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Uber.Contract where + +import WebApi +import Data.Proxy +import Data.Text.Encoding +import Data.Text (Text) +import Uber.Auth +import Uber.Types.Product +import Uber.Types.PriceEstimate +import Uber.Types.TimeEstimate +import Uber.Types.History +import Uber.Types.UserInfo +import Uber.Types.RideRequest +import Uber.Types.Misc +import Uber.Types.Reminder + +data UberAPI + +type ProductsR = Static "products" +type ProductDetailsR = "products" :/ Text +type PriceEstimateR = "estimates" :/ "price" +type TimeEstimateR = "estimates" :/ "time" +type HistoryR = Static "history" +type UserInfoR = Static "me" +type RequestRideR = Static "requests" +type CurrentRequestR = "requests" :/ "current" +type RideR = "requests" :/ Text +type RideEstimateR = "requests" :/ "estimate" +type TrackingMapR = "requests" :/ Text :/ "map" +type ReceiptR = "requests" :/ Text :/ "receipts" +type PlaceR = "places" :/ Text +type PaymentMethodR = Static "payment-methods" +type CreateReminderR = Static "reminders" +type ReminderR = "reminders" :/ Text + +instance WebApi UberAPI where + type Apis UberAPI = + '[ Route '[GET ] ProductsR + , Route '[GET ] ProductDetailsR + , Route '[GET ] PriceEstimateR + , Route '[GET ] TimeEstimateR + , Route '[GET ] HistoryR + , Route '[GET ] UserInfoR + , Route '[POST ] RequestRideR + , Route '[GET, PATCH, DELETE ] CurrentRequestR + , Route '[GET, PATCH, DELETE ] RideR + , Route '[POST ] RideEstimateR + , Route '[GET ] TrackingMapR + , Route '[GET ] ReceiptR + , Route '[GET, PUT ] PlaceR + , Route '[GET ] PaymentMethodR + , Route '[POST ] CreateReminderR + , Route '[GET, PATCH, DELETE ] ReminderR + ] + +instance ApiContract UberAPI GET ProductsR where + type HeaderIn GET ProductsR = Token + type QueryParam GET ProductsR = LatLng + type ApiOut GET ProductsR = Products + +instance ApiContract UberAPI GET ProductDetailsR where + type HeaderIn GET ProductDetailsR = Token + type PathParam GET ProductDetailsR = ProdId + type ApiOut GET ProductDetailsR = Product + +instance ApiContract UberAPI GET PriceEstimateR where + type HeaderIn GET PriceEstimateR = Token + type QueryParam GET PriceEstimateR = PriceEstimateParams + type ApiOut GET PriceEstimateR = PriceEstimates + +instance ApiContract UberAPI GET TimeEstimateR where + type HeaderIn GET TimeEstimateR = Token + type QueryParam GET TimeEstimateR = TimeEstimateParams + type ApiOut GET TimeEstimateR = TimeEstimates + +instance ApiContract UberAPI GET HistoryR where + type HeaderIn GET HistoryR = OAuthToken + type QueryParam GET HistoryR = HistoryParams + type ApiOut GET HistoryR = HistoryResp + +instance ApiContract UberAPI GET UserInfoR where + type HeaderIn GET UserInfoR = OAuthToken + type ApiOut GET UserInfoR = UserInfo + +instance ApiContract UberAPI POST RequestRideR where + type HeaderIn POST RequestRideR = OAuthToken + type RequestBody POST RequestRideR = '[RideReqParams] + type ApiOut POST RequestRideR = RideInfo + type ApiErr POST RequestRideR = ErrorResponse + +instance ApiContract UberAPI GET CurrentRequestR where + type HeaderIn GET CurrentRequestR = OAuthToken + type ApiOut GET CurrentRequestR = RideInfo + +instance ApiContract UberAPI PATCH CurrentRequestR where + type HeaderIn PATCH CurrentRequestR = OAuthToken + type RequestBody PATCH CurrentRequestR = '[RidePatchParams] + type ApiOut PATCH CurrentRequestR = HTMLText + type ApiErr PATCH CurrentRequestR = HTMLText + type ContentTypes PATCH CurrentRequestR = '[HTML] + +instance ApiContract UberAPI DELETE CurrentRequestR where + type HeaderIn DELETE CurrentRequestR = OAuthToken + type ApiOut DELETE CurrentRequestR = HTMLText + type ApiErr DELETE CurrentRequestR = HTMLText + type ContentTypes DELETE CurrentRequestR = '[HTML] + +instance ApiContract UberAPI POST RideEstimateR where + type HeaderIn POST RideEstimateR = OAuthToken + type RequestBody POST RideEstimateR = '[RideReqParams] + type ApiOut POST RideEstimateR = RideEstimate + +instance ApiContract UberAPI GET RideR where + type HeaderIn GET RideR = OAuthToken + type PathParam GET RideR = Text + type ApiOut GET RideR = RideInfo + +instance ApiContract UberAPI PATCH RideR where + type HeaderIn PATCH RideR = OAuthToken + type PathParam PATCH RideR = Text + type RequestBody PATCH RideR = '[RidePatchParams] + type ApiOut PATCH RideR = HTMLText + type ApiErr PATCH RideR = HTMLText + type ContentTypes PATCH RideR = '[HTML] + +instance ApiContract UberAPI DELETE RideR where + type HeaderIn DELETE RideR = OAuthToken + type PathParam DELETE RideR = Text + type ApiOut DELETE RideR = HTMLText + type ApiErr DELETE RideR = HTMLText + type ContentTypes DELETE RideR = '[HTML] + +instance ApiContract UberAPI GET TrackingMapR where + type HeaderIn GET TrackingMapR = OAuthToken + type PathParam GET TrackingMapR = Text + type ApiOut GET TrackingMapR = TrackingMap + +instance ApiContract UberAPI GET ReceiptR where + type HeaderIn GET ReceiptR = OAuthToken + type PathParam GET ReceiptR = Text + type ApiOut GET ReceiptR = Receipt + +instance ApiContract UberAPI GET PlaceR where + type HeaderIn GET PlaceR = OAuthToken + type PathParam GET PlaceR = Text + type ApiOut GET PlaceR = Address + +instance ApiContract UberAPI PUT PlaceR where + type HeaderIn PUT PlaceR = OAuthToken + type PathParam PUT PlaceR = Text + type RequestBody PUT PlaceR = '[Address] + type ApiOut PUT PlaceR = Address + +instance ApiContract UberAPI GET PaymentMethodR where + type HeaderIn GET PaymentMethodR = OAuthToken + type ApiOut GET PaymentMethodR = PaymentMethods + +instance ApiContract UberAPI POST CreateReminderR where + type HeaderIn POST CreateReminderR = ServerToken + type RequestBody POST CreateReminderR = '[ReminderParams] + type ApiOut POST CreateReminderR = Reminder + +instance ApiContract UberAPI GET ReminderR where + type HeaderIn GET ReminderR = ServerToken + type PathParam GET ReminderR = Text + type ApiOut GET ReminderR = Reminder + +instance ApiContract UberAPI PATCH ReminderR where + type HeaderIn PATCH ReminderR = ServerToken + type PathParam PATCH ReminderR = Text + type RequestBody PATCH ReminderR = '[ReminderPatchParams] + type ApiOut PATCH ReminderR = Reminder + +instance ApiContract UberAPI DELETE ReminderR where + type HeaderIn DELETE ReminderR = ServerToken + type PathParam DELETE ReminderR = Text + type ApiOut DELETE ReminderR = HTMLText + type ApiErr DELETE ReminderR = HTMLText + type ContentTypes DELETE ReminderR = '[HTML] + +instance Decode HTML HTMLText where + decode _ = (HTMLText <$>) . (decode (Proxy :: Proxy PlainText)) + +data HTMLText = HTMLText Text deriving Show diff --git a/src/Uber/Settings.hs b/src/Uber/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Settings.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +module Uber.Settings + ( defSettings + , sandboxSettings + , auth + , Settings + , toClientSettings + ) where + +import Data.Text (unpack, Text) +import Uber.Auth +import WebApi + +data Settings = Settings + { url :: Text + , auth :: Token + , manager :: Manager + } + +sandboxSettings :: Manager -> Settings +sandboxSettings mngr = Settings "https://sandbox-api.uber.com" (Server $ ServerToken "") mngr + +defSettings :: Manager -> Settings +defSettings mngr = Settings "https://api.uber.com" (Server (ServerToken "")) mngr + +toClientSettings :: Settings -> ClientSettings +toClientSettings (Settings u _ m) = ClientSettings (unpack u) m diff --git a/src/Uber/Types/History.hs b/src/Uber/Types/History.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Types/History.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Uber.Types.History where + +import Data.Aeson +import Data.Aeson.Types +import Data.Text (Text) +import GHC.Generics (Generic) +import Uber.Auth +import WebApi + +data HistoryParams = HistoryParams + { offset :: Maybe Int + , limit :: Maybe Int + } deriving (Show, Generic) + +data HistoryResp = HistoryResp + { h_offset :: Int + , h_limit :: Int + , h_count :: Int + , h_history :: [History] + } deriving (Show, Generic) + +data History = History + { request_id :: Text + , request_time :: Integer + , product_id :: Text + , status :: Text + , distance :: Double + , start_time :: Integer + , start_city :: City + } deriving (Show, Generic) + +data City = City + { display_name :: Text + , latitude :: Double + , longitude :: Double + } deriving (Show, Generic) + +instance ToParam HistoryParams 'QueryParam +instance FromJSON History where +instance FromJSON City where +instance FromJSON HistoryResp where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } diff --git a/src/Uber/Types/Misc.hs b/src/Uber/Types/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Types/Misc.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Uber.Types.Misc where + +import Data.Aeson +import Data.Aeson.Types +import Data.Text (Text) +import GHC.Generics (Generic) +import Uber.Types.RideRequest (toUnderscores) +import WebApi + +data TrackingMap = TrackingMap + { t_request_id :: Text + , t_href :: Text + } deriving (Generic, Show) + +data Receipt = Receipt + { request_id :: Text + , charges :: [Charge] + , surge_charge :: Maybe Charge + , charge_adjustments :: [Charge] + , normal_fare :: Text + , subtotal :: Text + , total_charged :: Text + , total_owed :: Maybe Double + , currency_code :: Text + , duration :: Text + , distance :: Text + , distance_label :: Text + } deriving (Generic, Show) + +data Charge = Charge + { name :: Text + , amount :: Double + } deriving (Generic, Show) + +data Address = Address + { address :: Text + } deriving (Generic, Show) + +newtype PaymentMethods = PaymentMethods + { payment_methods :: [PaymentMethod] + } deriving (Generic, Show) + +data PaymentMethod = PaymentMethod + { p_payment_method_id :: Text + , p_type :: PaymentType + , p_description :: Maybe Text + , p_last_used :: Maybe Text + } deriving (Generic, Show) + +data PaymentType + = AirtelMoney + | Alipay + | ApplePay + | AmericanExpress + | BaiduWallet + | BusinessAccount + | Cash + | Discover + | GoogleWallet + | Jcb + | Lianlian + | Maestro + | Mastercard + | Paypal + | Paytm + | Ucharge + | Unionpay + | Unknown + | Visa + | Zaakpay + deriving (Generic, Show) + +instance FromJSON Receipt where +instance FromJSON Charge where +instance FromJSON Address where +instance FromJSON PaymentMethods where +instance ToJSON Address where +instance FromJSON PaymentMethod where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON TrackingMap where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON PaymentType where + parseJSON = genericParseJSON defaultOptions { allNullaryToStringTag = True + , constructorTagModifier = toUnderscores + } diff --git a/src/Uber/Types/PriceEstimate.hs b/src/Uber/Types/PriceEstimate.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Types/PriceEstimate.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Uber.Types.PriceEstimate where + +import Data.Aeson +import Data.Text (Text) +import GHC.Generics (Generic) +import Uber.Auth +import WebApi + +data PriceEstimateParams = PriceEstimateParams + { start_latitude :: Double + , start_longitude :: Double + , end_latitude :: Double + , end_longitude :: Double + } deriving (Show, Generic) + +newtype PriceEstimates = PriceEstimates + { prices :: [PriceEstimate] + } deriving (Show, Generic) + +data PriceEstimate = PriceEstimate + { product_id :: Text + , currency_code :: Text + , display_name :: Text + , estimate :: Text + , low_estimate :: Int + , high_estimate :: Int + , surge_multiplier :: Double + , duration :: Int + , distance :: Double + } deriving (Show, Generic) + +instance ToParam PriceEstimateParams 'QueryParam +instance FromJSON PriceEstimates +instance FromJSON PriceEstimate diff --git a/src/Uber/Types/Product.hs b/src/Uber/Types/Product.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Types/Product.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Uber.Types.Product where + +import Data.Aeson +import Data.Text (Text) +import GHC.Generics (Generic) +import Uber.Auth +import WebApi + +data LatLng = LatLng + { latitude :: Double + , longitude :: Double + } deriving (Show, Generic) + +newtype Products = Products { products :: [Product] } + deriving (Show, Generic) + +data Product = Product + { product_id :: Text + , short_description :: Maybe Text + , description :: Text + , display_name :: Text + , capacity :: Int + , image :: Text + , price_details :: PriceDetails + } deriving (Show, Generic) + +data PriceDetails = PriceDetails + { base :: Double + , minimum :: Double + , cost_per_minute :: Double + , cost_per_distance :: Double + , distance_unit :: Text + , cancellation_fee :: Double + , currency_code :: Text + , service_fees :: [AdditionalFee] + } deriving (Show, Generic) + +data AdditionalFee = AdditionalFee + { name :: Text + , fee :: Double + } deriving (Show, Generic) + +newtype ProdId = ProdId + { pid :: Field "product_id" Text + } deriving (Generic) + +data ProductId = ProductId Text + +instance ToParam LatLng 'QueryParam +instance ToParam ProdId 'PathParam +instance FromJSON Products +instance FromJSON Product +instance FromJSON PriceDetails +instance FromJSON AdditionalFee diff --git a/src/Uber/Types/Reminder.hs b/src/Uber/Types/Reminder.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Types/Reminder.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Uber.Types.Reminder where + +import Data.Aeson +import Data.Aeson.Types +import Data.Char (toLower) +import Data.Text (Text) +import GHC.Generics (Generic) +import WebApi + +data ReminderParams = ReminderParams + { reminder_time :: Integer + , phone_number :: Text + , event :: Event + , trip_branding :: Maybe TripBranding + } deriving (Generic, Show) + +data Event = Event + { time :: Integer + , name :: Maybe Text + , location :: Maybe Text + , latitude :: Maybe Double + , longitude :: Maybe Double + , product_id :: Maybe Text + } deriving (Generic, Show) + +data TripBranding = TripBranding + { link_text :: Maybe Text + , partner_deeplink :: Maybe Text + } deriving (Generic, Show) + +data Reminder = Reminder + { r_event :: Event + --, r_product_id :: Maybe Text + , r_reminder_id :: Text + , r_reminder_time :: Integer + , r_reminder_status :: ReminderStatus + , r_trip_branding :: Maybe TripBranding + } deriving (Generic, Show) + +data ReminderStatus = Pending | Sent + deriving (Generic, Show) + +data ReminderPatchParams = ReminderPatchParams + { p_reminder_time :: Maybe Int + , p_phone_number :: Maybe Text + , p_event :: Maybe Event + --, p_trip_branding :: Maybe TripBranding + } deriving (Generic, Show) + + +instance ToJSON ReminderParams +instance FromJSON Event +instance FromJSON TripBranding +instance ToJSON Event +instance ToJSON TripBranding +instance ToJSON ReminderPatchParams where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON Reminder where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON ReminderStatus where + parseJSON = genericParseJSON defaultOptions { allNullaryToStringTag = True + , constructorTagModifier = map toLower + } diff --git a/src/Uber/Types/RideRequest.hs b/src/Uber/Types/RideRequest.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Types/RideRequest.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Uber.Types.RideRequest where + +import Data.Aeson +import Data.Aeson.Types +import Data.Char +import Data.List (intercalate) +import Data.Text (Text) +import GHC.Generics (Generic) +import Uber.Auth +import WebApi + +data RideReqParams = RideReqParams + { product_id :: Maybe Text + , start_latitude :: Maybe Double + , start_longitude :: Maybe Double + , start_nickname :: Maybe Text + , start_address :: Maybe Text + , start_place_id :: Maybe Text + , end_latitude :: Maybe Double + , end_longitude :: Maybe Double + , end_nickname :: Maybe Text + , end_address :: Maybe Text + , end_place_id :: Maybe Text + , surge_confirmation_id :: Maybe Text + , payment_method_id :: Maybe Text + } deriving (Generic, Show) + +defRideReqParams :: RideReqParams +defRideReqParams = RideReqParams Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data RideInfo = RideInfo + { request_id :: Text + , status :: Status + , vehicle :: Maybe Vehicle + , driver :: Maybe Driver + , location :: Maybe Location + , eta :: Maybe Integer + , surge_multiplier :: Maybe Double + , pickup :: Maybe Pickup + , destination ::Maybe Destination + } deriving (Generic, Show) + +data Status = Processing + | NoDriversAvailable + | Accepted + | Arriving + | InProgress + | DriverCanceled + | RiderCanceled + | Completed + deriving (Generic, Show) + +data Vehicle = Vehicle + { make :: Text + , model :: Text + , license_plate :: Text + , picture_url :: Text + } deriving (Generic, Show) + +data Driver = Driver + { d_phone_number :: Text + , d_rating :: Double + , d_picture_url :: Text + , d_name :: Text + } deriving (Generic, Show) + +data Location = Location + { latitude :: Double + , longitude :: Double + , bearing :: Int + } deriving (Generic, Show) + +data Pickup = Pickup + { p_latitude :: Double + , p_longitude :: Double + , p_eta :: Double + } deriving (Generic, Show) + +data Destination = Destination + { d_latitude :: Double + , d_longitude :: Double + , d_eta :: Maybe Double + } deriving (Generic, Show) + +data RidePatchParams = RidePatchParams + { r_end_latitude :: Maybe Double + , r_end_longitude :: Maybe Double + , r_end_address :: Maybe Text + , r_end_nickname :: Maybe Text + , r_end_place_id :: Maybe Text + } deriving (Generic, Show) + +data RideEstimate = RideEstimate + { pickup_estimate :: Int + , price :: Price + , trip :: Maybe Trip + } deriving (Generic, Show) + +data Price = Price + { p_surge_multiplier :: Double + , p_surge_confirmation_id :: Maybe Text + , p_surge_confirmation_href :: Maybe Text + , p_minimum :: Int + , p_display :: Maybe Text + , p_low_estimate :: Maybe Int + , p_high_estimate :: Maybe Int + , p_currency_code :: Text + } deriving (Generic, Show) + +data Trip = Trip + { distance_estimate :: Double + , distance_unit :: Text + , duration_estimate :: Int + } deriving (Generic, Show) + +data ErrorResponse = ErrorResponse + { meta :: SurgeError + , errors :: [UberError] + } deriving (Generic, Show) + +data UberError = UberError + { u_status :: Int + , u_code :: Text + , u_title :: Text + } deriving (Generic, Show) + +data SurgeError = SurgeError + { surge_confirmation :: SurgeConfirmation + } deriving (Generic, Show) + +data SurgeConfirmation = SurgeConfirmation + { s_href :: Text + , s_surge_confirmation_id :: Text + , s_multiplier :: Double + , s_expires_at :: Integer + } deriving (Generic, Show) + +instance ToJSON RideReqParams where +instance FromJSON RideInfo where +instance FromJSON Vehicle where +instance FromJSON Location where +instance FromJSON RideEstimate where +instance FromJSON Trip where +instance FromJSON ErrorResponse where +instance FromJSON SurgeError where +instance FromJSON Price where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON Driver where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON Pickup where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON Destination where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON SurgeConfirmation where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON UberError where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } +instance FromJSON Status where + parseJSON = genericParseJSON defaultOptions { allNullaryToStringTag = True + , constructorTagModifier = toUnderscores + } +instance ToJSON RidePatchParams where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = drop 2 } + +splitOnUpper :: String -> [String] +splitOnUpper [] = [] +splitOnUpper s = let (ys, zs) = fn (lowerHead s) in (ys : splitOnUpper zs) + where + fn [] = ([], []) + fn (x:xs) = if isUpper x + then ([], toLower x : xs) + else let (ys, zs) = fn xs in (x:ys, zs) + lowerHead [] = [] + lowerHead (x:xs) = toLower x : xs + +toUnderscores :: String -> String +toUnderscores = map toLower . intercalate "_" . splitOnUpper diff --git a/src/Uber/Types/TimeEstimate.hs b/src/Uber/Types/TimeEstimate.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Types/TimeEstimate.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Uber.Types.TimeEstimate where + +import Data.Aeson +import Data.Aeson.Types +import Data.Text (Text) +import GHC.Generics (Generic) +import Uber.Auth +import WebApi + +data TimeEstimateParams = TimeEstimateParams + { start_latitude :: Double + , start_longitude :: Double + , product_id :: Maybe Text + } deriving (Show, Generic) + +newtype TimeEstimates = TimeEstimates { times :: [TimeEstimate] } + deriving (Show, Generic) + +data TimeEstimate = TimeEstimate + { t_product_id :: Text + , t_display_name :: Text + , t_estimate :: Int + } deriving (Show, Generic) + +instance ToParam TimeEstimateParams 'QueryParam +instance FromJSON TimeEstimates where +instance FromJSON TimeEstimate where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 2 } + diff --git a/src/Uber/Types/UserInfo.hs b/src/Uber/Types/UserInfo.hs new file mode 100644 --- /dev/null +++ b/src/Uber/Types/UserInfo.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Uber.Types.UserInfo where + +import Data.Aeson +import Data.Aeson.Types +import Data.Text (Text) +import GHC.Generics (Generic) +import Uber.Auth +import WebApi + +data UserInfo = UserInfo + { first_name :: Text + , last_name :: Text + , email :: Text + , mobile_verified :: Bool + , promo_code :: Text + , uuid :: Text + } deriving (Generic, Show) + +instance FromJSON UserInfo diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +import Data.Text as T +import Uber +import Uber.Types.History +import Uber.Types.Misc +import Uber.Types.PriceEstimate +import Uber.Types.Product +import Uber.Types.Reminder +import Uber.Types.RideRequest as RR +import Uber.Types.TimeEstimate +import Uber.Types.UserInfo +import System.Environment (getEnv) +import Test.Hspec + +main :: IO () +main = do + oauthTkn <- getEnv "UBER_OAUTH_TOKEN" + serverTkn <- getEnv "UBER_SERVER_TOKEN" + manager <- newManager tlsManagerSettings + hspec $ do + let fakeSettings = (sandboxSettings manager) { auth = OAuth (OAuthToken "FakeToken") } + settingsWithOAuth = (sandboxSettings manager) { auth = OAuth (OAuthToken $ T.pack oauthTkn) } + settingsWithServerToken = (sandboxSettings manager) { auth = Server (ServerToken $ T.pack serverTkn) } + describe "getProducts: Authentication with FakeToken" $ do + it "should fail" $ do + resp <- getProducts fakeSettings (LatLng 13.0827 80.2707) + resp `shouldSatisfy` (not . isSuccess) + describe "getProducts: Authentication with OAuthToken" $ do + shouldPass $ getProducts settingsWithOAuth (LatLng 13.0827 80.2707) + describe "getProducts: Authentication with ServerToken" $ do + shouldPass $ getProducts settingsWithServerToken (LatLng 13.0827 80.2707) + describe "getProductDetails:" $ do + shouldPass $ getProductDetails settingsWithOAuth (ProductId "c58b6622-0be7-4de1-ad60-a9c4d6f4eaa5") + describe "getPriceEstimate:" $ do + shouldPass $ getPriceEstimate settingsWithOAuth (PriceEstimateParams 12.9760 80.2212 13.0012 80.2565) + describe "getTimeEstimate:" $ do + shouldPass $ getTimeEstimate settingsWithOAuth (TimeEstimateParams 12.9760 80.2212 Nothing) + describe "getHistory:" $ do + shouldPass $ getHistory settingsWithOAuth (HistoryParams Nothing Nothing) + describe "getUserInfo:" $ do + shouldPass $ getUserInfo settingsWithOAuth + describe "getCurrentRequest:" $ do + shouldPass $ getCurrentRequest settingsWithOAuth + describe "updateCurrentRequest:" $ do + shouldPass $ updateCurrentRequest settingsWithOAuth $ RidePatchParams (Just 13.0012) (Just 80.2565) Nothing Nothing Nothing + describe "cancelCurrentRequest:" $ do + shouldPass $ cancelCurrentRequest settingsWithOAuth + describe "getRideEstimate:" $ do + shouldPass $ getRideEstimate settingsWithOAuth (defRideReqParams + { RR.start_latitude = Just 12.9760 + , RR.start_longitude = Just 80.2212 + }) + describe "requestARide:" $ do + it "should pass" $ do + resp <- requestARide settingsWithOAuth (defRideReqParams + { RR.start_latitude = Just 12.9760 + , RR.start_longitude = Just 80.2212 + }) + case resp of + Success _ r _ _ -> do + let rid = RR.request_id r + res1 <- getRideStatus settingsWithOAuth rid + res2 <- updateRide settingsWithOAuth rid $ RidePatchParams (Just 13.0012) (Just 80.2565) Nothing Nothing Nothing + res3 <- cancelRide settingsWithOAuth rid + case (res1, res2, res3) of + (Success {}, Success {}, Success {}) -> return () + _ -> fail "Reminder request failed!" + Failure {} -> fail "`requestARide` Failed" + describe "getPaymentMethods:" $ do + shouldPass $ getPaymentMethods settingsWithOAuth + describe "reminder:" $ do + it "should pass" $ do + resp <- createReminder settingsWithServerToken $ ReminderParams 1461984150 "+919876543210" (Event 1462984150 Nothing Nothing Nothing Nothing Nothing) (Just $ TripBranding Nothing Nothing) + case resp of + Success _ r _ _ -> do + let rid = r_reminder_id r + res1 <- getReminderInfo settingsWithServerToken rid + res2 <- updateReminder settingsWithServerToken rid $ ReminderPatchParams (Just 1461984150) (Just "+911234567890") (Just $ Event 1462984150 Nothing Nothing Nothing Nothing Nothing) + res3 <- deleteReminder settingsWithServerToken rid + case (res1, res2, res3) of + (Success {}, Success {}, Success {}) -> return () + _ -> fail "Reminder request failed!" + Failure {} -> fail "`createReminder` Failed" + +shouldPass :: (Show (ApiOut m r), Show (ApiErr m r)) => IO (Response m r) -> SpecWith () +shouldPass x = do + it "should pass" $ do + resp <- x + resp `shouldSatisfy` isSuccess + +instance Show OtherError where + show (OtherError e) = show e + +instance (Show (ApiOut m r), Show (ApiErr m r)) => Show (Response m r) where + show (Success _ x _ _) = show x + show (Failure (Left x)) = show x + show (Failure (Right x)) = show x + +instance Show (ApiErr m r) => Show (ApiError m r) where + show (ApiError _ x _ _) = show x + +isSuccess :: Response m r -> Bool +isSuccess r = case r of + Success {} -> True + Failure {} -> False diff --git a/uber.cabal b/uber.cabal new file mode 100644 --- /dev/null +++ b/uber.cabal @@ -0,0 +1,50 @@ +name: uber +version: 0.1.0.0 +synopsis: Uber client for Haskell +description: Bindings for Uber API +homepage: https://github.com/byteally/webapi-uber.git +license: BSD3 +license-file: LICENSE +author: Tarun +maintainer: Tarun +--copyright: 2016 Author name here +category: Web, Network +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Uber + , Uber.Auth + , Uber.Client + , Uber.Contract + , Uber.Settings + , Uber.Types.Product + , Uber.Types.PriceEstimate + , Uber.Types.TimeEstimate + , Uber.Types.History + , Uber.Types.UserInfo + , Uber.Types.RideRequest + , Uber.Types.Misc + , Uber.Types.Reminder + build-depends: base >= 4.7 && < 5 + , aeson + , text + , webapi == 0.2.* + default-language: Haskell2010 + +test-suite uber-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , hspec + , text + , uber + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/byteally/webapi-uber.git