diff --git a/cabal.project b/cabal.project index 435fffc3..0298c4df 100644 --- a/cabal.project +++ b/cabal.project @@ -58,6 +58,16 @@ source-repository-package tag: 37434cb1b2515a9aa74a0544da9716bfbabea7ca subdir: ./raven-haskell +source-repository-package + type: git + location: https://github.com/haskell-servant/servant + tag: 831423ead6e2f0ed0d04d5b21cd61f2e0994a18d + subdir: + ./servant + ./servant-server + ./servant-client + ./servant-client-core + source-repository-package type: git location: https://github.com/flora-pm/wai-middleware-heartbeat diff --git a/flora.cabal b/flora.cabal index 408fb8bd..3306d1ce 100644 --- a/flora.cabal +++ b/flora.cabal @@ -155,6 +155,7 @@ library Lucid.Orphans OSV.Reference.Orphans Pandoc.Orphans + Prometheus.Servant.HasEndpoint Servant.API.ContentTypes.GZip build-depends: @@ -211,6 +212,7 @@ library , resource-pool , sel , servant + , servant-prometheus , servant-server , slugify , souffle-haskell ==4.0.0 @@ -226,6 +228,7 @@ library , utf8-string , uuid , vector + , wai , zlib ghc-options: -fplugin=Effectful.Plugin @@ -395,6 +398,7 @@ library flora-web , flora-advisories , flora-jobs , flora-search + , generics-sop , haddock-library , htmx-lucid , http-api-data diff --git a/src/datatypes/Prometheus/Servant/HasEndpoint.hs b/src/datatypes/Prometheus/Servant/HasEndpoint.hs new file mode 100644 index 00000000..10373a23 --- /dev/null +++ b/src/datatypes/Prometheus/Servant/HasEndpoint.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Prometheus.Servant.HasEndpoint where + +import Data.Proxy +import Network.Wai +import Prometheus.Servant.Internal +import Servant.API.MultiVerb +import Servant.API.Verbs + +instance ReflectMethod method => HasEndpoint (MultiVerb method requestContentType returnValues responses) where + getEndpoint _ req = case pathInfo req of + [] | requestMethod req == method -> Just (Endpoint [] method) + _ -> Nothing + where + method = reflectMethod (Proxy :: Proxy method) + + enumerateEndpoints _ = [Endpoint mempty method] + where + method = reflectMethod (Proxy :: Proxy method) diff --git a/src/web/FloraWeb/Common/Guards.hs b/src/web/FloraWeb/Common/Guards.hs index 2690754d..fa3ea174 100644 --- a/src/web/FloraWeb/Common/Guards.hs +++ b/src/web/FloraWeb/Common/Guards.hs @@ -9,14 +9,12 @@ import Effectful.Trace (Trace) import Log qualified import Monitor.Tracing qualified as Tracing import Optics.Core -import Servant (respond) -import Servant.API.UVerb import Flora.Model.Package import Flora.Model.PackageIndex.Query as Query import Flora.Model.PackageIndex.Types (PackageIndex) import Flora.Model.User (User) -import FloraWeb.Pages.Routes.Sessions (CreateSessionResponses) +import FloraWeb.Pages.Routes.Sessions import FloraWeb.Pages.Templates import FloraWeb.Pages.Templates.Screens.Sessions qualified as Sessions import FloraWeb.Session (Session) @@ -40,15 +38,16 @@ guardThatPackageIndexExists namespace action = guardThatUserHasProvidedTOTP :: Session (Maybe User) -> Maybe Text - -> (Text -> FloraEff (Union CreateSessionResponses)) - -> FloraEff (Union CreateSessionResponses) -guardThatUserHasProvidedTOTP session mTOTP action = do + -> (Text -> FloraEff CreateSessionResult) + -> FloraEff CreateSessionResult +guardThatUserHasProvidedTOTP session mTOTP totpAction = do case mTOTP of - Just totp -> action totp + Just totp -> totpAction totp Nothing -> do Log.logInfo_ "User did not provide a TOTP code" templateDefaults <- templateFromSession session defaultTemplateEnv let templateEnv = templateDefaults & (#flashError ?~ mkError "Must provide an OTP code") - respond $ WithStatus @401 $ renderUVerb templateEnv Sessions.newSession + body <- render templateEnv Sessions.newSession + pure $ AuthenticationFailure body diff --git a/src/web/FloraWeb/Pages/Routes/Sessions.hs b/src/web/FloraWeb/Pages/Routes/Sessions.hs index 318232e0..f6fdaf5a 100644 --- a/src/web/FloraWeb/Pages/Routes/Sessions.hs +++ b/src/web/FloraWeb/Pages/Routes/Sessions.hs @@ -1,10 +1,14 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + module FloraWeb.Pages.Routes.Sessions where import Data.Text +import Generics.SOP (I (..), NP (..), NS (..)) import Lucid -import Servant +import Servant.API import Servant.API.ContentTypes.Lucid import Servant.API.Generic +import Servant.API.MultiVerb import Web.Cookie import Web.FormUrlEncoded @@ -12,29 +16,82 @@ import Flora.Model.PersistentSession type Routes = NamedRoutes Routes' +newtype Location = Location Text + deriving + (Eq, FromHttpApiData, Ord, ToHttpApiData) + via Text + type NewSession = "new" - :> UVerb 'GET '[HTML] NewSessionResponses + :> MultiVerb + 'GET + '[HTML] + NewSessionResponses + NewSessionResult type NewSessionResponses = - '[ -- User is not logged-in, dispay the login page - WithStatus 200 (Html ()) - , -- User is already logged-in, redirect to home page - WithStatus 301 (Headers '[Header "Location" Text] NoContent) + '[ -- User is already logged-in, redirect to home page + WithHeaders + '[Header "Location" Location] + ((), Location) + (RespondEmpty 301 "Already logged-in") + , -- User is not logged-in, dispay the login page + Respond 200 "Log-in required" (Html ()) ] +data NewSessionResult + = AlreadyAuthenticated Location + | AuthenticationRequired (Html ()) + deriving stock (Generic) + +instance AsUnion NewSessionResponses NewSessionResult where + toUnion (AlreadyAuthenticated location) = Z (I ((), location)) + toUnion (AuthenticationRequired response) = S (Z (I response)) + + fromUnion (Z (I ((), location))) = AlreadyAuthenticated location + fromUnion (S (Z (I response))) = AuthenticationRequired response + fromUnion (S (S x)) = case x of {} + +instance AsHeaders '[Location] () Location where + toHeaders location = (I location :* Nil, ()) + fromHeaders (I location :* Nil, _) = location + +instance AsHeaders '[Location, SetCookie] () (Location, SetCookie) where + toHeaders (location, cookie) = (I location :* I cookie :* Nil, ()) + fromHeaders (I location :* I cookie :* Nil, ()) = (location, cookie) + type CreateSession = "new" :> ReqBody '[FormUrlEncoded] LoginForm - :> UVerb 'POST '[HTML] CreateSessionResponses + :> MultiVerb + 'POST + '[HTML] + CreateSessionResponses + CreateSessionResult type CreateSessionResponses = '[ -- Failure, send login page back - WithStatus 401 (Html ()) + Respond 401 "Authentication failed" (Html ()) , -- Success, redirected to home page - WithStatus 301 (Headers '[Header "Location" Text, Header "Set-Cookie" SetCookie] NoContent) + WithHeaders + '[Header "Location" Location, Header "Set-Cookie" SetCookie] + (Location, SetCookie) + (RespondEmpty 301 "Authentication succeeded") ] +data CreateSessionResult + = AuthenticationFailure (Html ()) + | AuthenticationSuccess (Location, SetCookie) + deriving stock (Generic) + +instance AsUnion CreateSessionResponses CreateSessionResult where + toUnion (AuthenticationFailure body) = Z (I body) + toUnion (AuthenticationSuccess (location, cookie)) = S (Z (I (location, cookie))) + + fromUnion (Z (I body)) = AuthenticationFailure body + fromUnion (S (Z (I headers))) = AuthenticationSuccess headers + fromUnion (S (S x)) = case x of {} + type DeleteSession = "delete" :> Capture "session_id" PersistentSessionId diff --git a/src/web/FloraWeb/Pages/Routes/Settings.hs b/src/web/FloraWeb/Pages/Routes/Settings.hs index f9fbc301..49c809aa 100644 --- a/src/web/FloraWeb/Pages/Routes/Settings.hs +++ b/src/web/FloraWeb/Pages/Routes/Settings.hs @@ -4,17 +4,21 @@ module FloraWeb.Pages.Routes.Settings , TwoFactorSetupResponses , TwoFactorConfirmationForm (..) , DeleteTwoFactorSetupResponse + , TwoFactorSetupResult (..) ) where import Data.Text (Text) +import Generics.SOP (I (..), NS (..)) import Lucid import Servant import Servant.API.ContentTypes.Lucid import Servant.API.Generic +import Servant.API.MultiVerb import Web.FormUrlEncoded import FloraWeb.Common.Auth () +import FloraWeb.Pages.Routes.Sessions (Location (..)) type Routes = NamedRoutes Routes' @@ -35,10 +39,33 @@ type GetTwoFactorSettingsPage = :> Get '[HTML] (Html ()) type TwoFactorSetupResponses = - '[ WithStatus 200 (Html ()) - , WithStatus 301 (Headers '[Header "Location" Text] NoContent) + '[ WithHeaders + '[Header "Location" Location] + ((), Location) + (RespondEmpty 301 "2FA Validation Success") + , WithHeaders + '[Header "Location" Location] + ((), Location) + (RespondEmpty 301 "") + , Respond 400 "2FA Validation Failed" (Html ()) ] +data TwoFactorSetupResult + = TwoFactorSetupSuccess Location + | TwoFactorSetupNotEnabled Location + | TwoFactorSetupFailure (Html ()) + deriving stock (Generic) + +instance AsUnion TwoFactorSetupResponses TwoFactorSetupResult where + toUnion (TwoFactorSetupSuccess location) = Z (I ((), location)) + toUnion (TwoFactorSetupNotEnabled location) = S (Z (I ((), location))) + toUnion (TwoFactorSetupFailure response) = S (S (Z (I response))) + + fromUnion (Z (I ((), location))) = TwoFactorSetupSuccess location + fromUnion (S (Z (I ((), location)))) = TwoFactorSetupNotEnabled location + fromUnion (S (S (Z (I response)))) = TwoFactorSetupFailure response + fromUnion (S (S (S x))) = case x of {} + data TwoFactorConfirmationForm = TwoFactorConfirmationForm { code :: Text } @@ -51,7 +78,7 @@ type PostTwoFactorSetup = :> "two-factor" :> "setup" :> ReqBody '[FormUrlEncoded] TwoFactorConfirmationForm - :> UVerb 'POST '[HTML] TwoFactorSetupResponses + :> MultiVerb 'POST '[HTML] TwoFactorSetupResponses TwoFactorSetupResult type DeleteTwoFactorSetup = AuthProtect "cookie-auth" diff --git a/src/web/FloraWeb/Pages/Server/Sessions.hs b/src/web/FloraWeb/Pages/Server/Sessions.hs index d6ff10a1..8e90804d 100644 --- a/src/web/FloraWeb/Pages/Server/Sessions.hs +++ b/src/web/FloraWeb/Pages/Server/Sessions.hs @@ -32,22 +32,23 @@ server s = , delete = deleteSessionHandler } -newSessionHandler :: SessionWithCookies (Maybe User) -> FloraEff (Union NewSessionResponses) +newSessionHandler :: SessionWithCookies (Maybe User) -> FloraEff NewSessionResult newSessionHandler (Headers session _) = do let mUser = session.user case mUser of Nothing -> do Log.logInfo_ "[+] No user logged-in" templateDefaults <- templateFromSession session defaultTemplateEnv - respond $ WithStatus @200 $ renderUVerb templateDefaults Sessions.newSession + html <- render templateDefaults Sessions.newSession + pure $ AuthenticationRequired html Just u -> do Log.logInfo_ $ "[+] User is already logged: " <> display u - respond $ WithStatus @301 (redirect "/") + pure $ AlreadyAuthenticated (Location "/") createSessionHandler :: SessionWithCookies (Maybe User) -> LoginForm - -> FloraEff (Union CreateSessionResponses) + -> FloraEff CreateSessionResult createSessionHandler (Headers session _) LoginForm{email, password, totp} = do mUser <- Query.getUserByEmail email case mUser of @@ -57,39 +58,41 @@ createSessionHandler (Headers session _) LoginForm{email, password, totp} = do let templateEnv = templateDefaults & (#flashError ?~ mkError "Could not authenticate") - respond $ WithStatus @401 $ renderUVerb templateEnv Sessions.newSession + body <- render templateEnv Sessions.newSession + pure $ AuthenticationFailure body Just user -> if user.userFlags.canLogin then if Sel.verifyText user.password password then do if user.totpEnabled - then guardThatUserHasProvidedTOTP session totp $ \userCode -> do - checkTOTPIsValid session userCode user + then guardThatUserHasProvidedTOTP session totp $ \userCode -> checkTOTPIsValid session userCode user else do sessionId <- persistSession session.sessionId user.userId let sessionCookie = craftSessionCookie sessionId True - respond $ WithStatus @301 $ redirectWithCookie "/" sessionCookie + pure $ AuthenticationSuccess (Location "/", sessionCookie) else do Log.logInfo_ "Invalid password" templateDefaults <- templateFromSession session defaultTemplateEnv let templateEnv = templateDefaults & (#flashError ?~ mkError "Could not authenticate") - respond $ WithStatus @401 $ renderUVerb templateEnv Sessions.newSession + body <- render templateEnv Sessions.newSession + pure $ AuthenticationFailure body else do Log.logInfo_ "User not allowed to log-in" templateDefaults <- templateFromSession session defaultTemplateEnv let templateEnv = templateDefaults & (#flashError ?~ mkError "Could not authenticate") - respond $ WithStatus @401 $ renderUVerb templateEnv Sessions.newSession + body <- render templateEnv Sessions.newSession + pure $ AuthenticationFailure body checkTOTPIsValid :: Session (Maybe User) -> Text -> User - -> FloraEff (Union CreateSessionResponses) + -> FloraEff CreateSessionResult checkTOTPIsValid session userCode user = do validated <- liftIO $ TwoFactor.validateTOTP (fromJust user.totpKey) userCode if validated @@ -97,14 +100,15 @@ checkTOTPIsValid session userCode user = do Log.logInfo_ "[+] User connected!" sessionId <- persistSession session.sessionId user.userId let sessionCookie = craftSessionCookie sessionId True - respond $ WithStatus @301 $ redirectWithCookie "/" sessionCookie + pure $ AuthenticationSuccess (Location "/", sessionCookie) else do Log.logInfo_ "[+] Couldn't authenticate user's TOTP code" templateDefaults <- templateFromSession session defaultTemplateEnv let templateEnv = templateDefaults & (#flashError ?~ mkError "Could not authenticate") - respond $ WithStatus @401 $ renderUVerb templateEnv Sessions.newSession + body <- render templateEnv Sessions.newSession + pure $ AuthenticationFailure body deleteSessionHandler :: PersistentSessionId -> FloraEff DeleteSessionResponse deleteSessionHandler sessionId = do diff --git a/src/web/FloraWeb/Pages/Server/Settings.hs b/src/web/FloraWeb/Pages/Server/Settings.hs index e90cf8fc..8aa71ca1 100644 --- a/src/web/FloraWeb/Pages/Server/Settings.hs +++ b/src/web/FloraWeb/Pages/Server/Settings.hs @@ -15,7 +15,7 @@ import Log qualified import Lucid import Optics.Core import Sel.HMAC.SHA256 qualified as HMAC -import Servant (HasServer (..), Headers (..), Union, WithStatus (..), respond) +import Servant (HasServer (..), Headers (..)) import Flora.Environment.Env import Flora.Model.User @@ -23,8 +23,9 @@ import Flora.Model.User.Update qualified as Update import Flora.QRCode qualified as QRCode import FloraWeb.Common.Auth.TwoFactor qualified as TwoFactor import FloraWeb.Common.Utils (redirect) +import FloraWeb.Pages.Routes.Sessions (Location (..)) import FloraWeb.Pages.Routes.Settings -import FloraWeb.Pages.Templates (render, renderUVerb) +import FloraWeb.Pages.Templates (render) import FloraWeb.Pages.Templates.Screens.Settings qualified as Settings import FloraWeb.Pages.Templates.Types import FloraWeb.Session @@ -112,19 +113,19 @@ postTwoFactorSetupHandler ) => SessionWithCookies User -> TwoFactorConfirmationForm - -> Eff es (Union TwoFactorSetupResponses) + -> Eff es TwoFactorSetupResult postTwoFactorSetupHandler (Headers session _) TwoFactorConfirmationForm{code = userCode} = do let user = session.user templateEnv' <- templateFromSession session defaultTemplateEnv case user.totpKey of - Nothing -> respond $ WithStatus @301 (redirect "/settings/security/two-factor") + Nothing -> pure $ TwoFactorSetupNotEnabled (Location "/settings/security/two-factor") Just userKey -> do validated <- liftIO $ TwoFactor.validateTOTP userKey userCode if validated then do Update.confirmTOTP user.userId Log.logInfo_ "Code validation succeeded" - respond $ WithStatus @301 (redirect "/settings/security/two-factor") + pure $ TwoFactorSetupSuccess (Location "/settings/security/two-factor") else do Log.logAttention_ "Code validation failed" let templateEnv = @@ -137,12 +138,12 @@ postTwoFactorSetupHandler (Headers session _) TwoFactorConfirmationForm{code = u let qrCode = QRCode.generateQRCode uri & Text.decodeUtf8 - respond $ - WithStatus @200 $ - renderUVerb templateEnv $ - Settings.twoFactorSettings - qrCode - (Base32.encodeBase32Unpadded $ HMAC.unsafeAuthenticationKeyToBinary userKey) + body <- + render templateEnv $ + Settings.twoFactorSettings + qrCode + (Base32.encodeBase32Unpadded $ HMAC.unsafeAuthenticationKeyToBinary userKey) + pure $ TwoFactorSetupFailure body deleteTwoFactorSetupHandler :: (DB :> es, Time :> es) => SessionWithCookies User -> Eff es DeleteTwoFactorSetupResponse deleteTwoFactorSetupHandler (Headers session _) = do diff --git a/src/web/FloraWeb/Pages/Templates.hs b/src/web/FloraWeb/Pages/Templates.hs index d7cc85c1..4f48b555 100644 --- a/src/web/FloraWeb/Pages/Templates.hs +++ b/src/web/FloraWeb/Pages/Templates.hs @@ -1,6 +1,5 @@ module FloraWeb.Pages.Templates ( render - , renderUVerb , mkErrorPage , module Types ) @@ -20,12 +19,9 @@ import FloraWeb.Components.Header (header) import FloraWeb.Pages.Templates.Types as Types render :: Monad m => TemplateEnv -> FloraHTML -> m (Html ()) -render env template = pure (renderUVerb env template) - -renderUVerb :: TemplateEnv -> FloraHTML -> Html () -renderUVerb env template = +render env template = do let deploymentEnv = env.environment - in toHtmlRaw $ runIdentity $ runReaderT (renderBST (rendered deploymentEnv template)) env + pure $ toHtmlRaw $ runIdentity $ runReaderT (renderBST (rendered deploymentEnv template)) env mkErrorPage :: TemplateEnv -> FloraHTML -> ByteString mkErrorPage env template = diff --git a/src/web/FloraWeb/Server.hs b/src/web/FloraWeb/Server.hs index 6b9374ea..29cbb485 100644 --- a/src/web/FloraWeb/Server.hs +++ b/src/web/FloraWeb/Server.hs @@ -91,6 +91,7 @@ import FloraWeb.Pages.Templates (defaultTemplateEnv, defaultsToEnv) import FloraWeb.Pages.Templates.Error (renderError) import FloraWeb.Routes import FloraWeb.Types +import Prometheus.Servant.HasEndpoint () type FloraAuthContext = '[ OptionalAuthContext