diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Config.hs | 32 | ||||
| -rw-r--r-- | lib/Server.hs | 13 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 140 | ||||
| -rw-r--r-- | lib/Yesod/Auth/Uffd.hs | 73 |
4 files changed, 210 insertions, 48 deletions
diff --git a/lib/Config.hs b/lib/Config.hs index c76261e..65ac697 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -1,21 +1,31 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} -- | module Config where -import Conferer (DefaultConfig (configDef), - FromConfig) +import Conferer (DefaultConfig (configDef)) +import Conferer.FromConfig import Conferer.FromConfig.Warp () import Data.ByteString (ByteString) import Data.Text (Text) import GHC.Generics (Generic) import Network.Wai.Handler.Warp (Settings) +import URI.ByteString + +data UffdConfig = UffdConfig + { uffdConfigUrl :: URIRef Absolute + , uffdConfigClientSecret :: Text + , uffdConfigClientName :: Text + , uffdConfigEnable :: Bool + } deriving (Generic, Show) data ServerConfig = ServerConfig { serverConfigWarp :: Settings , serverConfigDbString :: ByteString , serverConfigGtfs :: FilePath , serverConfigZoneinfoPath :: FilePath - } deriving Generic + , serverConfigLogin :: UffdConfig + } deriving (Generic) instance FromConfig ServerConfig @@ -25,4 +35,18 @@ instance DefaultConfig ServerConfig where , serverConfigDbString = "" , serverConfigGtfs = "./gtfs.zip" , serverConfigZoneinfoPath = "/etc/zoneinfo/" + , serverConfigLogin = configDef } + +instance DefaultConfig UffdConfig where + configDef = UffdConfig uri "secret" "uffdclient" False + where Right uri = parseURI strictURIParserOptions "http://www.example.org" + +instance FromConfig UffdConfig where + fromConfig key config = do + url <- fetchFromConfig (key /. "url") config + let Right uffdConfigUrl = parseURI strictURIParserOptions url + uffdConfigClientName <- fetchFromConfig (key /. "clientName") config + uffdConfigClientSecret <- fetchFromConfig (key /. "clientSecret") config + uffdConfigEnable <- fetchFromConfig (key /. "enable") config + pure UffdConfig {..} diff --git a/lib/Server.hs b/lib/Server.hs index 8cab47a..6b32826 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -57,7 +57,6 @@ import Server.Util (Service, ServiceM, runService, sendErrorMsg) import Yesod (toWaiAppPlain) -import Conferer (fetch, mkConfig) import Extrapolation (Extrapolator (..), LinearExtrapolator (..)) import System.IO.Unsafe @@ -68,14 +67,14 @@ import Data.ByteString.Lazy (toStrict) import Prometheus import Prometheus.Metric.GHC -application :: GTFS -> Pool SqlBackend -> IO Application -application gtfs dbpool = do +application :: GTFS -> Pool SqlBackend -> ServerConfig -> IO Application +application gtfs dbpool settings = do doMigration dbpool metrics <- Metrics <$> register (gauge (Info "ws_connections" "Number of WS Connections")) register ghcMetrics subscribers <- atomically $ newTVar mempty - pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics subscribers dbpool + pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics subscribers dbpool settings -- databaseMigration :: ConnectionString -> IO () doMigration pool = runSql pool $ @@ -84,14 +83,14 @@ doMigration pool = runSql pool $ -- returns an empty list runMigration migrateAll -server :: GTFS -> Metrics -> TVar (M.Map TripID ([TQueue (Maybe TrainPing)])) -> Pool SqlBackend -> Service CompleteAPI -server gtfs@GTFS{..} Metrics{..} subscribers dbpool = handleDebugAPI +server :: GTFS -> Metrics -> TVar (M.Map TripID ([TQueue (Maybe TrainPing)])) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI +server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI :<|> (handleStations :<|> handleTimetable :<|> handleTrip :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS :<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister :<|> gtfsRealtimeServer gtfs dbpool) :<|> metrics - :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool))) + :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings))) 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 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 diff --git a/lib/Yesod/Auth/Uffd.hs b/lib/Yesod/Auth/Uffd.hs new file mode 100644 index 0000000..4d5e5af --- /dev/null +++ b/lib/Yesod/Auth/Uffd.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE RecordWildCards #-} +module Yesod.Auth.Uffd (uffdClient, UffdUser(..)) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.=)) +import qualified Data.Aeson as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString.Lazy (fromStrict, toStrict) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import URI.ByteString (Absolute, URIRef (..)) +import Yesod.Auth +import Yesod.Auth.OAuth2.Prelude +import Yesod.Core (PathPiece (..)) +import Yesod.Core.Handler (setSession) + +data UffdUser = UffdUser + { uffdId :: Int + , uffdName :: Text + , uffdDisplayName :: Text + , uffdEmail :: Text + , uffdGroups :: [Text] + } deriving (Show) + +instance PathPiece UffdUser where + fromPathPiece = A.decode . fromStrict . C8.pack . T.unpack + toPathPiece = decodeUtf8 . toStrict . A.encode + +instance FromJSON UffdUser where + parseJSON = withObject "User" $ \o -> UffdUser + <$> o .: "id" + <*> o .: "nickname" + <*> o .: "name" + <*> o .: "email" + <*> o .: "groups" + +instance ToJSON UffdUser where + toJSON UffdUser {..} = A.object + [ "id" .= uffdId + , "nickname" .= uffdName + , "name" .= uffdDisplayName + , "email" .= uffdEmail + , "groups" .= uffdGroups + ] + +pluginName = "uffd" + + +uffdClient :: YesodAuth m => URIRef Absolute -> Text -> Text -> AuthPlugin m +uffdClient url clientId clientSecret = + authOAuth2 "uffd" oauth2 $ \manager token -> do + resp@(user@UffdUser {..}, userResponse) <- authGetProfile + "uffd" + manager + token + (url { uriPath = "/oauth2/userinfo" }) + + pure Creds { credsPlugin = "uffd" + , credsIdent = T.pack $ show uffdId + , credsExtra = + [ ("json", decodeUtf8 $ toStrict (A.encode user)) ] + -- just dump the entire extra thing into the session, so we can reconstruct it later + } + where oauth2 = OAuth2 + { oauth2ClientId = clientId + , oauth2ClientSecret = Just clientSecret + , oauth2AuthorizeEndpoint = + url { uriPath = "/oauth2/authorize" } + , oauth2TokenEndpoint = + url { uriPath = "/oauth2/token" } + , oauth2RedirectUri = Nothing + } |