diff options
Diffstat (limited to 'lib/Server/ControlRoom.hs')
| -rw-r--r-- | lib/Server/ControlRoom.hs | 140 |
1 files changed, 103 insertions, 37 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index ee0f686..11e72d5 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -17,57 +17,66 @@ module Server.ControlRoom (ControlRoom(..)) where -import Control.Monad (forM_, join) -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.List.NonEmpty (nonEmpty) -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 (UTCTime (..), 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.Float (int2Double) -import GHC.Generics (Generic) -import Server.Util (Service, secondsNow) -import Text.Blaze.Html (ToMarkup (..)) -import Text.Blaze.Internal (MarkupM (Empty)) -import Text.ProtocolBuffers (Default (defaultValue)) -import Text.Read (readMaybe) +import Control.Monad (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.Functor ((<&>)) +import Data.List (lookup) +import Data.List.NonEmpty (nonEmpty) +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 (UTCTime (..), 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.Float (int2Double) +import GHC.Generics (Generic) +import Server.Util (Service, secondsNow) +import Text.Blaze.Html (ToMarkup (..)) +import Text.Blaze.Internal (MarkupM (Empty)) +import Text.ProtocolBuffers (Default (defaultValue)) +import Text.Read (readMaybe) import Text.Shakespeare.Text import Yesod +import Yesod.Auth +import Yesod.Auth.OAuth2.Prelude import Yesod.Form -import Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) +import Config (ServerConfig (..), UffdConfig (..)) +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..)) import GTFS -import Numeric (showFFloat) +import Numeric (showFFloat) import Persist +import Yesod.Auth.OpenId (IdentifierType (..), authOpenId) +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) data ControlRoom = ControlRoom - { getGtfs :: GTFS - , getPool :: Pool SqlBackend + { getGtfs :: GTFS + , getPool :: Pool SqlBackend + , getSettings :: ServerConfig } mkMessage "ControlRoom" "messages" "en" mkYesod "ControlRoom" [parseRoutes| / RootR GET +/auth AuthR Auth getAuth /trains TrainsR GET /train/id/#TripID/#Day TrainViewR GET /train/map/#TripID/#Day TrainMapViewR GET @@ -85,6 +94,18 @@ emptyMarkup (Empty _) = True emptyMarkup _ = False instance Yesod ControlRoom where + authRoute _ = Just $ AuthR LoginR + isAuthorized OnboardUnitMenuR _ = pure Authorized + isAuthorized (OnboardUnitR _ _) _ = pure Authorized + isAuthorized (AuthR _) _ = pure Authorized + isAuthorized _ _ = do + UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin + if uffdConfigEnable then maybeAuthId >>= \case + Just _ -> pure Authorized + Nothing -> pure AuthenticationRequired + else pure Authorized + + defaultLayout w = do PageContent{..} <- widgetToPageContent w msgs <- getMessages @@ -152,6 +173,48 @@ instance YesodPersist ControlRoom where 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) $ \(key, val) -> + setSession key val + -- 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 TrainsR @@ -159,6 +222,7 @@ getTrainsR :: Handler Html getTrainsR = do req <- getRequest let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) + mdisplayname <- maybeAuthId <&> fmap uffdDisplayName day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) gtfs <- getYesod <&> getGtfs @@ -166,6 +230,8 @@ getTrainsR = do defaultLayout $ do [whamlet| <h1>Trains on #{day} +$maybe name <- mdisplayname + <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a> <section><ol> $forall trip@Trip{..} <- trips <li><a href="@{TrainViewR tripTripID day}">#{tripName trip}</a> @@ -183,7 +249,7 @@ getTrainViewR trip day = do tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires] lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] [] - <&> nonEmpty . (fmap entityVal) + <&> nonEmpty . fmap entityVal nowSeconds <- secondsNow day defaultLayout $ do mr <- getMessageRender |