Store user plugin in db & allow bypassing when using dummy-auth

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

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

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

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{..}