Use MultiVerb

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

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

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)

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

src/web/FloraWeb/Pages/Routes/Sessions.hs

@@ -1,40 +1,97 @@
+{-# 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
 
 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

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"

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,54 +58,57 @@ 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
     then 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