aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/Frontend.hs20
-rw-r--r--lib/Server/Frontend/Gtfs.hs57
-rw-r--r--lib/Server/Frontend/OnboardUnit.hs174
-rw-r--r--lib/Server/Frontend/Routes.hs145
-rw-r--r--lib/Server/Frontend/Tickets.hs (renamed from lib/Server/ControlRoom.hs)381
5 files changed, 477 insertions, 300 deletions
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))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 06:29:42 +0000