diff options
| -rw-r--r-- | lib/Persist.hs | 10 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 38 |
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 |