module Handler.Utils
  ( module Handler.Utils
  ) where

import Import

import Utils.Lens

import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.CaseInsensitive (original)
-- import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as Conduit

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
-- import Language.Haskell.TH.Datatype

import Text.Hamlet (shamletFile)

import Handler.Utils.DateTime as Handler.Utils
import Handler.Utils.Form as Handler.Utils
import Handler.Utils.Table as Handler.Utils
import Handler.Utils.Table.Pagination as Handler.Utils

import Handler.Utils.Zip        as Handler.Utils
import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
-- import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Sheet      as Handler.Utils
import Handler.Utils.Mail       as Handler.Utils
import Handler.Utils.ContentDisposition as Handler.Utils

import System.Directory (listDirectory)
import System.FilePath.Posix (takeBaseName, takeFileName)

import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty

import Control.Monad.Logger


-- | Simply send a `File`-Value
sendThisFile :: File -> Handler TypedContent
sendThisFile File{..}
  | Just fileContent' <- fileContent = do
      setContentDisposition' . Just $ takeFileName fileTitle
      return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
  | otherwise = sendResponseStatus noContent204 ()

-- | Serve a single file, identified through a given DB query
serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent
serveOneFile source = do
  results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
  case results of
    [file] -> sendThisFile file
    []     -> notFound
    other  -> do
      $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
      error "Multiple matching files found."

-- | Serve one file directly or a zip-archive of files, identified through a given DB query
--
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
serveSomeFiles archiveName source = do
  results <- runDB . runConduit $ source .| peekN 2

  $logDebugS "serveSomeFiles" . tshow $ length results

  case results of
    []         -> notFound
    [file]     -> sendThisFile file
    _moreFiles -> do
      setContentDisposition' $ Just archiveName
      respondSourceDB typeZip $ do
        let zipComment = T.encodeUtf8 $ pack archiveName
        source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder

-- | Serve any number of files as a zip-archive of files, identified through a given DB query
--
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
serveZipArchive :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
serveZipArchive archiveName source = do
  results <- runDB . runConduit $ source .| peekN 2

  $logDebugS "serveZipArchive" . tshow $ length results

  case results of
    []         -> notFound
    _moreFiles -> do
      setContentDisposition' $ Just archiveName
      respondSourceDB typeZip $ do
        let zipComment = T.encodeUtf8 $ pack archiveName
        source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder



---------
-- Simple utilities for consistent display
-- Please use these throughout, to ensure that users have a consistent experience

tidFromText :: Text -> Maybe TermId
tidFromText = fmap TermKey . maybeRight . termFromText

-- | Display given UTCTime and maybe an invisible icon if it is in the future
--
--   Also see `Handler.Utils.Table.Cells.dateTimeCellVisible` for a similar function (in case of refactoring)
visibleUTCTime :: SelDateTimeFormat -> UTCTime -> Widget
visibleUTCTime dtf t = do
    let timeStampWgt = formatTimeW dtf t
    now <- liftIO getCurrentTime
    if now >= t
      then timeStampWgt
      else $(widgetFile "widgets/date-time/yet-invisible")


-- | Simple link to a known route
simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]

simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget
simpleLinkI lbl url = [whamlet|<a href=@{url}>_{lbl}|]

-- | toWidget-Version of @nameHtml@, for convenience
nameWidget :: Text    -- ^ userDisplayName
           -> Text    -- ^ userSurname
           -> Widget
nameWidget displayName surname = toWidget $ nameHtml displayName surname

-- | toWidget-Version of @nameEmailHtml@, for convenience
nameEmailWidget :: UserEmail -- ^ userEmail
                -> Text    -- ^ userDisplayName
                -> Text    -- ^ userSurname
                -> Widget
nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname

-- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used
nameEmailWidget' :: (UserEmail, Text, Text)-> Widget
nameEmailWidget' = $(uncurryN 3) nameEmailWidget

-- | Show user's displayName, highlighting the surname if possible.
--   Otherwise appends the surname in parenthesis
nameHtml :: Text -> Text -> Html
nameHtml displayName surname
  | null surname = toHtml displayName
  | otherwise = case reverse $ T.splitOn surname displayName of
      [_notContained] -> [shamlet|$newline never
                            #{displayName} (
                            <b .surname>#{surname}
                            )|]
      (suffix:prefixes) ->
        let prefix = T.intercalate surname $ reverse prefixes
        in [shamlet|$newline never
              #{prefix}
              <b .surname>#{surname}
              #{suffix}
            |]
      [] -> error "Data.Text.splitOn returned empty list in violation of specification."

