diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Config.hs | 114 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 17 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 14 |
3 files changed, 92 insertions, 53 deletions
diff --git a/lib/Config.hs b/lib/Config.hs index 4c8e3fd..88206f1 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} module Config (UffdConfig(..), ServerConfig(..), LoggingConfig(..)) where -import Conferer (DefaultConfig (configDef), fetch, - unsafeFetchKey) -import Conferer.FromConfig -import Conferer.FromConfig.Warp () +import Conftrack +import Conftrack.Value (ConfigValue (..)) import Data.ByteString (ByteString) +import Data.Function ((&)) import Data.Functor ((<&>)) +import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) import GHC.Generics (Generic) -import Network.Wai.Handler.Warp (Settings) +import qualified Network.Wai.Handler.Warp as Warp import System.OsPath (OsPath, encodeUtf, osp) import URI.ByteString @@ -23,13 +27,13 @@ data UffdConfig = UffdConfig } deriving (Generic, Show) data ServerConfig = ServerConfig - { serverConfigWarp :: Settings + { serverConfigWarp :: Warp.Settings , serverConfigDbString :: ByteString , serverConfigGtfs :: OsPath , serverConfigAssets :: OsPath , serverConfigZoneinfoPath :: OsPath , serverConfigDebugMode :: Bool - , serverConfigLogin :: UffdConfig + , serverConfigLogin :: Maybe UffdConfig , serverConfigLogging :: LoggingConfig } deriving (Generic) @@ -39,41 +43,69 @@ data LoggingConfig = LoggingConfig , loggingConfigHostname :: Text } deriving (Generic) -instance FromConfig ServerConfig +instance ConfigValue (URIRef Absolute) where + fromConfig val@(ConfigString text) = + case parseURI strictURIParserOptions text of + Right uri -> Right uri + Left err -> Left $ ParseError (T.pack $ show err) + fromConfig val = Left (TypeMismatch "URI" val) -instance FromConfig OsPath where - fromConfig = fetchFromConfigWith (encodeUtf . T.unpack) + prettyValue uri = decodeUtf8 (serializeURIRef' uri) -instance DefaultConfig ServerConfig where - configDef = ServerConfig - { serverConfigWarp = configDef - , serverConfigDbString = "" - , serverConfigGtfs = [osp|./gtfs.zip|] - , serverConfigAssets = [osp|./assets|] - , serverConfigZoneinfoPath = [osp|/etc/zoneinfo/|] - , serverConfigDebugMode = False - , serverConfigLogin = configDef - , serverConfigLogging = configDef - } +instance Config UffdConfig where + readConfig = do + uffdConfigUrl <- readRequiredValue [key|url|] + uffdConfigClientName <- readRequiredValue [key|clientName|] + uffdConfigClientSecret <- readRequiredValue [key|clientSecret|] + uffdConfigEnable <- readRequiredValue [key|enable|] + pure UffdConfig {..} -instance DefaultConfig UffdConfig where - configDef = UffdConfig uri "secret" "uffdclient" False - where Right uri = parseURI strictURIParserOptions "http://www.example.org" +instance Config LoggingConfig where + readConfig = LoggingConfig + <$> readOptionalValue [key|ntfyToken|] + <*> readValue "tracktrain" [key|ntfyTopic|] + <*> readValue "tracktrain" [key|name|] -instance FromConfig UffdConfig where - fromConfig key config = do - url <- fetchFromConfig (key /. "url") config - let Right uffdConfigUrl = parseURI strictURIParserOptions url - uffdConfigClientName <- fetchFromConfig (key /. "clientName") config - uffdConfigClientSecret <- fetchFromConfig (key /. "clientSecret") config - uffdConfigEnable <- fetchFromConfig (key /. "enable") config - pure UffdConfig {..} +instance Config Warp.Settings where + readConfig = do + port <- readOptionalValue [key|port|] + host <- readOptionalValue [key|host|] + timeout <- readOptionalValue [key|timeout|] + fdCacheDuration <- readOptionalValue [key|fdCacheDuration|] + fileInfoCacheDuration <- readOptionalValue [key|fileInfoCacheDuration|] + noParsePath <- readOptionalValue [key|noParsePath|] + serverName <- readOptionalValue [key|serverName|] + maximumBodyFlush <- readOptionalValue [key|maximumBodyFlush|] + gracefulShutdownTimeout <- readOptionalValue [key|gracefulShutdownTimeout|] + altSvc <- readOptionalValue [key|altSvc|] + + pure $ Warp.defaultSettings + & doIf port Warp.setPort + & doIf host Warp.setHost + & doIf timeout Warp.setTimeout + & doIf fdCacheDuration Warp.setFdCacheDuration + & doIf fileInfoCacheDuration Warp.setFileInfoCacheDuration + & doIf noParsePath Warp.setNoParsePath + & doIf serverName Warp.setServerName + & doIf maximumBodyFlush Warp.setMaximumBodyFlush + & doIf gracefulShutdownTimeout Warp.setGracefulShutdownTimeout + & doIf altSvc Warp.setAltSvc + + where doIf Nothing _ = id + doIf (Just a) f = f a + +instance ConfigValue Warp.HostPreference where + fromConfig (ConfigString buf) = Right $ fromString (T.unpack (decodeUtf8 buf)) + fromConfig val = Left (TypeMismatch "HostPreference" val) -instance FromConfig LoggingConfig where - fromConfig key config = LoggingConfig - <$> fetchFromConfig (key /. "ntfyToken") config - <*> fetchFromConfig (key /. "ntfyTopic") config - <*> fetchFromConfig (key /. "name") config +instance Config ServerConfig where + readConfig = ServerConfig + <$> readNested [key|warp|] + <*> readValue "" [key|dbstring|] + <*> readValue [osp|./gtfs.zip|] [key|gtfs|] + <*> readValue [osp|./assets|] [key|assets|] + <*> readValue [osp|/etc/zoneinfo/|] [key|zoneinfopath|] + <*> readValue False [key|debugmode|] + <*> readNestedOptional [key|login|] + <*> readNested [key|logging|] -instance DefaultConfig LoggingConfig where - configDef = LoggingConfig Nothing "tracktrain" "" diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs index 18cf0a1..9245e6a 100644 --- a/lib/Server/Frontend/Routes.hs +++ b/lib/Server/Frontend/Routes.hs @@ -69,11 +69,12 @@ instance Yesod Frontend where isAuthorized OnboardTrackerR _ = pure Authorized isAuthorized (AuthR _) _ = pure Authorized isAuthorized _ _ = do - UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings - if uffdConfigEnable then maybeAuthId >>= \case - Just _ -> pure Authorized - Nothing -> pure AuthenticationRequired - else pure Authorized + maybeUffd <- getYesod <&> serverConfigLogin . getSettings + case maybeUffd of + Nothing -> pure Authorized + Just UffdConfig{..} -> maybeAuthId >>= \case + Just _ -> pure Authorized + Nothing -> pure AuthenticationRequired defaultLayout w = do @@ -118,9 +119,9 @@ instance YesodAuth Frontend where type AuthId Frontend = UffdUser authPlugins cr = case config of - UffdConfig {..} -> if uffdConfigEnable - then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] - else [] + Just UffdConfig {..} -> + [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] + Nothing -> [] where config = serverConfigLogin (getSettings cr) maybeAuthId = do diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index 9c52e9c..5ad4b40 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -16,14 +16,14 @@ import Data.Coerce (coerce) import Data.Functor ((<&>)) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Pool (Pool) import Data.ProtoLens (defMessage) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime (utctDay), addUTCTime, - getCurrentTime) + diffUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (systemSeconds), getSystemTime, utcToSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) @@ -96,7 +96,8 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = ) handleTripUpdates = runSql dbpool $ do - today <- liftIO $ getCurrentTime <&> utctDay + now <- liftIO getCurrentTime + let today = utctDay now nowSeconds <- secondsNow today -- let running = M.toList (tripsOnDay gtfs today) tickets <- selectList [TicketCompleted ==. False, TicketDay ==. today] [Asc TicketTripName] @@ -114,10 +115,15 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = let atStations = flip fmap stops $ \(stop, station) -> (, stop, station) <$> extrapolateAtPosition LinearExtrapolator anchorEntities (int2Double (stopSequence stop)) let (lastAnchor, lastStop, lastStation) = last (catMaybes atStations) + + -- google's TripUpdateTooOld does not like information on trips which have ended let stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today > nowSeconds + 5 * 60 + -- google's TripUpdateTooOld check fails if the given timestamp is older than ~ half an hour + let isOutdated = maybe False + (\a -> trainAnchorCreated a `diffUTCTime` now < 20 * 60) lastCall - pure $ if not stillRunning then Nothing else Just $ defMessage + pure $ if not stillRunning && not isOutdated then Nothing else Just $ defMessage & RT.id .~ UUID.toText (coerce key) & RT.tripUpdate .~ (defMessage & RT.trip .~ |