aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
authorstuebinm2023-01-22 01:37:20 +0100
committerstuebinm2023-01-22 01:47:31 +0100
commit3d0980811d61a78f265ec06dd5bd4ef2cde1cbdf (patch)
tree00bea044e80ca5eebc730a23edf0b13f0d019091 /lib/Server
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 'lib/Server')
-rw-r--r--lib/Server/ControlRoom.hs140
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