chore(guess-user): first stub with different return type

src/Handler/Utils/Users.hs

@@ -6,6 +6,7 @@ module Handler.Utils.Users
   , matchesName
   , GuessUserInfo(..)
   , guessUser
+  , guessUserTmp
   ) where
 
 import Import
@@ -14,6 +15,7 @@ import Auth.LDAP (campusUserMatr')
 import Crypto.Hash (hashlazy)
 
 import Data.ByteArray (constEq)
+import qualified Data.List.NonEmpty as NonEmpty (fromList)
 
 import qualified Data.Aeson as JSON
 
@@ -119,3 +121,69 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
           -> doLdap userMatr >>= maybe (go True) (return . Just)
         | otherwise
           -> return Nothing
+
+
+-- TODO replace guessUser with guessUserTmp when finished
+-- TODO PredDNF GuessUserInfo instead of Set GuessUserInfo
+guessUserTmp :: Set GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))
+guessUserTmp (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
+  where
+    asWords :: Text -> [Text]
+    asWords = filter (not . Text.null) . Text.words . Text.strip
+
+    containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
+    
+    toSql user = \case
+      GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer  E.==.          E.val (Just userMatriculation')
+      GuessUserDisplayName    userDisplayName'   -> user E.^. UserDisplayName    `containsAsSet` userDisplayName'
+      GuessUserSurname        userSurname'       -> user E.^. UserSurname        `containsAsSet` userSurname'
+      GuessUserFirstName      userFirstName'     -> user E.^. UserFirstName      `containsAsSet` userFirstName'
+
+    go didLdap = do
+      let retrieveUsers = E.select . E.from $ \user -> do
+            E.where_ . E.and $ map (toSql user) criteria 
+            return user
+      users <- retrieveUsers
+      let users' = sortBy (flip closeness) users
+
+          matchesMatriculation :: Entity User -> Maybe Bool
+          matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> all ((== userMatr) . Just) $ criteria ^.. folded . _guessUserMatrikelnummer)
+
+          closeness :: Entity User -> Entity User -> Ordering
+          closeness = mconcat $ concat
+            [ pure $ comparing (fmap Down . matchesMatriculation)
+            , (criteria ^.. folded . _guessUserSurname) <&> \surn -> comparing (view $ _entityVal . _userSurname . to (`matchesName` surn))
+            , (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (view $ _entityVal . _userFirstName . to (`matchesName` firstn))
+            , (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (view $ _entityVal . _userDisplayName . to (`matchesName` dispn))
+            ]
+
+          doLdap userMatr = do
+            ldapPool' <- getsYesod $ view _appLdapPool
+            fmap join . for ldapPool' $ \ldapPool -> do
+              ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
+              for ldapData $ upsertCampusUser UpsertCampusUser
+
+      let
+        aux []  = []
+        aux [x] = [x]
+        aux (x:x':xs)
+          | EQ <- x `closeness` x' = x : aux (x':xs)
+          | otherwise = [x]
+
+      if
+        | x : [] <- users'
+        , fromMaybe False (matchesMatriculation x) || didLdap
+          -> return $ Just $ Right x
+        | x : x' : _ <- users'
+        , fromMaybe False (matchesMatriculation x) || didLdap
+        , GT <- x `closeness` x'
+          -> return $ Just $ Right x
+        | xs@(x:_:_) <- aux users'
+        , fromMaybe False (matchesMatriculation x) || didLdap
+          -> return $ Just $ Left $ NonEmpty.fromList xs
+        | not didLdap
+        , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer
+        , all (== userMatr) userMatrs'
+          -> doLdap userMatr >>= maybe (go True) (return . Just . Right)
+        | otherwise
+          -> return Nothing