diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs (renamed from lib/Server/ControlRoom.hs) | 381 |
1 files changed, 81 insertions, 300 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/Frontend/Tickets.hs index 5292620..43f24aa 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/Frontend/Tickets.hs @@ -1,192 +1,55 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Server.ControlRoom (ControlRoom(..)) where - -import Config (ServerConfig (..), UffdConfig (..)) -import Control.Monad (forM, forM_, join) -import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import qualified Data.Aeson as A -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as LB -import Data.Coerce (coerce) -import Data.Function (on, (&)) -import Data.Functor ((<&>)) -import Data.List (lookup, nubBy) -import Data.List.NonEmpty (nonEmpty) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (catMaybes, fromJust, isJust) -import Data.Pool (Pool) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime (..), addDays, - 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 Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) -import Fmt ((+|), (|+)) -import GHC.Float (int2Double) -import GHC.Generics (Generic) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Frontend.Tickets + ( getTicketsR + , postGtfsTicketImportR + , getTicketViewR + , getTicketMapViewR + , getDelAnnounceR + , postAnnounceR + , getTokenBlock + ) where + +import Server.Frontend.Routes + +import Config (ServerConfig (..), UffdConfig (..)) +import Control.Monad (forM, forM_, join) +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Coerce (coerce) +import Data.Function (on, (&)) +import Data.Functor ((<&>)) +import Data.List (lookup, nubBy) +import Data.List.NonEmpty (nonEmpty) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromJust, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime (..), addDays, + 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 Extrapolation (Extrapolator (..), + LinearExtrapolator (..)) +import Fmt ((+|), (|+)) +import GHC.Float (int2Double) import qualified GTFS -import Numeric (showFFloat) +import Numeric (showFFloat) import Persist -import Server.Util (Service, secondsNow) -import Text.Blaze.Html (ToMarkup (..)) -import Text.Blaze.Internal (MarkupM (Empty)) -import Text.Read (readMaybe) -import Text.Shakespeare.Text +import Server.Util (Service, secondsNow) +import Text.Read (readMaybe) import Yesod import Yesod.Auth -import Yesod.Auth.OAuth2.Prelude -import Yesod.Auth.OpenId (IdentifierType (..), authOpenId) -import Yesod.Auth.Uffd (UffdUser (..), uffdClient) -import Yesod.Form -import Yesod.Orphans () +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) -data ControlRoom = ControlRoom - { getGtfs :: GTFS.GTFS - , getPool :: Pool SqlBackend - , getSettings :: ServerConfig - } - -mkMessage "ControlRoom" "messages" "en" - -mkYesod "ControlRoom" [parseRoutes| -/ RootR GET -/auth AuthR Auth getAuth - -/tickets TicketsR GET -/ticket/#UUID TicketViewR GET -/ticket/map/#UUID TicketMapViewR GET -/ticket/announce/#UUID AnnounceR POST -/ticket/del-announce/#UUID DelAnnounceR GET - -/token/block/#Token TokenBlock GET - -/gtfs/trips GtfsTripsViewR GET -/gtfs/trip/#GTFS.TripId GtfsTripViewR GET -/gtfs/import/#Day GtfsTicketImportR POST - -/obu OnboardUnitMenuR GET -/obu/#UUID OnboardUnitR GET -/tracker OnboardTrackerR GET -|] - -emptyMarkup :: MarkupM a -> Bool -emptyMarkup (Empty _) = True -emptyMarkup _ = False - -instance Yesod ControlRoom where - authRoute _ = Just $ AuthR LoginR - isAuthorized OnboardUnitMenuR _ = pure Authorized - isAuthorized (OnboardUnitR _) _ = pure Authorized - isAuthorized OnboardTrackerR _ = pure Authorized - isAuthorized (AuthR _) _ = pure Authorized - isAuthorized _ _ = do - UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings - if uffdConfigEnable then maybeAuthId >>= \case - Just _ -> pure Authorized - Nothing -> pure AuthenticationRequired - else pure Authorized - - - defaultLayout w = do - PageContent{..} <- widgetToPageContent w - msgs <- getMessages - - withUrlRenderer [hamlet| - $newline never - $doctype 5 - <html> - <head> - <title> - $if emptyMarkup pageTitle - Tracktrain - $else - #{pageTitle} - $maybe description <- pageDescription - <meta name="description" content="#{description}"> - ^{pageHead} - <link rel="stylesheet" href="/assets/style.css"> - <meta name="viewport" content="width=device-width, initial-scale=1"> - <body> - $forall (status, msg) <- msgs - <!-- <p class="message #{status}">#{msg} --> - ^{pageBody} - |] - - -instance RenderMessage ControlRoom FormMessage where - renderMessage _ _ = defaultFormMessage - -instance YesodPersist ControlRoom where - type YesodPersistBackend ControlRoom = SqlBackend - runDB action = do - pool <- getYesod <&> getPool - runSqlPool action pool - - --- this instance is only slightly cursed (it keeps login information --- as json in a session cookie and hopes nothing will ever go wrong) -instance YesodAuth ControlRoom where - type AuthId ControlRoom = UffdUser - - authPlugins cr = case config of - UffdConfig {..} -> if uffdConfigEnable - then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] - else [] - where config = serverConfigLogin (getSettings cr) - - maybeAuthId = do - e <- lookupSession "json" - pure $ case e of - Nothing -> Nothing - Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) - - authenticate creds = do - forM_ (credsExtra creds) (uncurry setSession) - -- extra <- lookupSession "extra" - -- pure (Authenticated ( undefined)) - e <- lookupSession "json" - case e of - Nothing -> error "no session information" - Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of - Nothing -> error "malformed session information" - Just user -> pure $ Authenticated user - - loginDest _ = RootR - logoutDest _ = RootR - -- hardcode redirecting to uffd directly; showing the normal login - -- screen is kinda pointless when there's only one option - loginHandler = do - redirect ("/auth/page/uffd/forward" :: Text) - onLogout = do - clearSession - - - - -getRootR :: Handler Html -getRootR = redirect TicketsR - getTicketsR :: Handler Html getTicketsR = do req <- getRequest @@ -439,46 +302,47 @@ getTicketMapViewR ticketId = do } |] +tripImportForm + :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)] + -> Html + -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget) +tripImportForm trips extra = do + forms <- forM trips $ \(trip, day) -> do + (aRes, aView) <- mreq checkBoxField "import" Nothing + let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes + pure (trip, day, dings, aView) + let widget = toWidget [whamlet| + #{extra} + <ol> + $forall (trip@GTFS.Trip{..}, day, res, view) <- forms + <li> + ^{fvInput view} + <label for="^{fvId view}"> + _{MsgTrip} #{GTFS.tripName trip} + : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip} + |] -getGtfsTripsViewR :: Handler Html -getGtfsTripsViewR = do - GTFS.GTFS{..} <- getYesod <&> getGtfs - defaultLayout $ do - setTitle "List of Trips" - [whamlet| -<h1>List of Trips -<section><ul> - $forall trip@GTFS.Trip{..} <- trips - <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a> - : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} -|] + let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) = + sequenceA (fmap (\(_,_,res,_) -> res) forms) + pure (fmap catMaybes a, widget) -getGtfsTripViewR :: GTFS.TripId -> Handler Html -getGtfsTripViewR tripId = do - GTFS.GTFS{..} <- getYesod <&> getGtfs - case M.lookup tripId trips of - Nothing -> notFound - Just trip@GTFS.Trip{..} -> defaultLayout [whamlet| -<h1>_{MsgTrip} #{GTFS.tripName trip} -<section> - <h2>_{MsgInfo} - <p><strong>_{MsgtripId}:</strong> #{tripTripId} - <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign} - <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName} -<section> - <h2>_{MsgStops} - <ol> - $forall GTFS.Stop{..} <- tripStops - <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation} -<section> - <h2>Dates - <ul> - TODO! -|] +gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text +gtfsHeadsign GTFS.Trip{..} = + case tripHeadsign of + Just headsign -> headsign + Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops)) +announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget) +announceForm ticketId = renderDivs $ Announcement + <$> pure (TicketKey ticketId) + <*> areq textField (fieldSettingsLabel MsgHeader) Nothing + <*> areq textField (fieldSettingsLabel MsgText) Nothing + <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing + <*> lift (liftIO getCurrentTime <&> Just) + postAnnounceR :: UUID -> Handler Html postAnnounceR ticketId = do ((result, widget), enctype) <- runFormPost (announceForm ticketId) @@ -520,86 +384,3 @@ getTokenBlock token = do Just ticket -> TicketViewR (coerce ticket) Nothing -> RootR Nothing -> notFound - -getOnboardUnitMenuR :: Handler Html -getOnboardUnitMenuR = do - day <- liftIO getCurrentTime <&> utctDay - - tickets <- - runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do - firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ] - pure (ticket, entityVal $ fromJust firstStop)) - - defaultLayout $ do - [whamlet| - <h1>_{MsgOBU} - <section> - _{MsgChooseTrain} - $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets - <hr> - <a href="@{OnboardUnitR ticketId}"> - #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop} - <section> - <a href="@{OnboardTrackerR}">_{MsgStartTracking} - |] - -getOnboardUnitR :: UUID -> Handler Html -getOnboardUnitR ticketId = do - Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case - Nothing -> notFound - Just ticket -> pure ticket - defaultLayout $(whamletFile "site/obu.hamlet") - -getOnboardTrackerR :: Handler Html -getOnboardTrackerR = do - defaultLayout - $( whamletFile "site/tracker.hamlet") - - -announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget) -announceForm ticketId = renderDivs $ Announcement - <$> pure (TicketKey ticketId) - <*> areq textField (fieldSettingsLabel MsgHeader) Nothing - <*> areq textField (fieldSettingsLabel MsgText) Nothing - <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing - <*> lift (liftIO getCurrentTime <&> Just) - - - -tripImportForm - :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)] - -> Html - -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget) -tripImportForm trips extra = do - forms <- forM trips $ \(trip, day) -> do - (aRes, aView) <- mreq checkBoxField "import" Nothing - let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes - pure (trip, day, dings, aView) - - let widget = toWidget [whamlet| - #{extra} - <ol> - $forall (trip@GTFS.Trip{..}, day, res, view) <- forms - <li> - ^{fvInput view} - <label for="^{fvId view}"> - _{MsgTrip} #{GTFS.tripName trip} - : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip} - |] - - let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) = - sequenceA (fmap (\(_,_,res,_) -> res) forms) - - pure (fmap catMaybes a, widget) - - -mightbe :: Maybe Text -> Text -mightbe (Just a) = a -mightbe Nothing = "" - - -gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text -gtfsHeadsign GTFS.Trip{..} = - case tripHeadsign of - Just headsign -> headsign - Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops)) |