redirecting auth code back to client

oauth2-mock-server.cabal

@@ -32,6 +32,7 @@ library
   build-depends:
       aeson
     , base >=4.7 && <5
+    , bytestring
     , containers
     , http-client
     , servant
@@ -56,6 +57,7 @@ executable oauth2-mock-server-exe
   build-depends:
       aeson
     , base >=4.7 && <5
+    , bytestring
     , containers
     , http-client
     , oauth2-mock-server
@@ -82,6 +84,7 @@ test-suite oauth2-mock-server-test
   build-depends:
       aeson
     , base >=4.7 && <5
+    , bytestring
     , containers
     , http-client
     , oauth2-mock-server

package.yaml

@@ -32,6 +32,7 @@ dependencies:
 - stm
 - time
 - transformers
+- bytestring
 
 ghc-options:
 - -Wall

src/AuthCode.hs

@@ -33,7 +33,7 @@ genUnencryptedCode client url expiration state = do
   now <- getCurrentTime
   let
     expiresAt = expiration `addUTCTime` now
-    simpleCode = client <> url <> show now <> show expiresAt
+    simpleCode = filter (/= ' ') $ client <> url <> show now <> show expiresAt
   success <- atomically . stateTVar state $ \s ->
     let mEntry = M.lookup simpleCode s.activeCodes
     in

src/Server.hs

@@ -17,8 +17,11 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
 
 import Data.Aeson
-import Data.List (find)
-import Data.Text hiding (elem, find, head, map, words)
+import Data.ByteString (ByteString (..))
+import Data.List (find, elemIndex)
+import Data.Maybe (fromMaybe)
+import Data.String (IsString (..))
+import Data.Text hiding (elem, find, head, length, map, null, splitAt, tail, words)
 import Data.Text.Encoding (decodeUtf8)
 
 import qualified Data.Map.Strict as Map
@@ -97,7 +100,19 @@ authServer = handleAuth
       mAuthCode <- asks (genUnencryptedCode client url 600) >>= liftIO
       liftIO $ print mAuthCode
       liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
-      return uData
+      -- return uData
+      redirect $ url `withCode` mAuthCode
+    redirect :: Maybe ByteString -> AuthHandler userData
+    redirect (Just url) = throwError err302 { errHeaders = [("Location", url)]}
+    redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
+    withCode :: String -> Maybe String -> Maybe ByteString
+    withCode url Nothing = Nothing
+    withCode url (Just code) =
+      let qPos = fromMaybe (length url) $ elemIndex '?' url
+          (pre, post) = splitAt qPos url
+          post' = if not (null post) then '&' : tail post else post
+      in Just . fromString $ pre ++ "?authorization_code=" ++ code ++ post'
+
 
 exampleAuthServer :: AuthServer (Auth User (Map.Map Text Text))
 exampleAuthServer = authServer