aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2022-08-28 21:33:33 +0200
committerstuebinm2022-08-28 21:34:54 +0200
commitf7066888652ed3326017adf2eb6786a21043ebf5 (patch)
tree82b14b74bd352b553eb4036f48b15d3a2c4cae37 /lib
parent1b2e30c134c996e82c282b21099f21501dd966ac (diff)
some config thingyesod
works kinda well, but doesn't complain about unknown config values in json, which is kinda hmpf tbh
Diffstat (limited to 'lib')
-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
6 files changed, 64 insertions, 29 deletions
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))