module Network.Transportation.Germany.DVB.Route
( RouteRequest(..)
, RouteResult
, Route(..)
, Trip(..)
, Leg(..)
, Stop(..)
, StopArrival(..)
, StopDeparture(..)
, Error(..)
, route
) where
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BS8
import Data.Functor
import Data.Time.Calendar
import Data.Time.Format
import Data.Time.LocalTime
import Network.HTTP
import Network.Stream
import Network.Transportation.Germany.DVB
import qualified Network.Transportation.Germany.DVB.Route.JSON as JSON
import System.Locale
data RouteRequest = RouteRequest
{ routeReqOrigin :: Location
, routeReqDestination :: Location
, routeReqCityOrigin :: City
, routeReqCityDestination :: City
, routeReqTime :: LocalTime
, routeReqTimeType :: TimeType
} deriving (Show)
type RouteResult = Either Error Route
data Route = Route { routeTrips :: [Trip] } deriving (Show)
data Trip = Trip
{ tripDuration :: String
, tripLegs :: [Leg]
} deriving (Show)
data Leg = Leg
{ legNumber :: String
, legDesc :: String
, legStops :: [Stop]
} deriving (Show)
data Stop = Stop
{ stopName :: String
, stopPlatformName :: String
, stopArrival :: Maybe StopArrival
, stopDeparture :: Maybe StopDeparture
} deriving (Show)
data StopArrival = StopArrival
{ stopArrivalTime :: LocalTime
, stopArrivalDelayMins :: Integer
} deriving (Show)
data StopDeparture = StopDeparture
{ stopDepartureTime :: LocalTime
, stopDepartureDelayMins :: Integer
} deriving (Show)
data Error = HttpResetError | HttpClosedError | HttpParseError String |
HttpMiscError String | JsonParseError String deriving (Show)
route :: RouteRequest -> IO RouteResult
route req = do
let (Location origin) = routeReqOrigin req
(Location destination) = routeReqDestination req
(City cityOrigin) = routeReqCityOrigin req
(City cityDestination) = routeReqCityDestination req
(year, month, day) = toGregorian $ localDay $ routeReqTime req
(TimeOfDay hour minute _) = localTimeOfDay $ routeReqTime req
params = [("sessionID", "0"),
("requestID", "0"),
("language", "de"),
("execInst", "normal"),
("command", ""),
("ptOptionsActive", "-1"),
("itOptionsActive", ""),
("itdTripDateTimeDepArr", show $ routeReqTimeType req),
("itDateDay", show day),
("itDateMonth", show month),
("itDateYear", show year),
("itdTimeHour", show hour),
("idtTimeMinute", show minute),
("place_origin", cityOrigin),
("placeState_origin", "empty"),
("type_origin", "stop"),
("name_origin", origin),
("nameState_origin", "empty"),
("place_destination", cityDestination),
("placeState_destination", "empty"),
("type_destination", "stop"),
("name_destination", destination),
("nameState_destination", "empty"),
("outputFormat", "JSON"),
("coordOutputFormat", "WGS84"),
("coordOutputFormatTail", "0")]
result <- simpleHTTP (getRequest (routeUrl ++ "?" ++ urlEncodeVars params))
case result of
Left connError -> return $ Left $ connErrToResultErr connError
Right response' ->
let body = BS8.pack $ rspBody response'
in case eitherDecode body of
Left err -> return $ Left $ JsonParseError err
Right route' -> return $ Right (fromJsonRoute route')
routeUrl :: String
routeUrl = "http://efa.vvo-online.de:8080/dvb/XML_TRIP_REQUEST2"
connErrToResultErr :: ConnError -> Error
connErrToResultErr ErrorReset = HttpResetError
connErrToResultErr ErrorClosed = HttpClosedError
connErrToResultErr (ErrorParse msg) = HttpParseError msg
connErrToResultErr (ErrorMisc msg) = HttpMiscError msg
fromJsonRoute :: JSON.Route -> Route
fromJsonRoute route' =
Route { routeTrips = map fromJsonTrip $ JSON.routeTrips route' }
fromJsonTrip :: JSON.Trip -> Trip
fromJsonTrip trip' =
Trip {
tripDuration = JSON.tripDuration trip',
tripLegs = map fromJsonLeg $ JSON.tripLegs trip'
}
fromJsonLeg :: JSON.Leg -> Leg
fromJsonLeg leg' =
Leg {
legNumber = JSON.legModeNumber $ JSON.legMode leg',
legDesc = JSON.legModeDesc $ JSON.legMode leg',
legStops = map fromJsonStop $ JSON.legStops leg'
}
fromJsonStop :: JSON.Stop -> Stop
fromJsonStop stop' =
let arrTime = JSON.stopRefArrivalTime $ JSON.stopRef stop'
arrDelayMins = JSON.stopRefArrivalDelayMins $ JSON.stopRef stop'
arrival = case (arrTime, arrDelayMins) of
(Just arrTime', Just arrDelayMins') ->
let parsedArrTime = parseTime defaultTimeLocale "%Y%m%d %H:%M"
arrTime'
arrTimeToStopDeparture arrTime'' = StopArrival {
stopArrivalTime = arrTime'',
stopArrivalDelayMins = properDelay $ read arrDelayMins'
}
in arrTimeToStopDeparture <$> parsedArrTime
_ -> Nothing
depTime = JSON.stopRefDepartureTime $ JSON.stopRef stop'
depDelayMins = JSON.stopRefDepartureDelayMins $ JSON.stopRef stop'
departure = case (depTime, depDelayMins) of
(Just depTime', Just depDelayMins') ->
let parsedDepTime = parseTime defaultTimeLocale "%Y%m%d %H:%M"
depTime'
depTimeToStopDeparture depTime'' = StopDeparture {
stopDepartureTime = depTime'',
stopDepartureDelayMins = properDelay $ read depDelayMins'
}
in depTimeToStopDeparture <$> parsedDepTime
_ -> Nothing
in Stop {
stopName = JSON.stopName stop',
stopPlatformName = JSON.stopPlatformName stop',
stopArrival = arrival,
stopDeparture = departure
}
properDelay :: Integer -> Integer
properDelay (1) = 0
properDelay x = x