diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Braden Walters + +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. 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/dresdner-verkehrsbetriebe.cabal b/dresdner-verkehrsbetriebe.cabal new file mode 100644 --- /dev/null +++ b/dresdner-verkehrsbetriebe.cabal @@ -0,0 +1,43 @@ +name: dresdner-verkehrsbetriebe +version: 0.1.0 +synopsis: Library and program for querying DVB (Dresdner Verkehrsbetriebe AG) +license: MIT +license-file: LICENSE +author: Braden Walters +maintainer: vc@braden-walters.info +category: Network +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: + Network.Transportation.Germany.DVB + , Network.Transportation.Germany.DVB.Route + build-depends: + base >= 4.7 && < 4.8 + , HTTP >= 4000.2 && < 4000.3 + , old-locale >= 1.0.0 && < 1.0.1 + , time >= 1.4 && < 1.5 + , aeson >= 0.10.0 && < 0.11.0 + , vector >= 0.11.0 && < 0.12.0 + , bytestring >= 0.10.0 && < 0.11.0 + , unordered-containers >= 0.2.0 && < 0.3.0 + hs-source-dirs: src + default-language: Haskell2010 + +executable dresdner-verkehrsbetriebe + main-is: Main.hs + build-depends: + base >= 4.7 && < 4.8 + , HTTP >= 4000.2 && < 4000.3 + , old-locale >= 1.0.0 && < 1.0.1 + , time >= 1.4 && < 1.5 + , aeson >= 0.10.0 && < 0.11.0 + , vector >= 0.11.0 && < 0.12.0 + , bytestring >= 0.10.0 && < 0.11.0 + , unordered-containers >= 0.2.0 && < 0.3.0 + -- Executable-specific dependencies + , optparse-applicative >= 0.12.0 && < 0.13.0 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -O2 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,141 @@ +-- | +-- Module: Main +-- Copyright: (C) 2015 Braden Walters +-- License: MIT (see LICENSE file) +-- Maintainer: Braden Walters +-- Stability: experimental +-- Portability: ghc + +module Main where + +import Control.Applicative +import Data.Time.Clock +import Data.Time.Format +import Data.Time.LocalTime +import Network.Transportation.Germany.DVB +import Network.Transportation.Germany.DVB.Route +import Options.Applicative +import System.Locale + +-- |Data structure containing all program options. +data ProgramOptions = ProgramOptions + { poOrigin :: Location + , poDestination :: Location + , poOriginCity :: City + , poDestinationCity :: City + , poTime :: Maybe LocalTime + , poTimeType :: Maybe TimeType + } + +-- |Program options parser. +programOptionsParser :: LocalTime -> Parser ProgramOptions +programOptionsParser currentTime = + ProgramOptions <$> + (Location <$> + strOption (long "origin" <> + help "Location in the city from which to travel.")) <*> + (Location <$> + strOption (long "destination" <> + help "Location in the city to which to travel.")) <*> + (City <$> + strOption (long "origin-city" <> + value (show defaultCity) <> + help "City from which to travel.")) <*> + (City <$> + strOption (long "destination-city" <> + value (show defaultCity) <> + help "City to which to travel.")) <*> + (strToTime currentTime <$> + strOption (long "time" <> + value "now" <> + help "Time of departure of arrival.")) <*> + (strToTimeType <$> + strOption (long "time-type" <> + value (show DepartureTime) <> + help "Departure (dep) or arrival (arr) time.")) + where + -- |Given the current time and a time string, return a time if possible. + strToTime :: LocalTime -> String -> Maybe LocalTime + strToTime now "now" = Just now + strToTime _ strTime = parseTime defaultTimeLocale "%d/%m/%Y %H:%M" strTime + -- |Given a time type ("dep" or "arr"), return a TimeType if possible. + strToTimeType :: String -> Maybe TimeType + strToTimeType "dep" = Just DepartureTime + strToTimeType "arr" = Just ArrivalTime + strToTimeType _ = Nothing + +-- |Information about the program options parser. +programOptionsInfo :: LocalTime -> ParserInfo ProgramOptions +programOptionsInfo currentTime = + info (programOptionsParser currentTime) fullDesc + +-- |Main program function. +main :: IO () +main = do + timezone <- getCurrentTimeZone + currentTime <- utcToLocalTime timezone <$> getCurrentTime + execParser (programOptionsInfo currentTime) >>= optMain + +-- |Main program function after options parsing. +optMain :: ProgramOptions -> IO () +optMain opts = + case programOptionsToRequest opts of + Just request -> do + result <- route request + case result of + Left err -> error ("The result is invalid: " ++ show err) + Right route' -> putStrLn $ prettyRoute route' + Nothing -> error "There are problems with the request." + +-- |Generate a route request from program options. +programOptionsToRequest :: ProgramOptions -> Maybe RouteRequest +programOptionsToRequest opts = + case (poTime opts, poTimeType opts) of + (Just time, Just timeType) -> Just $ RouteRequest { + routeReqOrigin = poOrigin opts, + routeReqDestination = poDestination opts, + routeReqCityOrigin = poOriginCity opts, + routeReqCityDestination = poDestinationCity opts, + routeReqTime = time, + routeReqTimeType = timeType + } + (_, _) -> Nothing + +-- |Print a route to be displayed to the user. +prettyRoute :: Route -> String +prettyRoute route' = concat $ map prettyTrip $ routeTrips route' + where + prettyTrip trip = + let l1 = "===== Strecke: ==============================================" + l2 = " Dauer: " ++ tripDuration trip + rest = concat $ map prettyLeg $ tripLegs trip + in l1 ++ "\n" ++ l2 ++ "\n" ++ rest + prettyLeg leg = + let l1 = " * Teilstrecke (Linie: " ++ legNumber leg ++ "): " ++ + legDesc leg + rest = concat $ map prettyStop $ legStops leg + in l1 ++ "\n" ++ rest + prettyStop stop = + let platform = if null $ stopPlatformName stop + then "" else " (Gleis: " ++ stopPlatformName stop ++ ")" + arrival = case stopArrival stop of + Just arr -> + " (Ankunft am " ++ + formatTime defaultTimeLocale "%d.%m.%Y" (stopArrivalTime arr) ++ + " um " ++ + formatTime defaultTimeLocale "%H:%M" (stopArrivalTime arr) ++ + " mit [" ++ show (stopArrivalDelayMins arr) ++ + " Minuten] Verspätung)" + Nothing -> "" + departure = case stopDeparture stop of + Just dep -> + " (Abfahrt am " ++ + formatTime defaultTimeLocale "%d.%m.%Y" (stopDepartureTime dep) ++ + " um " ++ + formatTime defaultTimeLocale "%H:%M" (stopDepartureTime dep) ++ + " mit [" ++ show (stopDepartureDelayMins dep) ++ + " Minuten] Verspätung)" + Nothing -> "" + l1 = " ~ Haltestelle: " ++ stopName stop ++ platform ++ arrival ++ + departure ++ "\n" + in l1 diff --git a/src/Network/Transportation/Germany/DVB.hs b/src/Network/Transportation/Germany/DVB.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transportation/Germany/DVB.hs @@ -0,0 +1,37 @@ +-- | +-- Module: Network.Transportation.Germany.DVB +-- Copyright: (C) 2015 Braden Walters +-- License: MIT (see LICENSE file) +-- Maintainer: Braden Walters +-- Stability: experimental +-- Portability: ghc + +module Network.Transportation.Germany.DVB +( Location(..) +, City(..) +, TimeType(..) +, defaultCity +) where + +-- |The name of a location in the city. +newtype Location = Location String + +instance Show Location where + show (Location str) = str + +-- |The name of the city (probably Dresden). +newtype City = City String + +instance Show City where + show (City str) = str + +-- |Whether the time should be interpreted as departure or arrival time. +data TimeType = DepartureTime | ArrivalTime + +instance Show TimeType where + show DepartureTime = "dep" + show ArrivalTime = "arr" + +-- |The default city, Dresden. +defaultCity :: City +defaultCity = City "Dresden" diff --git a/src/Network/Transportation/Germany/DVB/Route.hs b/src/Network/Transportation/Germany/DVB/Route.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transportation/Germany/DVB/Route.hs @@ -0,0 +1,204 @@ +-- | +-- Module: Network.Transportation.Germany.DVB.Route +-- Copyright: (C) 2015 Braden Walters +-- License: MIT (see LICENSE file) +-- Maintainer: Braden Walters +-- Stability: experimental +-- Portability: ghc + +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 + +-- |All data sent to DVB to query routes. +data RouteRequest = RouteRequest + { routeReqOrigin :: Location + , routeReqDestination :: Location + , routeReqCityOrigin :: City + , routeReqCityDestination :: City + , routeReqTime :: LocalTime + , routeReqTimeType :: TimeType + } deriving (Show) + +-- |Either route data or an error. +type RouteResult = Either Error Route + +-- |All route data returned from a routing request. +data Route = Route { routeTrips :: [Trip] } deriving (Show) + +-- |One of the possible trips to get from the origin to the destination. +data Trip = Trip + { tripDuration :: String + , tripLegs :: [Leg] + } deriving (Show) + +-- |One segment of a trip (for example: one vehicle). +data Leg = Leg + { legNumber :: String + , legDesc :: String + , legStops :: [Stop] + } deriving (Show) + +-- |A stop that the vehicle makes in a leg. +data Stop = Stop + { stopName :: String + , stopPlatformName :: String + , stopArrival :: Maybe StopArrival + , stopDeparture :: Maybe StopDeparture + } deriving (Show) + +-- |Arrival at a stop. +data StopArrival = StopArrival + { stopArrivalTime :: LocalTime + , stopArrivalDelayMins :: Integer + } deriving (Show) + +-- |Departure from a stop. +data StopDeparture = StopDeparture + { stopDepartureTime :: LocalTime + , stopDepartureDelayMins :: Integer + } deriving (Show) + +-- |All possible errors which could occur while fetching data, including HTTP +-- errors and JSON parsing errors. +data Error = HttpResetError | HttpClosedError | HttpParseError String | + HttpMiscError String | JsonParseError String deriving (Show) + +-- |Given information about a desired route, query and return data from DVB. +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') + +-- |The HTTP URL to query for DVB route data. +routeUrl :: String +routeUrl = "http://efa.vvo-online.de:8080/dvb/XML_TRIP_REQUEST2" + +-- |Take an HTTP connection error and convert it into an error which can be +-- returned in a RouteResult. +connErrToResultErr :: ConnError -> Error +connErrToResultErr ErrorReset = HttpResetError +connErrToResultErr ErrorClosed = HttpClosedError +connErrToResultErr (ErrorParse msg) = HttpParseError msg +connErrToResultErr (ErrorMisc msg) = HttpMiscError msg + +-- |Convert intermediate parsed JSON type to exported route type. +fromJsonRoute :: JSON.Route -> Route +fromJsonRoute route' = + Route { routeTrips = map fromJsonTrip $ JSON.routeTrips route' } + +-- |Convert intermediate parsed JSON type to exported trip type. +fromJsonTrip :: JSON.Trip -> Trip +fromJsonTrip trip' = + Trip { + tripDuration = JSON.tripDuration trip', + tripLegs = map fromJsonLeg $ JSON.tripLegs trip' + } + +-- |Convert intermediate parsed JSON type to exported leg type. +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' + } + +-- |Convert intermediate parsed JSON type to exported stop type. +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 + } + +-- |Convert the arrival/departure delay that is received from the server to a +-- more meaningful value. +properDelay :: Integer -> Integer +properDelay (-1) = 0 +properDelay x = x