backend/feat: #38 integrate OSRM route api

nammayatri · Mar 9, 2023 · 671e764 · 671e764
1 parent 0655c0d
commit 671e764
Show file tree

Hide file tree

Showing 3 changed files with 114 additions and 3 deletions.
diff --git a/lib/mobility-core/src/Kernel/External/Maps/Interface.hs b/lib/mobility-core/src/Kernel/External/Maps/Interface.hs
@@ -112,7 +112,7 @@ getRoutes ::
   m GetRoutesResp
 getRoutes serviceConfig req = case serviceConfig of
   GoogleConfig cfg -> Google.getRoutes cfg req
-  OSRMConfig _ -> throwNotProvidedError "getRoutes" OSRM
+  OSRMConfig osrmCfg -> OSRM.getRoutes osrmCfg req
   MMIConfig cfg -> MMI.getRoutes cfg req
 
 snapToRoadProvided :: MapsService -> Bool

diff --git a/lib/mobility-core/src/Kernel/External/Maps/Interface/OSRM.hs b/lib/mobility-core/src/Kernel/External/Maps/Interface/OSRM.hs
@@ -17,21 +17,24 @@ module Kernel.External.Maps.Interface.OSRM
     callOsrmMatch,
     getDistances,
     getOSRMTable,
+    getRoutes,
   )
 where
 
 import qualified Data.List.NonEmpty as NE
+import GHC.Float (double2Int)
 import Kernel.External.Maps.Google.Config as Reexport
 import Kernel.External.Maps.Google.PolyLinePoints
 import Kernel.External.Maps.HasCoordinates as Reexport (HasCoordinates (..))
 import Kernel.External.Maps.Interface.Types
 import Kernel.External.Maps.OSRM.Config
+import Kernel.External.Maps.OSRM.RoadsClient
 import qualified Kernel.External.Maps.OSRM.RoadsClient as OSRM
 import Kernel.External.Maps.Types as Reexport
 import Kernel.Prelude
 import qualified Kernel.Tools.Metrics.CoreMetrics as Metrics
-import Kernel.Types.App
-import Kernel.Types.Common
+import Kernel.Types.Error
+import Kernel.Utils.Common
 
 callOsrmMatch ::
   ( HasCallStack,
@@ -98,3 +101,39 @@ getOSRMTable tableResponse request = do
         )
         []
         pairOfIndexSource
+
+getRoutes ::
+  ( HasCallStack,
+    Metrics.CoreMetrics m,
+    MonadFlow m
+  ) =>
+  OSRMCfg ->
+  GetRoutesReq ->
+  m GetRoutesResp
+getRoutes osrmCfg request = do
+  response <- OSRM.callOsrmRouteAPI osrmCfg.osrmUrl $ OSRM.PointsList {getPointsList = NE.take 2 request.waypoints}
+  getOSRMRoute response
+
+convertRouteToRouteInfo :: (Log m, MonadThrow m) => OSRM.OSRMRouteRoutes -> m RouteInfo
+convertRouteToRouteInfo osrmRouteRoutes =
+  if length osrmRouteRoutes.legs < 1
+    then do
+      throwError $ InternalError "OSRM snapped waypoints has no routes"
+    else
+      return
+        RouteInfo
+          { distance = Just $ Meters $ double2Int $ osrmRouteRoutes.distance,
+            duration = Just $ Seconds $ double2Int $ osrmRouteRoutes.duration,
+            points = map (.getLatLong) osrmRouteRoutes.geometry.coordinates,
+            snappedWaypoints = map (\steps -> getLatLong $ head steps.geometry.coordinates) $ OSRM.steps $ head osrmRouteRoutes.legs,
+            boundingBox = Nothing
+          }
+
+getOSRMRoute ::
+  ( HasCallStack,
+    Metrics.CoreMetrics m,
+    MonadFlow m
+  ) =>
+  OSRM.OSRMRouteResponse ->
+  m GetRoutesResp
+getOSRMRoute osrmRouteResponse = sequence $ map convertRouteToRouteInfo osrmRouteResponse.routes
diff --git a/lib/mobility-core/src/Kernel/External/Maps/OSRM/RoadsClient.hs b/lib/mobility-core/src/Kernel/External/Maps/OSRM/RoadsClient.hs
@@ -52,6 +52,16 @@ type TableAPI =
     :> MandatoryQueryParam "destinations" DestinationsList
     :> Get '[JSON] OSRMTableResponse
 
