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

import Import
import Auth.LDAP (campusUserMatr')

import Crypto.Hash (Digest, SHA3_256, 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