show logout success before redirecting

oauth2-mock-server.cabal

@@ -38,6 +38,7 @@ library
     , bytestring
     , containers
     , cookie
+    , ghc
     , http-api-data
     , http-client
     , http-media
@@ -74,6 +75,7 @@ executable oauth2-mock-server-exe
     , conduit
     , containers
     , cookie
+    , ghc
     , http-api-data
     , http-client
     , http-media
@@ -115,6 +117,7 @@ test-suite oauth2-mock-server-test
     , bytestring
     , containers
     , cookie
+    , ghc
     , http-api-data
     , http-client
     , http-media

package.yaml

@@ -25,6 +25,7 @@ description:         Please see the README # on GitHub at <https://github.com/gi
 
 dependencies:
 - base >= 4.7 && < 5
+- ghc
 - servant
 - servant-server
 - servant-client

src/LoginForm.hs

@@ -14,11 +14,13 @@ module LoginForm
 
 import Prelude hiding (head)
 
-import qualified Data.Map as M
 import Data.Aeson (encode)
-import qualified Data.String.Interpolate as I
 import Data.String (IsString(..))
-import Data.Text (Text)
+import Data.Text (Text, unpack)
+import qualified Data.Map as M
+import qualified Data.String.Interpolate as I
+
+import GHC.Data.Maybe (whenIsJust)
 
 import Network.HTTP.Media ((//), (/:))
 
@@ -74,8 +76,8 @@ loginPage uri headers = docTypeHtml $ head' >> body'
         |]
 
 
-logoutPage :: Html
-logoutPage = docTypeHtml $ head' >> body'
+logoutPage :: Maybe Text -> Html
+logoutPage mUri = docTypeHtml $ head' >> body'
   where
     head' = head $ do
       meta ! A.charset "UTF-8"
@@ -83,4 +85,10 @@ logoutPage = docTypeHtml $ head' >> body'
       title "UniWorX Oauth2 Mock Server"
     body' = body $ do
       h1 "UniWorX Oauth2 Mock Server"
-      p "Logout successful."
+      p "Logout successful."
+      whenIsJust mUri $ \uri -> do
+        a ! A.href (fromString $ unpack uri) $ "Continue"
+        script $
+          [I.i|
+            setTimeout(_ => window.location.replace('#{uri}'), 2000); |]
+            

src/Server.hs

@@ -13,6 +13,7 @@
     , AllowAmbiguousTypes
     , LambdaCase
     , FlexibleContexts
+    , KindSignatures
 #-}
 
 module Server
@@ -35,19 +36,19 @@ import Control.Concurrent
 import Control.Concurrent.STM (atomically)
 import Control.Concurrent.STM.TVar (newTVarIO, readTVar, modifyTVar)
 import Control.Exception (bracket)
-import Control.Monad (unless, (>=>), foldM)
+import Control.Monad (unless, (>=>), foldM, void)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Error (Error(..))
 import Control.Monad.Trans.Reader
 
 import Data.Aeson
-import Data.ByteString (fromStrict, ByteString)
+import Data.ByteString (fromStrict, toStrict, ByteString)
 import Data.List (find, elemIndex)
 import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)
 import Data.String (IsString (..))
 import Data.Text hiding (elem, find, head, length, map, null, splitAt, tail, words)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Data.Text.Encoding.Base64
 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime)
 
@@ -58,20 +59,22 @@ import GHC.Read (readPrec, lexP)
 import Jose.Jwk (generateRsaKeyPair, KeyUse(..), KeyId)
 import Jose.Jwt hiding (decode, encode)
 
-import Network.HTTP.Client (newManager, defaultManagerSettings)
+import Network.HTTP.Client (newManager, defaultManagerSettings, httpLbs, parseRequest)
 import Network.Wai.Handler.Warp
 
 import Servant
 import Servant.Client hiding (client)
 import Servant.API
 
+import System.Environment (getEnv)
+
 import Text.ParserCombinators.ReadPrec (look, pfail)
 import Text.Read (readMaybe)
 
 import qualified Text.Read.Lex as Lex
 
 import Web.Cookie (parseCookiesText)
