dresdner-verkehrsbetriebe (empty) → 0.1.0
raw patch · 6 files changed
+447/−0 lines, 6 filesdep +HTTPdep +aesondep +basesetup-changed
Dependencies added: HTTP, aeson, base, bytestring, old-locale, optparse-applicative, time, unordered-containers, vector
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- dresdner-verkehrsbetriebe.cabal +43/−0
- src/Main.hs +141/−0
- src/Network/Transportation/Germany/DVB.hs +37/−0
- src/Network/Transportation/Germany/DVB/Route.hs +204/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dresdner-verkehrsbetriebe.cabal view
@@ -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
+ src/Main.hs view
@@ -0,0 +1,141 @@+-- |+-- Module: Main+-- Copyright: (C) 2015 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- 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
+ src/Network/Transportation/Germany/DVB.hs view
@@ -0,0 +1,37 @@+-- |+-- Module: Network.Transportation.Germany.DVB+-- Copyright: (C) 2015 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- 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"
+ src/Network/Transportation/Germany/DVB/Route.hs view
@@ -0,0 +1,204 @@+-- |+-- Module: Network.Transportation.Germany.DVB.Route+-- Copyright: (C) 2015 Braden Walters+-- License: MIT (see LICENSE file)+-- Maintainer: Braden Walters <vc@braden-walters.info>+-- 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