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.

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