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.StudyFeatures
import Handler.Utils.SchoolLdap
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
  | CampusUserInvalidSex
  | 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
    userIdent''         = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
    userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
    userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ]
    userEmail'          = fold $ do
      k' <- toList ldapUserEmail
      (k, v) <- ldapData
      guard $ k' == k
      return v
    userDisplayName''   = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
    userTitle'          = fold [ v | (k, v) <- ldapData, k == ldapUserTitle         ]
    userSex'            = fold [ v | (k, v) <- ldapData, k == ldapSex               ]

    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
  userTitle <- if
    | all ByteString.null userTitle'
      -> return Nothing
    | [bs] <- userTitle'
    , Right userTitle <- Text.decodeUtf8' bs
      -> return $ Just userTitle
    | otherwise
      -> throwM CampusUserInvalidTitle
  userMatrikelnummer <- if
    | [bs] <- userMatrikelnummer'
    , Right userMatrikelnummer <- Text.decodeUtf8' bs
      -> return $ Just userMatrikelnummer
    | [] <- userMatrikelnummer'
      -> return Nothing
    | otherwise
      -> throwM CampusUserInvalidMatriculation
  userSex <- if
    | [bs] <- userSex'
    , Right userSex'' <- Text.decodeUtf8' bs
    , Just userSex''' <- readMay userSex''
    , Just userSex <- userSex''' ^? iso5218
      -> return $ Just userSex
    | [] <- userSex'
      -> return   Nothing
    | otherwise
      -> throwM CampusUserInvalidSex
  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
      , userNotificationSettings = def
      , userLanguages            = Nothing
      , userCsvOptions           = def
      , userTokensIssuedAfter    = Nothing
      , userCreated              = now
      , userLastLdapSynchronisation = Just now
      , userDisplayName          = userDisplayName'
      , userDisplayEmail         = userEmail
      , ..
      }
    userUpdate =  [ UserMatrikelnummer          =. userMatrikelnummer
                  -- , UserDisplayName             =. userDisplayName
                  , UserFirstName               =. userFirstName
                  , UserSurname                 =. userSurname
                  , UserTitle                   =. userTitle
                  , UserEmail                   =. userEmail
                  , UserSex                     =. userSex
                  , UserLastLdapSynchronisation =. Just now
                  , UserLdapPrimaryKey          =. userLdapPrimaryKey
                  ] ++
                  [ 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 userTitle userFirstName userSurname $ userDisplayName userRec) $
    update userId [ UserDisplayName =. userDisplayName' ]

  let
    userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
    userStudyFeatures' = do
      (k, v) <- ldapData
      guard $ k == ldapUserStudyFeatures
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str

    termNames = nubOrdOn CI.mk $ do
      (k, v) <- ldapData
      guard $ k == ldapUserFieldName
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str

    userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
    userSubTermsSemesters' = do
      (k, v) <- ldapData
      guard $ k == ldapUserSubTermsSemester
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str

  fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
  sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters

  let
    studyTermCandidates = Set.fromList $ do
      let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
          subTermsKeys = unStudyTermsKey . fst <$> sts

      (,) <$> sfKeys ++ subTermsKeys <*> termNames

  let
    assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) (SqlPersistT m) [StudyFeatures]
    assimilateSubTerms [] xs = return xs
    assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
      standalone <- lift $ get subterm
      case standalone of
        _other
          | (match : matches, unusedFeats') <- partition
              (\StudyFeatures{..} -> subterm     == studyFeaturesField
                                  && subSemester == studyFeaturesSemester
              ) unusedFeats
            -> do
              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
              (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
          | any ((== subterm) . studyFeaturesField) unusedFeats
            -> do
              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
              assimilateSubTerms subterms unusedFeats
        Just StudyTerms{..}
          | Just defDegree <- studyTermsDefaultDegree
          , Just defType   <- studyTermsDefaultType
            -> do
              $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
              let sf = StudyFeatures
                    { studyFeaturesUser = userId
                    , studyFeaturesDegree = defDegree
                    , studyFeaturesField = subterm
                    , studyFeaturesSuperField = Nothing
                    , studyFeaturesType = defType
                    , studyFeaturesSemester = subSemester
                    , studyFeaturesFirstObserved = Just now
                    , studyFeaturesLastObserved = now
                    , studyFeaturesValid = True
                    , studyFeaturesRelevanceCached = Nothing
                    }
              (sf :) <$> assimilateSubTerms subterms unusedFeats
        Nothing
          | [] <- unusedFeats -> do
              $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
              tell $ Set.singleton (subterm, Nothing)
              assimilateSubTerms subterms []
        _other -> do
          knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
          let matchingFeatures = case knownParents of
                []      -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
                ps      -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
          when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
            tell $ Set.singleton (subterm, Just studyFeaturesField)
          if
            | not $ null knownParents -> do
                $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
                let setSuperField sf = sf
                      & _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField))
                      & _studyFeaturesField .~ subterm
                (++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
            | otherwise -> do
                $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
                assimilateSubTerms subterms unusedFeats
  $logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
  (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'

  let
    studyTermCandidateIncidence
      = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
      . UUID.fromByteString
      . fromStrict
      . (convert :: Digest (SHAKE128 128) -> ByteString)
      . runConduitPure
      $ C.yieldMany ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash

  candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
    E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
         E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
         E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)

  unless candidatesRecorded $ do
    let
      studyTermCandidates' = do
        (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
        let studyTermNameCandidateIncidence = studyTermCandidateIncidence
        return StudyTermNameCandidate{..}
    insertMany_ studyTermCandidates'

    let
      studySubTermParentCandidates' = do
        (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
        let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
        return StudySubTermParentCandidate{..}
    insertMany_ studySubTermParentCandidates'

    let
      studyTermStandaloneCandidates' = do
        (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
        let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
        return StudyTermStandaloneCandidate{..}
    insertMany_ studyTermStandaloneCandidates'

  E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
  forM_ fs $ \f@StudyFeatures{..} -> do
    insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
    void $ upsert f
      [ StudyFeaturesLastObserved =. now
      , StudyFeaturesValid =. True
      , StudyFeaturesSuperField =. studyFeaturesSuperField
      ]
  associateUserSchoolsByTerms userId

  cacheStudyFeatureRelevance $ \studyFeatures -> studyFeatures E.^. StudyFeaturesUser E.==. E.val userId

  let
    userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
    userAssociatedSchools' = do
      (k, v) <- ldapData
      guard $ k == ldapUserSchoolAssociation
      v' <- v
      Right str <- return $ Text.decodeUtf8' v'
      return str

  ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools

  forM_ ss $ \frag -> void . runMaybeT $ do
    let
      exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
      infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
        E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
             E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
        return schoolLdap
    Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
    ssh <- hoistMaybe schoolLdapSchool

    lift . void $ insertUnique UserSchool
      { userSchoolUser     = userId
      , userSchoolSchool   = ssh
      , userSchoolIsOptOut = False
      }

  forM_ ss $ void . insertUnique . SchoolLdap Nothing

  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
  where
    insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())

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
