module Handler.Utils.Users
  ( computeUserAuthenticationDigest
  , Digest, SHA3_256
  , constEq
  , NameMatchQuality(..)
  , matchesName
  , 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

import qualified Data.MultiSet as MultiSet
import qualified Data.Map as Map
import qualified Data.Text as Text


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

data NameMatchQuality
  = NameMatchSuffix
  | NameMatchPrefix
  | NameMatchPermutation
  | NameMatchEqual
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

matchesName :: Textual t
            => t -- ^ haystack
            -> t -- ^ needle
            -> Maybe NameMatchQuality
matchesName (repack -> haystack) (repack -> needle)
  = fmap (view _1) . Map.lookupMax $ Map.filter id tests
  where
    asWords :: Text -> [CI Text]
    asWords = map CI.mk . filter (not . Text.null) . Text.words . Text.strip

    tests :: Map NameMatchQuality Bool
    tests = mconcat
      [ singletonMap NameMatchEqual       $ asWords needle == asWords haystack
      , singletonMap NameMatchPrefix      $ asWords needle `isPrefixOf` asWords haystack
      , singletonMap NameMatchSuffix      $ asWords needle `isSuffixOf` asWords haystack
      , singletonMap NameMatchPermutation $ ((==) `on` MultiSet.fromList) (asWords needle) (asWords haystack)
      ]

guessUser :: Set GuessUserInfo -> DB (Maybe UserId)
guessUser (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
            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

      if
        | x@(Entity pid _) : [] <- users'
        , fromMaybe False (matchesMatriculation x) || didLdap
          -> return $ Just pid
        | x@(Entity pid _) : x' : _ <- users'
        , 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)
        | otherwise
          -> return Nothing