diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/API.hs | 4 | ||||
| -rw-r--r-- | lib/Lucid/Forms.hs | 115 | ||||
| -rw-r--r-- | lib/Persist.hs | 3 | ||||
| -rw-r--r-- | lib/Server.hs | 5 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 354 | ||||
| -rw-r--r-- | tracktrain.cabal | 5 |
6 files changed, 214 insertions, 272 deletions
@@ -19,7 +19,7 @@ import Servant (Application, FormUrlEncoded, Server, err401, err404, type (:>)) import Servant.API (Capture, Get, JSON, NoContent, PlainText, Post, QueryParam, - ReqBody, type (:<|>) ((:<|>))) + ReqBody, type (:<|>) ((:<|>)), Raw) import Servant.API.WebSocket (WebSocket) import Servant.GTFS.Realtime (Proto) import Servant.Swagger (HasSwagger (..)) @@ -69,7 +69,7 @@ type AdminAPI = -- documented, which would be silly and way to verbose. type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger :<|> API - :<|> "cr" :> ControlRoomAPI + :<|> "cr" :> Raw -- TODO write something useful here! (and if it's just "hey this is some websocket thingie") diff --git a/lib/Lucid/Forms.hs b/lib/Lucid/Forms.hs deleted file mode 100644 index 918c942..0000000 --- a/lib/Lucid/Forms.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - - -module Lucid.Forms ( GToHtmlForm(..) - , GToHtmlFormInput(..) - , ToHtmlForm(..) - , ToHtmlFormInput(..) - , HtmlFormOptions(..) - ) where - -import Data.Maybe (maybeToList) -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (Day) -import GHC.Generics (C1, D1, Generic (Rep), K1, Meta (..), - Rec0, S1, U1, type (:*:), type (:+:)) -import GHC.TypeLits (KnownSymbol, symbolVal) -import Lucid (Html, HtmlT, ToHtml (toHtml), action_, - div_, for_, form_, id_, input_, label_, - method_, name_, placeholder_, type_, - value_) -import Lucid.Base (relaxHtmlT) -import Text.ProtocolBuffers (Default (defaultValue)) - -class GToHtmlFormInput a where - gtoHtmlFormInput :: Text -> Proxy (a p) -> Html () - -instance (KnownSymbol name) - => GToHtmlFormInput (C1 (MetaCons name f s) U1) where - gtoHtmlFormInput group _ = do - input_ [type_ "radio", id_ name, value_ name, name_ group] -- need a shared name for all options here - label_ [for_ name] (toHtml name) - where name = T.pack (symbolVal (Proxy @name)) - -instance (GToHtmlFormInput l, GToHtmlFormInput r) => GToHtmlFormInput (l :+: r) where - gtoHtmlFormInput group _ = do - gtoHtmlFormInput group (Proxy @(l _)) - gtoHtmlFormInput group (Proxy @(r _)) - --- | ignore constructor & type metainfo -instance GToHtmlFormInput a => GToHtmlFormInput (D1 r a) where - gtoHtmlFormInput group _ = gtoHtmlFormInput group (Proxy @(a _)) - --- | class for things which can be (single) options (i.e. a single input-tag or --- | a group of radio buttons) in an html form -class ToHtmlFormInput a where - toFormInput :: Text -> Proxy a -> Html () - default toFormInput :: (GToHtmlFormInput (Rep a)) => Text -> Proxy a -> Html () - toFormInput group p = gtoHtmlFormInput group (Proxy @(Rep a _)) - -instance ToHtmlFormInput Text where - toFormInput name _ = input_ [type_ "text", name_ name, placeholder_ name] -instance ToHtmlFormInput Day where - toFormInput name _ = input_ [type_ "text", name_ name] -instance ToHtmlFormInput Bool where - toFormInput name _ = input_ [type_ "checkbox", name_ name] -instance ToHtmlFormInput (Maybe Bool) where - toFormInput name _ = input_ [type_ "checkbox", name_ name] - - --- | generic conversion of record data types to input forms -class GToHtmlForm a where - gtoHtmlForm :: Proxy (a p) -> Html () - --- | each record field is a form input -instance (KnownSymbol name, ToHtmlFormInput a) - => GToHtmlForm (S1 (MetaSel (Just name) su ss ds) (Rec0 a)) where - gtoHtmlForm _ = toFormInput (T.pack (symbolVal (Proxy @name))) (Proxy @a) - --- | just chain all fields -instance (GToHtmlForm l, GToHtmlForm r) => GToHtmlForm (l :*: r) where - gtoHtmlForm _ = do - gtoHtmlForm (Proxy @(l _)) - gtoHtmlForm (Proxy @(r _)) - --- | ignore constructor & type metainfo -instance GToHtmlForm a => GToHtmlForm (D1 r a) where - gtoHtmlForm _ = gtoHtmlForm (Proxy @(a _)) -instance GToHtmlForm a => GToHtmlForm (C1 r a) where - gtoHtmlForm _ = gtoHtmlForm (Proxy @(a _)) - --- | class for things which can be entered via html forms -class ToHtmlForm a where - toHtmlForm :: Monad m => HtmlFormOptions -> Proxy a -> HtmlT m () - default toHtmlForm :: (GToHtmlForm (Rep a), Monad m) => HtmlFormOptions -> Proxy a -> HtmlT m () - toHtmlForm options = relaxHtmlT . genericToHtmlForm options - -data HtmlFormOptions = HtmlFormOptions - { formAction :: Maybe Text - , formMethod :: Text - , formSubmitButtonText :: Text - } - -defaultOptions ::HtmlFormOptions -defaultOptions = HtmlFormOptions Nothing "post" "Ok" - -instance Default HtmlFormOptions where - defaultValue = defaultOptions - -genericToHtmlForm :: (GToHtmlForm (Rep a2)) => HtmlFormOptions -> Proxy a2 -> Html () -genericToHtmlForm HtmlFormOptions{..} (Proxy :: Proxy a) = - form_ ((method_ formMethod) : maybeToList (fmap action_ formAction)) $ do - gtoHtmlForm (Proxy @(Rep a _)) - input_ [type_ "submit", value_ formSubmitButtonText] diff --git a/lib/Persist.hs b/lib/Persist.hs index f42c1cc..c9c7901 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -46,7 +46,6 @@ 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 @@ -60,7 +59,7 @@ instance ToParamSchema Token where toParamSchema _ = toParamSchema (Proxy @String) data AmendmentStatus = Cancelled | Added - deriving (ToJSON, FromJSON, Generic, Show, Read, Eq, ToHtmlFormInput) + deriving (ToJSON, FromJSON, Generic, Show, Read, Eq) derivePersistField "AmendmentStatus" instance FromHttpApiData AmendmentStatus where parseUrlPiece "Cancelled" = Right Cancelled diff --git a/lib/Server.hs b/lib/Server.hs index cc86cd2..24f29f9 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -47,6 +47,9 @@ import Persist import Server.ControlRoom import Server.GTFS_RT (gtfsRealtimeServer) import Server.Util (Service, ServiceM, runService) +import Yesod (toWaiAppPlain) + +import System.IO.Unsafe application :: GTFS -> Pool SqlBackend -> IO Application application gtfs dbpool = do @@ -65,7 +68,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|> gtfsRealtimeServer gtfs dbpool :<|> adminServer gtfs dbpool) - :<|> controlRoomServer gtfs dbpool + :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom "http://localhost:4000/cr" gtfs dbpool))) where handleStations = pure stations handleTimetable station maybeDay = do -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index d7aee07..0971e79 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -10,8 +10,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} -module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where +module Server.ControlRoom (ControlRoom(..)) where import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -20,21 +24,6 @@ import qualified Data.Map as M import Data.Swagger (ToSchema (..)) import Data.Text (Text) import qualified Data.Text as T -import Lucid (Html, HtmlT, ToHtml (toHtml), a_, - action_, class_, div_, em_, for_, - form_, h1_, h2_, h3_, href_, id_, - input_, label_, li_, main_, - method_, name_, ol_, placeholder_, - type_, ul_, value_) -import Servant (Capture, EmptyAPI, FormUrlEncoded, - Get, Handler, JSON, - NoContent (..), PlainText, Post, - Proxy (Proxy), QueryParam, - QueryParam', ReqBody, Required, - ServerError, Strict, err302, - err404, errHeaders, throwError, - type (:<|>) (..), type (:>)) -import Servant.HTML.Lucid (HTML) import Web.FormUrlEncoded (ToForm) import Web.Internal.FormUrlEncoded (Form) @@ -50,10 +39,9 @@ import Data.UUID (UUID) import qualified Data.UUID as UUID import Database.Persist (Entity (..), delete, entityVal, get, insert, selectList, (==.)) -import Database.Persist.Sql (SqlBackend) +import Database.Persist.Sql (SqlBackend, PersistFieldSql, + runSqlPool) import GHC.Generics (Generic) -import Lucid.Forms (ToHtmlForm (..), - ToHtmlFormInput (..), formAction) import Persist (AmendmentStatus, Announcement (..), EntityField (..), Key (..), @@ -62,136 +50,204 @@ import Persist (AmendmentStatus, 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 GTFS -data TrainView = TrainView - { tvDay :: Day - , tvTrip :: Trip Deep Deep - , tvAnnouncements :: [Entity Announcement] - , tvRunning :: Bool - } deriving Show - -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 ControlRoom = ControlRoom + { getBaseurl :: Text + , getGtfs :: GTFS + , getPool :: Pool SqlBackend + } + +mkYesod "ControlRoom" [parseRoutes| +/main MainR GET +/train/#TripID/#Day TrainViewR GET +|] + +instance Yesod ControlRoom where + approot = ApprootMaster (\cr -> getBaseurl cr) + +-- 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 + req <- getRequest + let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) + + day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) + gtfs <- getYesod <&> getGtfs + let trips = tripsOnDay gtfs day + defaultLayout [whamlet| +<h1>Trips 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 + 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 +<ul> + $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns + <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="">delete</a> + $if null anns + <li><em>(none)</em> + <li><a href="">Add Announcement</a> +<h2>Stops +<ol> + $forall Stop{..} <- tripStops + <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} + +<h2>Vehicle Position +<div> Todo! +|] + + + +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 diff --git a/tracktrain.cabal b/tracktrain.cabal index 253999b..ef3a1f2 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -77,8 +77,6 @@ library , servant-swagger , servant-docs , servant-websockets - , servant-lucid - , lucid , websockets , lens , persistent @@ -94,12 +92,13 @@ library , transformers , extra , vector-algorithms + , yesod + , blaze-html hs-source-dirs: lib exposed-modules: GTFS , Server , Server.GTFS_RT , Server.ControlRoom - , Lucid.Forms , PersistOrphans , Persist , API |