diff options
| -rw-r--r-- | lib/Server.hs | 4 | ||||
| -rw-r--r-- | lib/Server/Frontend.hs | 20 | ||||
| -rw-r--r-- | lib/Server/Frontend/Gtfs.hs | 57 | ||||
| -rw-r--r-- | lib/Server/Frontend/OnboardUnit.hs | 174 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 145 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs (renamed from lib/Server/ControlRoom.hs) | 381 | ||||
| -rw-r--r-- | site/obu.hamlet | 132 | ||||
| -rw-r--r-- | site/tracker.hamlet | 147 | ||||
| -rw-r--r-- | tracktrain.cabal | 9 |
9 files changed, 487 insertions, 582 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 1833aa0..055e440 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -40,7 +40,7 @@ import Servant.API ((:<|>) (..)) import Servant.Server (hoistServer) import Servant.Swagger (toSwagger) import Server.Base (ServerState) -import Server.ControlRoom (ControlRoom (ControlRoom)) +import Server.Frontend (Frontend (..)) import Server.GTFS_RT (gtfsRealtimeServer) import Server.Ingest (handleTrackerRegister, handleTrainPing, handleWS) @@ -82,7 +82,7 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool) :<|> handleMetrics :<|> serveDirectoryFileServer (serverConfigAssets settings) - :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings))) + :<|> pure (unsafePerformIO (toWaiAppPlain (Frontend gtfs dbpool settings))) where handleDebugState = do now <- liftIO getCurrentTime diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs new file mode 100644 index 0000000..8d744db --- /dev/null +++ b/lib/Server/Frontend.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Server.Frontend (Frontend(..), Handler) where + +import Server.Frontend.Gtfs +import Server.Frontend.OnboardUnit +import Server.Frontend.Routes +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..2d74338 --- /dev/null +++ b/lib/Server/Frontend/Routes.hs @@ -0,0 +1,145 @@ +{-# 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 + +/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 + UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings + 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"> + <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 + 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 diff --git a/lib/Server/ControlRoom.hs b/lib/Server/Frontend/Tickets.hs index 5292620..43f24aa 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/Frontend/Tickets.hs @@ -1,192 +1,55 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Server.ControlRoom (ControlRoom(..)) where - -import Config (ServerConfig (..), UffdConfig (..)) -import Control.Monad (forM, 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.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.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 Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) -import Fmt ((+|), (|+)) -import GHC.Float (int2Double) -import GHC.Generics (Generic) +{-# 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 Numeric (showFFloat) import Persist -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 Server.Util (Service, secondsNow) +import Text.Read (readMaybe) import Yesod import Yesod.Auth -import Yesod.Auth.OAuth2.Prelude -import Yesod.Auth.OpenId (IdentifierType (..), authOpenId) -import Yesod.Auth.Uffd (UffdUser (..), uffdClient) -import Yesod.Form -import Yesod.Orphans () +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) -data ControlRoom = ControlRoom - { getGtfs :: GTFS.GTFS - , getPool :: Pool SqlBackend - , getSettings :: ServerConfig - } - -mkMessage "ControlRoom" "messages" "en" - -mkYesod "ControlRoom" [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 - -/token/block/#Token TokenBlock GET - -/gtfs/trips GtfsTripsViewR GET -/gtfs/trip/#GTFS.TripId GtfsTripViewR GET -/gtfs/import/#Day GtfsTicketImportR POST - -/obu OnboardUnitMenuR GET -/obu/#UUID OnboardUnitR GET -/tracker OnboardTrackerR 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 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 - - - 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 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 TicketsR - getTicketsR :: Handler Html getTicketsR = do req <- getRequest @@ -439,46 +302,47 @@ getTicketMapViewR ticketId = do } |] +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} + |] -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))} -|] + let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) = + sequenceA (fmap (\(_,_,res,_) -> res) forms) + pure (fmap catMaybes a, widget) -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! -|] +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) @@ -520,86 +384,3 @@ getTokenBlock token = do Just ticket -> TicketViewR (coerce ticket) Nothing -> RootR Nothing -> notFound - -getOnboardUnitMenuR :: Handler Html -getOnboardUnitMenuR = do - day <- liftIO getCurrentTime <&> utctDay - - tickets <- - runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do - firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ] - pure (ticket, entityVal $ fromJust firstStop)) - - defaultLayout $ do - [whamlet| - <h1>_{MsgOBU} - <section> - _{MsgChooseTrain} - $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets - <hr> - <a href="@{OnboardUnitR ticketId}"> - #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop} - <section> - <a href="@{OnboardTrackerR}">_{MsgStartTracking} - |] - -getOnboardUnitR :: UUID -> Handler Html -getOnboardUnitR ticketId = do - Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case - Nothing -> notFound - Just ticket -> pure ticket - defaultLayout $(whamletFile "site/obu.hamlet") - -getOnboardTrackerR :: Handler Html -getOnboardTrackerR = do - defaultLayout - $( whamletFile "site/tracker.hamlet") - - -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) - - - -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) - - -mightbe :: Maybe Text -> Text -mightbe (Just a) = a -mightbe Nothing = "" - - -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)) diff --git a/site/obu.hamlet b/site/obu.hamlet deleted file mode 100644 index ed8017a..0000000 --- a/site/obu.hamlet +++ /dev/null @@ -1,132 +0,0 @@ -<h1>_{MsgOBU} - -<section> - <h2>#{ticketTripName} _{Msgon} #{ticketDay} - <strong>Token:</strong> <span id="token"> - -<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"> - -<section> - <h2>Status - <p id="status">_{MsgNone} - <p id>_{MsgError}: <span id="error"> - - -<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; - - async function geoError(error) { - document.getElementById("status").innerText = "error"; - alert(`_{MsgPermissionFailed}: \n${error.message}`); - console.log(error); - } - - 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/train/ping/ws"); - ws.onerror = wsError; - ws.onclose = wsClose; - ws.onmessage = wsMsg - ws.onopen = (event) => initGeopos(); - } - - 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; - - ws.send(JSON.stringify({ - token: token, - lat: geoloc.coords.latitude, - long: geoloc.coords.longitude, - timestamp: (new Date()).toISOString() - })); - counter += 1; - document.getElementById("status").innerText = `sent ${counter} pings`; - } - - - async function main() { - let trip = await (await fetch("/api/trip/#{ticketTripName}")).json(); - console.log("got trip info"); - - token = await (await fetch("/api/train/register/#{UUID.toText ticketId}", { - method: "POST", - body: JSON.stringify({agent: "onboard-unit"}), - headers: {"Content-Type": "application/json"} - })).json(); - - - if (token.error) { - alert("could not obtain token: \n" + token.msg); - document.getElementById("status").innerText = "_{MsgTokenFailed}"; - } else { - console.log("got token"); - - document.getElementById("token").innerText = token; - - openWebsocket(); - } - } - - main() diff --git a/site/tracker.hamlet b/site/tracker.hamlet deleted file mode 100644 index 2cc05e4..0000000 --- a/site/tracker.hamlet +++ /dev/null @@ -1,147 +0,0 @@ -<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/tracktrain.cabal b/tracktrain.cabal index 5bf213f..542f986 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -102,7 +102,7 @@ library exposed-modules: GTFS , Server , Server.GTFS_RT - , Server.ControlRoom + , Server.Frontend , PersistOrphans , Persist , Extrapolation @@ -112,6 +112,13 @@ library , Yesod.Auth.Uffd , Yesod.Orphans , MultiLangText + , Server.Base + , Server.Ingest + , Server.Subscribe + , Server.Frontend.Routes + , Server.Frontend.Tickets + , Server.Frontend.OnboardUnit + , Server.Frontend.Gtfs default-language: GHC2021 default-extensions: OverloadedStrings , ScopedTypeVariables |