fradrive/src/Handler/Utils.hs

module Handler.Utils
  ( module Handler.Utils
  ) where

import Import

import qualified Data.Text.Encoding as T
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Conduit.List as Conduit

import Handler.Utils.DateTime as Handler.Utils
import Handler.Utils.Form as Handler.Utils
import Handler.Utils.Table 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 Handler.Utils.I18n       as Handler.Utils
import Handler.Utils.Widgets    as Handler.Utils
import Handler.Utils.Database   as Handler.Utils

import System.FilePath.Posix (takeFileName)

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


-- | 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


-- | 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

studyFeaturesWidget :: StudyFeaturesId -> Widget
studyFeaturesWidget featId = do
  (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
  [whamlet|
    $newline never
    _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
  |]