mock login without passwords

oauth2-mock-server.cabal

@@ -21,6 +21,7 @@ library
   exposed-modules:
       AuthCode
       DB
+      LoginForm
       Server
       User
   other-modules:
@@ -34,15 +35,18 @@ library
       aeson
     , base >=4.7 && <5
     , base64
+    , blaze-html
     , bytestring
     , containers
     , http-api-data
     , http-client
+    , http-media
     , jose-jwt
     , servant
     , servant-client
     , servant-server
     , stm
+    , string-interpolate
     , text
     , time
     , transformers
@@ -63,16 +67,19 @@ executable oauth2-mock-server-exe
       aeson
     , base >=4.7 && <5
     , base64
+    , blaze-html
     , bytestring
     , containers
     , http-api-data
     , http-client
+    , http-media
     , jose-jwt
     , oauth2-mock-server
     , servant
     , servant-client
     , servant-server
     , stm
+    , string-interpolate
     , text
     , time
     , transformers
@@ -94,16 +101,19 @@ test-suite oauth2-mock-server-test
       aeson
     , base >=4.7 && <5
     , base64
+    , blaze-html
     , bytestring
     , containers
     , http-api-data
     , http-client
+    , http-media
     , jose-jwt
     , oauth2-mock-server
     , servant
     , servant-client
     , servant-server
     , stm
+    , string-interpolate
     , text
     , time
     , transformers

package.yaml

@@ -37,6 +37,9 @@ dependencies:
 - base64
 - http-api-data
 - uuid
+- blaze-html
+- http-media
+- string-interpolate
 
 ghc-options:
 - -Wall

src/LoginForm.hs

@@ -0,0 +1,61 @@
+{-# Language OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, QuasiQuotes #-}
+
+module LoginForm (HTML(..), Html, loginPage) where
+
+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 Network.HTTP.Media ((//), (/:))
+
+import Servant.API 
+
+-- import Text.Blaze
+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
+import Text.Blaze.Html5
+import qualified Text.Blaze.Html5.Attributes as A
+
+data HTML
+
+instance Accept HTML where
+  contentType _ = "text" // "html" /: ("charset", "utf-8")
+
+instance MimeRender HTML Html where
+  mimeRender _ = renderHtml
+
+loginPage :: M.Map Text Text -> Html
+loginPage headers = docTypeHtml $ head' >> body'
+  where
+    headers' = encode headers
+    formID = "loginForm" :: String
+    emailID = "email" :: String
+    buttonID = "loginButton" :: String
+    head' = head $ do
+      meta ! A.charset "UTF-8"
+      meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0"
+      title "UniWorX Oauth2 Mock Server"
+    body' = body $ do
+      h1 "UniWorX Oauth2 Mock Server"
+      form ! A.id (fromString formID) ! A.autocomplete "on" $ do
+        label ! A.for "email" $ "User"
+        input ! A.type_ "email" ! A.name "email" ! A.id (fromString emailID) ! A.autocomplete "email"
+      button ! A.type_ "button" ! A.id (fromString buttonID) $ "Login"
+      script $
+        [I.i|
+          #{buttonID}.onclick = async (e) => {
+            let headers = new Headers(#{headers'});
+            let formData = new FormData(#{formID});
+            let creds = formData.get('#{emailID}') + ':' + '';
+            headers.append('Authorization', btoa(creds));
+            alert(creds);
+            alert(headers.get('Authorization'));
+            e.preventDefault();
+              await fetch('../code', {
+              method: 'GET',
+              headers: headers
+            })};
+        |]

src/Server.hs

@@ -7,6 +7,7 @@ module Server
 )-} where
 
 import AuthCode
+import LoginForm
 import User
 
 import Control.Applicative ((<|>))
@@ -25,6 +26,7 @@ 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 Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Text.Encoding.Base64
 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime)
 import Data.UUID.V4
 
@@ -52,11 +54,6 @@ import qualified Text.Read.Lex as Lex
 import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe)
 
 
