diff --git a/dresdner-verkehrsbetriebe.cabal b/dresdner-verkehrsbetriebe.cabal --- a/dresdner-verkehrsbetriebe.cabal +++ b/dresdner-verkehrsbetriebe.cabal @@ -1,5 +1,5 @@ name: dresdner-verkehrsbetriebe -version: 0.1.1 +version: 1.0.0 synopsis: Library and program for querying DVB (Dresdner Verkehrsbetriebe AG) license: MIT license-file: LICENSE @@ -8,19 +8,23 @@ category: Network build-type: Simple cabal-version: >= 1.10 +Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 library exposed-modules: Network.Transportation.Germany.DVB , Network.Transportation.Germany.DVB.Route + , Network.Transportation.Germany.DVB.Monitor other-modules: Network.Transportation.Germany.DVB.Route.JSON + , Network.Transportation.Germany.DVB.Monitor.JSON build-depends: - base >= 4.7 && < 4.8 - , HTTP >= 4000.2 && < 4000.3 + base >= 4 && < 5 + , HTTP >= 4000.2 && < 4000.4 , old-locale >= 1.0.0 && < 1.0.1 - , time >= 1.4 && < 1.5 - , aeson >= 0.10.0 && < 0.11.0 + , time >= 1.5 && < 1.7 + , aeson >= 0.10.0 && < 1.0.0 + , text >= 1.1.1.0 , vector >= 0.11.0 && < 0.12.0 , bytestring >= 0.10.0 && < 0.11.0 , unordered-containers >= 0.2.0 && < 0.3.0 @@ -30,11 +34,12 @@ executable dresdner-verkehrsbetriebe main-is: Main.hs build-depends: - base >= 4.7 && < 4.8 - , HTTP >= 4000.2 && < 4000.3 + base >= 4 && < 5 + , HTTP >= 4000.2 && < 4000.4 , old-locale >= 1.0.0 && < 1.0.1 - , time >= 1.4 && < 1.5 - , aeson >= 0.10.0 && < 0.11.0 + , time >= 1.5 && < 1.7 + , aeson >= 0.10.0 && < 1.0.0 + , text >= 1.1.1.0 , vector >= 0.11.0 && < 0.12.0 , bytestring >= 0.10.0 && < 0.11.0 , unordered-containers >= 0.2.0 && < 0.3.0 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -8,23 +8,24 @@ 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 Network.Transportation.Germany.DVB.Monitor import Options.Applicative -import System.Locale -- |Data structure containing all program options. data ProgramOptions = ProgramOptions { poOrigin :: Location - , poDestination :: Location + , poDestination :: Maybe Location , poOriginCity :: City , poDestinationCity :: City , poTime :: Maybe LocalTime , poTimeType :: Maybe TimeType + , poOffset :: Integer + , poLimit :: Integer } -- |Program options parser. @@ -34,9 +35,11 @@ (Location <$> strOption (long "origin" <> help "Location in the city from which to travel.")) <*> - (Location <$> + (strToMaybeLocation <$> strOption (long "destination" <> - help "Location in the city to which to travel.")) <*> + value "" <> + help ("Location in the city to which to travel. Omit to " ++ + "monitor the origin stop."))) <*> (City <$> strOption (long "origin-city" <> value (show defaultCity) <> @@ -52,8 +55,21 @@ (strToTimeType <$> strOption (long "time-type" <> value (show DepartureTime) <> - help "Departure (dep) or arrival (arr) time.")) + help "Departure (dep) or arrival (arr) time.")) <*> + (read <$> + strOption (long "offset" <> + value "0" <> + help "Offset of entries when monitoring the origin stop.")) <*> + (read <$> + strOption (long "limit" <> + value "10" <> + help "Limit of entries when monitoring the origin stop.")) where + -- |Given a string that either contains text or is blank, return either a + -- location or nothing respectively. + strToMaybeLocation :: String -> Maybe Location + strToMaybeLocation "" = Nothing + strToMaybeLocation str = Just $ Location str -- |Given the current time and a time string, return a time if possible. strToTime :: LocalTime -> String -> Maybe LocalTime strToTime now "now" = Just now @@ -80,25 +96,41 @@ optMain :: ProgramOptions -> IO () optMain opts = case programOptionsToRequest opts of - Just request -> do + Just (Left request) -> do result <- route request case result of Left err -> error ("The result is invalid: " ++ show err) Right route' -> putStrLn $ prettyRoute route' + Just (Right request) -> do + result <- monitor request + case result of + Left err -> error ("The result is invalid: " ++ show err) + Right connections -> putStrLn $ prettyMonitor connections Nothing -> error "There are problems with the request." --- |Generate a route request from program options. -programOptionsToRequest :: ProgramOptions -> Maybe RouteRequest +-- |Generate a route or monitor request from program options. +programOptionsToRequest :: ProgramOptions -> + Maybe (Either RouteRequest MonitorRequest) 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 - } + (Just time, Just timeType) -> + case poDestination opts of + Just destination -> + return $ Left $ RouteRequest { + routeReqOrigin = poOrigin opts, + routeReqDestination = destination, + routeReqCityOrigin = poOriginCity opts, + routeReqCityDestination = poDestinationCity opts, + routeReqTime = time, + routeReqTimeType = timeType + } + Nothing -> + return $ Right $ MonitorRequest { + monitorReqCity = poOriginCity opts, + monitorReqStop = poOrigin opts, + monitorReqOffset = poOffset opts, + monitorReqLimit = poLimit opts + } (_, _) -> Nothing -- |Print a route to be displayed to the user. @@ -139,3 +171,15 @@ l1 = " ~ Haltestelle: " ++ stopName stop ++ platform ++ arrival ++ departure ++ "\n" in l1 + +-- |Print transit connections to be displayed to the user. +prettyMonitor :: [TransitConnection] -> String +prettyMonitor connections = concat $ map prettyConnection connections + where + prettyConnection connection = + let l1 = "===== Verbindung: ===========================================" + l2 = " " ++ transConnDesc connection ++ + " (Linie: " ++ transConnNumber connection ++ ")" + l3 = " Kommt in: " ++ show (transConnArrivalMinutes connection) ++ + " Minuten" + in l1 ++ "\n" ++ l2 ++ "\n" ++ l3 ++ "\n" diff --git a/src/Network/Transportation/Germany/DVB/Monitor.hs b/src/Network/Transportation/Germany/DVB/Monitor.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transportation/Germany/DVB/Monitor.hs @@ -0,0 +1,87 @@ +-- | +-- Module: Network.Transportation.Germany.DVB.Monitor +-- Copyright: (C) 2016 Braden Walters +-- License: MIT (see LICENSE file) +-- Maintainer: Braden Walters +-- Stability: experimental +-- Portability: ghc + +module Network.Transportation.Germany.DVB.Monitor +( MonitorRequest(..) +, MonitorResult(..) +, TransitConnection(..) +, Error(..) +, monitor +) where + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BS8 +import Network.HTTP +import Network.Stream +import Network.Transportation.Germany.DVB +import qualified Network.Transportation.Germany.DVB.Monitor.JSON as JSON + +-- |All data sent to DVB to monitor a stop. +data MonitorRequest = MonitorRequest + { monitorReqCity :: City + , monitorReqStop :: Location + , monitorReqOffset :: Integer + , monitorReqLimit :: Integer + } deriving (Show) + +-- |Either monitor data or an error. +type MonitorResult = Either Error [TransitConnection] + +-- |An arriving vehicle at the stop. +data TransitConnection = TransitConnection + { transConnNumber :: String + , transConnDesc :: String + , transConnArrivalMinutes :: 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 stop, query and return data from DVB about +-- vehicles stopping there. +monitor :: MonitorRequest -> IO MonitorResult +monitor req = do + let (City city) = monitorReqCity req + (Location stop) = monitorReqStop req + params = [("ort", city), + ("hst", stop), + ("vz", show $ monitorReqOffset req), + ("lim", show $ monitorReqLimit req)] + result <- simpleHTTP (getRequest (monitorUrl ++ "?" ++ 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 transConns -> + return $ Right (map fromJsonTransitConnection transConns) + +-- |The HTTP URL to query for DVB monitor data. +monitorUrl :: String +monitorUrl = "http://widgets.vvo-online.de/abfahrtsmonitor/Abfahrten.do" + +-- |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 + +fromJsonTransitConnection :: JSON.TransitConnection -> TransitConnection +fromJsonTransitConnection transConn = + TransitConnection { + transConnNumber = JSON.transConnNumber transConn, + transConnDesc = JSON.transConnDesc transConn, + -- TODO: Use a total function instead of read. + transConnArrivalMinutes = read $ JSON.transConnArrivalMinutes transConn + } diff --git a/src/Network/Transportation/Germany/DVB/Monitor/JSON.hs b/src/Network/Transportation/Germany/DVB/Monitor/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transportation/Germany/DVB/Monitor/JSON.hs @@ -0,0 +1,36 @@ +-- | +-- Module: Network.Transportation.Germany.DVB.Monitor.JSON +-- Copyright: (C) 2016 Braden Walters +-- License: MIT (see LICENSE file) +-- Maintainer: Braden Walters +-- Stability: experimental +-- Portability: ghc + +{-# LANGUAGE OverloadedStrings #-} + +module Network.Transportation.Germany.DVB.Monitor.JSON +( TransitConnection(..) +) where + +import Data.Aeson +import Control.Monad +import qualified Data.Text as T +import qualified Data.Vector as V + +-- |An arriving vehicle at the stop. +data TransitConnection = TransitConnection + { transConnNumber :: String + , transConnDesc :: String + , transConnArrivalMinutes :: String + } deriving (Show) + +instance FromJSON TransitConnection where + parseJSON (Array arr) = + if V.length arr == 3 then + case (arr V.! 0, arr V.! 1, arr V.! 2) of + (String number, String desc, String arrivalMinutes) -> + return $ TransitConnection (T.unpack number) (T.unpack desc) + (T.unpack arrivalMinutes) + _ -> mzero + else mzero + parseJSON _ = mzero diff --git a/src/Network/Transportation/Germany/DVB/Route.hs b/src/Network/Transportation/Germany/DVB/Route.hs --- a/src/Network/Transportation/Germany/DVB/Route.hs +++ b/src/Network/Transportation/Germany/DVB/Route.hs @@ -29,7 +29,7 @@ import Network.Stream import Network.Transportation.Germany.DVB import qualified Network.Transportation.Germany.DVB.Route.JSON as JSON -import System.Locale +import System.Locale hiding (defaultTimeLocale) -- |All data sent to DVB to query routes. data RouteRequest = RouteRequest