diff options
Diffstat (limited to 'lib')
| -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 |
6 files changed, 64 insertions, 29 deletions
@@ -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)) |