-testUsers :: [User] -- TODO move to db
-testUsers =
-  [ User {name = "Fallback User", email = "foo@bar.com", password = "0000", uID = "0"}
-  , User {name = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"}
-  , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}]
 
 data AuthClient = Client
   { ident :: Text
@@ -89,19 +86,34 @@ type QClient   = String
 type QResType  = String
 type QRedirect = String
 type QState    = Text
+type QAuth     = Text
 
 type QParam = QueryParam' [Required, Strict]
 
-type Auth user userData = BasicAuth "login" user
+-- type Oauth2Params = QParam "scope" QScope
-                       :> "auth"
+--                  :> QParam "client_id" QClient
-                       :> QParam "scope" QScope
+--                  :> QParam "response_type" QResType
-                       :> QParam "client_id" QClient
+--                  :> QParam "redirect_uri" QRedirect
-                       :> QParam "response_type" QResType
+--                  :> QueryParam "state" QState
-                       :> QParam "redirect_uri" QRedirect
-                       :> QueryParam "state" QState
-                       :> Get '[JSON] userData
 
--- type Insert = "insert" :> Post '[JSON] User
+-- type ProtectedAuth user = BasicAuth "login" user :> "auth" :> Auth -- Prompts for username & password
+-- type QuickAuth = "qauth" :> Auth -- Prompts for username only
+type Foo user userData = BasicAuth "login" user :> "foo" :> Get '[JSON] userData
+type Auth = "auth"
+         :> QParam "scope" QScope
+         :> QParam "client_id" QClient
+         :> QParam "response_type" QResType
+         :> QParam "redirect_uri" QRedirect
+         :> QueryParam "state" QState
+         :> Get '[HTML] Html -- login
+
+type AuthCode = "code"
+             :> HeaderR "Authorization" QAuth
+             :> HeaderR "OA2_Scope" QScope
+             :> HeaderR "OA2_Client_ID" QClient
+             :> HeaderR "OA2_Redirect_URI" QRedirect
+             :> Header "OA2_State" QState
+             :> Get '[JSON] () -- returns auth code
 
 
 type AuthHandler user = ReaderT (AuthState user) Handler
@@ -110,29 +122,50 @@ type AuthServer user a = ServerT a (AuthHandler user)
 toHandler :: forall user userData a . UserData user userData => AuthState user -> AuthHandler user a -> Handler a
 toHandler s h = runReaderT h s
 
-authServer :: forall user userData . UserData user userData => AuthServer user (Auth user userData)
+loginServer :: forall user userData . UserData user userData => AuthServer user Auth
-authServer = handleAuth
+loginServer = handleAuth
   where
-    handleAuth :: user
+    handleAuth :: QScope
-               -> QScope
                -> QClient
                -> QResType
                -> QRedirect
                -> Maybe QState
-               -> AuthHandler user userData
+               -> AuthHandler user Html
-    handleAuth u scopes client responseType url mState = do
+    handleAuth scopes client responseType url mState = do
+      let
+        responseType' = read @ResponseType responseType
+        headers = Map.fromList @Text @Text
+          [ ("OA2_Scope", pack scopes)
+          , ("OA2_Client_ID", pack client)
+          , ("OA2_Redirect_URI", pack 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'
+
+codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode
+codeServer  = handleCreds
+  where
+    handleCreds :: QAuth
+                -> QScope
+                -> QClient
+                -> QRedirect
+                -> Maybe QState
+                -> AuthHandler user ()
+    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."}
       let
-        responseType' = read @ResponseType responseType
         scopes' = map (readScope @user @userData) $ words scopes
-      liftIO $ print responseType'
+        [userName, password] = splitOn ":" $ decodeBase64Lenient creds
-      unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }  
+      liftIO $ print userName
+      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
       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 userData
+    redirect :: Maybe ByteString -> AuthHandler user ()
     redirect (Just url) = liftIO (print url) >> throwError err303 { errHeaders = [("Location", url)]}
     redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
     addParams :: String -> Maybe Text -> Maybe Text -> Maybe ByteString
@@ -143,6 +176,7 @@ authServer = handleAuth
           rState = case mState of {Just s -> "&state=" ++ (unpack . replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
           post' = if not (null post) then '&' : tail post else post
       in Just . fromString $ pre ++ "?code=" ++ (unpack code) ++ post' ++ rState
+    
 
 
  ----------------------
@@ -284,16 +318,22 @@ userListEndpoint = handleUserData
 ---- Server Main ----
  -------------------
 
-type Routing user userData = Auth user userData
+type Routing user userData = Auth
+                        :<|> AuthCode
                         :<|> Token
                         :<|> Me userData
                         :<|> UserList userData
+                        :<|> Foo user userData
+                        -- :<|> "qauth" :> Get '[HTML] Html
 
 routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData)
-routing = authServer @user @userData
+routing = loginServer @user @userData
+     :<|> codeServer @user @userData
      :<|> tokenEndpoint @user @userData
      :<|> userEndpoint @user @userData
      :<|> userListEndpoint @user @userData
+     :<|> undefined
+    --  :<|> return (loginPage "/foobar")
 
 exampleAuthServer :: AuthServer User (Routing User (Map.Map Text Text))
 exampleAuthServer = routing

src/User.hs

@@ -3,20 +3,26 @@
 module User
 ( UserData(..)
 , User (..)
+, testUsers
 ) where
 
 import Data.Aeson
+import Data.List (find)
 import Data.Map.Strict
-import Data.Text hiding (singleton)
+import Data.Maybe
+import Data.Text hiding (singleton, find)
 
 import GHC.Generics
 
+type UserName = Text
+type Password = Text
 
 class (Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary, but currently needed for TypeApplications
   data Scope u
   readScope :: String -> Scope u
   showScope :: Scope u -> String
   userScope  :: u -> Scope u -> a
+  lookupUser :: UserName -> Password -> IO (Maybe u)
 
 
 data User = User
@@ -26,10 +32,17 @@ data User = User
   , uID      :: Text
   } deriving (Eq, Show)
 
+testUsers :: [User] -- TODO move to db
+testUsers =
+  [ User {name = "Fallback User", email = "foo@bar.com", password = "0000", uID = "0"}
+  , User {name = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"}
+  , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}]
+
 
 instance UserData User (Map Text Text) where
   data Scope User = ID | Profile deriving (Show, Read, Eq)
   readScope = read
   showScope = show
   userScope User{..} ID = singleton "id" uID
-  userScope User{..} Profile = fromList [("name", name), ("email", email)]
+  userScope User{..} Profile = fromList [("name", name), ("email", email)]
+  lookupUser e _ = return $ find (\User{..} -> email == e) testUsers