-- | Like nameHtml just show a users displayname with hightlighted surname,
--   but also wrap the name with a mailto-link
nameEmailHtml :: UserEmail -> Text -> Text -> Html
nameEmailHtml email displayName surname =
  wrapMailto email $ nameHtml displayName surname

-- | Wrap mailto around given Html using single hamlet-file for consistency
wrapMailto :: UserEmail -> Html -> Html
wrapMailto (original -> email) linkText
  | null email = linkText
  | otherwise  = $(shamletFile "templates/widgets/link-email.hamlet")

-- | Just show an email address in a standard way, for convenience inside hamlet files.
mailtoHtml :: UserEmail -> Html
mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")

-- | Generic i18n text for "edited at sometime by someone"
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
editedByW fmt tm usr  = do
  ft <- handlerToWidget $ formatTime fmt tm
  [whamlet|_{MsgEditedBy usr ft}|]

-- | Prefix a message with a short course id,
--   eg. for window title bars, etc.
--   This function should help to make this consistent everywhere
prependCourseTitle :: (RenderMessage UniWorX msg) =>
  TermId -> SchoolId -> CourseShorthand -> msg -> UniWorXMessages
prependCourseTitle tid ssh csh msg = UniWorXMessages
  [ SomeMessage $ toPathPiece tid
  , SomeMessage dashText
  , SomeMessage $ toPathPiece ssh
  , SomeMessage dashText
  , SomeMessage csh
  , SomeMessage colonText
  , SomeMessage msg
  ]
 where
    dashText :: Text
    dashText = "-"

    colonText :: Text
    colonText = ":"

warnTermDays :: (RenderMessage UniWorX msg) => TermId -> Map UTCTime msg -> DB ()
warnTermDays tid timeNames = do
  Term{..} <- get404 tid
  MsgRenderer mr <- getMsgRenderer
  let alldays       = Map.keysSet timeNames
      warnholidays  = let hdays = Set.fromList termHolidays in
                      Set.filter (\(utctDay -> d) -> Set.member d hdays)                         alldays
      outoftermdays = Set.filter (\(utctDay -> d) -> d < termStart        || d > termEnd       ) alldays
      outoflecture  = Set.filter (\(utctDay -> d) -> d < termLectureStart || d > termLectureEnd) alldays
                        `Set.difference` outoftermdays -- out of term implies out of lecture-time
      warnI msg d   = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid (mr (timeNames ! d)) dt
  forM_ warnholidays  $ warnI MsgDayIsAHoliday
  forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
  forM_ outoftermdays $ warnI MsgDayIsOutOfTerm

-- | Add language dependent template files
--
-- For large files which are translated as a whole.
--
-- Argument musst be a directory under @/templates@,
-- which contains a file for each language,
-- eg. @imprint@ for choosing between
-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@,
-- and @/templates/imprint/en.hamlet@
--
-- Dependency detection cannot work properly (no `addDependentFile`-equivalent
-- for directories)
-- @$ stack clean@ is required so new translations show up
i18nWidgetFile :: FilePath -> Q Exp
i18nWidgetFile basename = do
  -- Construct list of available translations (@de@, @en@, ...) at compile time
  let i18nDirectory = "templates" </> "i18n" </> basename
  availableFiles <- qRunIO $ listDirectory i18nDirectory
  let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
  availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations

  -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
  ws <- newName "ws" -- Name for dispatch function
  letE
    [ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ "i18n" </> basename </> l) []
                | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
                ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
    ] [e|selectLanguage availableTranslations' >>= $(varE ws)|]



-- | return a value only if the current user ist authorized for a given route
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
                      , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h)))
  => Route UniWorX -> a -> m (ReaderT SqlBackend h) a
guardAuthorizedFor link val =
  val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)


runAppLoggingT :: UniWorX -> LoggingT m a -> m a
runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
  where
    logFunc loc src lvl str = do
      f <- messageLoggerSource app <$> readTVarIO loggerTVar
      f loc src lvl str