-import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..))
+import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..), urlEncodeParams)
 
 
 
@@ -364,23 +367,66 @@ userListEndpoint = handleUserData
 ---- Logout ----
  --------------
 
+{-type Redirect (cs :: [*]) (hs :: [*]) a = Verb 'GET 303 cs (Headers (Header "Location" Text : hs) a)
+
+type CookieLogout = "clogout"
+                 :> QParam "redirect" QRedirect
+                 :> Redirect '[HTML] '[] Text
+clogoutEndpoint :: forall user userData . UserData user userData => AuthServer user CookieLogout
+clogoutEndpoint uri = do
+    return $ addHeader uri ""-}
+
+
 type Logout = "logout"
            :> QueryParam "post_logout_redirect_uri" QRedirect
            :> HeaderR "Cookie" QCookie
            :> Get '[HTML] (Headers '[Header "Set-Cookie" Text] Html)
+           {- :> Redirect '[HTML] '[Header "Set-Cookie" Text] NoContent
+         :<|> "logout"
+           :> HeaderR "Cookie" QCookie
+           :> Get '[HTML] (Headers '[Header "Set-Cookie" Text] Html) -}
 
 logoutEndpoint :: forall user userData . UserData user userData => AuthServer user Logout
-logoutEndpoint = logout
+logoutEndpoint = logout -- rLogout :<|> logout
   where
     logout :: Maybe QRedirect
            -> QCookie
            -> AuthHandler user (Headers '[Header "Set-Cookie" Text] Html)
-    logout mUri cookie = do
+    logout mRedir cookie = do
       let mCreds = lookup authCookie . parseCookiesText $ encodeUtf8 cookie
       unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" }
-      addHeader (authCookie <> "=\"\"") <$> case mUri of
-        Just uri -> throwError err303 { errHeaders = [("Location", encodeUtf8 uri)]}
-        Nothing -> return logoutPage
+      liftIO . putStrLn $ "\nLOGOUT\n "
+      return . addHeader (authCookie <> "=\"\"") $ logoutPage mRedir
+
+    {- checkCookie :: QCookie -> AuthHandler user ()
+    checkCookie cookie = do
+      let mCreds = lookup authCookie . parseCookiesText $ encodeUtf8 cookie
+      unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" }
+      return ()
+
+    rLogout :: QRedirect
+            -> QCookie
+            -> AuthHandler user (Headers '[ Header "Location" Text
+                                          , Header "Set-Cookie" Text
+                                          ] NoContent)
+    rLogout uri cookie = do
+      liftIO . putStrLn $ "\nLOGOUT with uri " <> show uri <> "\n"
+      checkCookie cookie
+      let param = decodeUtf8 . toStrict $ urlEncodeParams [("redirect", uri)]
+          uri' = "../clogout?" <> param
+      addHeader uri' . addHeader (authCookie <> "=\"\"") <$> return NoContent
+
+    logout :: QCookie
+           -> AuthHandler user (Headers '[Header "Set-Cookie" Text] Html)
+    logout cookie = do
+      liftIO . putStrLn $ "\nLOGOUT\n "
+      checkCookie cookie
+      return . addHeader (authCookie <> "=\"\"")$ logoutPage Nothing
+      -- liftIO $ do
+        -- port <- getEnv "OAUTH2_SERVER_PORT"
+        -- manager <- newManager defaultManagerSettings
+        -- req <- parseRequest $ "GET http://localhost:" ++ port ++ "/clogout" -- TODO get root
+        -- void $ httpLbs req manager -}
 
 
  -------------------
@@ -392,6 +438,7 @@ type Routing user userData = Auth
                         :<|> Token
                         :<|> Me userData
                         :<|> UserList userData
+                        -- :<|> CookieLogout
                         :<|> Logout
 
 routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData)
@@ -400,6 +447,7 @@ routing = loginServer @user @userData
      :<|> tokenEndpoint @user @userData
      :<|> userEndpoint @user @userData
      :<|> userListEndpoint @user @userData
+     -- :<|> clogoutEndpoint @user @userData
      :<|> logoutEndpoint @user @userData