aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Persist.hs10
-rw-r--r--lib/Server/ControlRoom.hs38
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