+type RouteAPI =
+  "route"
+    :> "v1"
+    :> "driving"
+    :> Capture "coordinates" PointsList
+    :> MandatoryQueryParam "geometries" GeometryRespType
+    :> MandatoryQueryParam "alternatives" Bool
+    :> MandatoryQueryParam "steps" Bool
+    :> Get '[JSON] OSRMRouteResponse
+
 newtype PointsList = PointsList {getPointsList :: [Maps.LatLong]}
 
 newtype SourcesList = SourcesList {getSourcesList :: [Int]}
@@ -133,6 +143,55 @@ newtype Location = Location {getLatLong :: Maps.LatLong}
   deriving stock (Generic, Show, Eq)
   deriving (PrettyShow) via (Showable Location)
 
+data OSRMRouteResponse = OSRMRouteResponse
+  {
+    routes :: [OSRMRouteRoutes],
+    waypoints :: [OSRMRouteWaypoint]
+  }
+  deriving stock (Generic, Show, Eq)
+  deriving anyclass (FromJSON, ToJSON)
+
+data OSRMRouteRoutes = OSRMRouteRoutes
+  {
+    geometry :: RouteGeometry,
+    legs :: [RouteResponseLeg],
+    distance :: Double, -- meters
+    duration :: Double, -- seconds
+    weight :: Double
+  }
+  deriving stock (Generic, Show, Eq)
+  deriving anyclass (FromJSON, ToJSON)
+
+data RouteResponseLeg = RouteResponseLeg {
+  steps :: [Steps],
+  distance :: Double,
+  duration :: Double,
+  weight :: Double
+}
+  deriving stock (Generic, Show, Eq)
+  deriving anyclass (FromJSON, ToJSON)
+
+data Steps = Steps {
+  geometry :: RouteGeometry,
+  maneuver :: Maneuver
+}
+  deriving stock (Generic, Show, Eq)
+  deriving anyclass (FromJSON, ToJSON)
+
+newtype Maneuver = Maneuver {
+  location :: Location
+}
+  deriving stock (Generic, Show, Eq)
+  deriving anyclass (FromJSON, ToJSON)
+
+data OSRMRouteWaypoint = OSRMRouteWaypoint
+ {
+  distance :: Double,
+  location :: Location
+ }
+ deriving stock (Generic, Show, Eq)
+ deriving anyclass (FromJSON, ToJSON)
+
 instance FromJSON Location where
   parseJSON = withArray "array [lon, lat]" $ \arr_ -> case toList arr_ of
     [lonVal, latVal] -> Location ... Maps.LatLong <$> parseJSON latVal <*> parseJSON lonVal
@@ -182,3 +241,16 @@ callOsrmGetDistancesAPI osrmUrl pointsList sourcesList destinationsList =
     let eulerClient = Euler.client (Proxy @TableAPI)
     callAPI osrmUrl (eulerClient pointsList "distance,duration" sourcesList destinationsList) "osrm-table"
     >>= fromEitherM (\err -> InternalError $ "Failed to call osrm table API: " <> show err)
+
+callOsrmRouteAPI ::
+  ( HasCallStack,
+    Metrics.CoreMetrics m,
+    MonadFlow m
+  ) =>
+  BaseUrl ->
+  PointsList ->
+  m OSRMRouteResponse
+callOsrmRouteAPI osrmUrl pointsList = do
+  let eulerClient = Euler.client (Proxy @RouteAPI)
+  callAPI osrmUrl (eulerClient pointsList GeoJson True True ) "osrm-route"
+    >>= fromEitherM (\err -> InternalError $ "Failed to call osrm route API: " <> show err)