aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/Base.hs9
-rw-r--r--lib/Server/ControlRoom.hs446
-rw-r--r--lib/Server/Frontend.hs22
-rw-r--r--lib/Server/Frontend/Gtfs.hs57
-rw-r--r--lib/Server/Frontend/OnboardUnit.hs174
-rw-r--r--lib/Server/Frontend/Routes.hs151
-rw-r--r--lib/Server/Frontend/SpaceTime.hs195
-rw-r--r--lib/Server/Frontend/Ticker.hs63
-rw-r--r--lib/Server/Frontend/Tickets.hs404
-rw-r--r--lib/Server/GTFS_RT.hs150
-rw-r--r--lib/Server/Ingest.hs275
-rw-r--r--lib/Server/Subscribe.hs63
-rw-r--r--lib/Server/Util.hs103
13 files changed, 1582 insertions, 530 deletions
diff --git a/lib/Server/Base.hs b/lib/Server/Base.hs
new file mode 100644
index 0000000..14b77ca
--- /dev/null
+++ b/lib/Server/Base.hs
@@ -0,0 +1,9 @@
+
+module Server.Base (ServerState) where
+
+import Control.Concurrent.STM (TQueue, TVar)
+import qualified Data.Map as M
+import Data.UUID (UUID)
+import Persist (TrainPing)
+
+type ServerState = TVar (M.Map UUID [TQueue (Maybe TrainPing)])
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
deleted file mode 100644
index 402f0b8..0000000
--- a/lib/Server/ControlRoom.hs
+++ /dev/null
@@ -1,446 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Server.ControlRoom (ControlRoom(..)) where
-
-import Control.Monad (forM_, join)
-import Control.Monad.Extra (maybeM)
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import qualified Data.Aeson as A
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy as LB
-import Data.Functor ((<&>))
-import Data.List (lookup)
-import Data.List.NonEmpty (nonEmpty)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Pool (Pool)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time (UTCTime (..), addDays,
- getCurrentTime, utctDay)
-import Data.Time.Calendar (Day)
-import Data.Time.Format.ISO8601 (iso8601Show)
-import Data.UUID (UUID)
-import qualified Data.UUID as UUID
-import qualified Data.Vector as V
-import Database.Persist (Entity (..), delete, entityVal, get,
- insert, selectList, (==.))
-import Database.Persist.Sql (PersistFieldSql, SqlBackend,
- runSqlPool)
-import Fmt ((+|), (|+))
-import GHC.Float (int2Double)
-import GHC.Generics (Generic)
-import Server.Util (Service, secondsNow)
-import Text.Blaze.Html (ToMarkup (..))
-import Text.Blaze.Internal (MarkupM (Empty))
-import Text.Read (readMaybe)
-import Text.Shakespeare.Text
-import Yesod
-import Yesod.Auth
-import Yesod.Auth.OAuth2.Prelude
-import Yesod.Form
-
-import Config (ServerConfig (..), UffdConfig (..))
-import Extrapolation (Extrapolator (..),
- LinearExtrapolator (..))
-import GTFS
-import Numeric (showFFloat)
-import Persist
-import Yesod.Auth.OpenId (IdentifierType (..), authOpenId)
-import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
-import Yesod.Orphans ()
-
-
-data ControlRoom = ControlRoom
- { getGtfs :: GTFS
- , getPool :: Pool SqlBackend
- , getSettings :: ServerConfig
- }
-
-mkMessage "ControlRoom" "messages" "en"
-
-mkYesod "ControlRoom" [parseRoutes|
-/ RootR GET
-/auth AuthR Auth getAuth
-/trains TrainsR GET
-/train/id/#TripID/#Day TrainViewR GET
-/train/map/#TripID/#Day TrainMapViewR GET
-/train/announce/#TripID/#Day AnnounceR POST
-/train/del-announce/#UUID DelAnnounceR GET
-/token/block/#Token TokenBlock GET
-/trips TripsViewR GET
-/trip/#TripID TripViewR GET
-/obu OnboardUnitMenuR GET
-/obu/#TripID/#Day OnboardUnitR GET
-|]
-
-emptyMarkup :: MarkupM a -> Bool
-emptyMarkup (Empty _) = True
-emptyMarkup _ = False
-
-instance Yesod ControlRoom where
- authRoute _ = Just $ AuthR LoginR
- isAuthorized OnboardUnitMenuR _ = pure Authorized
- isAuthorized (OnboardUnitR _ _) _ = pure Authorized
- isAuthorized (AuthR _) _ = pure Authorized
- isAuthorized _ _ = do
- UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin
- if uffdConfigEnable then maybeAuthId >>= \case
- Just _ -> pure Authorized
- Nothing -> pure AuthenticationRequired
- else pure Authorized
-
-
- defaultLayout w = do
- PageContent{..} <- widgetToPageContent w
- msgs <- getMessages
-
- withUrlRenderer [hamlet|
- $newline never
- $doctype 5
- <html>
- <head>
- <title>
- $if emptyMarkup pageTitle
- Tracktrain
- $else
- #{pageTitle}
- $maybe description <- pageDescription
- <meta name="description" content="#{description}">
- ^{pageHead}
- <link rel="stylesheet" href="/assets/style.css">
- <body>
- $forall (status, msg) <- msgs
- <!-- <p class="message #{status}">#{msg} -->
- ^{pageBody}
- |]
-
-
-instance RenderMessage ControlRoom FormMessage where
- renderMessage _ _ = defaultFormMessage
-
-instance YesodPersist ControlRoom where
- type YesodPersistBackend ControlRoom = SqlBackend
- runDB action = do
- pool <- getYesod <&> getPool
- runSqlPool action pool
-
-
--- this instance is only slightly cursed (it keeps login information
--- as json in a session cookie and hopes nothing will ever go wrong)
-instance YesodAuth ControlRoom where
- type AuthId ControlRoom = UffdUser
-
- authPlugins cr = case config of
- UffdConfig {..} -> if uffdConfigEnable
- then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
- else []
- where config = serverConfigLogin (getSettings cr)
-
- maybeAuthId = do
- e <- lookupSession "json"
- pure $ case e of
- Nothing -> Nothing
- Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra)
-
- authenticate creds = do
- forM_ (credsExtra creds) (uncurry setSession)
- -- extra <- lookupSession "extra"
- -- pure (Authenticated ( undefined))
- e <- lookupSession "json"
- case e of
- Nothing -> error "no session information"
- Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of
- Nothing -> error "malformed session information"
- Just user -> pure $ Authenticated user
-
- loginDest _ = RootR
- logoutDest _ = RootR
- -- hardcode redirecting to uffd directly; showing the normal login
- -- screen is kinda pointless when there's only one option
- loginHandler = do
- redirect ("/auth/page/uffd/forward" :: Text)
- onLogout = do
- clearSession
-
-
-
-
-getRootR :: Handler Html
-getRootR = redirect TrainsR
-
-getTrainsR :: Handler Html
-getTrainsR = do
- req <- getRequest
- let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
- mdisplayname <- maybeAuthId <&> fmap uffdDisplayName
-
- (day, isToday) <- liftIO $ getCurrentTime <&> utctDay <&> \today ->
- case maybeDay of
- Just day -> (day, day == today)
- Nothing -> (today, True)
-
- let prevday = (T.pack . iso8601Show . addDays (-1)) day
- let nextday = (T.pack . iso8601Show . addDays 1) day
- gtfs <- getYesod <&> getGtfs
- let trips = tripsOnDay gtfs day
- defaultLayout $ do
- [whamlet|
-<h1> _{MsgTrainsOnDay (iso8601Show day)}
-$maybe name <- mdisplayname
- <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a>
-<nav>
- <a class="nav-left" href="@?{(TrainsR, [("day", prevday)])}">← #{prevday}
- $if isToday
- _{Msgtoday}
- $else
- <a href="@{TrainsR}">_{Msgtoday}
- <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} →
-<section>
- <ol>
- $forall trip@Trip{..} <- trips
- <li><a href="@{TrainViewR tripTripID day}">_{MsgTrip} #{tripName trip}</a>
- : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
- $if null trips
- <li style="text-align: center"><em>(_{MsgNone})
-|]
-
-getTrainViewR :: TripID -> Day -> Handler Html
-getTrainViewR trip day = do
- GTFS{..} <- getYesod <&> getGtfs
- (widget, enctype) <- generateFormPost (announceForm day trip)
- case M.lookup trip trips of
- Nothing -> notFound
- Just res@Trip{..} -> do
- anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
- tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires]
- lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp]
- anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] []
- <&> nonEmpty . fmap entityVal
- nowSeconds <- secondsNow day
- defaultLayout $ do
- mr <- getMessageRender
- setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text))
- [whamlet|
-<h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a>
-<section>
- <h2>_{MsgLive}
- <p><strong>_{MsgLastPing}: </strong>
- $maybe Entity _ TrainPing{..} <- lastPing
- _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp}
- (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>)
- $nothing
- <em>(_{MsgNoTrainPing})
- <p><strong>_{MsgEstimatedDelay}</strong>:
- $maybe history <- anchors
- $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds
- \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
- $nothing
- <em> (_{MsgNone})
- <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a>
-<section>
- <h2>_{MsgStops}
- <ol>
- $forall Stop{..} <- tripStops
- <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation}
- $maybe history <- anchors
- $maybe delay <- guessDelay history (int2Double stopSequence)
- \ (#{delay})
-<section>
- <h2>_{MsgAnnouncements}
- <ul>
- $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
- <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">_{Msgdelete}</a>
- $if null anns
- <li><em>(_{MsgNone})</em>
- <h3>_{MsgNewAnnouncement}
- <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
- ^{widget}
- <button>_{MsgSubmit}
-<section>
- <h2>_{MsgTokens}
- <table>
- <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
- $if null tokens
- <tr><td></td><td style="text-align:center"><em>(_{MsgNone})
- $forall Entity (RunningKey key) Running{..} <- tokens
- <tr :runningBlocked:.blocked>
- <td title="#{runningAgent}">#{runningAgent}
- <td title="#{key}">#{key}
- <td title="#{runningExpires}">#{runningExpires}
- $if runningBlocked
- <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
- $else
- <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
-|]
- where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history
- guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
-
-
-getTrainMapViewR :: TripID -> Day -> Handler Html
-getTrainMapViewR tripId day = do
- GTFS{..} <- getYesod <&> getGtfs
- (widget, enctype) <- generateFormPost (announceForm day tripId)
- case M.lookup tripId trips of
- Nothing -> notFound
- Just res@Trip{..} -> do defaultLayout [whamlet|
-<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a>
-<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
- integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
- crossorigin=""/>
-<script src="https://unpkg.com/leaflet@1.9.3/dist/leaflet.js"
- integrity="sha256-WBkoXOwTeyKclOHuWtc+i2uENFpDZ9YPdf5Hf+D7ewM="
- crossorigin=""></script>
-<div id="map">
-<p id="status">
-<script>
- let map = L.map('map');
-
- L.tileLayer('https://tile.openstreetmap.org/{z}/{x}/{y}.png', {
- attribution: '&copy; <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'
- }).addTo(map);
-
- ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripID}/#{day}");
-
- var marker = null;
-
- ws.onmessage = (msg) => {
- let json = JSON.parse(msg.data);
- if (marker === null) {
- marker = L.marker([json.lat, json.long]);
- marker.addTo(map);
- } else {
- marker.setLatLng([json.lat, json.long]);
- }
- map.setView([json.lat, json.long], 13);
- document.getElementById("status").innerText = "_{MsgLastPing}: "+json.lat+","+json.long+" ("+json.timestamp+")";
- }
-|]
-
-
-
-getTripsViewR :: Handler Html
-getTripsViewR = do
- GTFS{..} <- getYesod <&> getGtfs
- defaultLayout $ do
- setTitle "List of Trips"
- [whamlet|
-<h1>List of Trips
-<section><ul>
- $forall trip@Trip{..} <- trips
- <li><a href="@{TripViewR tripTripID}">#{tripName trip}</a>
- : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))}
-|]
-
-
-getTripViewR :: TripID -> Handler Html
-getTripViewR tripId = do
- GTFS{..} <- getYesod <&> getGtfs
- case M.lookup tripId trips of
- Nothing -> notFound
- Just trip@Trip{..} -> defaultLayout [whamlet|
-<h1>_{MsgTrip} #{tripName trip}
-<section>
- <h2>_{MsgInfo}
- <p><strong>_{MsgtripId}:</strong> #{tripTripID}
- <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
- <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
-<section>
- <h2>_{MsgStops}
- <ol>
- $forall Stop{..} <- tripStops
- <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation}
-<section>
- <h2>Dates
- <ul>
- TODO!
-|]
-
-
-postAnnounceR :: TripID -> Day -> Handler Html
-postAnnounceR trip day = do
- ((result, widget), enctype) <- runFormPost (announceForm day trip)
- case result of
- FormSuccess ann -> do
- runDB $ insert ann
- redirect (TrainViewR trip day)
- _ -> defaultLayout
- [whamlet|
- <p>_{MsgInvalidInput}.
- <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
- ^{widget}
- <button>_{MsgSubmit}
- |]
-
-getDelAnnounceR :: UUID -> Handler Html
-getDelAnnounceR uuid = do
- ann <- runDB $ do
- a <- get (AnnouncementKey uuid)
- delete (AnnouncementKey uuid)
- pure a
- case ann of
- Nothing -> notFound
- Just Announcement{..} ->
- redirect (TrainViewR announcementTrip announcementDay)
-
-getTokenBlock :: Token -> Handler Html
-getTokenBlock token = do
- YesodRequest{..} <- getRequest
- let blocked = lookup "unblock" reqGetParams /= Just "true"
- maybe <- runDB $ do
- update (RunningKey token) [ RunningBlocked =. blocked ]
- get (RunningKey token)
- case maybe of
- Just r@Running{..} -> do
- liftIO $ print r
- redirect (TrainViewR runningTrip runningDay)
- Nothing -> notFound
-
-getOnboardUnitMenuR :: Handler Html
-getOnboardUnitMenuR = do
- day <- liftIO getCurrentTime <&> utctDay
- gtfs <- getYesod <&> getGtfs
- let trips = tripsOnDay gtfs day
- defaultLayout $ do
- [whamlet|
-<h1>_{MsgOBU}
-<section>
- _{MsgChooseTrain}
- $forall Trip{..} <- trips
- <hr>
- <a href="@{OnboardUnitR tripTripID day}">
- #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)}
-|]
-
-getOnboardUnitR :: TripID -> Day -> Handler Html
-getOnboardUnitR tripId day =
- defaultLayout $(whamletFile "site/obu.hamlet")
-
-announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
-announceForm day tripId = renderDivs $ Announcement
- <$> pure tripId
- <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
- <*> areq textField (fieldSettingsLabel MsgText) Nothing
- <*> pure day
- <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
- <*> lift (liftIO getCurrentTime <&> Just)
-
-mightbe :: Maybe Text -> Text
-mightbe (Just a) = a
-mightbe Nothing = ""
-
diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs
new file mode 100644
index 0000000..a9c2f69
--- /dev/null
+++ b/lib/Server/Frontend.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Server.Frontend (Frontend(..), Handler) where
+
+import Server.Frontend.Gtfs
+import Server.Frontend.OnboardUnit
+import Server.Frontend.Routes
+import Server.Frontend.SpaceTime
+import Server.Frontend.Ticker
+import Server.Frontend.Tickets
+
+import Yesod
+import Yesod.Auth
+
+
+mkYesodDispatch "Frontend" resourcesFrontend
+
+
+getRootR :: Handler Html
+getRootR = redirect TicketsR
+
+
diff --git a/lib/Server/Frontend/Gtfs.hs b/lib/Server/Frontend/Gtfs.hs
new file mode 100644
index 0000000..bc21ab7
--- /dev/null
+++ b/lib/Server/Frontend/Gtfs.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Gtfs (getGtfsTripViewR, getGtfsTripsViewR) where
+
+import Server.Frontend.Routes
+
+import Data.Functor ((<&>))
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Vector as V
+import qualified GTFS
+import Text.Blaze.Html (Html)
+import Yesod
+
+getGtfsTripsViewR :: Handler Html
+getGtfsTripsViewR = do
+ GTFS.GTFS{..} <- getYesod <&> getGtfs
+ defaultLayout $ do
+ setTitle "List of Trips"
+ [whamlet|
+<h1>List of Trips
+<section><ul>
+ $forall trip@GTFS.Trip{..} <- trips
+ <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a>
+ : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))}
+|]
+
+
+getGtfsTripViewR :: GTFS.TripId -> Handler Html
+getGtfsTripViewR tripId = do
+ GTFS.GTFS{..} <- getYesod <&> getGtfs
+ case M.lookup tripId trips of
+ Nothing -> notFound
+ Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
+<h1>_{MsgTrip} #{GTFS.tripName trip}
+<section>
+ <h2>_{MsgInfo}
+ <p><strong>_{MsgtripId}:</strong> #{tripTripId}
+ <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign}
+ <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName}
+<section>
+ <h2>_{MsgStops}
+ <ol>
+ $forall GTFS.Stop{..} <- tripStops
+ <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
+<section>
+ <h2>Dates
+ <ul>
+ TODO!
+|]
+
+mightbe :: Maybe Text -> Text
+mightbe (Just a) = a
+mightbe Nothing = ""
diff --git a/lib/Server/Frontend/OnboardUnit.hs b/lib/Server/Frontend/OnboardUnit.hs
new file mode 100644
index 0000000..6a8fe6e
--- /dev/null
+++ b/lib/Server/Frontend/OnboardUnit.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.OnboardUnit (getOnboardTrackerR) where
+
+import Server.Frontend.Routes
+
+import Data.Functor ((<&>))
+import qualified Data.Map as M
+import Data.Maybe (fromJust)
+import Data.Text (Text)
+import Data.Time (UTCTime (..), getCurrentTime)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.Vector as V
+import qualified GTFS
+import Persist (EntityField (..), Key (..), Stop (..),
+ Ticket (..))
+import Text.Blaze.Html (Html)
+import Yesod
+
+
+getOnboardTrackerR :: Handler Html
+getOnboardTrackerR = do defaultLayout [whamlet|
+ <h1>_{MsgOBU}
+
+ <section>
+ <h2>Tracker
+ <strong>Token:</strong> <span id="token">
+ <section>
+ <h2>Status
+ <p id="status">_{MsgNone}
+ <p id>_{MsgError}: <span id="error">
+ <section>
+ <h2>_{MsgLive}
+ <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span>
+ <p><strong>Accuracy: </strong><span id="acc">
+ <section>
+ <h2>_{MsgEstimated}
+ <p><strong>_{MsgDelay}</strong>: <span id="delay">
+ <p><strong>_{MsgSequence}</strong>: <span id="sequence">
+
+
+ <script>
+ var token = null;
+
+ let euclid = (a,b) => {
+ let x = a[0]-b[0];
+ let y = a[1]-b[1];
+ return x*x+y*y;
+ }
+
+ let minimalDist = (point, list, proj, norm) => {
+ return list.reduce (
+ (min, x) => {
+ let dist = norm(point, proj(x));
+ return dist < min[0] ? [dist,x] : min
+ },
+ [norm(point, proj(list[0])), list[0]]
+ )[1]
+ }
+
+ let counter = 0;
+ let ws;
+ let id;
+
+ function setStatus(msg) {
+ document.getElementById("status").innerText = msg
+ }
+
+ async function geoError(error) {
+ setStatus("error");
+ alert(`_{MsgPermissionFailed}: \n${error.message}`);
+ console.error(error);
+ main();
+ }
+
+ async function wsError(error) {
+ // alert(`_{MsgWebsocketError}: \n${error.message === undefined ? error.reason : error.message}`);
+ console.log(error);
+ navigator.geolocation.clearWatch(id);
+ }
+
+ async function wsClose(error) {
+ console.log(error);
+ document.getElementById("error").innerText = `websocket closed (reason: ${error.reason}). reconnecting …`;
+ navigator.geolocation.clearWatch(id);
+ setTimeout(openWebsocket, 1000);
+ }
+
+ function wsMsg(msg) {
+ let json = JSON.parse(msg.data);
+ console.log(json);
+ document.getElementById("delay").innerText =
+ `${json.delay}s (${Math.floor(json.delay / 60)}min)`;
+ document.getElementById("sequence").innerText = json.sequence;
+ }
+
+
+ function initGeopos() {
+ document.getElementById("error").innerText = "";
+ id = navigator.geolocation.watchPosition(
+ geoPing,
+ geoError,
+ {enableHighAccuracy: true}
+ );
+ }
+
+
+ function openWebsocket () {
+ ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/tracker/ping/ws");
+ ws.onerror = wsError;
+ ws.onclose = wsClose;
+ ws.onmessage = wsMsg;
+ ws.onopen = (event) => {
+ setStatus("connected");
+ };
+ }
+
+ async function geoPing(geoloc) {
+ console.log("got position update " + counter);
+ document.getElementById("lat").innerText = geoloc.coords.latitude;
+ document.getElementById("long").innerText = geoloc.coords.longitude;
+ document.getElementById("acc").innerText = geoloc.coords.accuracy;
+
+ if (ws !== undefined && ws.readyState == 1) {
+ ws.send(JSON.stringify({
+ token: token,
+ geopos: [ geoloc.coords.latitude, geoloc.coords.longitude ],
+ timestamp: (new Date()).toISOString()
+ }));
+ counter += 1;
+ setStatus(`sent ${counter} pings`);
+ } else {
+ setStatus(`websocket readystate ${ws.readyState}`);
+ }
+ }
+
+
+ async function main() {
+ initGeopos();
+
+ let urlparams = new URLSearchParams(window.location.search);
+
+ token = urlparams.get("token");
+
+ if (token === null) {
+ token = await (await fetch("/api/tracker/register/", {
+ method: "POST",
+ body: JSON.stringify({agent: "tracktrain-website"}),
+ headers: {"Content-Type": "application/json"}
+ })).json();
+
+ if (token.error) {
+ alert("could not obtain token: \n" + token.msg);
+ setStatus("_{MsgTokenFailed}");
+ } else {
+ console.log("got token");
+ window.location.search = `?token=${token}`;
+ }
+ }
+
+ console.log(token)
+
+ if (token !== null) {
+ document.getElementById("token").innerText = token;
+ openWebsocket();
+ }
+ }
+
+ main()
+ |]
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
new file mode 100644
index 0000000..9245e6a
--- /dev/null
+++ b/lib/Server/Frontend/Routes.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Server.Frontend.Routes where
+
+import Config (ServerConfig (..), UffdConfig (..))
+import Control.Monad (forM_)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as LB
+import Data.Functor ((<&>))
+import Data.Pool (Pool)
+import qualified Data.Text as T
+import Data.Time (UTCTime)
+import Data.Time.Calendar (Day)
+import Data.UUID (UUID)
+import Database.Persist.Sql (SqlBackend, runSqlPool)
+import qualified GTFS
+import Persist (Token)
+import Text.Blaze.Internal (MarkupM (Empty))
+import Yesod
+import Yesod.Auth
+import Yesod.Auth.OAuth2.Prelude
+import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
+import Yesod.Orphans ()
+
+data Frontend = Frontend
+ { getGtfs :: GTFS.GTFS
+ , getPool :: Pool SqlBackend
+ , getSettings :: ServerConfig
+ }
+
+mkMessage "Frontend" "messages" "en"
+
+mkYesodData "Frontend" [parseRoutes|
+/ RootR GET
+/auth AuthR Auth getAuth
+
+/tickets TicketsR GET
+/ticket/#UUID TicketViewR GET
+/ticket/map/#UUID TicketMapViewR GET
+/ticket/announce/#UUID AnnounceR POST
+/ticket/del-announce/#UUID DelAnnounceR GET
+
+/ticker/announce TickerAnnounceR POST
+/ticker/delete TickerDeleteR POST
+
+/spacetime SpaceTimeDiagramR GET
+
+/token/block/#Token TokenBlock GET
+
+/gtfs/trips GtfsTripsViewR GET
+/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
+/gtfs/import/#Day GtfsTicketImportR POST
+
+/tracker OnboardTrackerR GET
+|]
+
+emptyMarkup :: MarkupM a -> Bool
+emptyMarkup (Empty _) = True
+emptyMarkup _ = False
+
+
+instance Yesod Frontend where
+ authRoute _ = Just $ AuthR LoginR
+ isAuthorized OnboardTrackerR _ = pure Authorized
+ isAuthorized (AuthR _) _ = pure Authorized
+ isAuthorized _ _ = do
+ maybeUffd <- getYesod <&> serverConfigLogin . getSettings
+ case maybeUffd of
+ Nothing -> pure Authorized
+ Just UffdConfig{..} -> maybeAuthId >>= \case
+ Just _ -> pure Authorized
+ Nothing -> pure AuthenticationRequired
+
+
+ defaultLayout w = do
+ PageContent{..} <- widgetToPageContent w
+ msgs <- getMessages
+
+ withUrlRenderer [hamlet|
+ $newline never
+ $doctype 5
+ <html>
+ <head>
+ <title>
+ $if emptyMarkup pageTitle
+ Tracktrain
+ $else
+ #{pageTitle}
+ $maybe description <- pageDescription
+ <meta name="description" content="#{description}">
+ ^{pageHead}
+ <link rel="stylesheet" href="/assets/style.css">
+ <meta name="viewport" content="width=device-width, initial-scale=1">
+ <body>
+ $forall (status, msg) <- msgs
+ <!-- <p class="message #{status}">#{msg} -->
+ ^{pageBody}
+ |]
+
+
+instance RenderMessage Frontend FormMessage where
+ renderMessage _ _ = defaultFormMessage
+
+instance YesodPersist Frontend where
+ type YesodPersistBackend Frontend = SqlBackend
+ runDB action = do
+ pool <- getYesod <&> getPool
+ runSqlPool action pool
+
+
+-- this instance is only slightly cursed (it keeps login information
+-- as json in a session cookie and hopes nothing will ever go wrong)
+instance YesodAuth Frontend where
+ type AuthId Frontend = UffdUser
+
+ authPlugins cr = case config of
+ Just UffdConfig {..} ->
+ [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
+ Nothing -> []
+ where config = serverConfigLogin (getSettings cr)
+
+ maybeAuthId = do
+ e <- lookupSession "json"
+ pure $ case e of
+ Nothing -> Nothing
+ Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra)
+
+ authenticate creds = do
+ forM_ (credsExtra creds) (uncurry setSession)
+ -- extra <- lookupSession "extra"
+ -- pure (Authenticated ( undefined))
+ e <- lookupSession "json"
+ case e of
+ Nothing -> error "no session information"
+ Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of
+ Nothing -> error "malformed session information"
+ Just user -> pure $ Authenticated user
+
+ loginDest _ = RootR
+ logoutDest _ = RootR
+ -- hardcode redirecting to uffd directly; showing the normal login
+ -- screen is kinda pointless when there's only one option
+ loginHandler = do
+ redirect ("/auth/page/uffd/forward" :: Text)
+ onLogout = do
+ clearSession
diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs
new file mode 100644
index 0000000..16e8205
--- /dev/null
+++ b/lib/Server/Frontend/SpaceTime.hs
@@ -0,0 +1,195 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where
+
+import Server.Frontend.Routes
+
+import Control.Monad (forM, when)
+import Data.Coerce (coerce)
+import Data.Function (on, (&))
+import Data.Functor ((<&>))
+import Data.Graph (path)
+import Data.List
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (Day, UTCTime (..), getCurrentTime)
+import qualified Data.Vector as V
+import Fmt ((+|), (|+))
+import GHC.Float (double2Int, int2Double)
+import GTFS (Seconds (unSeconds))
+import qualified GTFS
+import Persist
+import Server.Util (getTzseries)
+import Text.Blaze.Html (Html)
+import Text.Read (readMaybe)
+import Yesod
+
+getSpaceTimeDiagramR :: Handler Html
+getSpaceTimeDiagramR = do
+ req <- getRequest
+ day <- case lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) of
+ Just day -> pure day
+ Nothing -> liftIO $ getCurrentTime <&> utctDay
+
+ mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ] >>= \case
+ Nothing -> notFound
+ Just widget -> defaultLayout [whamlet|
+ <h1>_{MsgSpaceTimeDiagram}
+ <section>
+ ^{widget}
+ |]
+
+mkSpaceTimeDiagramHandler :: Double -> Day -> [Filter Ticket] -> Handler (Maybe Widget)
+mkSpaceTimeDiagramHandler scale day filter = do
+ tickets <- runDB $ selectList filter [ Asc TicketId ] >>= mapM (\ticket -> do
+ stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do
+ arrival <- lift $ timeToPos scale day stopArrival
+ departure <- lift $ timeToPos scale day stopDeparture
+ pure (stop, arrival, departure))
+ anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence]
+ pure (ticket, stops, anchors))
+
+ case tickets of
+ [] ->
+ pure Nothing
+ _ ->
+ mkSpaceTimeDiagram scale day tickets
+ <&> Just
+
+-- | Safety: tickets may not be empty
+mkSpaceTimeDiagram
+ :: Double
+ -> Day
+ -> [(Entity Ticket, [(Stop, Double, Double)], [Entity TrainAnchor])]
+ -> Handler Widget
+mkSpaceTimeDiagram scale day tickets = do
+ -- we take the longest trip of the day. This will lead to unreasonable results
+ -- if there's more than one shape (this whole route should probably take a shape id tbh)
+ stations <- runDB $ fmap (\(_,stops,_) -> stops) tickets
+ & maximumBy (compare `on` length)
+ & fmap (\(stop, _, _) -> stop)
+ & sortOn stopSequence
+ & zip [0..]
+ & mapM (\(idx, stop) -> do
+ station <- getJust (stopStation stop)
+ pure (station, stop { stopSequence = idx }))
+
+ let reference = stations
+ <&> \(_, stop) -> stop
+ let maxSequence = stopSequence (last reference)
+ let scaleSequence a = a * 100 / int2Double maxSequence
+
+
+ (minY, maxY) <- tickets
+ <&> (\(_,stops,_) -> stops)
+ & concat
+ & mapM (timeToPos scale day . stopDeparture . (\(stop, _, _) -> stop))
+ <&> (\ys -> (minimum ys - 10, maximum ys + 30))
+
+ let timezone = head reference
+ & stopArrival
+ & GTFS.tzname
+
+ timeLines <- ([0,(double2Int $ 3600 / scale)..(24*3600)]
+ & mapM ((\a -> timeToPos scale day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone))
+ <&> takeWhile ((< maxY - 20) . fst) . filter ((> minY) . fst)
+
+ pure [whamlet|
+ <svg viewBox="-6 #{minY} 108 #{maxY - minY}" width="100%">
+
+ -- horizontal lines per hour
+ $forall (y, time) <- timeLines
+ <path
+ style="fill:none;stroke:grey;stroke-width:0.2;stroke-dasharray:1"
+ d="M 0,#{y} 100,#{y}"
+ >
+ <text style="font-size:1pt;">
+ <tspan x="-5" y="#{y + 0.1}">#{time}
+
+ -- vertical lines per station
+ $forall (station, Stop{..}) <- stations
+ <path
+ style="fill:none;stroke:#79797a;stroke-width:0.3"
+ d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}"
+ >
+ <text style="font-size:2pt;" transform="rotate(-90)">
+ <tspan
+ x="#{0 - maxY}"
+ y="#{scaleSequence (int2Double stopSequence) - 0.5}"
+ >#{stationName station}
+
+ -- trips
+ $forall (ticket, stops, anchors) <- tickets
+ <path
+ style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5"
+ d="M #{mkStopsline scaleSequence reference stops}"
+ >
+ <path
+ style="fill:none;stroke:red;stroke-width:0.3;"
+ d="M #{mkAnchorline scale scaleSequence reference stops anchors}"
+ >
+ |]
+
+mkStopsline :: (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> Text
+mkStopsline scaleSequence reference stops = stops
+ <&> mkStop
+ & T.concat
+ where mkStop (stop, arrival, departure) =
+ " "+|scaleSequence s|+","+|arrival|+" "
+ +|scaleSequence s|+","+|departure|+""
+ where s = mapSequenceWith reference stop & int2Double
+
+mkAnchorline :: Double -> (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text
+mkAnchorline scale scaleSequence reference stops anchors =
+ anchors
+ <&> (mkAnchor . entityVal)
+ & T.concat
+ where
+ mkAnchor TrainAnchor{..} =
+ " "+|scaleSequence transformed|+","
+ -- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already
+ +|secondsToPos scale trainAnchorWhen|+""
+ where
+ transformed = int2Double (mapSequence lastStop) + offset
+
+ offset =
+ abs (trainAnchorSequence - int2Double (stopSequence lastStop))
+ / int2Double (stopSequence lastStop - stopSequence nextStop)
+ -- the below is necessary to flip if necessary (it can be either -1 or +1)
+ * int2Double (mapSequence lastStop - mapSequence nextStop)
+
+ mapSequence = mapSequenceWith reference
+
+ lastStop = stops
+ & filter (\(Stop{..},_,_) ->
+ int2Double stopSequence <= trainAnchorSequence)
+ & last
+ & \(stop,_,_) -> stop
+ nextStop = stops
+ & filter (\(Stop{..},_,_) ->
+ int2Double stopSequence > trainAnchorSequence)
+ & head
+ & \(stop,_,_) -> stop
+
+-- | map a stop sequence number into the graph's space
+mapSequenceWith :: [Stop] -> Stop -> Int
+mapSequenceWith reference stop = filter
+ (\referenceStop -> stopStation referenceStop == stopStation stop) reference
+ & head
+ & stopSequence
+
+-- | SAFETY: ignores time zones
+secondsToPos :: Double -> Seconds -> Double
+secondsToPos scale = (* scale) . (/ 600) . int2Double . GTFS.unSeconds
+
+timeToPos :: Double -> Day -> GTFS.Time -> Handler Double
+timeToPos scale day time = do
+ settings <- getYesod <&> getSettings
+ tzseries <- liftIO $ getTzseries settings (GTFS.tzname time)
+ pure $ secondsToPos scale (GTFS.toSeconds time tzseries day)
diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs
new file mode 100644
index 0000000..861197a
--- /dev/null
+++ b/lib/Server/Frontend/Ticker.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where
+import Data.Functor ((<&>))
+import Data.Time (getCurrentTime)
+import Persist (EntityField (TickerAnnouncementArchived),
+ TickerAnnouncement (..))
+import Server.Frontend.Routes (FrontendMessage (..), Handler,
+ Route (..), Widget)
+import Yesod
+
+
+tickerAnnounceForm
+ :: Maybe TickerAnnouncement
+ -> Html
+ -> MForm Handler (FormResult TickerAnnouncement, Widget)
+tickerAnnounceForm maybeCurrent = renderDivs $ TickerAnnouncement
+ <$> areq textField (fieldSettingsLabel MsgHeader)
+ (maybeCurrent <&> tickerAnnouncementHeader)
+ <*> fmap unTextarea (areq textareaField (fieldSettingsLabel MsgText)
+ (maybeCurrent <&> (Textarea . tickerAnnouncementMessage)))
+ <*> pure False
+ <*> lift (liftIO getCurrentTime)
+
+tickerWidget :: Handler Html
+tickerWidget = do
+ current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] []
+
+ (widget, enctype) <-
+ generateFormPost (tickerAnnounceForm (current <&> entityVal))
+
+ defaultLayout [whamlet|
+ <h2>_{Msgincident}
+ <form method=post action=@{TickerAnnounceR} enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgSubmit}
+ <form method=post action=@{TickerDeleteR}>
+ <button>_{Msgdelete}
+ |]
+
+postTickerAnnounceR :: Handler Html
+postTickerAnnounceR = do
+ current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] []
+ ((result, widget), enctype) <-
+ runFormPost (tickerAnnounceForm (current <&> entityVal))
+ case result of
+ FormSuccess ann -> do
+ runDB $ do
+ updateWhere [] [ TickerAnnouncementArchived =. True ]
+ insert ann
+ redirect RootR
+ _ -> defaultLayout
+ [whamlet|
+ <p>_{MsgInvalidInput}.
+ <form method=post action=@{TickerAnnounceR} enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgSubmit}
+ |]
+
+postTickerDeleteR :: Handler Html
+postTickerDeleteR = do
+ runDB $ updateWhere [] [ TickerAnnouncementArchived =. True ]
+ redirect RootR
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
new file mode 100644
index 0000000..9b88a48
--- /dev/null
+++ b/lib/Server/Frontend/Tickets.hs
@@ -0,0 +1,404 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Tickets
+ ( getTicketsR
+ , postGtfsTicketImportR
+ , getTicketViewR
+ , getTicketMapViewR
+ , getDelAnnounceR
+ , postAnnounceR
+ , getTokenBlock
+ ) where
+
+import Server.Frontend.Routes
+
+import Config (ServerConfig (..), UffdConfig (..))
+import Control.Monad (forM, forM_, join)
+import Control.Monad.Extra (maybeM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Coerce (coerce)
+import Data.Function (on, (&))
+import Data.Functor ((<&>))
+import Data.List (lookup, nubBy)
+import Data.List.NonEmpty (nonEmpty)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromJust, isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (UTCTime (..), addDays,
+ getCurrentTime, utctDay)
+import Data.Time.Calendar (Day)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.Vector as V
+import Extrapolation (Extrapolator (..),
+ LinearExtrapolator (..))
+import Fmt ((+|), (|+))
+import GHC.Float (int2Double)
+import qualified GTFS
+import Numeric (showFFloat)
+import Persist
+import Server.Frontend.SpaceTime (mkSpaceTimeDiagram,
+ mkSpaceTimeDiagramHandler)
+import Server.Frontend.Ticker (tickerWidget)
+import Server.Util (Service, secondsNow)
+import Text.Read (readMaybe)
+import Yesod
+import Yesod.Auth
+import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
+
+
+getTicketsR :: Handler Html
+getTicketsR = do
+ req <- getRequest
+ let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
+ mdisplayname <- maybeAuthId <&> fmap uffdDisplayName
+
+ (day, isToday) <- liftIO $ getCurrentTime <&> utctDay <&> \today ->
+ case maybeDay of
+ Just day -> (day, day == today)
+ Nothing -> (today, True)
+
+ maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ]
+
+ let prevday = (T.pack . iso8601Show . addDays (-1)) day
+ let nextday = (T.pack . iso8601Show . addDays 1) day
+ gtfs <- getYesod <&> getGtfs
+
+ -- TODO: tickets should have all trip information saved
+ tickets <- runDB $ selectList [ TicketDay ==. day ] [ Asc TicketTripName ] >>= mapM (\ticket -> do
+ stops <- selectList [ StopTicket ==. entityKey ticket ] []
+ startStation <- getJust (stopStation $ entityVal $ head stops)
+ pure (ticket, startStation, fmap entityVal stops))
+
+ let trips = GTFS.tripsOnDay gtfs day
+
+ tickerAnnounceWidget <- tickerWidget
+
+ (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+ defaultLayout $ do
+ [whamlet|
+<h1> _{MsgTrainsOnDay (iso8601Show day)}
+$maybe name <- mdisplayname
+ <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a>
+<nav>
+ <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday}
+ $if isToday
+ _{Msgtoday}
+ $else
+ <a href="@{TicketsR}">_{Msgtoday}
+ <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} →
+<section>
+ ^{tickerAnnounceWidget}
+<section>
+ <h2>_{MsgTickets}
+ <ol>
+ $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets
+ <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a>
+ : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign}
+ $if null tickets
+ <li style="text-align: center"><em>(_{MsgNone})</em>
+$maybe spaceTime <- maybeSpaceTime
+ <section>
+ ^{spaceTime}
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
+ $if null trips
+ <li style="text-align: center"><em>(_{MsgNone})
+|]
+
+
+-- TODO: this function should probably look for duplicate imports
+postGtfsTicketImportR :: Day -> Handler Html
+postGtfsTicketImportR day = do
+ gtfs <- getYesod <&> getGtfs
+ let trips = GTFS.tripsOnDay gtfs day
+ ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips)))
+ case result of
+ FormSuccess selected -> do
+ now <- liftIO getCurrentTime
+
+ shapeMap <- selected
+ <&> (\(trip@GTFS.Trip{..}, _) -> (GTFS.shapeId tripShape, tripShape))
+ & nubBy ((==) `on` fst)
+ & mapM (\(shapeId, shape) -> runDB $ do
+ key <- insert Shape
+ insertMany
+ $ shape
+ & GTFS.shapePoints
+ & V.indexed
+ & V.toList
+ <&> \(idx, pos) -> ShapePoint (Geopos pos) idx key
+ pure (shapeId, key))
+ <&> M.fromList
+
+ stationMap <- selected
+ <&> (\(trip@GTFS.Trip{..}, _) -> V.toList (tripStops <&> GTFS.stopStation))
+ & concat
+ & nubBy ((==) `on` GTFS.stationId)
+ & mapM (\GTFS.Station{..} -> runDB $ do
+ maybeExists <- selectFirst [ StationShortName ==. stationId ] []
+ case maybeExists of
+ Nothing -> do
+ key <- insert Station
+ { stationGeopos = Geopos (stationLat, stationLon)
+ , stationShortName = stationId , stationName }
+ pure (stationId, key)
+ Just (Entity key _) -> pure (stationId, key))
+ <&> M.fromList
+
+ selected
+ <&> (\(trip@GTFS.Trip{..}, day) ->
+ let
+ ticket = Ticket
+ { ticketTripName = tripTripId, ticketDay = day, ticketImported = now
+ , ticketSchedule_version = Nothing, ticketVehicle = Nothing
+ , ticketCompleted = False, ticketHeadsign = gtfsHeadsign trip
+ , ticketShape = fromJust (M.lookup (GTFS.shapeId tripShape) shapeMap)}
+ stops = V.toList tripStops <&> \GTFS.Stop{..} ticketId -> Stop
+ { stopTicket = ticketId
+ , stopStation = fromJust (M.lookup (GTFS.stationId stopStation) stationMap)
+ , stopArrival, stopDeparture, stopSequence}
+ in (ticket, stops))
+ & unzip
+ & \(tickets, stops) -> runDB $ do
+ ticketIds <- insertMany tickets
+ forM (zip ticketIds stops) $ \(ticketId, unfinishedStops) ->
+ insertMany (fmap (\s -> s ticketId) unfinishedStops)
+
+ redirect (TicketsR, [("day", T.pack (iso8601Show day))])
+
+ FormFailure _ -> defaultLayout [whamlet|
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
+|]
+
+getTicketViewR :: UUID -> Handler Html
+getTicketViewR ticketId = do
+ let ticketKey = TicketKey ticketId
+ Ticket{..} <- runDB $ get ticketKey
+ >>= \case {Nothing -> notFound; Just a -> pure a}
+
+ stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do
+ station <- getJust (stopStation (entityVal stop))
+ pure (entityVal stop, station))
+
+ anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []
+ joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] []
+ <&> fmap (trackerTicketTracker . entityVal)
+ trackers <- runDB $ selectList
+ ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ])
+ [Asc TrackerExpires]
+ lastPing <- runDB $ selectFirst [ TrainPingTicket ==. coerce ticketId ] [Desc TrainPingTimestamp]
+ anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
+ <&> nonEmpty . fmap entityVal
+
+ spaceTimeMaybe <- mkSpaceTimeDiagramHandler 2 ticketDay [ TicketId ==. coerce ticketId ]
+
+ (widget, enctype) <- generateFormPost (announceForm ticketId)
+
+ nowSeconds <- secondsNow ticketDay
+ defaultLayout $ do
+ mr <- getMessageRender
+ setTitle (toHtml (""+|mr MsgTrip|+" "+|ticketTripName|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text))
+ [whamlet|
+<h1>_{MsgTrip} #
+ <a href="@{GtfsTripViewR ticketTripName}">#{ticketTripName}
+ _{Msgon}
+ <a href="@?{(TicketsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay}
+<section>
+ <h2>_{MsgLive}
+ <p><strong>_{MsgLastPing}: </strong>
+ $maybe Entity _ TrainPing{..} <- lastPing
+ _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp}
+ (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
+ $nothing
+ <em>(_{MsgNoTrainPing})
+ <p><strong>_{MsgEstimatedDelay}</strong>:
+ $maybe history <- anchors
+ $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds
+ \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
+ $nothing
+ <em> (_{MsgNone})
+ <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a>
+<section>
+ <h2>_{MsgStops}
+ <ol>
+ $forall (Stop{..}, Station{..}) <- stops
+ <li value="#{stopSequence}"> #{stopArrival} #{stationName}
+ $maybe history <- anchors
+ $maybe delay <- guessDelay history (int2Double stopSequence)
+ \ (#{delay})
+$maybe spaceTime <- spaceTimeMaybe
+ <section>
+ ^{spaceTime}
+<section>
+ <h2>_{MsgAnnouncements}
+ <ul>
+ $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
+ <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">_{Msgdelete}</a>
+ $if null anns
+ <li><em>(_{MsgNone})</em>
+ <h3>_{MsgNewAnnouncement}
+ <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgSubmit}
+<section>
+ <h2>_{MsgTokens}
+ <table>
+ <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th>
+ $if null trackers
+ <tr><td></td><td style="text-align:center"><em>(_{MsgNone})
+ $forall Entity (TrackerKey key) Tracker{..} <- trackers
+ <tr :trackerBlocked:.blocked>
+ <td title="#{trackerAgent}">#{trackerAgent}
+ <td title="#{key}">#{key}
+ <td title="#{trackerExpires}">#{trackerExpires}
+ $if trackerBlocked
+ <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a>
+ $else
+ <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a>
+|]
+ where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history
+ guessAtSeconds = extrapolateAtSeconds LinearExtrapolator
+
+
+getTicketMapViewR :: UUID -> Handler Html
+getTicketMapViewR ticketId = do
+ Ticket{..} <- runDB $ get (TicketKey ticketId)
+ >>= \case { Nothing -> notFound ; Just ticket -> pure ticket }
+
+ stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do
+ station <- getJust (stopStation (entityVal stop))
+ pure (entityVal stop, station))
+
+ (widget, enctype) <- generateFormPost (announceForm ticketId)
+
+ defaultLayout [whamlet|
+<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{ticketTripName} _{Msgon} #{ticketDay}</a>
+<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css"
+ integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI="
+ crossorigin=""/>
+<script src="https://unpkg.com/leaflet@1.9.3/dist/leaflet.js"
+ integrity="sha256-WBkoXOwTeyKclOHuWtc+i2uENFpDZ9YPdf5Hf+D7ewM="
+ crossorigin=""></script>
+<div id="map">
+<p id="status">
+<script>
+ let map = L.map('map');
+
+ L.tileLayer('https://tile.openstreetmap.org/{z}/{x}/{y}.png', {
+ attribution: '&copy; <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'
+ }).addTo(map);
+
+ ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/ticket/subscribe/#{UUID.toText ticketId}");
+
+ var marker = null;
+
+ ws.onmessage = (msg) => {
+ let json = JSON.parse(msg.data);
+ console.log(json)
+ if (marker === null) {
+ marker = L.marker(json.geopos);
+ marker.addTo(map);
+ } else {
+ marker.setLatLng(json.geopos);
+ }
+ map.setView(json.geopos, 13);
+ document.getElementById("status").innerText = "_{MsgLastPing}: "+json.geopos[0]+","+json.geopos[1]+" ("+json.timestamp+")";
+ }
+|]
+
+tripImportForm
+ :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)]
+ -> Html
+ -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget)
+tripImportForm trips extra = do
+ forms <- forM trips $ \(trip, day) -> do
+ (aRes, aView) <- mreq checkBoxField "import" Nothing
+ let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes
+ pure (trip, day, dings, aView)
+
+ let widget = toWidget [whamlet|
+ #{extra}
+ <ol>
+ $forall (trip@GTFS.Trip{..}, day, res, view) <- forms
+ <li>
+ ^{fvInput view}
+ <label for="^{fvId view}">
+ _{MsgTrip} #{GTFS.tripName trip}
+ : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip}
+ |]
+
+ let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) =
+ sequenceA (fmap (\(_,_,res,_) -> res) forms)
+
+ pure (fmap catMaybes a, widget)
+
+gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text
+gtfsHeadsign GTFS.Trip{..} =
+ case tripHeadsign of
+ Just headsign -> headsign
+ Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops))
+
+
+announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget)
+announceForm ticketId = renderDivs $ Announcement
+ <$> pure (TicketKey ticketId)
+ <*> areq textField (fieldSettingsLabel MsgHeader) Nothing
+ <*> areq textField (fieldSettingsLabel MsgText) Nothing
+ <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
+ <*> lift (liftIO getCurrentTime <&> Just)
+
+postAnnounceR :: UUID -> Handler Html
+postAnnounceR ticketId = do
+ ((result, widget), enctype) <- runFormPost (announceForm ticketId)
+ case result of
+ FormSuccess ann -> do
+ runDB $ insert ann
+ redirect RootR -- (TicketViewR trip day)
+ _ -> defaultLayout
+ [whamlet|
+ <p>_{MsgInvalidInput}.
+ <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgSubmit}
+ |]
+
+getDelAnnounceR :: UUID -> Handler Html
+getDelAnnounceR uuid = do
+ ann <- runDB $ do
+ a <- get (AnnouncementKey uuid)
+ delete (AnnouncementKey uuid)
+ pure a
+ case ann of
+ Nothing -> notFound
+ Just Announcement{..} ->
+ let (TicketKey ticketId) = announcementTicket
+ in redirect (TicketViewR ticketId)
+
+getTokenBlock :: Token -> Handler Html
+getTokenBlock token = do
+ YesodRequest{..} <- getRequest
+ let blocked = lookup "unblock" reqGetParams /= Just "true"
+ maybe <- runDB $ do
+ update (TrackerKey token) [ TrackerBlocked =. blocked ]
+ get (TrackerKey token)
+ case maybe of
+ Just r@Tracker{..} -> do
+ liftIO $ print r
+ redirect $ case trackerCurrentTicket of
+ Just ticket -> TicketViewR (coerce ticket)
+ Nothing -> RootR
+ Nothing -> notFound
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index cfb02ce..5ad4b40 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
@@ -12,17 +12,18 @@ import Control.Lens ((&), (.~))
import Control.Monad (forM)
import Control.Monad.Extra (mapMaybeM)
import Control.Monad.IO.Class (MonadIO (..))
+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)
@@ -31,21 +32,24 @@ import qualified Data.UUID as UUID
import qualified Data.Vector as V
import Database.Persist (Entity (..),
PersistQueryRead (selectFirst),
- selectList, (==.))
+ SelectOpt (Asc, Desc), get,
+ getJust, selectKeysList,
+ selectList, (<-.), (==.))
import Database.Persist.Postgresql (SqlBackend)
import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds),
LinearExtrapolator (..))
import GHC.Float (double2Float, int2Double)
import GTFS (Depth (..), GTFS (..),
- Seconds (..), Stop (..),
- Trip (..), TripID,
+ Seconds (..), Trip (..), TripId,
showTimeWithSeconds, stationId,
toSeconds, toUTC, tripsOnDay)
import Persist (Announcement (..),
EntityField (..), Key (..),
- Running (..), Token (..),
- TrainAnchor (..), TrainPing (..),
- runSql)
+ Station (..), Stop (..),
+ Ticket (..), Token (..),
+ Tracker (..), TrainAnchor (..),
+ TrainPing (..), latitude,
+ longitude, runSql)
import qualified Proto.GtfsRealtime as RT
import qualified Proto.GtfsRealtime_Fields as RT
import Servant.API ((:<|>) (..))
@@ -71,17 +75,20 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
where
handleServiceAlerts = runSql dbpool $ do
announcements <- selectList [] []
- defFeedMessage (fmap mkAlert announcements)
+ alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do
+ ticket <- getJust announcementTicket
+ pure $ mkAlert uuid announcement ticket
+ defFeedMessage alerts
where
- mkAlert :: Entity Announcement -> RT.FeedEntity
- mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) =
+ mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity
+ mkAlert uuid Announcement{..} Ticket{..} =
defMessage
& RT.id .~ UUID.toText uuid
& RT.alert .~ (defMessage
& RT.activePeriod .~ [ defMessage :: RT.TimeRange ]
& RT.informedEntity .~ [ defMessage
- & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing
+ & RT.trip .~ defTripDescriptor ticketTripName (Just ticketDay) Nothing
]
& RT.maybe'url .~ fmap (monolingual "de") announcementUrl
& RT.headerText .~ monolingual "de" announcementHeader
@@ -89,74 +96,93 @@ 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)
- anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do
- entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] []
- case nonEmpty (fmap entityVal entities) of
+ -- let running = M.toList (tripsOnDay gtfs today)
+ tickets <- selectList [TicketCompleted ==. False, TicketDay ==. today] [Asc TicketTripName]
+
+ tripUpdates <- forM tickets $ \(Entity key Ticket{..}) -> do
+ selectList [TrainAnchorTicket ==. key] [] >>= \a -> case nonEmpty a of
Nothing -> pure Nothing
- Just anchors -> pure $ Just (tripId, trip, anchors)
+ Just anchors -> do
+ stops <- selectList [StopTicket ==. key] [Asc StopArrival] >>= mapM (\(Entity _ stop) -> do
+ station <- getJust (stopStation stop)
+ pure (stop, station))
- defFeedMessage (mapMaybe (mkTripUpdate today nowSeconds) anchors)
- where
- mkTripUpdate :: Day -> Seconds -> (Text, Trip 'Deep 'Deep, NonEmpty TrainAnchor) -> Maybe RT.FeedEntity
- mkTripUpdate today nowSeconds (tripId :: Text, Trip{..} :: Trip Deep Deep, anchors) =
- let lastCall = extrapolateAtSeconds LinearExtrapolator anchors nowSeconds
- stations = tripStops
- <&> (\stop@Stop{..} -> (, stop)
- <$> extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence))
- (lastAnchor, lastStop) = V.last (V.catMaybes stations)
- stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today
- < nowSeconds + 5 * 60
- in if not stillRunning then Nothing else Just $ defMessage
- & RT.id .~ (tripId <> "-" <> T.pack (iso8601Show today))
- & RT.tripUpdate .~ (defMessage
- & RT.trip .~ defTripDescriptor tripId (Just today) (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ V.head tripStops))
- & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes $ V.toList stations)
- & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
- & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
- )
- where
- mkStopTimeUpdate :: (TrainAnchor, Stop Deep) -> RT.TripUpdate'StopTimeUpdate
- mkStopTimeUpdate (TrainAnchor{..}, Stop{..}) = defMessage
- & RT.stopSequence .~ fromIntegral stopSequence
- & RT.stopId .~ stationId stopStation
- & RT.arrival .~ (defMessage
+ let anchorEntities = fmap entityVal anchors
+ let lastCall = extrapolateAtSeconds LinearExtrapolator anchorEntities nowSeconds
+ 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 && not isOutdated then Nothing else Just $ defMessage
+ & RT.id .~ UUID.toText (coerce key)
+ & RT.tripUpdate .~ (defMessage
+ & RT.trip .~
+ defTripDescriptor
+ ticketTripName (Just today)
+ (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ fst $ head stops))
+ & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes atStations)
+ & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay)
+ & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall
+ )
+ where
+ mkStopTimeUpdate :: (TrainAnchor, Stop, Station) -> RT.TripUpdate'StopTimeUpdate
+ mkStopTimeUpdate (TrainAnchor{..}, Stop{..}, Station{..}) = defMessage
+ & RT.stopSequence .~ fromIntegral stopSequence
+ & RT.stopId .~ stationShortName
+ & RT.arrival .~ (defMessage
& RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
& RT.time .~ toStupidTime (addUTCTime
(fromIntegral $ unSeconds trainAnchorDelay)
(toUTC stopArrival tzseries today))
& RT.uncertainty .~ 60
- )
- & RT.departure .~ (defMessage
- & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
- & RT.time .~ toStupidTime (addUTCTime
+ )
+ & RT.departure .~ (defMessage
+ & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay)
+ & RT.time .~ toStupidTime (addUTCTime
(fromIntegral $ unSeconds trainAnchorDelay)
(toUTC stopDeparture tzseries today))
- & RT.uncertainty .~ 60
- )
- & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
+ & RT.uncertainty .~ 60
+ )
+ & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED
+
+ defFeedMessage (catMaybes tripUpdates)
handleVehiclePositions = runSql dbpool $ do
- (running :: [Entity Running]) <- selectList [] []
- pings <- forM running $ \(Entity key entity) -> do
- selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity)
- defFeedMessage (mkPosition <$> catMaybes pings)
+
+ ticket <- selectList [TicketCompleted ==. False] []
+
+ -- TODO: reimplement this (since trainpings no longer reference tickets it's gone for now)
+ -- positions <- forM ticket $ \(Entity key ticket) -> do
+ -- selectFirst [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case
+ -- Nothing -> pure Nothing
+ -- Just lastPing ->
+ -- pure (Just $ mkPosition (lastPing, ticket))
+
+ defFeedMessage [] -- (catMaybes positions)
where
- mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity
- mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage
+ mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity
+ mkPosition (Entity key TrainPing{..}, Ticket{..}) = defMessage
& RT.id .~ T.pack (show key)
& RT.vehicle .~ (defMessage
- & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing
- & RT.maybe'vehicle .~ case runningVehicle of
+ & RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing
+ & RT.maybe'vehicle .~ case ticketVehicle of
Nothing -> Nothing
Just trainset -> Just $ defMessage
& RT.label .~ trainset
& RT.position .~ (defMessage
- & RT.latitude .~ double2Float trainPingLat
- & RT.longitude .~ double2Float trainPingLong
+ & RT.latitude .~ double2Float (latitude trainPingGeopos)
+ & RT.longitude .~ double2Float (longitude trainPingGeopos)
)
-- TODO: should probably give currentStopSequence/stopId here as well
& RT.timestamp .~ toStupidTime trainPingTimestamp
@@ -181,7 +207,7 @@ defFeedMessage entities = do
)
& RT.entity .~ entities
-defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor
+defTripDescriptor :: TripId -> Maybe Day -> Maybe Text -> RT.TripDescriptor
defTripDescriptor tripId day starttime = defMessage
& RT.tripId .~ tripId
& RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED
diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs
new file mode 100644
index 0000000..959a4c6
--- /dev/null
+++ b/lib/Server/Ingest.hs
@@ -0,0 +1,275 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Ingest (handleTrackerRegister, handleTrainPing, handleWS) where
+import API (Metrics (..),
+ RegisterJson (..),
+ SentPing (..))
+import Control.Concurrent.STM (atomically, readTVar,
+ writeTQueue)
+import Control.Monad (forM, forever, unless,
+ void, when)
+import Control.Monad.Catch (handle)
+import Control.Monad.Extra (ifM, mapMaybeM, whenJust,
+ whenJustM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Logger (LoggingT, logInfoN,
+ logWarnN)
+import Control.Monad.Reader (ReaderT)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as C8
+import Data.Coerce (coerce)
+import Data.Functor ((<&>))
+import qualified Data.Map as M
+import Data.Pool (Pool)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeASCII, decodeUtf8)
+import Data.Time (NominalDiffTime,
+ UTCTime (..), addUTCTime,
+ diffUTCTime,
+ getCurrentTime,
+ nominalDay)
+import qualified Data.Vector as V
+import Database.Persist
+import Database.Persist.Postgresql (SqlBackend)
+import Fmt ((+|), (|+))
+import qualified GTFS
+import qualified Network.WebSockets as WS
+import Persist
+import Servant (err400, throwError)
+import Servant.Server (Handler)
+import Server.Util (ServiceM, getTzseries,
+ utcToSeconds)
+
+import Config (LoggingConfig,
+ ServerConfig (..))
+import Control.Exception (throw)
+import Control.Monad.Logger.CallStack (logErrorN)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy (toStrict)
+import Data.Foldable (find, minimumBy)
+import Data.Function (on, (&))
+import qualified Data.Text as T
+import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)
+import qualified Data.UUID as UUID
+import Extrapolation (Extrapolator (..),
+ LinearExtrapolator (..),
+ euclid)
+import GHC.Generics (Generic)
+import GTFS (seconds2Double)
+import Prometheus (decGauge, incGauge)
+import Server.Base (ServerState)
+
+
+handleTrackerRegister
+ :: Pool SqlBackend
+ -> RegisterJson
+ -> ServiceM Token
+handleTrackerRegister dbpool RegisterJson{..} = do
+ today <- liftIO getCurrentTime <&> utctDay
+ expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
+ runSql dbpool $ do
+ TrackerKey tracker <- insert (Tracker expires False registerAgent Nothing)
+ pure tracker
+ where
+ validityPeriod :: NominalDiffTime
+ validityPeriod = nominalDay
+
+handleTrainPing
+ :: Pool SqlBackend
+ -> ServerState
+ -> ServerConfig
+ -> LoggingT (ReaderT LoggingConfig Handler) a
+ -> SentPing
+ -> LoggingT (ReaderT LoggingConfig Handler) (Maybe TrainAnchor)
+handleTrainPing dbpool subscribers cfg onError ping@SentPing{..} =
+ isTokenValid dbpool sentPingToken >>= \case
+ Nothing -> onError >> pure Nothing
+ Just tracker@Tracker{..} -> do
+
+ -- unless (serverConfigDebugMode cfg) $ do
+ -- now <- liftIO getCurrentTime
+ -- let timeDiff = sentPingTimestamp `diffUTCTime` now
+ -- when (utctDay sentPingTimestamp /= utctDay now) $ do
+ -- logErrorN "received ping for wrong day"
+ -- throw err400
+ -- when (timeDiff < 10) $ do
+ -- logWarnN "received ping more than 10 seconds out of date"
+ -- throw err400
+ -- when (timeDiff > 10) $ do
+ -- logWarnN "received ping from more than 10 seconds in the future"
+ -- throw err400
+
+ ticketId <- case trackerCurrentTicket of
+ Just ticketId -> pure ticketId
+ -- if the tracker is not associated with a ticket, it is probably new
+ -- & should be auto-associated with the most fitting current ticket
+ Nothing -> runSql dbpool (guessTicketFromPing cfg ping) >>= \case
+ Just ticketId -> pure ticketId
+ Nothing -> do
+ logWarnN $ "Tracker "+|UUID.toString (coerce sentPingToken)|+
+ " sent a ping, but no trips are running today."
+ throwError err400
+
+
+ runSql dbpool $ insertSentPing subscribers cfg ping tracker ticketId
+
+insertSentPing
+ :: ServerState
+ -> ServerConfig
+ -> SentPing
+ -> Tracker
+ -> TicketId
+ -> InSql (Maybe TrainAnchor)
+insertSentPing subscribers cfg ping@SentPing{..} tracker@Tracker{..} ticketId = do
+ ticket@Ticket{..} <- getJust ticketId
+
+ stations <- selectList [ StopTicket ==. ticketId ] [Asc StopArrival]
+ >>= mapM (\stop -> do
+ station <- getJust (stopStation (entityVal stop))
+ tzseries <- liftIO $ getTzseries cfg (GTFS.tzname (stopArrival (entityVal stop)))
+ pure (entityVal stop, station, tzseries))
+ <&> V.fromList
+
+ shapePoints <- selectList [ShapePointShape ==. ticketShape] [Asc ShapePointIndex]
+ <&> (V.fromList . fmap entityVal)
+
+
+ let anchor = extrapolateAnchorFromPing LinearExtrapolator
+ ticketId ticket stations shapePoints ping
+
+
+ maybeReassign <- selectFirst
+ [ TrainPingTicket ==. ticketId ]
+ [ Desc TrainPingTimestamp ]
+ <&> find (\ping -> trainPingSequence (entityVal ping) > trainAnchorSequence anchor)
+ >> guessTicketFromPing cfg ping
+ <&> find (/= ticketId)
+
+
+ -- mapM (\newTicketId -> if ticketId /= newTicketId then Just newTicketId else Nothing))
+ -- >>= (\ping -> guessTicketFromPing cfg ping >>= \case
+ -- Just newTicketId | ticketId /= newTicketId -> pure (Just newTicketId)
+ -- _ -> pure Nothing)
+
+ case maybeReassign of
+ Just newTicketId -> do
+ update sentPingToken
+ [TrackerCurrentTicket =. Just newTicketId ]
+ logInfoN $ "tracker "+|UUID.toText (coerce sentPingToken)|+
+ "has switched direction, and was reassigned to ticket "
+ +|UUID.toText (coerce newTicketId)|+"."
+ insertSentPing subscribers cfg ping tracker newTicketId
+ Nothing -> do
+ let trackedPing = TrainPing
+ { trainPingToken = sentPingToken
+ , trainPingGeopos = sentPingGeopos
+ , trainPingTimestamp = sentPingTimestamp
+ , trainPingSequence = trainAnchorSequence anchor
+ , trainPingTicket = ticketId
+ }
+
+ insert trackedPing
+
+ last <- selectFirst [TrainAnchorTicket ==. ticketId] [Desc TrainAnchorWhen]
+ -- only insert new estimates if they've actually changed anything
+ when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor))
+ $ void $ insert anchor
+
+ -- are we at the final stop? if so, mark this ticket as done
+ -- & the tracker as free
+ let maxSequence = V.last stations
+ & (\(stop, _, _) -> stopSequence stop)
+ & fromIntegral
+ when (trainAnchorSequence anchor + 0.1 >= maxSequence) $ do
+ update sentPingToken
+ [TrackerCurrentTicket =. Nothing]
+ update ticketId
+ [TicketCompleted =. True]
+ logInfoN $ "Tracker "+|UUID.toString (coerce sentPingToken)|+
+ " has completed ticket "+|UUID.toString (coerce ticketId)|+
+ " (trip "+|ticketTripName|+")"
+
+ queues <- liftIO $ atomically $ do
+ queues <- readTVar subscribers <&> M.lookup (coerce ticketId)
+ whenJust queues $
+ mapM_ (\q -> writeTQueue q (Just trackedPing))
+ pure queues
+ pure (Just anchor)
+
+handleWS
+ :: Pool SqlBackend
+ -> ServerState
+ -> ServerConfig
+ -> Metrics
+ -> WS.Connection -> ServiceM ()
+handleWS dbpool subscribers cfg Metrics{..} conn = do
+ liftIO $ WS.forkPingThread conn 30
+ incGauge metricsWSGauge
+ handle (\(e :: WS.ConnectionException) -> decGauge metricsWSGauge) $ forever $ do
+ msg <- liftIO $ WS.receiveData conn
+ case A.eitherDecode msg of
+ Left err -> do
+ logWarnN ("stray websocket message: "+|decodeASCII (toStrict msg)|+" (could not decode: "+|err|+")")
+ liftIO $ WS.sendClose conn (C8.pack err)
+ -- TODO: send a close msg (Nothing) to the subscribed queues? decGauge metricsWSGauge
+ Right ping -> do
+ -- if invalid token, send a "polite" close request. Note that the client may
+ -- ignore this and continue sending messages, which will continue to be handled.
+ handleTrainPing dbpool subscribers cfg (liftIO $ WS.sendClose conn ("" :: ByteString)) ping >>= \case
+ Just anchor -> liftIO $ WS.sendTextData conn (A.encode anchor)
+ Nothing -> pure ()
+
+
+guessTicketFromPing :: ServerConfig -> SentPing -> InSql (Maybe (Key Ticket))
+guessTicketFromPing cfg SentPing{..} = do
+ tickets <- selectList [ TicketDay ==. utctDay sentPingTimestamp, TicketCompleted ==. False ] []
+
+ ticketsWithStation <- forM tickets (\ticket@(Entity ticketId _) -> do
+ stops <- selectList [StopTicket ==. ticketId] [Asc StopSequence] >>= mapM (\(Entity _ stop) -> do
+ station <- getJust (stopStation stop)
+ tzseries <- liftIO $ getTzseries cfg (GTFS.tzname (stopDeparture stop))
+ pure (station, stop, tzseries))
+ pure (ticket, stops))
+
+ if null ticketsWithStation then pure Nothing else do
+ let (closestTicket, _) = ticketsWithStation
+ & minimumBy (compare `on` (\(Entity _ ticket, stations) ->
+ let
+ runningDay = ticketDay ticket
+ smallestDistance = stations
+ <&> (\(station, stop, tzseries) -> spaceAndTimeDiff
+ (sentPingGeopos, utcToSeconds sentPingTimestamp runningDay)
+ (stationGeopos station, GTFS.toSeconds (stopDeparture stop) tzseries runningDay))
+ & minimum
+ in smallestDistance))
+
+ logInfoN
+ $ "Tracker "+|UUID.toString (coerce sentPingToken)|+
+ " is now handling ticket "+|UUID.toString (coerce (entityKey closestTicket))|+
+ " (trip "+|ticketTripName (entityVal closestTicket)|+")."
+
+ update sentPingToken
+ [TrackerCurrentTicket =. Just (entityKey closestTicket)]
+
+ pure (Just (entityKey closestTicket))
+
+spaceAndTimeDiff :: (Geopos, GTFS.Seconds) -> (Geopos, GTFS.Seconds) -> Double
+spaceAndTimeDiff (pos1, time1) (pos2, time2) =
+ spaceDistance + abs (seconds2Double timeDiff / 3600)
+ where spaceDistance = euclid pos1 pos2
+ timeDiff = time1 - time2
+
+-- TODO: proper debug logging for expired tokens
+isTokenValid :: Pool SqlBackend -> TrackerId -> ServiceM (Maybe Tracker)
+isTokenValid dbpool token = runSql dbpool $ get token >>= \case
+ Just tracker | not (trackerBlocked tracker) -> do
+ ifM (hasExpired (trackerExpires tracker))
+ (pure Nothing)
+ (pure (Just tracker))
+ _ -> pure Nothing
+
+hasExpired :: MonadIO m => UTCTime -> m Bool
+hasExpired limit = do
+ now <- liftIO getCurrentTime
+ pure (now > limit)
diff --git a/lib/Server/Subscribe.hs b/lib/Server/Subscribe.hs
new file mode 100644
index 0000000..831f4c9
--- /dev/null
+++ b/lib/Server/Subscribe.hs
@@ -0,0 +1,63 @@
+
+module Server.Subscribe where
+import Conduit (MonadIO (..))
+import Control.Concurrent.STM (atomically, newTQueue, readTQueue,
+ readTVar, writeTVar)
+import Control.Exception (handle)
+import Control.Monad.Extra (forever, whenJust)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as C8
+import Data.Coerce (coerce)
+import Data.Functor ((<&>))
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Pool
+import Data.UUID (UUID)
+import Database.Persist (Entity (entityKey), SelectOpt (Desc),
+ entityVal, selectFirst, selectList,
+ (<-.), (==.), (||.))
+import Database.Persist.Sql (SqlBackend)
+import qualified Network.WebSockets as WS
+import Persist
+import Server.Base (ServerState)
+import Server.Util (ServiceM)
+
+
+handleSubscribe
+ :: Pool SqlBackend
+ -> ServerState
+ -> UUID
+ -> WS.Connection
+ -> ServiceM ()
+handleSubscribe dbpool subscribers (ticketId :: UUID) conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do
+ queue <- atomically $ do
+ queue <- newTQueue
+ qs <- readTVar subscribers
+ writeTVar subscribers
+ $ M.insertWith (<>) ticketId [queue] qs
+ pure queue
+
+ -- send most recent ping, if any (so we won't have to wait for movement)
+ runSqlWithoutLog dbpool
+ (selectFirst [TrainPingTicket ==. coerce ticketId] [Desc TrainPingTimestamp])
+ <&> fmap entityVal
+ >>= flip whenJust (WS.sendTextData conn . A.encode)
+
+ handle (\(e :: WS.ConnectionException) -> removeSubscriber queue) $ forever $ do
+ res <- atomically $ readTQueue queue
+ case res of
+ Just ping -> WS.sendTextData conn (A.encode ping)
+ Nothing -> do
+ removeSubscriber queue
+ WS.sendClose conn (C8.pack "train ended")
+ where removeSubscriber queue = atomically $ do
+ qs <- readTVar subscribers
+ writeTVar subscribers
+ $ M.adjust (filter (/= queue)) ticketId qs
+
+-- getTicketTrackers :: (MonadLogger (t (ResourceT IO)), MonadIO (t (ResourceT IO)))
+-- => UUID -> ReaderT SqlBackend (t (ResourceT IO)) [Entity Tracker]
+getTicketTrackers ticketId = do
+ joins <- selectList [TrackerTicketTicket ==. TicketKey ticketId] []
+ <&> fmap (trackerTicketTracker . entityVal)
+ selectList ([TrackerId <-. joins] ||. [TrackerCurrentTicket ==. Just (TicketKey ticketId)]) []
diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs
index 41d26f7..b519a86 100644
--- a/lib/Server/Util.hs
+++ b/lib/Server/Util.hs
@@ -1,32 +1,79 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE RecordWildCards #-}
-- | mostly the monad the service runs in
-module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds) where
-
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.Logger (LoggingT, runStderrLoggingT)
-import qualified Data.Aeson as A
-import Data.ByteString (ByteString)
-import Data.Text (Text)
-import Data.Time (Day, UTCTime (..), diffUTCTime,
- getCurrentTime,
- nominalDiffTimeToSeconds)
-import GTFS (Seconds (..))
-import Prometheus (MonadMonitor (doIO))
-import Servant (Handler, ServerError, ServerT, err404,
- errBody, errHeaders, throwError)
-
-type ServiceM = LoggingT Handler
+module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds, runLogging, getTzseries, serveDirectoryFileServer) where
+
+import Config (LoggingConfig (..),
+ ServerConfig (..))
+import Control.Exception (handle, try)
+import Control.Monad.Extra (void, whenJust)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Logger (Loc, LogLevel (..),
+ LogSource, LogStr,
+ LoggingT (..),
+ defaultOutput, fromLogStr,
+ runStderrLoggingT)
+import Control.Monad.Reader (ReaderT (..))
+import qualified Data.Aeson as A
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as C8
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8Lenient)
+import Data.Time (Day, UTCTime (..),
+ diffUTCTime,
+ getCurrentTime,
+ nominalDiffTimeToSeconds)
+import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlsonFile)
+import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)
+import Fmt ((+|), (|+))
+import GHC.IO (unsafePerformIO)
+import GHC.IO.Exception (IOException (IOError))
+import GTFS (Seconds (..))
+import Prometheus (MonadMonitor (doIO))
+import qualified Servant
+import Servant (Handler, ServerError,
+ ServerT, err404, errBody,
+ errHeaders, throwError)
+import System.IO (stderr)
+import System.OsPath (OsPath, decodeFS,
+ decodeUtf, encodeUtf,
+ (</>))
+import System.Process.Extra (callProcess)
+
+type ServiceM = LoggingT (ReaderT LoggingConfig Handler)
type Service api = ServerT api ServiceM
-runService :: ServiceM a -> Handler a
-runService = runStderrLoggingT
+runService :: LoggingConfig -> ServiceM a -> Handler a
+runService conf m = runReaderT (runLogging conf m) conf
instance MonadMonitor ServiceM where
doIO = liftIO
+runLogging :: MonadIO m => LoggingConfig -> LoggingT m a -> m a
+runLogging LoggingConfig{..} logging = runLoggingT logging printLogMsg
+ where printLogMsg loc source level msg = do
+ -- this is what runStderrLoggingT does
+ defaultOutput stderr loc source level msg
+
+ whenJust loggingConfigNtfyToken \token -> handle ntfyFailed do
+ callProcess "ntfy"
+ [ "send"
+ , "--token=" <> T.unpack token
+ , "--title="+|loggingConfigHostname|+"/"+|"tracktrain"
+ , "--priority="+|show (ntfyPriority level)|+""
+ , T.unpack loggingConfigNtfyTopic
+ , T.unpack (decodeUtf8Lenient (fromLogStr msg)) ]
+
+ ntfyFailed (e :: IOError) =
+ putStrLn ("calling ntfy failed:"+|show e|+".")
+ ntfyPriority level = case level of
+ LevelDebug -> 2
+ LevelInfo -> 3
+ LevelWarn -> 4
+ LevelError -> 5
+ LevelOther _ -> 0
+
sendErrorMsg :: Text -> ServiceM a
sendErrorMsg msg = throwError err404
@@ -42,3 +89,15 @@ secondsNow runningDay = do
utcToSeconds :: UTCTime -> Day -> Seconds
utcToSeconds time day =
Seconds $ round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0)
+
+getTzseries :: ServerConfig -> Text -> IO TimeZoneSeries
+getTzseries settings tzname = do
+ suffix <- encodeUtf (T.unpack tzname)
+ -- TODO: submit a patch to timezone-olson making it accept OsPath
+ legacyPath <- decodeFS (serverConfigZoneinfoPath settings </> suffix)
+ getTimeZoneSeriesFromOlsonFile legacyPath
+
+-- TODO: patch servant / wai to use OsPath?
+serveDirectoryFileServer :: OsPath -> ServerT Servant.Raw m
+serveDirectoryFileServer =
+ Servant.serveDirectoryFileServer . unsafePerformIO . decodeUtf
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-07 02:44:59 +0000