aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2023-01-22 01:37:20 +0100
committerstuebinm2023-01-22 01:47:31 +0100
commit3d0980811d61a78f265ec06dd5bd4ef2cde1cbdf (patch)
tree00bea044e80ca5eebc730a23edf0b13f0d019091
parent6c0f21b276ad73f383a80fe00729c6520a6b874a (diff)
oauth2 via uffd
this is unfortunately uffd-specific, since oauth2 is apparently sort of a vague standard. But since it doesn't actually do much it should probably be possible to make it fully configurable & generic if needed.
Diffstat (limited to '')
-rw-r--r--app/Main.hs4
-rw-r--r--config.yaml10
-rw-r--r--lib/Config.hs32
-rw-r--r--lib/Server.hs13
-rw-r--r--lib/Server/ControlRoom.hs140
-rw-r--r--lib/Yesod/Auth/Uffd.hs73
-rw-r--r--messages/de.msg2
-rw-r--r--messages/en.msg2
-rw-r--r--tracktrain.cabal8
9 files changed, 232 insertions, 52 deletions
diff --git a/app/Main.hs b/app/Main.hs
index 204e4d7..f99a198 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -36,12 +36,12 @@ main = do
>>= addSource (ConfAeson.fromFilePath "./config.json")
>>= addSource (ConfEnv.fromConfig "tracktrain")
- ServerConfig{..} <- fetch confconfig
+ settings@ServerConfig{..} <- fetch confconfig
gtfs <- loadGtfs serverConfigGtfs serverConfigZoneinfoPath
loggerMiddleware <- mkRequestLogger
$ def { outputFormat = Detailed True }
runStderrLoggingT $ withPostgresqlPool serverConfigDbString 10 $ \pool -> liftIO $ do
- app <- application gtfs pool
+ app <- application gtfs pool settings
putStrLn "starting server …"
runSettings serverConfigWarp (loggerMiddleware app)
diff --git a/config.yaml b/config.yaml
index 49063e0..123031d 100644
--- a/config.yaml
+++ b/config.yaml
@@ -1,9 +1,17 @@
-dbString: ""
+
+dbstring: "dbname=tracktrain"
gtfs: "./gtfs.zip"
zoneinfoPath: "/etc/zoneinfo/"
+# generic warp server options (see warp docs)
warp:
port: 9000
+# only oauth2 with uffd supported (for now)
+login:
+ enable: true
+ clientname: tracktrain
+ clientsecret: secret
+ url: http://localhost:8080
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
+ }
diff --git a/messages/de.msg b/messages/de.msg
index 425b7c2..92450f2 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -3,6 +3,8 @@ None: nichts
NewAnnouncement: Neuer Hinweis
Header: Überschrift
Text: Text
+LoggedInAs name: Angemeldet als #{name}
+Logout: Abmelden
MaybeWeblink: Link (optional)
TripOnDay tripId day: #{tripId} an #{day}
on: am
diff --git a/messages/en.msg b/messages/en.msg
index 2c1d861..184a64d 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -3,6 +3,8 @@ None: none
NewAnnouncement: New Announcement
Header: Header
Text: Text
+LoggedInAs name@Text: Logged in as #{name}
+Logout: Log out
MaybeWeblink: Link (optional)
TripOnDay tripId@Text day@String: #{tripId} on #{day}
on: on
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 9492f4e..c373b66 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -31,7 +31,7 @@ executable tracktrain
, aeson
, tracktrain
, wai-extra
- , warp < 3.3.22
+ , warp
, data-default-class >= 0.1.2
, persistent-postgresql
, monad-logger
@@ -67,6 +67,7 @@ library
, zip-archive
, cassava >= 0.5.2.0
, bytestring >= 0.10.10.0
+ , uri-bytestring
, vector >= 0.12.3.1
, regex-tdfa
, text
@@ -102,6 +103,10 @@ library
, vector-algorithms
, yesod
, yesod-form
+ , yesod-auth
+ , yesod-auth-oauth2
+ , yesod-core
+ , hoauth2 <= 2.6.0
, blaze-html
, blaze-markup
, timezone-olson
@@ -122,6 +127,7 @@ library
, API
, Config
other-modules: Server.Util
+ , Yesod.Auth.Uffd
default-language: Haskell2010
default-extensions: OverloadedStrings
, ScopedTypeVariables