redirecting to client via javascript

app/Main.hs

@@ -12,7 +12,7 @@ main :: IO ()
 main = do
   args <- getArgs >>= flip buildArgs M.empty
   port <- determinePort args
-  putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=localhost"
+  putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=http:%2F%2Flocalhost:0000%2F"
   runMockServer port
     where
       buildArgs :: [String] -> M.Map String String -> IO (M.Map String String)

src/LoginForm.hs

@@ -47,15 +47,18 @@ loginPage headers = docTypeHtml $ head' >> body'
       script $
         [I.i|
           #{buttonID}.onclick = async (e) => {
-            let headers = new Headers(#{headers'});
+            const headers = new Headers(#{headers'});
-            let formData = new FormData(#{formID});
+            const formData = new FormData(#{formID});
-            let creds = formData.get('#{emailID}') + ':' + '';
+            const creds = formData.get('#{emailID}') + ':' + '';
             headers.append('Authorization', btoa(creds));
             alert(creds);
-            alert(headers.get('Authorization'));
             e.preventDefault();
-              await fetch('../code', {
+            fetch('../code', {
               method: 'GET',
               headers: headers
-            })};
+            })
+            .then(response => response.text())
+            .then(url => window.location.replace(url.substring(1, url.length - 1)));
+            // Response.redirect(url);
+          };
         |]

src/Server.hs

@@ -25,6 +25,7 @@ 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 (decodeUtf8, encodeUtf8)
 import Data.Text.Encoding.Base64
 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime)
@@ -84,7 +85,7 @@ instance Read ResponseType where
 type QScope    = String
 type QClient   = String
 type QResType  = String
-type QRedirect = String
+type QRedirect = Text
 type QState    = Text
 type QAuth     = Text
 
@@ -113,7 +114,7 @@ type AuthCode = "code"
              :> HeaderR "OA2_Client_ID" QClient
              :> HeaderR "OA2_Redirect_URI" QRedirect
              :> Header "OA2_State" QState
-             :> Get '[JSON] () -- returns auth code
+             :> Get '[JSON] Text -- returns auth code
 
 
 type AuthHandler user = ReaderT (AuthState user) Handler
@@ -137,7 +138,7 @@ loginServer = handleAuth
         headers = Map.fromList @Text @Text
           [ ("OA2_Scope", pack scopes)
           , ("OA2_Client_ID", pack client)
-          , ("OA2_Redirect_URI", pack url)]
+          , ("OA2_Redirect_URI", url)]
         headers' = if isJust mState then Map.insert "OA2_State" (fromJust mState) headers else headers
       unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }
       return $ loginPage headers'
@@ -150,7 +151,7 @@ codeServer  = handleCreds
                 -> QClient
                 -> QRedirect
                 -> Maybe QState
-                -> AuthHandler user ()
+                -> AuthHandler user Text
     handleCreds creds scopes client url mState = do
       unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
         throwError $ err404 { errBody = "Not a trusted client."}
@@ -161,21 +162,21 @@ codeServer  = handleCreds
       mUser <- liftIO $ lookupUser @user @userData userName password
       unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
       let u = fromJust mUser
-      mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') url) >>= liftIO
+      mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') (unpack url)) >>= liftIO
       liftIO $ print mAuthCode
       liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
       redirect $ addParams url mAuthCode mState
-    redirect :: Maybe ByteString -> AuthHandler user ()
+    redirect :: Maybe Text -> AuthHandler user Text
-    redirect (Just url) = liftIO (print url) >> throwError err303 { errHeaders = [("Location", url)]}
+    redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]}
     redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
-    addParams :: String -> Maybe Text -> Maybe Text -> Maybe ByteString
+    addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text
     addParams url Nothing _ = Nothing
     addParams url (Just code) mState =
-      let qPos = fromMaybe (length url) $ elemIndex '?' url
+      let urlParts = splitOn "?" url
-          (pre, post) = splitAt qPos url
+          (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "")
-          rState = case mState of {Just s -> "&state=" ++ (unpack . replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
+          rState = case mState of {Just s -> "&state=" <> (replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
-          post' = if not (null post) then '&' : tail post else post
+          post' = if not (T.null post) then "&" <> T.tail post else post
-      in Just . fromString $ pre ++ "?code=" ++ (unpack code) ++ post' ++ rState
+      in Just $ pre <> "?code=" <> code <> post' <> rState