aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/API.hs1
-rw-r--r--lib/Persist.hs7
-rw-r--r--lib/Server.hs13
-rw-r--r--lib/Server/Frontend.hs1
-rw-r--r--lib/Server/Frontend/Routes.hs3
-rw-r--r--lib/Server/Frontend/Ticker.hs63
-rw-r--r--lib/Server/Frontend/Tickets.hs5
-rw-r--r--messages/de.msg1
-rw-r--r--messages/en.msg1
-rw-r--r--tracktrain.cabal1
10 files changed, 95 insertions, 1 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 7ebfb06..416f71e 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -69,6 +69,7 @@ type API =
"tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
:<|> "tracker" :> "ping" :> ReqBody '[JSON] SentPing :> Post '[JSON] (Maybe TrainAnchor)
:<|> "tracker" :> "ping" :> "ws" :> WebSocket
+ :<|> "ticker" :> "current" :> Get '[JSON] Value
:<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket
:<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
:<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing]
diff --git a/lib/Persist.hs b/lib/Persist.hs
index e268455..f722487 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -166,6 +166,13 @@ Announcement json sql=tt_announcements
url Text Maybe
announcedAt UTCTime Maybe
deriving Generic Show
+
+TickerAnnouncement json sql=tt_ticker
+ header Text
+ message Text
+ archived Bool
+ created UTCTime
+ deriving Generic Show
|]
instance ToSchema TicketId where
diff --git a/lib/Server.hs b/lib/Server.hs
index 30141af..15027b3 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
@@ -12,6 +13,7 @@ import Control.Monad.Extra (forM, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (MonadLogger, logWarnN)
import Control.Monad.Reader (ReaderT)
+import qualified Data.Aeson as A
import Data.ByteString.Lazy (toStrict)
import Data.Functor ((<&>))
import qualified Data.Map as M
@@ -45,7 +47,7 @@ import Server.GTFS_RT (gtfsRealtimeServer)
import Server.Ingest (handleTrackerRegister,
handleTrainPing, handleWS)
import Server.Subscribe (handleSubscribe)
-import Server.Util (Service, runService, runLogging)
+import Server.Util (Service, runLogging, runService)
import System.IO.Unsafe (unsafePerformIO)
import Yesod (toWaiAppPlain)
@@ -80,6 +82,7 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI
:<|> (handleTrackerRegister dbpool
:<|> handleTrainPing dbpool subscribers settings (throwError err401)
:<|> handleWS dbpool subscribers settings metrics
+ :<|> handleCurrentTicker
:<|> handleSubscribe dbpool subscribers
:<|> handleDebugState :<|> handleDebugTrain
:<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool)
@@ -95,6 +98,14 @@ server gtfs metrics@Metrics{..} subscribers dbpool settings = handleDebugAPI
entities <- selectList [TrainPingToken ==. token] []
pure (uuid, fmap entityVal entities)
pure (M.fromList pairs)
+ handleCurrentTicker = runSql dbpool $ do
+ selectFirst [ TickerAnnouncementArchived ==. False ] [] <&> \case
+ Nothing -> A.object [ "error" A..= A.String "no message" ]
+ Just (Entity _ TickerAnnouncement{..}) -> A.object
+ [ "error" A..= A.Null
+ , "message" A..= tickerAnnouncementMessage
+ , "header" A..= tickerAnnouncementHeader
+ ]
handleDebugTrain ticketId = runSql dbpool $ do
trackers <- getTicketTrackers ticketId
pings <- forM trackers $ \(Entity token _) -> do
diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs
index cec4fa7..a9c2f69 100644
--- a/lib/Server/Frontend.hs
+++ b/lib/Server/Frontend.hs
@@ -6,6 +6,7 @@ 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
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
index 8dceda5..18cf0a1 100644
--- a/lib/Server/Frontend/Routes.hs
+++ b/lib/Server/Frontend/Routes.hs
@@ -45,6 +45,9 @@ mkYesodData "Frontend" [parseRoutes|
/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
diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs
new file mode 100644
index 0000000..8861daa
--- /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>_{MsgTicker}
+ <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
index 1f4ad3f..9b88a48 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -45,6 +45,7 @@ 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
@@ -77,6 +78,8 @@ getTicketsR = do
let trips = GTFS.tripsOnDay gtfs day
+ tickerAnnounceWidget <- tickerWidget
+
(widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips)))
defaultLayout $ do
[whamlet|
@@ -91,6 +94,8 @@ $maybe name <- mdisplayname
<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
diff --git a/messages/de.msg b/messages/de.msg
index 9fa87e7..bded427 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -41,6 +41,7 @@ Tickets: Tickets
delete: löschen
AccordingToGtfs: Weitere Fahrten im GTFS
SpaceTimeDiagram: Weg-Zeit
+Ticker: Ticker-Hinweis
OBU: Onboard-Unit
ChooseTrain: Fahrt auswählen
diff --git a/messages/en.msg b/messages/en.msg
index 61e8879..77f2f86 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -42,6 +42,7 @@ delete: delete
AccordingToGtfs: Additional Trips contained in the Gtfs
StartTracking: Start Tracking
SpaceTimeDiagram: Space-Time Diagram
+Ticker: Ticker-Message
OBU: Onboard-Unit
ChooseTrain: Choose a Train
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 074863e..3c3d72f 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -120,6 +120,7 @@ library
, Server.Frontend.OnboardUnit
, Server.Frontend.Gtfs
, Server.Frontend.SpaceTime
+ , Server.Frontend.Ticker
default-language: GHC2021
default-extensions: OverloadedStrings
, ScopedTypeVariables
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 12:14:42 +0000