module Foundation.Yesod.Auth
  ( authenticate
  , upsertCampusUser
  , CampusUserConversionException(..)
  , campusUserFailoverMode, updateUserLanguage
  ) where

import Import.NoFoundation hiding (authenticate)

import Foundation.Type
import Foundation.Types
import Foundation.I18n

import Handler.Utils.Profile
import Handler.Utils.LdapSystemFunctions
import Handler.Utils.Memcached
import Foundation.Authorization (AuthorizationCacheKey(..))

import Yesod.Auth.Message
import Auth.LDAP
import Auth.PWHash (apHash)
import Auth.Dummy (apDummy)

import qualified Data.CaseInsensitive as CI
import qualified Control.Monad.Catch as C (Handler(..))
import qualified Ldap.Client as Ldap
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
-- import qualified Data.ByteString as ByteString
import qualified Data.Set as Set
-- import qualified Data.Conduit.Combinators as C

-- import qualified Data.List as List ((\\))
  
-- import qualified Data.UUID as UUID
-- import Data.ByteArray (convert)
-- import Crypto.Hash (SHAKE128)
-- import qualified Data.Binary as Binary

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

-- import Crypto.Hash.Conduit (sinkHash)


authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                , YesodAuth UniWorX, UserId ~ AuthId UniWorX
                )
             => Creds UniWorX -> m (AuthenticationResult UniWorX)
authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
  now <- liftIO getCurrentTime

  let
    uAuth = UniqueAuthentication $ CI.mk credsIdent
    upsertMode = creds ^? _upsertCampusUserMode

    isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
    isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode

    excRecovery res
      | isDummy || isOther
      = do
          case res of
            UserError   err -> addMessageI Error   err
            ServerError err -> addMessage  Error $ toHtml err
            _other          -> return ()
          acceptExisting
      | otherwise
      = return res

    excHandlers =
      [ C.Handler $ \case
          CampusUserNoResult -> do
            $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
            excRecovery . UserError $ IdentifierNotFound credsIdent
          CampusUserAmbiguous -> do
            $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
            excRecovery . UserError $ IdentifierNotFound credsIdent
          err -> do
            $logErrorS "LDAP" $ tshow err
            mr <- getMessageRender
            excRecovery . ServerError $ mr MsgInternalLdapError
      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
          $logErrorS "LDAP" $ tshow cExc
          mr <- getMessageRender
          excRecovery . ServerError $ mr cExc
      ]

    acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
    acceptExisting = do
      res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
      case res of
        Authenticated uid
          -> associateUserSchoolsByTerms uid
        _other
          -> return ()
      case res of
        Authenticated uid
          | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
        _other -> return res

  $logDebugS "auth" $ tshow Creds{..}
  UniWorX{..} <- getYesod

  flip catches excHandlers $ case appLdapPool of
    Just ldapPool
      | Just upsertMode' <- upsertMode -> do
          ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
          Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
    _other
      -> acceptExisting

  
data CampusUserConversionException
  = CampusUserInvalidIdent
  | CampusUserInvalidEmail
  | CampusUserInvalidDisplayName
  | CampusUserInvalidGivenName
  | CampusUserInvalidSurname
  | CampusUserInvalidTitle
  | CampusUserInvalidMatriculation  
  | CampusUserInvalidFeaturesOfStudy Text
  | CampusUserInvalidAssociatedSchools Text
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (Exception)

_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
_upsertCampusUserMode mMode cs@Creds{..}
  | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent)
  | credsPlugin == apLdap  = setMode <$> mMode  UpsertCampusUserLoginLdap
  | otherwise              = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent)
  where
    setMode UpsertCampusUserLoginLdap
      = cs{ credsPlugin = apLdap }
    setMode (UpsertCampusUserLoginDummy ident)
      = cs{ credsPlugin = apDummy
          , credsIdent  = CI.original ident
          }
    setMode (UpsertCampusUserLoginOther ident)
      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
          , credsIdent  = CI.original ident
          }
    setMode _ = cs

    defaultOther = apHash

upsertCampusUser :: forall m.
                    ( MonadHandler m, HandlerSite m ~ UniWorX
                    , MonadThrow m
                    )
                 => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
