diff options
| -rw-r--r-- | app/Main.hs | 41 | ||||
| -rw-r--r-- | config.yaml | 9 | ||||
| -rw-r--r-- | lib/API.hs | 2 | ||||
| -rw-r--r-- | lib/Config.hs | 28 | ||||
| -rw-r--r-- | lib/Extrapolation.hs | 6 | ||||
| -rw-r--r-- | lib/GTFS.hs | 48 | ||||
| -rw-r--r-- | lib/Server.hs | 5 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 4 | ||||
| -rw-r--r-- | tracktrain.cabal | 8 |
9 files changed, 108 insertions, 43 deletions
diff --git a/app/Main.hs b/app/Main.hs index ec4b5e7..204e4d7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,34 +1,47 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} -- | The main module. Does little more than handle some basic ocnfic, then -- call the server module Main where - +import Conferer (fetch) +import Conferer.Config (addSource, emptyConfig) +import qualified Conferer.Source.Aeson as ConfAeson +import qualified Conferer.Source.CLIArgs as ConfCLI +import qualified Conferer.Source.Env as ConfEnv +import qualified Conferer.Source.Yaml as ConfYaml +import Control.Monad.Extra (ifM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (runStderrLoggingT) import Data.Default.Class (def) -import Database.Persist.Postgresql -import Network.Wai.Handler.Warp (run) +import Database.Persist.Postgresql (withPostgresqlPool) +import Network.Wai.Handler.Warp (runSettings) import Network.Wai.Middleware.RequestLogger (OutputFormat (..), RequestLoggerSettings (..), mkRequestLogger) -import System.Environment (getArgs) -import Data.Functor ((<&>)) -import Data.ByteString.Internal (packChars) - -import GTFS -import Server +import System.Directory (doesFileExist) +import Config (ServerConfig (..)) +import GTFS (loadGtfs) +import Server (application) main :: IO () main = do - connStr <- getArgs <&> \case {[str] -> packChars str; _ -> ""} + confconfig <- pure emptyConfig + >>= addSource ConfCLI.fromConfig + -- for some reason the yaml source fails if the file does not exist, but json works fine + >>= (\c -> ifM (doesFileExist "./config.yaml") + (addSource (ConfYaml.fromFilePath "./config.yaml") c) + (pure c)) + >>= addSource (ConfAeson.fromFilePath "./config.json") + >>= addSource (ConfEnv.fromConfig "tracktrain") + + ServerConfig{..} <- fetch confconfig - gtfs <- loadGtfs "./gtfs.zip" + gtfs <- loadGtfs serverConfigGtfs serverConfigZoneinfoPath loggerMiddleware <- mkRequestLogger $ def { outputFormat = Detailed True } - runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do + runStderrLoggingT $ withPostgresqlPool serverConfigDbString 10 $ \pool -> liftIO $ do app <- application gtfs pool putStrLn "starting server …" - run 4000 (loggerMiddleware app) + runSettings serverConfigWarp (loggerMiddleware app) diff --git a/config.yaml b/config.yaml new file mode 100644 index 0000000..49063e0 --- /dev/null +++ b/config.yaml @@ -0,0 +1,9 @@ + +dbString: "" +gtfs: "./gtfs.zip" +zoneinfoPath: "/etc/zoneinfo/" + +warp: + port: 9000 + + @@ -34,7 +34,7 @@ import GTFS.Realtime.FeedEntity import GTFS.Realtime.FeedMessage (FeedMessage) import Persist -data RegisterJson = RegisterJson +newtype RegisterJson = RegisterJson { registerAgent :: Text } deriving (Show, Generic) diff --git a/lib/Config.hs b/lib/Config.hs new file mode 100644 index 0000000..c76261e --- /dev/null +++ b/lib/Config.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | + +module Config where +import Conferer (DefaultConfig (configDef), + FromConfig) +import Conferer.FromConfig.Warp () +import Data.ByteString (ByteString) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.Wai.Handler.Warp (Settings) + +data ServerConfig = ServerConfig + { serverConfigWarp :: Settings + , serverConfigDbString :: ByteString + , serverConfigGtfs :: FilePath + , serverConfigZoneinfoPath :: FilePath + } deriving Generic + +instance FromConfig ServerConfig + +instance DefaultConfig ServerConfig where + configDef = ServerConfig + { serverConfigWarp = configDef + , serverConfigDbString = "" + , serverConfigGtfs = "./gtfs.zip" + , serverConfigZoneinfoPath = "/etc/zoneinfo/" + } diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs index 9b3f89f..4b427d0 100644 --- a/lib/Extrapolation.hs +++ b/lib/Extrapolation.hs @@ -50,7 +50,7 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $ print (observedProgress, expectedProgress) pure $ round $ (expectedProgress - observedProgress) * int2Double expectedTravelTime where closestPoint = - minimumBy (compare `on` (euclid (trainPingLat, trainPingLong))) line + minimumBy (compare `on` euclid (trainPingLat, trainPingLong)) line nextStop = snd $ minimumBy (compare `on` fst) $ V.filter (\(dist,_) -> dist > 0) @@ -64,8 +64,8 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = unsafePerformIO $ toSeconds (stopArrival nextStop) tzseries trainPingTimestamp - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp expectedProgress = - (int2Double ((utcToSeconds trainPingTimestamp runningDay) - - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp)) + int2Double (utcToSeconds trainPingTimestamp runningDay + - toSeconds (stopDeparture lastStop) tzseries trainPingTimestamp) / int2Double expectedTravelTime -- where crop a -- | a < 0 = 0 diff --git a/lib/GTFS.hs b/lib/GTFS.hs index 2047d56..9eed8b5 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -1,19 +1,18 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | All kinds of stuff that has to deal with GTFS directly -- (i.e. parsing, querying, Aeson instances, etc.) @@ -467,7 +466,7 @@ data GTFS = GTFS loadRawGtfs :: FilePath -> IO RawGTFS loadRawGtfs path = do - zip <- Zip.toArchive <$> LB.readFile "./gtfs.zip" + zip <- Zip.toArchive <$> LB.readFile path RawGTFS <$> decodeTable' "stops.txt" zip <*> decodeTable' "stop_times.txt" zip @@ -490,8 +489,13 @@ loadRawGtfs path = do Nothing -> fail $ "required file "+|path|+" not found in gtfs.zip" Just a -> pure a -loadGtfs :: FilePath -> IO GTFS -loadGtfs path = do +-- | load a gtfs file "the complicated way", creating data structures much nicer +-- to work with than the raw representation of GTFS. +-- +-- Note that this additionally needs a path to the machine's timezone info +-- (usually /etc/zoneinfo or /usr/shared/zoneinfo) +loadGtfs :: FilePath -> FilePath -> IO GTFS +loadGtfs path zoneinforoot = do shallow@RawGTFS{..} <- loadRawGtfs path -- TODO: sort these according to sequence numbers let shapes = @@ -500,9 +504,9 @@ loadGtfs path = do (fromMaybe mempty rawShapePoints) -- all agencies must have the same timezone, so just take the first's let tzname = agencyTimezone $ V.head rawAgencies - tzseries <- getTimeZoneSeriesFromOlsonFile (T.unpack $ "/etc/zoneinfo/"<>tzname) + tzseries <- getTimeZoneSeriesFromOlsonFile (zoneinforoot<>T.unpack tzname) let agencies' = fmap (\a -> a { agencyTimezone = tzseries }) rawAgencies - routes' <- V.mapM (\raw -> pushRoute agencies' raw) rawRoutes + routes' <- V.mapM (pushRoute agencies') rawRoutes <&> mapFromVector routeId stops' <- V.mapM (pushStop tzseries tzname rawStations) rawStops trips' <- V.mapM (pushTrip routes' stops' shapes) rawTrips @@ -573,7 +577,7 @@ loadGtfs path = do sortShapePoint :: ShapePoint -> Map Text Shape -> Map Text Shape - sortShapePoint ShapePoint{..} shapes = M.alter appendPoint shapePtId shapes + sortShapePoint ShapePoint{..} = M.alter appendPoint shapePtId where point = (shapePtLat, shapePtLong) appendPoint = \case diff --git a/lib/Server.hs b/lib/Server.hs index 055925f..1139ff8 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -51,10 +51,13 @@ import Server.Util (Service, ServiceM, runService, sendErrorMsg) import Yesod (toWaiAppPlain) +import Conferer (fetch, mkConfig) import Extrapolation (Extrapolator (guessAnchor), LinearExtrapolator) import System.IO.Unsafe +import Config (ServerConfig) + application :: GTFS -> Pool SqlBackend -> IO Application application gtfs dbpool = do doMigration dbpool @@ -87,7 +90,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI Nothing -> throwError err404 handleRegister tripID RegisterJson{..} = do today <- liftIO getCurrentTime <&> utctDay - when (not $ runsOnDay gtfs tripID today) + unless (runsOnDay gtfs tripID today) $ sendErrorMsg "this trip does not run today." expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent) diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 3c928f1..164d8ff 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -140,7 +140,7 @@ instance YesodPersist ControlRoom where runSqlPool action pool getRootR :: Handler Html -getRootR = redirect (TrainsR) +getRootR = redirect TrainsR getTrainsR :: Handler Html getTrainsR = do @@ -168,7 +168,7 @@ getTrainViewR trip day = do Just res@Trip{..} -> do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [] - lastPing <- runDB $ selectFirst [ TrainPingToken <-. (fmap entityKey tokens) ] [Desc TrainPingTimestamp] + lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] defaultLayout $ do mr <- getMessageRender setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text)) diff --git a/tracktrain.cabal b/tracktrain.cabal index 02eae01..492c3b6 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -36,6 +36,11 @@ executable tracktrain , monad-logger , gtfs , protocol-buffers + , conferer + , conferer-aeson + , conferer-yaml + , directory + , extra hs-source-dirs: app default-language: Haskell2010 default-extensions: OverloadedStrings @@ -99,6 +104,8 @@ library , blaze-markup , timezone-olson , timezone-series + , conferer + , conferer-warp hs-source-dirs: lib exposed-modules: GTFS , Server @@ -108,6 +115,7 @@ library , Persist , Extrapolation , API + , Config other-modules: Server.Util default-language: Haskell2010 default-extensions: OverloadedStrings |