aboutsummaryrefslogtreecommitdiff
path: root/lib/Server/Frontend
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server/Frontend')
-rw-r--r--lib/Server/Frontend/Ticker.hs26
-rw-r--r--lib/Server/Frontend/Tickets.hs116
2 files changed, 103 insertions, 39 deletions
diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs
index 861197a..7fc2874 100644
--- a/lib/Server/Frontend/Ticker.hs
+++ b/lib/Server/Frontend/Ticker.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE BlockArguments #-}
module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where
import Data.Functor ((<&>))
@@ -7,7 +8,8 @@ import Persist (EntityField (TickerAnnouncementArchived
TickerAnnouncement (..))
import Server.Frontend.Routes (FrontendMessage (..), Handler,
Route (..), Widget)
-import Yesod
+import Yesod hiding ((==.), (=.), update)
+import Database.Esqueleto.Experimental hiding ((<&>))
tickerAnnounceForm
@@ -24,7 +26,10 @@ tickerAnnounceForm maybeCurrent = renderDivs $ TickerAnnouncement
tickerWidget :: Handler Html
tickerWidget = do
- current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] []
+ current <- runDB $ selectOne do
+ ann <- from (table @TickerAnnouncement)
+ where_ (ann ^. TickerAnnouncementArchived ==. val False)
+ pure ann
(widget, enctype) <-
generateFormPost (tickerAnnounceForm (current <&> entityVal))
@@ -40,13 +45,19 @@ tickerWidget = do
postTickerAnnounceR :: Handler Html
postTickerAnnounceR = do
- current <- runDB $ selectFirst [ TickerAnnouncementArchived ==. False ] []
+ current <- runDB $ selectOne do
+ ann <- from (table @TickerAnnouncement)
+ where_ (ann ^. TickerAnnouncementArchived ==. val False)
+ pure ann
+
((result, widget), enctype) <-
- runFormPost (tickerAnnounceForm (current <&> entityVal))
+ runFormPost (tickerAnnounceForm (fmap entityVal current))
+
case result of
FormSuccess ann -> do
- runDB $ do
- updateWhere [] [ TickerAnnouncementArchived =. True ]
+ runDB do
+ update \t ->
+ set t [ TickerAnnouncementArchived =. val True ]
insert ann
redirect RootR
_ -> defaultLayout
@@ -59,5 +70,6 @@ postTickerAnnounceR = do
postTickerDeleteR :: Handler Html
postTickerDeleteR = do
- runDB $ updateWhere [] [ TickerAnnouncementArchived =. True ]
+ runDB $ update \t ->
+ set t [TickerAnnouncementArchived =. val True]
redirect RootR
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
index 9b88a48..c542074 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE BlockArguments #-}
module Server.Frontend.Tickets
( getTicketsR
@@ -48,10 +49,14 @@ import Server.Frontend.SpaceTime (mkSpaceTimeDiagram,
import Server.Frontend.Ticker (tickerWidget)
import Server.Util (Service, secondsNow)
import Text.Read (readMaybe)
-import Yesod
+import Yesod hiding ((==.), (||.), delete, update, (=.))
+import qualified Yesod
import Yesod.Auth
import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
+import Database.Esqueleto.Experimental hiding ((<&>), on) -- , on, delete, update, (=.))
+import qualified Database.Esqueleto.Experimental as E
+import Database.Esqueleto.Experimental ((^.), (:&)(..), where_, orderBy, asc, associateJoin)
getTicketsR :: Handler Html
getTicketsR = do
@@ -64,17 +69,23 @@ getTicketsR = do
Just day -> (day, day == today)
Nothing -> (today, True)
- maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ]
+ maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay Yesod.==. 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))
+
+ tickets <- runDB $ E.select do
+ ((ticket :& stop) :& station) <- E.from $
+ (E.table @Ticket `E.InnerJoin` E.table @Stop
+ `E.on` \(ticket :& stop) -> ticket ^. TicketId E.==. stop E.^. StopTicket)
+ `E.InnerJoin` E.table @Station `E.on` \((_ :& stop) :& station) -> stop E.^. StopStation E.==. station ^. StationId
+ where_ (ticket ^. TicketDay E.==. (E.val day))
+ orderBy [asc (ticket ^. TicketTripName)]
+ pure (ticket, (stop, station))
+ & fmap associateJoin
let trips = GTFS.tripsOnDay gtfs day
@@ -98,9 +109,9 @@ $maybe name <- mdisplayname
<section>
<h2>_{MsgTickets}
<ol>
- $forall (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets
+ $forall (TicketKey ticketId, (Ticket{..}, stops)) <- M.toList tickets
<li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a>
- : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign}
+ : _{Msgdep} #{stopDeparture (entityVal (fst (head stops)))} #{stationName (entityVal (snd (head stops)))} → #{ticketHeadsign}
$if null tickets
<li style="text-align: center"><em>(_{MsgNone})</em>
$maybe spaceTime <- maybeSpaceTime
@@ -144,16 +155,18 @@ postGtfsTicketImportR day = do
<&> (\(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
+ & mapM (\GTFS.Station{..} -> runDB $ E.selectOne do
+ station <- E.from (E.table @Station)
+ where_ (station ^. StationShortName E.==. E.val stationId)
+ pure station
+ >>= \case
Nothing -> do
key <- insert Station
{ stationGeopos = Geopos (stationLat, stationLon)
, stationShortName = stationId , stationName }
pure (stationId, key)
Just (Entity key _) -> pure (stationId, key))
- <&> M.fromList
+ & fmap M.fromList
selected
<&> (\(trip@GTFS.Trip{..}, day) ->
@@ -190,21 +203,52 @@ getTicketViewR ticketId = do
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 ] []
+ stops <- runDB $ select do
+ (stop :& station) <- from $ table @Stop `innerJoin` table @Station
+ `E.on` \(stop :& station) -> stop ^. StopStation ==. station ^. StationId
+ where_ (stop ^. StopTicket ==. val ticketKey)
+ pure (stop, station)
+ -- & fmap associateJoin
+ -- stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do
+ -- station <- getJust (stopStation (entityVal stop))
+ -- pure (entityVal stop, station))
+
+ anns <- runDB $ select do
+ ann <- from (table @Announcement)
+ where_ (ann ^. AnnouncementTicket ==. val ticketKey)
+ pure ann
+
+ -- anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] []
+
+ trackers <- runDB $ select do
+ (tt :& tracker) <- from $
+ table @TrackerTicket `innerJoin` table @Tracker
+ `E.on` \(tt :& tracker) -> tracker ^. TrackerId ==. tt ^. TrackerTicketTracker
+ where_ (tt ^. TrackerTicketTicket ==. val ticketKey
+ ||. tracker ^. TrackerCurrentTicket ==. val (Just ticketKey))
+ pure tracker
+
+ lastPing <- runDB $ selectOne do
+ trainping <- from $ table @TrainPing
+ where_ (trainping ^. TrainPingTicket ==. val (coerce ticketId))
+ orderBy [desc (trainping ^. TrainPingTimestamp)]
+ pure trainping
+
+ anchors <- runDB $ select do
+ anchor <- from $ table @TrainAnchor
+ where_ (anchor ^. TrainAnchorTicket ==. val ticketKey)
+ pure anchor
<&> nonEmpty . fmap entityVal
+ -- 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 ]
+ spaceTimeMaybe <- mkSpaceTimeDiagramHandler 2 ticketDay [ TicketId Yesod.==. coerce ticketId ]
(widget, enctype) <- generateFormPost (announceForm ticketId)
@@ -235,7 +279,7 @@ getTicketViewR ticketId = do
<section>
<h2>_{MsgStops}
<ol>
- $forall (Stop{..}, Station{..}) <- stops
+ $forall (Entity _ Stop{..}, Entity _ Station{..}) <- stops
<li value="#{stopSequence}"> #{stopArrival} #{stationName}
$maybe history <- anchors
$maybe delay <- guessDelay history (int2Double stopSequence)
@@ -279,9 +323,12 @@ 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))
+ -- stops <- runDB $ E.select do
+ -- (stop :& station) <- E.from $
+ -- E.table @Stop `E.InnerJoin` E.table @Station
+ -- `E.on` \(stop :& station) -> stop ^. StopStation E.==. station E.^. StationId
+ -- where_ (stop ^. StopTicket E.==. (E.val (TicketKey ticketId)))
+ -- pure (stop, station)
(widget, enctype) <- generateFormPost (announceForm ticketId)
@@ -380,7 +427,9 @@ getDelAnnounceR :: UUID -> Handler Html
getDelAnnounceR uuid = do
ann <- runDB $ do
a <- get (AnnouncementKey uuid)
- delete (AnnouncementKey uuid)
+ delete do
+ ann <- from (table @Announcement)
+ where_ (ann ^. AnnouncementId ==. val (AnnouncementKey uuid))
pure a
case ann of
Nothing -> notFound
@@ -392,8 +441,11 @@ getTokenBlock :: Token -> Handler Html
getTokenBlock token = do
YesodRequest{..} <- getRequest
let blocked = lookup "unblock" reqGetParams /= Just "true"
- maybe <- runDB $ do
- update (TrackerKey token) [ TrackerBlocked =. blocked ]
+ maybe <- runDB do
+ update \tracker -> do
+ set tracker [TrackerBlocked =. val blocked]
+ where_ (tracker ^. TrackerId ==. val (TrackerKey token))
+ -- Yesod.update (TrackerKey token) [ TrackerBlocked Yesod.=. blocked ]
get (TrackerKey token)
case maybe of
Just r@Tracker{..} -> do
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-16 20:50:06 +0000