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

import Import
import Auth.LDAP (campusUserMatr')
import Foundation.Yesod.Auth (upsertCampusUser)

import Crypto.Hash (hashlazy)

import Data.ByteArray (constEq)
import Data.Maybe (fromJust)
import qualified Data.List.NonEmpty as NonEmpty (fromList)

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 :: PredDNF GuessUserInfo  -- ^ guessing criteria
          -> Maybe Int64  -- ^ Should the query be limited to a maximum number of results?
          -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))  -- ^ Just (Left _) in case of multiple results, 
                                                                         --   Just (Right _) in case of single result, and
                                                                         --   Nothing in case of no result
guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) mQueryLimit = $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 pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
      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.or $ map (E.and . map (toSql user)) criteria
            when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
            return user
      users <- retrieveUsers
      let users' = sortBy (flip closeness) users

          matchesMatriculation :: Entity User -> Maybe Bool
          matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr ->
            any (\p -> all ((== userMatr) . Just) (p ^.. folded . _PLVariable . _guessUserMatrikelnummer)
                    && all ((/= userMatr) . Just) (p ^.. folded . _PLNegated  . _guessUserMatrikelnummer))
            $ criteria ^.. folded)

          closeness :: Entity User -> Entity User -> Ordering
          closeness ul ur = maximum $ impureNonNull $ criteria <&> \term -> 
            let
              matches userField name = _entityVal . userField . to (`matchesName` name)
              comp True  userField guess = (term ^.. folded . _PLVariable . guess) <&> \name ->
                compare (       ul ^. userField `matches` name)
                        (       ur ^. userField `matches` name)
              comp False userField guess = (term ^.. folded . _PLNegated  . guess) <&> \name ->
                compare (Down $ ul ^. userField `matches` name)
                        (Down $ ur ^. userField `matches` name)
            in mconcat $ concat $
                 [ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur)
                 ] <>
                 [ comp b userField guess
                 | (userField,guess) <- [(_userSurname    , _guessUserSurname)
                                        ,(_userFirstName  , _guessUserFirstName)
                                        ,(_userDisplayName, _guessUserDisplayName)
                                        ]
                  , b <- [True,False]
                  ]
          
          takeClosest []  = []
          takeClosest [x] = [x]
          takeClosest (x:x':xs)
            | EQ <- x `closeness` x' = x : takeClosest (x':xs)
            | otherwise = [x]

          doLdap userMatr = do
            ldapPool' <- getsYesod $ view _appLdapPool
            fmap join . for ldapPool' $ \ldapPool -> do
              ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
              for ldapData $ upsertCampusUser UpsertCampusUser

      let
        getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
        getTermMatr = getTermMatrAux Nothing where
          getTermMatrAux acc [] = acc
          getTermMatrAux acc (PLVariable (GuessUserMatrikelnummer matr):xs)
            | Just matr' <- acc, matr == matr' = getTermMatrAux acc xs
            | Nothing    <- acc                = getTermMatrAux (Just matr) xs
            | otherwise                        = Nothing
          getTermMatrAux acc (PLNegated  (GuessUserMatrikelnummer matr):xs)
            | Just matr' <- acc, matr /= matr' = getTermMatrAux acc xs
            | Nothing    <- acc                = getTermMatrAux acc xs
            | otherwise                        = Nothing
          getTermMatrAux acc (_:xs) = getTermMatrAux acc xs

        convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
        convertLdapResults []  = Nothing
        convertLdapResults [x] = Just $ Right x
        convertLdapResults xs  = Just $ Left $ NonEmpty.fromList xs
      
      if
        | [x] <- users'
        , Just True == matchesMatriculation x || didLdap
          -> return $ Just $ Right x
        | x : x' : _ <- users'
        , Just True == matchesMatriculation x || didLdap
        , GT <- x `closeness` x'
          -> return $ Just $ Right x
        | xs@(x:_:_) <- takeClosest users'
        , Just True == matchesMatriculation x || didLdap
          -> return $ Just $ Left $ NonEmpty.fromList xs
        | not didLdap
        , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
          -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
        | otherwise
          -> return Nothing