1 files changed, 84 insertions, 32 deletions

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