some work on the control room

(it can do useful stuff! but it also still breaks on some things!)

3 files changed, 80 insertions, 32 deletions

diff --git a/lib/Persist.hs b/lib/Persist.hs
index f2377b6..da23dae 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -88,7 +88,7 @@ Announcement json sql=tt_announcements
   day Day
   url Text Maybe
   announcedAt UTCTime Maybe
-  deriving Generic ToSchema
+  deriving Generic ToSchema Show
 
 -- | this table works as calendar_dates.txt in GTFS
 ScheduleAmendment json sql=tt_schedule_amendement
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 7a5bdb2..e4b69c2 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -13,21 +13,25 @@
 
 module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where
 
+import           Control.Monad               (unless, when)
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
+import qualified Data.ByteString.Char8       as C8
 import qualified Data.Map                    as M
 import           Data.Swagger                (ToSchema (..))
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
 import           Lucid                       (Html, HtmlT, ToHtml (toHtml), a_,
-                                              action_, div_, for_, form_, h1_,
-                                              h2_, href_, id_, input_, label_,
-                                              li_, main_, method_, name_, ol_,
-                                              placeholder_, type_, value_)
+                                              action_, class_, div_, em_, for_,
+                                              form_, h1_, h2_, h3_, href_, id_,
+                                              input_, label_, li_, main_,
+                                              method_, name_, ol_, placeholder_,
+                                              type_, ul_, value_)
 import           Servant                     (Capture, EmptyAPI, FormUrlEncoded,
-                                              Get, JSON, NoContent, PlainText,
-                                              Post, Proxy (Proxy), QueryParam,
-                                              ReqBody, err404, err302,
-                                              errHeaders, throwError,
+                                              Get, Handler, JSON,
+                                              NoContent (..), PlainText, Post,
+                                              Proxy (Proxy), QueryParam,
+                                              ReqBody, ServerError, err302,
+                                              err404, errHeaders, throwError,
                                               type (:<|>) (..), type (:>))
 import           Servant.HTML.Lucid          (HTML)
 import           Web.FormUrlEncoded          (ToForm)
@@ -41,28 +45,39 @@ import           Data.Pool                   (Pool)
 import           Data.Time                   (getCurrentTime, utctDay)
 import           Data.Time.Calendar          (Day)
 import           Data.Time.Format.ISO8601    (iso8601Show)
-import           Database.Persist            (insert)
+import           Data.UUID                   (UUID)
+import qualified Data.UUID                   as UUID
+import           Database.Persist            (Entity (..), delete, entityVal,
+                                              get, insert, selectList, (==.))
 import           Database.Persist.Sql        (SqlBackend)
 import           GHC.Generics                (Generic)
 import           Lucid.Forms                 (ToHtmlForm (..),
                                               ToHtmlFormInput (..), formAction)
-import           Persist                     (Announcement (..), Key (..),
+import           Persist                     (Announcement (..),
+                                              EntityField (..), Key (..),
                                               runSql)
-import           Server.Util                 (Service)
+import           Server.Util                 (Service, redirect)
 import           Text.ProtocolBuffers        (Default (defaultValue))
 import           Web.FormUrlEncoded          (FromForm)
 
 import           GTFS
 
+data TrainView = TrainView
+  { tvDay           :: Day
+  , tvTrip          :: Trip Deep Deep
+  , tvAnnouncements :: [Entity Announcement]
+  , tvRunning       :: Bool
+  } deriving Show
+
 type ControlRoomAPI =
   "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
-  :<|> "trip" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] (Day, Trip Deep Deep)
-  :<|> "irgendwo" :> ReqBody '[FormUrlEncoded] CalendarDate :> Post '[PlainText] Text
+  :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView
   :<|> ControlRoomCranks
 
 -- | train infra seems to involve turning lots of cranks, so here have some!
 type ControlRoomCranks =
   "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
+  :<|> "train" :> "del-announce" :> Capture "uuid" UUID :> Get '[PlainText] NoContent
   :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent
   :<|> "train" :> "date" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
   :<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
@@ -70,20 +85,20 @@ type ControlRoomCranks =
   :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
 
 data TrainAnnounceF = TrainAnnounceF
