From 514829dc259269c5edee97a7b3ad4cabbace93ed Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 4 Oct 2017 15:07:22 +0200
Subject: [PATCH] Store user plugin in db & allow bypassing when using
 dummy-auth

---
 models                      | 13 ++-----------
 src/Foundation.hs           | 16 ++++++++++++----
 test/Handler/ProfileSpec.hs |  4 ++--
 test/TestImport.hs          | 20 ++++++--------------
 4 files changed, 22 insertions(+), 31 deletions(-)

diff --git a/models b/models
index 527dbffdd..a90cbeab5 100644
--- a/models
+++ b/models
@@ -1,16 +1,7 @@
 User
+    plugin Text
     ident Text
-    password Text Maybe
-    UniqueUser ident
-    deriving Typeable
-Email
-    email Text
-    userId UserId Maybe
-    verkey Text Maybe
-    UniqueEmail email    
---
--- above from Template, needs editing
---
+    UniqueAuthentication plugin ident
 Term json
     name        Text
     shorthand   Text
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 7936a916f..7fa6dd380 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -5,6 +5,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternGuards #-}
 
 module Foundation where
 
@@ -228,13 +230,19 @@ instance YesodAuth UniWorX where
     -- Override the above two destinations when a Referer: header is present
     redirectToReferer _ = True
 
-    authenticate creds = runDB $ do
-        x <- getBy $ UniqueUser $ credsIdent creds
+    authenticate Creds{..} = runDB $ do
+        let auth
+              | credsPlugin == "dummy"
+              , [ dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
+              = UniqueAuthentication dummyPlugin dummyIdent
+              | otherwise
+              = UniqueAuthentication credsPlugin credsIdent
+        x <- getBy auth
         case x of
             Just (Entity uid _) -> return $ Authenticated uid
             Nothing -> Authenticated <$> insert User
-                { userIdent = credsIdent creds
-                , userPassword = Nothing
+                { userPlugin = credsPlugin
+                , userIdent = credsIdent
                 }
 
     -- You can add other plugins like Google Email, email or OAuth here
diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs
index 1f96f7f35..dff41b58b 100644
--- a/test/Handler/ProfileSpec.hs
+++ b/test/Handler/ProfileSpec.hs
@@ -13,14 +13,14 @@ spec = withApp $ do
             statusIs 403
 
         it "asserts access to my-account for authenticated users" $ do
-            userEntity <- createUser "foo"
+            userEntity <- createUser "dummy" "foo"
             authenticateAs userEntity
 
             get ProfileR
             statusIs 200
 
         it "asserts user's information is shown" $ do
-            userEntity <- createUser "bar"
+            userEntity <- createUser "dummy" "bar"
             authenticateAs userEntity
 
             get ProfileR
diff --git a/test/TestImport.hs b/test/TestImport.hs
index 47cd584ad..909ba72d4 100644
--- a/test/TestImport.hs
+++ b/test/TestImport.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
 module TestImport
     ( module TestImport
     , module X
@@ -70,23 +72,13 @@ getTables = do
 -- being set in test-settings.yaml, which enables dummy authentication in
 -- Foundation.hs
 authenticateAs :: Entity User -> YesodExample UniWorX ()
-authenticateAs (Entity _ u) = do
+authenticateAs (Entity _ User{..}) = do
     request $ do
         setMethod "POST"
-        addPostParam "ident" $ userIdent u
+        addPostParam "ident" $ userPlugin <> ":" <> userIdent
         setUrl $ AuthR $ PluginR "dummy" []
 
 -- | Create a user.  The dummy email entry helps to confirm that foreign-key
 -- checking is switched off in wipeDB for those database backends which need it.
-createUser :: Text -> YesodExample UniWorX (Entity User)
-createUser ident = runDB $ do
-    user <- insertEntity User
-        { userIdent = ident
-        , userPassword = Nothing
-        }
-    _ <- insert Email
-        { emailEmail = ident
-        , emailUserId = Just $ entityKey user
-        , emailVerkey = Nothing
-        }
-    return user
+createUser :: Text -> Text -> YesodExample UniWorX (Entity User)
+createUser userPlugin userIdent = runDB $ insertEntity User{..}