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 qualified Data.Set (Set)
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 System.Directory (listDirectory)
import System.FilePath.Posix (takeBaseName, takeFileName)

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


-- | Check whether the user's preference for files is inline-viewing or downloading
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
downloadFiles = do
  mauth <- liftHandlerT maybeAuth
  case mauth of
    Just (Entity _ User{..}) -> return userDownloadFiles
    Nothing -> do
      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
      return userDefaultDownloadFiles

setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m ()
setContentDisposition' mFileName = do
  wantsDownload <- downloadFiles
  setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName

-- | 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 "application/zip" $ do
        let zipComment = T.encodeUtf8 $ pack archiveName
        source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder


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

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 :: TermId -> [Maybe UTCTime] -> DB ()
warnTermDays tid times = do
  Term{..} <- get404 tid
  let alldays       = Set.map utctDay $ Set.fromList $ catMaybes times
      warnholidays  = Set.intersection alldays $ Set.fromList termHolidays
      outoftermdays = Set.filter (\d -> d < termStart        || d > termEnd       ) alldays
      outoflecture  = Set.filter (\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 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)