somewhat functioning control room

tbh i've kinda lost track at what has all been changed in this, but the
control room form handling now works, and i can write announcements into
the database. Now on to making it do useful things!

2 files changed, 91 insertions, 22 deletions

diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index edfdeb3..7a5bdb2 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DefaultSignatures   #-}
+{-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
@@ -10,52 +11,120 @@
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
 
-module Server.ControlRoom where
+module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where
 
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
+import qualified Data.Map                    as M
 import           Data.Swagger                (ToSchema (..))
 import           Data.Text                   (Text)
 import qualified Data.Text                   as T
-import           Lucid                       (Html, ToHtml (toHtml), action_,
-                                              div_, for_, form_, id_, input_,
-                                              label_, method_, name_,
+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_)
-import           Servant                     (Capture, FormUrlEncoded, Get,
-                                              JSON, NoContent, PlainText, Post,
-                                              QueryParam, ReqBody,
+import           Servant                     (Capture, EmptyAPI, FormUrlEncoded,
+                                              Get, JSON, NoContent, PlainText,
+                                              Post, Proxy (Proxy), QueryParam,
+                                              ReqBody, err404, err302,
+                                              errHeaders, throwError,
                                               type (:<|>) (..), type (:>))
 import           Servant.HTML.Lucid          (HTML)
 import           Web.FormUrlEncoded          (ToForm)
 import           Web.Internal.FormUrlEncoded (Form)
 
-import           GTFS                        (CalendarDate,
-                                              CalendarExceptionType, TripID)
+import           Control.Monad               (forM_)
+import           Control.Monad.Extra         (maybeM, whenM)
+import           Data.Functor                ((<&>))
+import           Data.Map                    (Map)
+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           Database.Persist.Sql        (SqlBackend)
+import           GHC.Generics                (Generic)
 import           Lucid.Forms                 (ToHtmlForm (..),
-                                              ToHtmlFormInput (..))
+                                              ToHtmlFormInput (..), formAction)
+import           Persist                     (Announcement (..), Key (..),
+                                              runSql)
 import           Server.Util                 (Service)
+import           Text.ProtocolBuffers        (Default (defaultValue))
+import           Web.FormUrlEncoded          (FromForm)
 
-data TripList = TripList
-  { tripListHeader :: Text
-  , tripListType   :: Text
-  , tripListTrips  :: [TripID]
-  }
+import           GTFS
 
 type ControlRoomAPI =
-  Get '[HTML] TripList
+  "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
+  :<|> ControlRoomCranks
 
-controlRoomServer :: Service ControlRoomAPI
-controlRoomServer =
-  (pure (TripList "hallo" "welt" []))
+-- | train infra seems to involve turning lots of cranks, so here have some!
+type ControlRoomCranks =
+  "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[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
+  :<|> "train" :> "metainfo" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
+  :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
+
+data TrainAnnounceF = TrainAnnounceF
+  { taMsg     :: Text
+  , taHeader  :: 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 …
+          Nothing  -> throwError err404
+        handleTimetable maybeDay = do
+          -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
+          day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
+          pure $ (day, tripsOnDay gtfs day)
+
+controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
+controlRoomCranks dbpool = undefined :<|> handleAnnounce :<|> undefined
+  where handleAnnounce tripID day TrainAnnounceF{..} = do
+          now <- liftIO $ getCurrentTime
+          AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement
+            { announcementTrip = tripID
+            , announcementMessage = taMsg
+            , announcementHeader = taHeader
+            , announcementDay = day
+            , announcementUrl = Nothing
+            , announcementAnnouncedAt =
+              fmap (const now) taLogTime
+            }
+          throwError $ err302 { errHeaders = [("Location", "/cr/main")] }
 
 
 instance ToHtmlFormInput CalendarExceptionType
 instance ToHtmlForm CalendarDate
 
-instance ToHtml TripList where
-  toHtml _ = div_ "todo"
 
+instance ToHtml (Day, Trip Deep Deep) where
+  toHtml (day, Trip{..}) = crPage tripTripID $ do
+    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)
+
+instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
+  toHtml (day, trips) = crPage ("trips on " <> T.pack (iso8601Show day)) $ do
+    ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
+      a_ [href_ ("/cr/trip/"<>tripTripID<>"/"<>T.pack (iso8601Show day))] (toHtml tripTripID)
+
+-- | control room page
+crPage :: Monad m => Text -> HtmlT m () -> HtmlT m ()
+crPage title content = do
+  h1_ (toHtml title)
+  main_ content
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index e3a07cb..d771736 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -123,7 +123,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
                   (dFeedEntity (toUtf8 . T.pack . show $ key))
                   { FE.vehicle = Just $ VehiclePosition
                     { trip = Just (dTripDescriptor runningTripTripNumber Nothing)
-                    , VP.vehicle = case runningTripTrainset of
+                    , VP.vehicle = case runningTripVehicle of
                         Nothing -> Nothing
                         Just trainset -> Just $ VehicleDescriptor
                              { VD.id = Nothing