diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/API.hs | 1 | ||||
| -rw-r--r-- | lib/Persist.hs | 7 | ||||
| -rw-r--r-- | lib/Server.hs | 13 | ||||
| -rw-r--r-- | lib/Server/Frontend.hs | 1 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 3 | ||||
| -rw-r--r-- | lib/Server/Frontend/Ticker.hs | 63 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs | 5 |
7 files changed, 92 insertions, 1 deletions
@@ -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 |