module Foundation.Yesod.Middleware
  ( yesodMiddleware
  , updateFavourites
  ) where

import Import.NoFoundation hiding (yesodMiddleware)

import Foundation.Type
import Foundation.Routes
import Foundation.Authorization

import Utils.Metrics

import qualified Network.Wai as W
import qualified Data.Aeson as JSON
import qualified Data.CaseInsensitive as CI
  
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Writer.Class (MonadWriter(..))

import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))


yesodMiddleware :: ( BearerAuthSite UniWorX
                   , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
                   , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                   )
                => HandlerFor UniWorX res -> HandlerFor UniWorX res
yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware
  where
    dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    dryRunMiddleware handler = do
      dryRun <- isDryRun
      if | dryRun -> do
             hData <- ask
             prevState <- readIORef (handlerState hData)
             let
               restoreSession =
                 modifyIORef (handlerState hData) $
                   \hst -> hst { ghsSession = ghsSession prevState
                               , ghsCache = ghsCache prevState
                               , ghsCacheBy = ghsCacheBy prevState
                               }
               site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing }
               handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler

             addCustomHeader HeaderDryRun $ toPathPiece True

             handler' `finally` restoreSession
         | otherwise -> handler
    updateFavouritesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
      route <- MaybeT getCurrentRoute
      case route of -- update Course Favourites here
        CourseR tid ssh csh _  -> do
          void . lift . runDB . runMaybeT $ do
            guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
            lift . updateFavourites $ Just (tid, ssh, csh)
        _other -> return ()
    normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
      route <- MaybeT getCurrentRoute
      (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers
      when changed $ do
        $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
        redirectWith movedPermanently301 route'
    headerMessagesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
      isModal <- hasCustomHeader HeaderIsModal
      dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
      massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
      $logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
      guard $ or
        [ isModal
        , dbTableShortcircuit
        , massInputShortcircuit
        ]

      lift . bracketOnError getMessages (mapM_ addMessage') $
        addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
    observeYesodCacheSizeMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
    csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    csrfMiddleware handler = do
      hasBearer <- is _Just <$> lookupBearerAuth

      if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
         | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
      where
        csrfSetCookieMiddleware' handler' = do
          mcsrf <- reqToken <$> getRequest
          whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
          handler'
    storeBearerMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    storeBearerMiddleware handler = do
      askBearer >>= \case
        Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
        Nothing       -> return ()

      handler
    setActiveAuthTagsMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    setActiveAuthTagsMiddleware handler = do
      mtagActive <- lookupSessionJson SessionActiveAuthTags :: HandlerFor UniWorX (Maybe AuthTagActive)
      when (is _Nothing mtagActive) $ do
        mAuthTagActive <- lookupRegisteredCookieJson CookieActiveAuthTags
        for_ mAuthTagActive $ setSessionJson SessionActiveAuthTags . review _ReducedActiveAuthTags

      handler

updateFavourites :: forall m backend.
                    ( MonadHandler m, HandlerSite m ~ UniWorX
                    , BackendCompatible SqlBackend backend
                    , YesodAuth UniWorX
                    , UserId ~ AuthId UniWorX
                    )
                 => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
                 -> ReaderT backend m ()
updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do
  $logDebugS "updateFavourites" "Updating favourites"

  now <- liftIO getCurrentTime
  uid <- MaybeT $ liftHandler maybeAuthId
  mcid  <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId)
  User{userMaxFavourites} <- MaybeT $ get uid

  -- update Favourites
  for_ mcid $ \cid ->
    void . lift $ upsertBy
      (UniqueCourseFavourite uid cid)
      (CourseFavourite uid cid FavouriteVisited now)
      [CourseFavouriteLastVisit =. now]
  -- prune Favourites to user-defined size
  oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
  let deleteFavs = oldFavs
        & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
        & drop userMaxFavourites
        & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
        & map entityKey
  unless (null deleteFavs) $
    lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]

  
routeNormalizers :: forall m backend.
                    ( BackendCompatible SqlReadBackend backend
                    , MonadHandler m, HandlerSite m ~ UniWorX
                    , BearerAuthSite UniWorX
                    ) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
  [ normalizeRender
  , ncSchool
  , ncAllocation
  , ncCourse
  , ncSheet
  , ncMaterial
  , ncTutorial
  , ncExam
  , ncExternalExam
  , verifySubmission
  , verifyCourseApplication
  , verifyCourseNews
  ]
  where
    normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
    normalizeRender route = route <$ do
      YesodRequest{..} <- liftHandler getRequest
      let original = (W.pathInfo reqWaiRequest, reqGetParams)
          rendered = renderRoute route
      if
        | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
            $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
        | otherwise -> do
            $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
            tell $ Any True

    maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) (Route UniWorX))
              -> Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
    maybeOrig f route = maybeT (return route) $ f route

    caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) ()
    caseChanged a b
      | ((/=) `on` CI.original) a b = do
          $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
          tell $ Any True
      | otherwise                   = return ()

    ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
      let schoolShort :: SchoolShorthand
          schoolShort = unSchoolKey ssh
      Entity ssh' _  <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
      (caseChanged `on` unSchoolKey) ssh ssh'
      return ssh'
    ncAllocation = maybeOrig $ \route -> do
      AllocationR tid ssh ash _ <- return route
      Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
      caseChanged ash allocationShorthand
      return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
    ncCourse = maybeOrig $ \route -> do
      CourseR tid ssh csh _ <- return route
      Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
      caseChanged csh courseShorthand
      return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
    ncSheet = maybeOrig $ \route -> do
      CSheetR tid ssh csh shn _ <- return route
      cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
      caseChanged shn sheetName
      return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
    ncMaterial = maybeOrig $ \route -> do
      CMaterialR tid ssh csh mnm _ <- return route
      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
      caseChanged mnm materialName
      return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
    ncTutorial = maybeOrig $ \route -> do
      CTutorialR tid ssh csh tutn _ <- return route
      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
      caseChanged tutn tutorialName
      return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
    ncExam = maybeOrig $ \route -> do
      CExamR tid ssh csh examn _ <- return route
      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
      Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
      caseChanged examn examName
      return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
    ncExternalExam = maybeOrig $ \route -> do
      EExamR tid ssh coursen examn _ <- return route
      Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
      caseChanged coursen externalExamCourseName
      caseChanged examn externalExamExamName
      return $ route
        & typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
        & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
    verifySubmission = maybeOrig $ \route -> do
      CSubmissionR _tid _ssh _csh _shn cID sr <- return route
      sId <- $cachedHereBinary cID $ decrypt cID
      Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
      Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
      Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
      let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
      tell . Any $ route /= newRoute
      return newRoute
    verifyCourseApplication = maybeOrig $ \route -> do
      CApplicationR _tid _ssh _csh cID sr <- return route
      aId <- decrypt cID
      CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
      let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
      tell . Any $ route /= newRoute
      return newRoute
    verifyCourseNews = maybeOrig $ \route -> do
      CNewsR _tid _ssh _csh cID sr <- return route
      aId <- decrypt cID
      CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
      let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
      tell . Any $ route /= newRoute
      return newRoute
