a little more control room work

2 files changed, 39 insertions, 9 deletions

diff --git a/lib/Persist.hs b/lib/Persist.hs
index da23dae..f42c1cc 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -29,7 +29,8 @@ import           Database.Persist.Sql        (PersistFieldSql,
 import           Database.Persist.TH
 import           GTFS
 import           PersistOrphans
-import           Servant                     (FromHttpApiData, ToHttpApiData)
+import           Servant                     (FromHttpApiData (..),
+                                              ToHttpApiData)
 
 import           Conduit                     (ResourceT)
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
@@ -45,6 +46,7 @@ import           Data.Time.Calendar          (Day, DayOfWeek (..))
 import           Data.Vector                 (Vector)
 import           Database.Persist.Postgresql (SqlBackend)
 import           GHC.Generics                (Generic)
+import           Lucid.Forms                 (ToHtmlFormInput)
 import           Web.PathPieces              (PathPiece)
 
 newtype Token = Token UUID
@@ -58,8 +60,12 @@ instance ToParamSchema Token where
   toParamSchema _ = toParamSchema (Proxy @String)
 
 data AmendmentStatus = Cancelled | Added
-  deriving (ToJSON, FromJSON, Generic, Show, Read, Eq)
+  deriving (ToJSON, FromJSON, Generic, Show, Read, Eq, ToHtmlFormInput)
 derivePersistField "AmendmentStatus"
+instance FromHttpApiData AmendmentStatus where
+  parseUrlPiece "Cancelled" = Right Cancelled
+  parseUrlPiece "Added"     = Right Added
+  parseUrlPiece other       = Left ("unknown AmendmentStatus: "<>other)
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 -- | tokens which have been issued
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index e4b69c2..d7aee07 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -30,7 +30,8 @@ import           Servant                     (Capture, EmptyAPI, FormUrlEncoded,
                                               Get, Handler, JSON,
                                               NoContent (..), PlainText, Post,
                                               Proxy (Proxy), QueryParam,
-                                              ReqBody, ServerError, err302,
+                                              QueryParam', ReqBody, Required,
+                                              ServerError, Strict, err302,
                                               err404, errHeaders, throwError,
                                               type (:<|>) (..), type (:>))
 import           Servant.HTML.Lucid          (HTML)
@@ -53,13 +54,16 @@ import           Database.Persist.Sql        (SqlBackend)
 import           GHC.Generics                (Generic)
 import           Lucid.Forms                 (ToHtmlForm (..),
                                               ToHtmlFormInput (..), formAction)
-import           Persist                     (Announcement (..),
+import           Persist                     (AmendmentStatus,
+                                              Announcement (..),
                                               EntityField (..), Key (..),
+                                              ScheduleAmendment (ScheduleAmendment),
                                               runSql)
 import           Server.Util                 (Service, redirect)
 import           Text.ProtocolBuffers        (Default (defaultValue))
 import           Web.FormUrlEncoded          (FromForm)
 
+import           Fmt                         ((+|), (|+))
 import           GTFS
 
 data TrainView = TrainView
@@ -72,6 +76,8 @@ data TrainView = TrainView
 type ControlRoomAPI =
   "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
   :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView
+  :<|> "trips" :> Get '[HTML] (Map TripID (Trip Deep Deep))
+  :<|> "trip" :> Capture "tripId" TripID :> Get '[HTML] (Trip Deep Deep)
   :<|> ControlRoomCranks
 
 -- | train infra seems to involve turning lots of cranks, so here have some!
@@ -79,7 +85,8 @@ 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" :> "date" :> Capture "tripId" TripID :> ReqBody '[FormUrlEncoded] TrainDateF :> Post '[PlainText] NoContent
+  :<|> "train" :> "date" :> Capture "tripId" TripID :> QueryParam' '[Required] "" TrainDateF :> Post '[PlainText] NoContent
   :<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
   :<|> "train" :> "metainfo" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
   :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
@@ -90,11 +97,17 @@ data TrainAnnounceF = TrainAnnounceF
   , taLogTime :: Maybe Bool
   } deriving (Generic, ToHtmlForm, FromForm)
 
+-- | TODO: can also be "normal"?
+data TrainDateF = TrainDateF
+  { tdDay    :: Day
+  , tdStatus :: AmendmentStatus
+  } deriving (Generic, ToHtmlForm, FromForm)
+
 
 controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
-controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
+controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrain :<|> handleTrips :<|> handleTrip
   :<|> controlRoomCranks dbpool
-  where handleTrip trip day = case M.lookup trip trips of
+  where handleTrain trip day = case M.lookup trip trips of
           Just res -> do
             as <- runSql dbpool
               $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
@@ -104,9 +117,13 @@ controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
           -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
           day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
           pure $ (day, tripsOnDay gtfs day)
+        handleTrips = pure trips
+        handleTrip tripId = case M.lookup tripId trips of
+          Just trip -> pure trip
+          Nothing   -> throwError err404
 
 controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
-controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> undefined
+controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> handleDate :<|> handleDate :<|> undefined
   where handleAnnounce tripID day TrainAnnounceF{..} = do
           now <- liftIO $ getCurrentTime
           AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement
@@ -127,7 +144,11 @@ controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce
           case ann of
             Nothing -> throwError err404
             Just Announcement{..} ->
-              redirect ("/cr/train/"<>C8.pack (T.unpack announcementTrip)<>"/"<>C8.pack (iso8601Show announcementDay))
+              redirect ("/cr/train/"+|announcementTrip|+"/"+| iso8601Show announcementDay|+"")
+        handleDate tripId TrainDateF{..} = do
+          -- TODO: check that tripId exists
+          runSql dbpool $ insert $ ScheduleAmendment tripId tdDay tdStatus
+          redirect ("/cr/train/"+|tripId|+"/"+| iso8601Show tdDay|+"")
 
 
 instance ToHtmlFormInput CalendarExceptionType
@@ -157,6 +178,9 @@ instance ToHtml TrainView  where
     h2_ "Vehicle Position"
     div_ "todo!"
 
+    h2_ "Cancellation Status"
+    a_ [href_ ("/cr/train/date/"+|tripTripID|+"?tdDate="+|iso8601Show day|+"&tdStatus=Cancelled")] "Cancel"
+
 
 instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
   toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do