aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--app/Main.hs41
-rw-r--r--config.yaml9
-rw-r--r--lib/API.hs2
-rw-r--r--lib/Config.hs28
-rw-r--r--lib/Extrapolation.hs6
-rw-r--r--lib/GTFS.hs48
-rw-r--r--lib/Server.hs5
-rw-r--r--lib/Server/ControlRoom.hs4
-rw-r--r--tracktrain.cabal8
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
+
+
diff --git a/lib/API.hs b/lib/API.hs
index 35bdee7..4a72d6c 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -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