-  { taMsg     :: Text
-  , taHeader  :: Text
+  { taHeader  :: Text
+  , taMsg     :: Text
   , taLogTime :: Maybe Bool
   } deriving (Generic, ToHtmlForm, FromForm)
 
+
 controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
 controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
-  :<|> (\text -> do
-           liftIO $ putStrLn (show text)
-           pure "hello"
-       )
   :<|> controlRoomCranks dbpool
   where handleTrip trip day = case M.lookup trip trips of
-          Just res -> pure (day, res) -- TODO: can't just assume it runs that day …
+          Just res -> do
+            as <- runSql dbpool
+              $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
+            pure (TrainView day res as True) -- TODO: can't just assume it runs that day …
           Nothing  -> throwError err404
         handleTimetable maybeDay = do
           -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
@@ -91,7 +106,7 @@ controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
           pure $ (day, tripsOnDay gtfs day)
 
 controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
-controlRoomCranks dbpool = undefined :<|> handleAnnounce :<|> undefined
+controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> undefined
   where handleAnnounce tripID day TrainAnnounceF{..} = do
           now <- liftIO $ getCurrentTime
           AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement
@@ -103,25 +118,53 @@ controlRoomCranks dbpool = undefined :<|> handleAnnounce :<|> undefined
             , announcementAnnouncedAt =
               fmap (const now) taLogTime
             }
-          throwError $ err302 { errHeaders = [("Location", "/cr/main")] }
+          redirect ("/cr/train/"<>C8.pack (T.unpack tripID)<>"/"<>C8.pack (iso8601Show day))
+        handleAnnounceDel uuid = do
+          ann <- runSql dbpool $ do
+            a <- get (AnnouncementKey uuid)
+            delete (AnnouncementKey uuid)
+            pure a
+          case ann of
+            Nothing -> throwError err404
+            Just Announcement{..} ->
+              redirect ("/cr/train/"<>C8.pack (T.unpack announcementTrip)<>"/"<>C8.pack (iso8601Show announcementDay))
 
 
 instance ToHtmlFormInput CalendarExceptionType
 instance ToHtmlForm CalendarDate
 
 
-instance ToHtml (Day, Trip Deep Deep) where
-  toHtml (day, Trip{..}) = crPage tripTripID $ do
+instance ToHtml TrainView  where
+  toHtml (TrainView day Trip{..} as running) = crPage tripTripID $ do
+    unless running $ do
+      div_ [class_ "warning"] "Warning: Trip not running on this day!"
+
+    h2_ "Announcements"
+    ul_ $ do
+      unless (null as) $ forM_ as $ \(Entity (AnnouncementKey uuid) Announcement{..}) -> do
+        li_ $ do
+          em_ (toHtml announcementHeader); ": "; toHtml announcementMessage
+          " "; a_ [href_ $ "/cr/train/del-announce/"<>UUID.toText uuid] "delete"
+      li_ $ do
+        "Add Announcement:"
+        toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
+          (Proxy @TrainAnnounceF)
+
     h2_ "Stops"
     ol_ $ forM_ tripStops $ \Stop{..} -> do
       div_ (toHtml (stationName stopStation))
-    toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
-      (Proxy @TrainAnnounceF)
+
+    h2_ "Vehicle Position"
+    div_ "todo!"
+
 
 instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
-  toHtml (day, trips) = crPage ("trips on " <> T.pack (iso8601Show day)) $ do
+  toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do
     ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
-      a_ [href_ ("/cr/trip/"<>tripTripID<>"/"<>T.pack (iso8601Show day))] (toHtml tripTripID)
+      a_ [href_ ("/cr/train/"<>tripTripID<>"/"<>shownDay)] (toHtml tripTripID)
+    when (null trips) $ do
+      em_ "(none)"
+    where shownDay = T.pack (iso8601Show day)
 
 -- | control room page
 crPage :: Monad m => Text -> HtmlT m () -> HtmlT m ()
diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs
index 45c2477..1c62663 100644
--- a/lib/Server/Util.hs
+++ b/lib/Server/Util.hs
@@ -1,13 +1,18 @@
-
+{-# LANGUAGE FlexibleContexts #-}
 
 -- | mostly the monad the service runs in
-module Server.Util (Service, ServiceM, runService) where
+module Server.Util (Service, ServiceM, runService, redirect) where
 
 import           Control.Monad.Logger (LoggingT, runStderrLoggingT)
-import           Servant              (Handler, ServerT)
+import           Data.ByteString      (ByteString)
+import           Servant              (Handler, ServerError, ServerT, err302,
+                                       errHeaders, throwError)
 
 type ServiceM  = LoggingT Handler
 type Service api = ServerT api ServiceM
 
 runService :: ServiceM a -> Handler a
 runService = runStderrLoggingT
+
+redirect :: ByteString -> ServiceM a
+redirect path = throwError $ err302 { errHeaders = [("Location", path)] }