diff options
Diffstat (limited to 'lib/Server')
| -rw-r--r-- | lib/Server/ControlRoom.hs | 348 | ||||
| -rw-r--r-- | lib/Server/Util.hs | 5 |
2 files changed, 157 insertions, 196 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 0971e79..0e3f01e 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -1,89 +1,98 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Server.ControlRoom (ControlRoom(..)) 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 Web.FormUrlEncoded (ToForm) -import Web.Internal.FormUrlEncoded (Form) - -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 Data.UUID (UUID) -import qualified Data.UUID as UUID -import Database.Persist (Entity (..), delete, entityVal, - get, insert, selectList, (==.)) -import Database.Persist.Sql (SqlBackend, PersistFieldSql, - runSqlPool) -import GHC.Generics (Generic) -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 Yesod -import Data.List (lookup) -import Text.Read (readMaybe) -import Text.Blaze.Html (ToMarkup(..)) -import qualified Data.Vector as V +import Control.Monad (forM_) +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.ByteString.Char8 as C8 +import Data.Functor ((<&>)) +import Data.List (lookup) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Pool (Pool) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (getCurrentTime, utctDay) +import Data.Time.Calendar (Day) +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.Vector as V +import Database.Persist (Entity (..), delete, entityVal, get, + insert, selectList, (==.)) +import Database.Persist.Sql (PersistFieldSql, SqlBackend, + runSqlPool) +import Fmt ((+|), (|+)) +import GHC.Generics (Generic) +import Persist (AmendmentStatus, Announcement (..), + EntityField (..), Key (..), + ScheduleAmendment (ScheduleAmendment), + runSql) +import Server.Util (Service) +import Text.Blaze.Html (ToMarkup (..)) +import Text.ProtocolBuffers (Default (defaultValue)) +import Text.Read (readMaybe) +import Yesod +import Yesod.Form import GTFS data ControlRoom = ControlRoom { getBaseurl :: Text - , getGtfs :: GTFS - , getPool :: Pool SqlBackend + , getGtfs :: GTFS + , getPool :: Pool SqlBackend } +mkMessage "ControlRoom" "messages" "en" + mkYesod "ControlRoom" [parseRoutes| -/main MainR GET -/train/#TripID/#Day TrainViewR GET +/ RootR GET +/trains TrainsR GET +/train/id/#TripID/#Day TrainViewR GET +/train/announce/#TripID/#Day AnnounceR POST +/train/del-announce/#UUID DelAnnounceR GET +/trips TripsViewR GET +/trip/#TripID TripViewR GET |] instance Yesod ControlRoom where approot = ApprootMaster (\cr -> getBaseurl cr) +instance RenderMessage ControlRoom FormMessage where + renderMessage _ _ = defaultFormMessage + -- which backend we're using and how to run an action. instance YesodPersist ControlRoom where type YesodPersistBackend ControlRoom = SqlBackend - runDB action = do pool <- getYesod <&> getPool runSqlPool action pool -getMainR :: Handler Html -getMainR = do + + +getRootR :: Handler Html +getRootR = redirect (TrainsR) + +getTrainsR :: Handler Html +getTrainsR = do req <- getRequest let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) @@ -91,30 +100,34 @@ getMainR = do gtfs <- getYesod <&> getGtfs let trips = tripsOnDay gtfs day defaultLayout [whamlet| -<h1>Trips on #{iso8601Show day} +<h1>Trains on #{iso8601Show day} <ol> $forall Trip{..} <- trips <li><a href="@{TrainViewR tripTripID day}">#{tripTripID}</a> : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} -|] -- TODO: display stuff +|] getTrainViewR :: TripID -> Day -> Handler Html getTrainViewR trip day = do GTFS{..} <- getYesod <&> getGtfs + (widget, enctype) <- generateFormPost (announceForm day trip) case M.lookup trip trips of Nothing -> notFound Just res@Trip{..} -> do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] defaultLayout [whamlet| -<h1>#{tripTripID} on #{iso8601Show day} -<h2>Announcements +<h1><a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{iso8601Show day}</a> +<h2>_{MsgAnnouncements} <ul> $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns - <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="">delete</a> + <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">delete</a> $if null anns - <li><em>(none)</em> - <li><a href="">Add Announcement</a> -<h2>Stops + <li><em>(_{MsgNone})</em> +<h3>_{MsgNewAnnouncement} +<form method=post action=@{AnnounceR trip day} enctype=#{enctype}> + ^{widget} + <button>Submit +<h2>_{MsgStops} <ol> $forall Stop{..} <- tripStops <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} @@ -124,130 +137,81 @@ getTrainViewR trip day = do |] +getTripsViewR :: Handler Html +getTripsViewR = do + GTFS{..} <- getYesod <&> getGtfs + defaultLayout [whamlet| +<h1>List of Trips +<ul> + $forall Trip{..} <- trips + <li><a href="@{TripViewR tripTripID}">#{tripTripID}</a> + : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} +|] + + +getTripViewR :: TripID -> Handler Html +getTripViewR tripId = do + GTFS{..} <- getYesod <&> getGtfs + case M.lookup tripId trips of + Nothing -> notFound + Just Trip{..} -> defaultLayout [whamlet| +<h1>Trip #{tripTripID} +<h2>Stops +<ol> + $forall Stop{..} <- tripStops + <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} +<h2>Dates +<ul> + TODO! +|] + + +postAnnounceR :: TripID -> Day -> Handler Html +postAnnounceR trip day = do + ((result, widget), enctype) <- runFormPost (announceForm day trip) + case result of + FormSuccess ann -> do + runDB $ insert ann + redirect (TrainViewR trip day) + _ -> defaultLayout + [whamlet| + <p>Invalid input, let's try again. + <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> + ^{widget} + <button>Submit + |] + +getDelAnnounceR :: UUID -> Handler Html +getDelAnnounceR uuid = do + ann <- runDB $ do + a <- get (AnnouncementKey uuid) + delete (AnnouncementKey uuid) + pure a + case ann of + Nothing -> notFound + Just Announcement{..} -> + redirect (TrainViewR announcementTrip announcementDay) instance ToMarkup Time where toMarkup time = toMarkup (show time) --- 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! --- 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" :> 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 - --- data TrainAnnounceF = TrainAnnounceF --- { taHeader :: Text --- , taMsg :: Text --- , 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 :<|> handleTrain :<|> handleTrips :<|> handleTrip --- :<|> controlRoomCranks dbpool --- where handleTrain trip day = case M.lookup trip trips of --- 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?) --- 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 :<|> handleDate :<|> handleDate :<|> 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 --- } --- 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/"+|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 --- instance ToHtmlForm CalendarDate - - --- 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)) - --- 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 --- ol_ $ forM_ trips $ \Trip{..} -> li_ $ do --- 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 () --- crPage title content = do --- h1_ (toHtml title) --- main_ content +data TrainAnnounceF = TrainAnnounceF + { taHeader :: Text + , taMsg :: Text + , taLogTime :: Bool + } deriving (Show) + + + +announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget) +announceForm day tripId = renderDivs $ Announcement + <$> pure tripId + <*> areq textField "Header" Nothing + <*> areq textField "Text" Nothing + <*> pure day + <*> aopt urlField "Link" Nothing + <*> lift (liftIO getCurrentTime <&> Just) + + + diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs index 1c62663..a7a358e 100644 --- a/lib/Server/Util.hs +++ b/lib/Server/Util.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -- | mostly the monad the service runs in -module Server.Util (Service, ServiceM, runService, redirect) where +module Server.Util (Service, ServiceM, runService) where import Control.Monad.Logger (LoggingT, runStderrLoggingT) import Data.ByteString (ByteString) @@ -13,6 +13,3 @@ type Service api = ServerT api ServiceM runService :: ServiceM a -> Handler a runService = runStderrLoggingT - -redirect :: ByteString -> ServiceM a -redirect path = throwError $ err302 { errHeaders = [("Location", path)] } |