upsertCampusUser upsertMode ldapData = do
  now <- liftIO getCurrentTime
  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults

  let    
    userEmail'          = fold $ do
      k' <- toList ldapUserEmail
      (k, v) <- ldapData
      guard $ k' == k
      return v
    -- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration?
    userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey        ]    
    userIdent''         = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]    
    userDisplayName''   = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
    userTelephone'      = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone     ]
    userMobile'         = fold [ v | (k, v) <- ldapData, k == ldapUserMobile        ]
    userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ]
    userFraportAbteilung'      = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung      ]

    userAuthentication
      | is _UpsertCampusUserLoginOther upsertMode
      = error "Non-LDAP logins should only work for users that are already known"
      | otherwise = AuthLDAP
    userLastAuthentication = guardOn isLogin now
    isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode

  userIdent <- if
    | [bs] <- userIdent''
    , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
    , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
      -> return userIdent'
    | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
      -> return userIdent'
    | otherwise
      -> throwM CampusUserInvalidIdent
  userEmail <- if
    | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
      -> return $ CI.mk userEmail
    | otherwise
      -> throwM CampusUserInvalidEmail
  userDisplayName' <- if
    | [bs] <- userDisplayName''
    , Right userDisplayName' <- Text.decodeUtf8' bs
      -> return userDisplayName'
    | otherwise
      -> throwM CampusUserInvalidDisplayName
  userFirstName <- if
    | [bs] <- userFirstName'
    , Right userFirstName <- Text.decodeUtf8' bs
      -> return userFirstName
    | otherwise
      -> throwM CampusUserInvalidGivenName
  userSurname <- if
    | [bs] <- userSurname'
    , Right userSurname <- Text.decodeUtf8' bs
      -> return userSurname
    | otherwise
      -> throwM CampusUserInvalidSurname
  userTelephone <- if 
    | [bs] <- userTelephone'
    , Right userTelephone <- Text.decodeUtf8' bs 
      -> return $ Just userTelephone
    | otherwise
      -> return Nothing
  userMobile <- if 
    | [bs] <- userMobile'
    , Right userMobile <- Text.decodeUtf8' bs 
      -> return $ Just userMobile
    | otherwise
      -> return Nothing
  userCompanyPersonalNumber  <- if 
    | [bs] <- userFraportPersonalnummer'
    , Right dt <- Text.decodeUtf8' bs 
      -> return $ Just dt
    | otherwise
      -> return Nothing
  userCompanyDepartment <- if 
    | [bs] <- userFraportAbteilung'
    , Right dt <- Text.decodeUtf8' bs 
      -> return $ Just dt
    | otherwise
      -> return Nothing

  userLdapPrimaryKey <- if
    | [bs] <- userLdapPrimaryKey'
    , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
    , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
      -> return $ Just userLdapPrimaryKey'''
    | otherwise
      -> return Nothing

  let
    newUser = User
      { userMaxFavourites        = userDefaultMaxFavourites
      , userMaxFavouriteTerms    = userDefaultMaxFavouriteTerms
      , userTheme                = userDefaultTheme
      , userDateTimeFormat       = userDefaultDateTimeFormat
      , userDateFormat           = userDefaultDateFormat
      , userTimeFormat           = userDefaultTimeFormat
      , userDownloadFiles        = userDefaultDownloadFiles
      , userWarningDays          = userDefaultWarningDays
      , userShowSex              = userDefaultShowSex
      , userSex                  = Nothing
      , userExamOfficeGetSynced  = userDefaultExamOfficeGetSynced
      , userExamOfficeGetLabels  = userDefaultExamOfficeGetLabels
      , userNotificationSettings = def
      , userLanguages            = Nothing
      , userCsvOptions           = def
      , userTokensIssuedAfter    = Nothing
      , userCreated              = now
      , userLastLdapSynchronisation = Just now
      , userDisplayName          = userDisplayName'
      , userDisplayEmail         = userEmail
      , userMatrikelnummer       = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
      , userTitle                = Nothing
      , ..
      }
    userUpdate =  [ 
                  -- UserDisplayName             =. userDisplayName -- never updated, since users are allowed to change their DisplayName
                    UserFirstName               =. userFirstName
                  , UserSurname                 =. userSurname                  
                  , UserEmail                   =. userEmail                  
                  , UserLastLdapSynchronisation =. Just now
                  , UserLdapPrimaryKey          =. userLdapPrimaryKey
                  , UserMobile                  =. userMobile
                  , UserTelephone               =. userTelephone
                  , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
                  , UserCompanyDepartment       =. userCompanyDepartment
                  ] ++
                  [ UserLastAuthentication =. Just now | isLogin ]

  oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []

  user@(Entity userId userRec) <- case oldUsers of
    Just [oldUserId] -> updateGetEntity oldUserId userUpdate
    _other           -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
  unless (validDisplayName Nothing userFirstName userSurname $ userDisplayName userRec) $
    update userId [ UserDisplayName =. userDisplayName' ]

  let
    userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
    userSystemFunctions' = do
      (k, v) <- ldapData
      guard $ k == ldapAffiliation
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      assertM' (not . Text.null) $ Text.strip str

  iforM_ userSystemFunctions $ \func preset -> do
    memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
    if | preset -> void $ upsert (UserSystemFunction userId func False False) []
       | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]

  return user  

associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
associateUserSchoolsByTerms uid = do
  sfs <- selectList [StudyFeaturesUser ==. uid] []

  forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
    schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
    forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
      void $ insertUnique UserSchool
        { userSchoolUser     = uid
        , userSchoolSchool   = schoolTermsSchool
        , userSchoolIsOptOut = False
        }
  
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
                      , YesodAuth UniWorX
                      , UserId ~ AuthId UniWorX
                      )
                   => Maybe Lang -> SqlPersistT m (Maybe Lang)
updateUserLanguage (Just lang) = do
  unless (lang `elem` appLanguages) $
    invalidArgs ["Unsupported language"]

  muid <- maybeAuthId
  for_ muid $ \uid -> do
    langs <- languages
    update uid [ UserLanguages =. Just (Languages $ lang : nubOrd (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
  setRegisteredCookie CookieLang lang
  return $ Just lang
updateUserLanguage Nothing = runMaybeT $ do
  uid <- MaybeT maybeAuthId
  User{..} <- MaybeT $ get uid
  setLangs <- toList . selectLanguages appLanguages <$> languages
  highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
  let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
  lang <- case (userLanguages', setLangs, highPrioSetLangs) of
    (_, _, hpl : _)
      -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
    (Just (l : _), _, _)
      -> return l
    (Nothing, l : _, _)
      -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
    (Just [], l : _, _)
      -> return l
    (_, [], _)
      -> mzero
  setRegisteredCookie CookieLang lang
  return lang

campusUserFailoverMode :: FailoverMode
campusUserFailoverMode = FailoverUnlimited

embedRenderMessage ''UniWorX ''CampusUserConversionException id
