{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

module Handler.Sheet where

import Import 
import System.FilePath (takeFileName)

import Handler.Utils
import Handler.Utils.Zip

-- import Data.Time
import qualified Data.Text as T
-- import Data.Function ((&))
-- 
import Colonnade hiding (fromMaybe, singleton)
import Yesod.Colonnade
-- 
import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E

import Control.Monad.Writer (MonadWriter(..), execWriterT)

import Network.Mime

import qualified Data.Set as Set


instance Eq (Unique Sheet) where
  (CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
    cid1 == cid2 && name1 == name2

{-
  * Implement Handlers
  * Implement Breadcrumbs in Foundation 
  * Implement Access in Foundation
-}

data SheetForm = SheetForm
      { sfName         :: Text
      , sfDescription  :: Maybe Html
      , sfType         :: SheetType
      , sfGrouping     :: SheetGroup
      , sfMarkingText  :: Maybe Html
      , sfVisibleFrom  :: Maybe UTCTime
      , sfActiveFrom   :: UTCTime
      , sfActiveTo     :: UTCTime
      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
      , sfHintFrom     :: Maybe UTCTime
      , sfHintF        :: Maybe FileInfo
      , sfSolutionFrom :: Maybe UTCTime
      , sfSolutionF    :: Maybe FileInfo
      -- Keine SheetId im Formular!
      }


makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
makeSheetForm msId template = identForm FIDsheet $ \html -> do
    let oldFileIds fType
          | Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
              E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
              E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
                   E.&&. sheetFile E.^. SheetFileType    E.==. E.val fType
              return (file E.^. FileId)
          | otherwise = return Set.empty
  
    (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
      <$> areq textField      (fsb "Name")                     (sfName <$> template)
      <*> aopt htmlField      (fsb "Hinweise für Teilnehmer")  (sfDescription <$> template)
      <*> sheetTypeAFormReq   (fsb "Bewertung")                (sfType <$> template)
      <*> sheetGroupAFormReq  (fsb "Abgabegruppengröße") (sfGrouping <$> template)
      <*> aopt htmlField      (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
      <*> aopt utcTimeField   (fsb "Sichtbar ab") (sfVisibleFrom  <$> template)
      <*> areq utcTimeField   (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
      <*> areq utcTimeField   (fsb "Abgabefrist") (sfActiveTo     <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fsb "Aufgabenstellung") (sfSheetF <$> template)
      <*> aopt utcTimeField   (fsb "Hinweis ab")  (sfHintFrom     <$> template)
      <*> fileAFormOpt        (fsb "Hinweis")
      <*> aopt utcTimeField   (fsb "Lösung ab")   (sfSolutionFrom <$> template)
      <*> fileAFormOpt        (fsb "Lösung")
      <*  submitButton
    return $ case result of
      FormSuccess sheetResult
        | errorMsgs <- validateSheet sheetResult
        , not $ null errorMsgs ->
            (FormFailure errorMsgs,
                  [whamlet|
                    <div class="alert alert-danger">
                      <h4> Fehler:
                      <ul>
                        $forall errmsg <- errorMsgs
                          <li> #{errmsg}
                    ^{widget}
                  |]
                )
      _ -> (result, widget)
  where
    validateSheet :: SheetForm -> [Text]
    validateSheet (SheetForm{..}) =
      [ msg | (False, msg) <-
        [ ( maybe True (sfActiveFrom >=) sfVisibleFrom
          , "Sichtbarkeit muss vor Beginn der Abgabefrist liegen."
          )
        , ( sfActiveTo >= sfActiveFrom
          , "Ende der Abgabefrist muss nach deren Beginn liegen."
          )
        -- TODO: continue validation here!!!
      ] ]




-- List Sheets
getSheetListCID :: CourseId -> Handler Html
getSheetListCID cid = getSheetList =<<
  (Entity cid) <$> (runDB $ get404 cid)

getSheetListR :: TermId -> Text -> Handler Html
getSheetListR tid csh = getSheetList =<<
  (runDB $ getBy404 $ CourseTermShort tid csh)

getSheetList :: Entity Course -> Handler Html
getSheetList courseEnt = do
  -- mbAid <- maybeAuthId
  let cid    = entityKey courseEnt
  let course = entityVal courseEnt
  let csh    = courseShorthand course
  let tid    = courseTerm course
  sheets <- runDB $ do
    rawSheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
    forM rawSheets $ \(Entity sid sheet) -> do
        let sheetsub = [SubmissionSheet ==. sid]
        submissions <- count sheetsub
        rated       <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
        return (sid, sheet, (submissions, rated))
  let colBase = mconcat
        [ headed "Blatt"       $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet
        , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
        , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
        , headed "Bewertung"   $ toWgt . show . sheetType . snd3
        ]
  let colAdmin = mconcat -- only show edit button for allowed course assistants
        [ headed "Korrigiert"  $ toWgt . snd . trd3
        , headed "Eingereicht" $ toWgt . fst . trd3
        , headed ""            $ \s -> linkButton "Edit"   BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s
        , headed ""            $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR  $ sheetName $ snd3 s
        ]
  showAdmin <- case sheets of
    ((_,firstSheet,_):_) -> do
      setUltDestCurrent
      (Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False
    _otherwise   -> return False
  let colSheets = if showAdmin
        then colBase `mappend` colAdmin
        else colBase
  let pageActions =
        [ PageActionPrime $ MenuItem
          { menuItemLabel = "Neues Übungsblatt"
          , menuItemIcon  = Nothing
          , menuItemRoute = CSheetR tid csh SheetNewR
          , menuItemAccessCallback' = return True
          }
        ]
  defaultLinkLayout pageActions $ do
    setTitle $ toHtml $ T.append "Übungsblätter " csh
    if null sheets
      then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
      else encodeWidgetTable tableDefault colSheets sheets


-- Show single sheet
getSheetShowR :: TermId -> Text -> Text -> Handler Html
getSheetShowR tid csh shn = do
  entSheet <- runDB $ fetchSheet tid csh shn
  let sheet = entityVal entSheet
      sid   = entityKey entSheet
  --
  fileNameTypes <- runDB $ E.select $ E.from $
    \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
      -- Restrict to consistent rows that correspond to each other
      E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
      E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
      -- filter to requested file
      E.where_ (sheet     E.^. SheetId      E.==. E.val sid )
      -- return desired columns
      return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType)
  let fileLinks = map (\(E.Value fName, E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) fileNameTypes

  let pageActions =
        [ PageActionPrime $ MenuItem
          { menuItemLabel = "Abgabe"
          , menuItemIcon  = Nothing
          , menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission)
          , menuItemAccessCallback' = return True
          }
        ]
  defaultLinkLayout pageActions $ do
    setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
    $(widgetFile "sheetShow")
    [whamlet| Under Construction !!! |] -- TODO

getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
getSheetFileR tid csh shn typ title = do
  content <- runDB $ E.select $ E.from $
    \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
      -- Restrict to consistent rows that correspond to each other
      E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
      E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
      E.on (sheet     E.^. SheetCourse    E.==. course    E.^. CourseId)
      -- filter to requested file
      E.where_ ((file      E.^. FileTitle       E.==. E.val title)
        E.&&.   (sheetFile E.^. SheetFileType   E.==. E.val typ  )
        E.&&.   (sheet     E.^. SheetName       E.==. E.val shn  )
        E.&&.   (course    E.^. CourseShorthand E.==. E.val csh  )
        E.&&.   (course    E.^. CourseTerm    E.==. E.val tid  )
        )
      -- return desired columns
      return $ file E.^. FileContent
  let mimeType = defaultMimeLookup $ pack title
  case content of
    [E.Value (Just nochmalContent)] -> do
      addHeader "Content-Disposition" "attachment"
      respond mimeType nochmalContent
    []     -> notFound
    _other -> error "Multiple matching files found."


getSheetNewR :: TermId -> Text -> Handler Html
getSheetNewR tid csh = do
  let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
  let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
        insertUnique $ newSheet
  handleSheetEdit tid csh Nothing template action

postSheetNewR :: TermId -> Text -> Handler Html
postSheetNewR = getSheetNewR


getSheetEditR :: TermId -> Text -> Text -> Handler Html
getSheetEditR tid csh shn = do
  (sheetEnt, sheetFileIds) <- runDB $ do
    ent <- fetchSheet tid csh shn
    fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent)
           E.&&. sheetFile E.^. SheetFileType    E.==. E.val SheetExercise
      return (file E.^. FileId)
    return (ent, fIds)
  let sid = entityKey sheetEnt
  let oldSheet@(Sheet {..}) = entityVal sheetEnt
  let template = Just $ SheetForm
        { sfName         = sheetName
        , sfDescription  = sheetDescription
        , sfType         = sheetType
        , sfGrouping     = sheetGrouping
        , sfMarkingText  = sheetMarkingText
        , sfVisibleFrom  = sheetVisibleFrom
        , sfActiveFrom   = sheetActiveFrom
        , sfActiveTo     = sheetActiveTo
        , sfSheetF       = Just . yieldMany . map Left $ Set.toList sheetFileIds
        , sfHintFrom     = sheetHintFrom
        , sfHintF        = Nothing -- TODO
        , sfSolutionFrom = sheetSolutionFrom
        , sfSolutionF    = Nothing -- TODO
        }
  let action newSheet = do
        replaceRes <- myReplaceUnique sid $ newSheet
        case replaceRes of
          Nothing     -> return $ Just sid
          (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
  handleSheetEdit tid csh (Just sid) template action

postSheetEditR :: TermId -> Text -> Text -> Handler Html
postSheetEditR = getSheetEditR

handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid csh msId template dbAction = do
  let tident = unTermKey tid
  let mbshn  = sfName <$> template
  aid  <- requireAuthId
  ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
  case res of
    (FormSuccess SheetForm{..}) -> do
      saveOkay <- runDB $ do
        actTime <- liftIO getCurrentTime
        cid <- getKeyBy404 $ CourseTermShort tid csh
        let newSheet = Sheet
              { sheetCourse     = cid
              , sheetName         = sfName
              , sheetDescription  = sfDescription
              , sheetType         = sfType
              , sheetGrouping     = sfGrouping
              , sheetMarkingText  = sfMarkingText
              , sheetVisibleFrom  = sfVisibleFrom
              , sheetActiveFrom   = sfActiveFrom
              , sheetActiveTo     = sfActiveTo
              , sheetHintFrom     = sfHintFrom
              , sheetSolutionFrom = sfSolutionFrom
              }
        mbsid <- dbAction newSheet
        case mbsid of
          Nothing    -> False <$ addMessageI "danger" (MsgSheetNameDup tident csh sfName)
          (Just sid) ->  do -- save files in DB:
            whenIsJust sfSheetF    $ insertSheetFile' sid SheetExercise
            whenIsJust sfHintF     $ insertSheetFile sid SheetHint
            whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution
            insert_ $ SheetEdit aid actTime sid
            addMessageI "info" $ MsgSheetEditOk tident csh sfName
            return True
      when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB
    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
    _ -> return ()
  let pageTitle = maybe (MsgSheetTitleNew tident csh)
                        (MsgSheetTitle    tident csh) mbshn
  let formTitle = pageTitle
  let formText  = Nothing :: Maybe UniWorXMessage
  actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute
  defaultLayout $ do
    setTitleI pageTitle
    $(widgetFile "formPageI18n")



getSheetDelR :: TermId -> Text -> Text -> Handler Html
getSheetDelR tid csh shn = do
  let tident = unTermKey tid
  ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
  case result of
    (FormSuccess BtnAbort)  -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn
    (FormSuccess BtnDelete) -> do
      runDB $ fetchSheetId tid csh shn >>= deleteCascade
      -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
      addMessageI "info" $ MsgSheetDelOk tident csh shn
      redirect $ CSheetR tid csh SheetListR
    _other -> do
      submissionno <- runDB $ do
          sid <- fetchSheetId tid csh shn
          count [SubmissionSheet ==. sid]
      let formTitle = MsgSheetDelTitle tident csh shn
      let formText  = Just $ MsgSheetDelText submissionno
      let actionUrl = CSheetR tid csh $ SheetDelR shn
      defaultLayout $ do
        setTitleI $ MsgSheetTitle tident csh shn
        $(widgetFile "formPageI18n")

postSheetDelR :: TermId -> Text -> Text -> Handler Html
postSheetDelR = getSheetDelR



insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
insertSheetFile sid ftype finfo = do
    runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
  where
    finsert file = do
      fid <- insert file
      void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step

insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
insertSheetFile' sid ftype fs = do
    oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
           E.&&. sheetFile E.^. SheetFileType    E.==. E.val ftype
      return (file E.^. FileId)
    keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
    mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
  where
    finsert (Left fileId) = tell $ singleton fileId
    finsert (Right file) = lift $ do
      fid <- insert file
      void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step