module Handler.Utils.Users
  ( computeUserAuthenticationDigest
  , Digest, SHA3_256
  , constEq
  , GuessUserInfo(..)
  , guessUser
  ) where

import Import
import Auth.LDAP (campusUserMatr')

import Crypto.Hash (hashlazy)

import Data.ByteArray (constEq)

import qualified Data.Aeson as JSON

import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E


computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
computeUserAuthenticationDigest = hashlazy . JSON.encode


data GuessUserInfo
  = GuessUserMatrikelnummer { guessUserMatrikelnummer :: UserMatriculation }
  | GuessUserDisplayName    { guessUserDisplayName    :: UserDisplayName   }
  | GuessUserSurname        { guessUserSurname        :: UserSurname       }
  | GuessUserFirstName      { guessUserFirstName      :: UserFirstName     }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Binary GuessUserInfo

makeLenses_ ''GuessUserInfo

guessUser :: Set GuessUserInfo -> DB (Maybe UserId)
guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
  where
    toSql user = \case
      GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer  E.==.       E.val (Just userMatriculation')
      GuessUserDisplayName    userDisplayName'   -> user E.^. UserDisplayName    `E.hasInfix` E.val userDisplayName'
      GuessUserSurname        userSurname'       -> user E.^. UserSurname        `E.hasInfix` E.val userSurname'
      GuessUserFirstName      userFirstName'     -> user E.^. UserFirstName      `E.hasInfix` E.val 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 (preview $ _entityVal . _userSurname . to CI.mk . only (CI.mk surn))
            , (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (preview $ _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn))
            , (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (preview $ _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn))
            ]

          doLdap userMatr = do
            app <- getYesod
            let ldap = (,) <$> app ^. _appLdapConf <*> app ^. _appLdapPool
            fmap (fmap entityKey . join) . for ldap $ \(ldapConf, ldapPool) -> do
              ldapData <- campusUserMatr' ldapConf ldapPool userMatr
              for ldapData $ upsertCampusUser UpsertCampusUser


      case users' of
        x@(Entity pid _) : xs
          | [] <- xs
          , fromMaybe False (matchesMatriculation x) || didLdap
            -> return $ Just pid
          | x' : _ <- xs
          , fromMaybe False (matchesMatriculation x) || didLdap
          , GT <- x `closeness` x'
            -> return $ Just pid
          | not didLdap
          , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer
          , all (== userMatr) userMatrs'
            -> doLdap userMatr >>= maybe (go True) (return . Just)
        _other
          -> return Nothing