Implement confidential OIDC authentication boundary

src/Nuthatch/Api.hs

@@ -2,9 +2,10 @@ module Nuthatch.Api
   ( Api
   , HealthEndpoint
   , ReadyEndpoint
-  , LoginPageEndpoint
   , BrowserScriptEndpoint
   , LoginEndpoint
+  , LoginStart
+  , OidcCallbackEndpoint
   , LoginSuccess
   , LogoutEndpoint
   , LogoutSuccess
@@ -25,10 +26,6 @@ module Nuthatch.Api
   , PaginationToken (..)
   , SearchQuery (..)
   , DeclaredSize (..)
-  , DevUsername (..)
-  , LoginRequest (..)
-  , LoginResponse (..)
-  , LoginView (..)
   , HealthResponse (..)
   , ReadyResponse (..)
   , BrowseResponse (..)
@@ -73,7 +70,6 @@ import           Nuthatch.Types
 import           Servant.API
 import           Servant.Server (HasServer (..))
 import           Servant.Server.Experimental.Auth (AuthServerData)
-import           Web.FormUrlEncoded (FromForm (..), lookupUnique)
 
 data HTML
 data JavaScript
@@ -121,44 +117,6 @@ newtype DeclaredSize = DeclaredSize { unDeclaredSize :: Integer }
   deriving stock (Eq, Ord, Show)
   deriving newtype (ToJSON, FromJSON)
 
-newtype DevUsername = DevUsername { unDevUsername :: Text }
-  deriving stock (Eq, Show)
-
-data LoginRequest = LoginRequest
-  { loginUsername :: DevUsername
-  }
-  deriving stock (Eq, Show)
-
-instance FromJSON LoginRequest where
-  parseJSON = withObject "LoginRequest" $ \o -> do
-    raw <- o .: "username"
-    LoginRequest <$> either (fail . T.unpack) pure (validateDevUsername raw)
-
-instance FromForm LoginRequest where
-  fromForm form = do
-    raw <- lookupUnique "username" form
-    LoginRequest <$> validateDevUsername raw
-
-data LoginResponse = LoginResponse
-  { loginUserId :: UserId
-  }
-  deriving stock (Eq, Show)
-
-instance ToJSON LoginResponse where
-  toJSON response = object ["user_id" .= loginUserId response]
-
-data LoginView = LoginView
-  { loginViewHtml :: HtmlPage
-  , loginViewJson :: LoginResponse
-  }
-  deriving stock (Eq, Show)
-
-instance MimeRender HTML LoginView where
-  mimeRender proxy = mimeRender proxy . loginViewHtml
-
-instance ToJSON LoginView where
-  toJSON = toJSON . loginViewJson
-
 newtype HealthResponse = HealthResponse { healthOk :: Bool }
   deriving stock (Eq, Show)
 
@@ -302,13 +260,16 @@ instance ToJSON ReadyError where
     errorValue "dependency_unavailable" "PostgreSQL is unavailable" Nothing
 
 data LoginError
-  = InvalidUsername
+  = OidcAuthorizationFailed
+  | OidcCallbackRejected
   | SessionCreationFailed Text
   deriving stock (Eq, Show)
 
 instance ToJSON LoginError where
-  toJSON InvalidUsername =
-    errorValue "invalid_username" "username must be one token" Nothing
+  toJSON OidcAuthorizationFailed =
+    errorValue "oidc_authorization_failed" "OIDC authorization could not start" Nothing
+  toJSON OidcCallbackRejected =
+    errorValue "oidc_callback_rejected" "OIDC callback validation failed" Nothing
   toJSON (SessionCreationFailed message) =
     errorValue "session_error" message Nothing
 
@@ -407,29 +368,43 @@ type HealthEndpoint =
 type ReadyEndpoint =
   "readyz" :> Throws ReadyError :> Get '[JSON] ReadyResponse
 
-type LoginPageEndpoint =
-  "login" :> Get '[HTML] HtmlPage
-
 type BrowserScriptEndpoint =
   "nuthatch.js" :> Get '[JavaScript] BrowserScript
 
+type LoginStart =
+  Headers
+    '[ Header "Set-Cookie" Text
+     , Header "Location" Text
+     ]
+    NoContent
+
+type LoginEndpoint =
+  "login"
+    :> Throws LoginError
+    :> Verb 'GET 303 '[JSON] LoginStart
+
 type LoginSuccess =
   Headers
     '[ Header "Set-Cookie" Text
      , Header "Set-Cookie" Text
-     , Header "X-CSRF-Token" CsrfToken
+     , Header "Set-Cookie" Text
+     , Header "Location" Text
      ]
-    LoginView
+    NoContent
 
-type LoginEndpoint =
-  "login"
+type OidcCallbackEndpoint =
+  "oidc"
+    :> "callback"
     :> Throws LoginError
-    :> ReqBody '[JSON, FormUrlEncoded] LoginRequest
-    :> Post '[HTML, JSON] LoginSuccess
+    :> QueryParam' '[Required, Strict] "code" Text
+    :> QueryParam' '[Required, Strict] "state" Text
+    :> Header' '[Required, Strict] "Cookie" Text
+    :> Verb 'GET 303 '[JSON] LoginSuccess
 
 type LogoutSuccess =
   Headers
     '[ Header "Set-Cookie" Text
+     , Header "Set-Cookie" Text
      , Header "Set-Cookie" Text
      ]
     NoContent
@@ -501,9 +476,9 @@ type DeletePrefixEndpoint =
 type Api =
        HealthEndpoint
   :<|> ReadyEndpoint
-  :<|> LoginPageEndpoint
   :<|> BrowserScriptEndpoint
   :<|> LoginEndpoint
+  :<|> OidcCallbackEndpoint
   :<|> LogoutEndpoint
   :<|> BrowseEndpoint
   :<|> DownloadEndpoint
@@ -554,16 +529,6 @@ validatePaginationToken raw
   | T.any isControl raw = Left "pagination token contains a control character"
   | otherwise = Right (PaginationToken raw)
 
-validateDevUsername :: Text -> Either Text DevUsername
-validateDevUsername raw
-  | T.null raw = Left "username must not be empty"
-  | T.length raw > 128 = Left "username is too long"
-  | T.any invalidCharacter raw = Left "username must be one printable token"
-  | otherwise = Right (DevUsername raw)
-  where
-    invalidCharacter character =
-      isControl character || character `elem` (" \t\r\n" :: String)
-
 mutationResultText :: MutationResult -> Text
 mutationResultText MutationPending   = "pending"
 mutationResultText MutationSucceeded = "succeeded"