module Handler.Material
  ( getMaterialListR
  , getMFileR, getMVideoR
  , getMShowR
  , getMEditR, postMEditR
  , getMaterialNewR, postMaterialNewR
  , getMDelR, postMDelR
  , getMArchiveR
  ) where

import Import

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

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E

import Utils.Form
import Handler.Utils
import Handler.Utils.Delete


data MaterialForm = MaterialForm
      { mfName         :: MaterialName
      , mfType         :: Maybe (CI Text)
      , mfDescription  :: Maybe StoredMarkup
      , mfVisibleFrom  :: Maybe UTCTime
      , mfFiles        :: Maybe FileUploads
      }

makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
  MsgRenderer mr <- getMsgRenderer
  let typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
      typeOptions = do
        let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
        previouslyUsed <- runDB $
          E.select $ E.from $ \material ->
            E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
              E.where_ $ material E.^. MaterialCourse E.==. E.val cid
                   E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
              return $ material E.^. MaterialType
        return . mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList
          $ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed)

  now <- liftIO getCurrentTime
  let ctime = ceilingQuarterHour now
  let visibleToolTip = case mfVisibleFrom <$> template of
        (Just (Just vistime))  |  vistime <= now
          -> MsgMaterialVisibleFromEditWarning
        _ -> MsgMaterialVisibleFromTip

  flip (renderAForm FormStandard) html $ MaterialForm
      <$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName)         (mfName        <$> template)
      <*> aopt (textField & cfStrip & guardField (not . null) & cfCI & addDatalist typeOptions)
                              (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
                                                             (mfType        <$> template)
      <*> aopt htmlField      (fslI MsgMaterialDescription)
                                                             (mfDescription <$> template)
      <*> aopt utcTimeField   (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip)
                                                            ((mfVisibleFrom <$> template) <|> pure (Just ctime))
      <*> aopt (multiFileField' . maybeVoid $ mfFiles =<< template)
                              (fslI MsgMaterialFiles)        (mfFiles <$> template)

fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
fetchMaterial tid ssh csh mnm =
  maybe notFound return . listToMaybe <=< E.select . E.from  $ -- uniqueness guaranteed by DB constraints
    \(course `E.InnerJoin` material) -> do
      E.on     $ course   E.^. CourseId   E.==.   material E.^. MaterialCourse
      E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
          E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
          E.&&.  course   E.^. CourseShorthand E.==. E.val csh
          E.&&.  material E.^. MaterialName    E.==. E.val mnm
      return material


getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getMaterialListR tid ssh csh = do
  let matLink :: MaterialName -> Route UniWorX
      matLink = CourseR tid ssh csh . flip MaterialR MShowR

      filesLink :: MaterialName -> SomeRoute UniWorX
      filesLink mnm = SomeRoute . CourseR tid ssh csh $ MaterialR mnm MArchiveR 

      materialModDateCell :: IsDBTable m a => Material -> DBCell m a
      materialModDateCell Material{materialVisibleFrom, materialLastEdit}
        | NTop materialVisibleFrom >= NTop (Just materialLastEdit)
            = mempty -- empty cells mean no modification after publication
        | otherwise = dateTimeCell materialLastEdit -- modification after publication is highlighted by being shown

  now <- liftIO getCurrentTime
  seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility
  MsgRenderer mr <- getMsgRenderer
  table <- runDB $ do
    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    let typeOptions :: HandlerFor UniWorX (OptionList Text)
        typeOptions = do
          previouslyUsed <- runDB $
            E.select $ E.from $ \material ->
              E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
                E.where_ $ material E.^. MaterialCourse E.==. E.val cid
                    E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
                return $ material E.^. MaterialType
          return . mkOptionList . map (\(CI.original -> t) -> Option t t t) . Set.toAscList . Set.fromList $ mapMaybe E.unValue previouslyUsed
    let row2material = view $ _dbrOutput . _1 . _entityVal
        psValidator  = def & defaultSorting [SortDescBy "last-edit"]
                           & forceFilter "may-access" (Any True)
    dbTableWidget' psValidator DBTable
      { dbtIdent     = "material-list" :: Text
      , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout } 
      , dbtParams    = def
      , dbtSQLQuery  = \material -> do 
          E.where_ $ material E.^. MaterialCourse  E.==.  E.val cid
          let filesNum :: E.SqlExpr (E.Value Int64)
              filesNum = E.subSelectCount . E.from $ \materialFile ->
                E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
          return (material, filesNum)
      , dbtRowKey    = (E.^. MaterialId)
      , dbtProj      = dbtProjFilteredPostId 
      , dbtColonnade = widgetColonnade $ mconcat 
            [ -- dbRow,
              sortable (Just "type") (i18nCell MsgMaterialType)
                $ foldMap (textCell . CI.original) . materialType . row2material
            , sortable (Just "name") (i18nCell MsgMaterialName)
                $ liftA2 anchorCell matLink toWgt . materialName . row2material
            , sortable (toNothingS "description") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialDescription))
                $ foldMap modalCell . materialDescription . row2material
            , sortable (toNothingS "zip-archive") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialFiles))
                $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
                  | fileNum == 0 -> mempty
                  | otherwise    -> anchorCell (filesLink materialName) iconFileDownload
            , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
                $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
            , sortable (Just "last-edit") (i18nCell MsgTableFileModified)
                $ if seeAllModificationTimestamps
                    then dateTimeCell . materialLastEdit . row2material
                    else materialModDateCell . row2material
            ]
      , dbtSorting   = Map.fromList
            [ ( "type"         , SortColumn (E.^. MaterialType)        )
            , ( "name"         , SortColumn (E.^. MaterialName)        )
            , ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) )
            , ( "last-edit"    , SortColumn (E.^. MaterialLastEdit)    )
            ]
      , dbtFilter    = mconcat
        [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr
            -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
        , singletonMap "name". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of
              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
              Just needle -> E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
        , singletonMap "type-and-description". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of
              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
              Just needle -> (E.maybe (E.val mempty) E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                       E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))   
        ]
      , dbtFilterUI  = \mPrev -> mconcat $ catMaybes
        [ Just  $ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch)
        , Just  $ prismAForm (singletonFilter "type-and-description") mPrev $ aopt (textField & addDatalist typeOptions) (fslI MsgFilterMaterialTypeAndDescriptionSearch)]
      , dbtCsvEncode  = noCsvEncode
      , dbtCsvDecode  = Nothing
      , dbtExtraReps = []
      }

  let headingLong  = prependCourseTitle tid ssh csh MsgMaterialListHeading
      headingShort = prependCourseTitle tid ssh csh MsgMaterialListHeading
  siteLayoutMsg headingLong $ do
    setTitleI headingShort
    $(widgetFile "material-list")




getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent
getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
  where
    fileQuery = E.selectSource $ E.from $
      \(course `E.InnerJoin` material `E.InnerJoin` matFile) -> do
        -- Restrict to consistent rows that correspond to each other
        E.on (matFile  E.^. MaterialFileMaterial E.==. material E.^. MaterialId)
        E.on (material E.^. MaterialCourse       E.==. course   E.^. CourseId)
        -- filter to requested file
        E.where_ ((matFile   E.^. MaterialFileTitle E.==. E.val title)
          E.&&.   (material  E.^. MaterialName      E.==. E.val mnm  )
          E.&&.   (course    E.^. CourseShorthand   E.==. E.val csh  )
          E.&&.   (course    E.^. CourseSchool      E.==. E.val ssh  )
          E.&&.   (course    E.^. CourseTerm        E.==. E.val tid  )
          )
        -- return file entity
        return matFile

getMVideoR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html
getMVideoR tid ssh csh mnm cID = do
  mfId <- decrypt cID
  MaterialFile{..} <- runDB $ get404 mfId
  let mimeType = mimeLookup $ pack materialFileTitle
      mfile = CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
  let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, toPathPiece True) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params)
  mfileText <- toTextUrl mfile
  mfileDownloadText <- toTextUrl mfileDownload
  unless (mimeType `Set.member` videoTypes) $
    redirectWith movedPermanently301 mfile
  siteLayout' Nothing $ do
    setTitleI . prependCourseTitle tid ssh csh $ MsgMaterialVideo mnm
    [whamlet|
      $newline never
      <section>
        <div .video-container>
          <video controls autoplay preload=auto>
            <source src=#{mfileText} type=#{decodeUtf8 mimeType}>
            _{MsgMaterialVideoUnsupported}
      <section>
        <a .btn href=#{mfileDownloadText}>
          ^{iconFileDownload} #
          _{MsgMaterialVideoDownload}
    |]
    

getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMShowR tid ssh csh mnm = do
  seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility

  (Entity _mid material@Material{materialType, materialDescription}, (Any hasFiles,fileTable), zipLink) <- runDB $ do
    let zipLink = CMaterialR tid ssh csh mnm MArchiveR
    matEnt <- fetchMaterial tid ssh csh mnm
    let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
        materialModDateCol = if seeAllModificationTimestamps
          then colFileModification
          else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt)
    let psValidator = def & defaultSortingByFileTitle
    fileTable' <- dbTable psValidator DBTable
      { dbtSQLQuery = \matFile -> do
            E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
                E.&&.  E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories
            return matFile
      , dbtRowKey = (E.^. MaterialFileId)
      , dbtColonnade = widgetColonnade $ mconcat
            [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgTableFileTitle) $ \(dbrOutput -> Entity mfId MaterialFile{..})
                -> let matLink
                         | isVideo
                         = CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId
                         | otherwise
                         = pure . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
                       wgt = [whamlet|
                               $newline never
                               <span .file-path>
                                 #{materialFileTitle}
                                 $if isVideo
                                   \ ^{iconVideo}
                             |]
                       isVideo = mimeLookup (pack materialFileTitle) `Set.member` videoTypes
                    in anchorCellM matLink wgt
            , materialModDateCol  (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified))
            ]
      , dbtProj     = dbtProjId
      , dbtStyle    = def
      , dbtParams   = def
      , dbtFilter   = mempty
      , dbtFilterUI = mempty
      , dbtIdent    = "material-files" :: Text
      , dbtSorting  = Map.fromList
        [ sortFilePath         id
        , sortFileModification id
        ]
      , dbtCsvEncode  = noCsvEncode
      , dbtCsvDecode  = Nothing
      , dbtExtraReps = []
      }
    return (matEnt,fileTable',zipLink)
  -- File table has no filtering by access, because we assume that
  -- access rights to material and material-files are identical.

  let matLastEdit      = formatTimeW    SelFormatDateTime  $  materialLastEdit    material
  let matVisibleFromMB = visibleUTCTime SelFormatDateTime <$> materialVisibleFrom material

  let headingLong  = prependCourseTitle tid ssh csh $ MsgMaterialHeading mnm
      headingShort = prependCourseTitle tid ssh csh $ SomeMessage mnm
  siteLayoutMsg headingLong $ do
    setTitleI headingShort
    $(widgetFile "material-show")


getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMEditR = postMEditR
postMEditR tid ssh csh mnm = do
  (Entity mid Material{..}, files) <- runDB $ do
    matEnt <- fetchMaterial tid ssh csh mnm
    mFileEnts <- selectList [ MaterialFileMaterial ==. entityKey matEnt ] []
    return (matEnt, mFileEnts)
  -- let cid = materialCourse
  let template = Just MaterialForm
        { mfName         = materialName
        , mfType         = materialType
        , mfDescription  = materialDescription
        , mfVisibleFrom  = materialVisibleFrom
        , mfFiles        = Just $ yieldMany [ matFile ^. _FileReference . _1 | Entity _ matFile <- files ]
        }
  editWidget <- handleMaterialEdit tid ssh csh materialCourse template $ uniqueReplace mid
  let headingLong  = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm
      headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle   mnm
  siteLayoutMsg headingLong $ do
    setTitleI headingShort
    editWidget


getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getMaterialNewR = postMaterialNewR
postMaterialNewR tid ssh csh = do
  Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  editWidget <- handleMaterialEdit tid ssh csh cid Nothing insertUnique
  let headingLong  = prependCourseTitle tid ssh csh MsgMaterialNewHeading
      headingShort = prependCourseTitle tid ssh csh MsgMaterialNewTitle
  siteLayoutMsg headingLong $ do
    setTitleI headingShort
    editWidget

handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> CourseId -> Maybe MaterialForm -> (Material -> DB (Maybe MaterialId)) -> Handler Widget
handleMaterialEdit tid ssh csh cid template dbMaterial = do
    ((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template
    formResult res saveMaterial
    -- actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute
    return $ wrapForm formWidget def
        { formAction   = Nothing -- Just $ SomeRoute actionUrl
        , formEncoding = formEnctype
        }
  where
    saveMaterial :: MaterialForm -> Handler ()
    saveMaterial MaterialForm{..} = do
      _aid <- requireAuthId
      now <- liftIO getCurrentTime
      let newMaterial = Material
            { materialCourse      = cid
            , materialName        = mfName
            , materialType        = mfType
            , materialDescription = mfDescription
            , materialVisibleFrom = mfVisibleFrom
            , materialLastEdit    = now
            }
      saveOk <- runDB $ do
        mbmid <- dbMaterial newMaterial
        case mbmid of
          Nothing -> False <$ addMessageI Error (MsgMaterialNameDup tid ssh csh mfName)
          (Just mid) -> do -- save files in DB
            insertMaterialFile' mid $ maybeVoid mfFiles
            addMessageI Success $ MsgMaterialSaveOk tid ssh csh mfName
            -- more info/warnings could go here
            return True
      when saveOk $ redirect -- redirect must happen outside of runDB
        $ CourseR tid ssh csh (MaterialR mfName MShowR)

    insertMaterialFile' :: MaterialId -> FileUploads -> DB ()
    insertMaterialFile' mid = (void . ) . replaceFileReferences mkFilter $ MaterialFileResidual mid
      where mkFilter MaterialFileResidual{..} = [ MaterialFileMaterial ==. materialFileResidualMaterial ]

getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand ->  MaterialName -> Handler Html
getMDelR = postMDelR
postMDelR tid ssh csh mnm = do
  matEnt <- runDB $ fetchMaterial tid ssh csh mnm
  deleteR DeleteRoute
    { drRecords = Set.singleton $ entityKey matEnt
    , drGetInfo = \(material `E.InnerJoin` course) -> do
        E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
        let filecount :: E.SqlExpr (E.Value Int64)
            filecount = E.subSelectCount . E.from $ \matfile ->
                E.where_ $ matfile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
        return (material,course,filecount)
    , drUnjoin  = \(material `E.InnerJoin` _course) -> material
    , drRenderRecord  = \(Entity _ Material{..}, Entity _ Course{..}, E.Value fileCount) -> do
        now <- liftIO getCurrentTime
        let isPublished = NTop (Just now)  >=  NTop materialVisibleFrom
            pCT = prependCourseTitle courseTerm courseSchool courseShorthand
        return [whamlet|
          _{SomeMessage $ pCT $ MsgMaterialHeading materialName}
          $if fileCount /= 0
            &nbsp;<i>_{SomeMessage $ MsgMaterialDelHasFiles fileCount}
          $if isPublished
            &nbsp;_{SomeMessage $ MsgMaterialIsVisible}
        |]
    , drRecordConfirmString = \(Entity _ Material{..}, Entity _ Course{..}, E.Value fileCount) ->
        return $ [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{materialName}|] <> bool mempty [st| + #{tshow fileCount} Files|] (fileCount /= 0)
    , drCaption        = SomeMessage   MsgMaterialDeleteCaption
    , drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm
    , drFormMessage = const $ return Nothing
    , drSuccess = SomeRoute $ CourseR tid ssh csh   MaterialListR
    , drAbort   = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
    , drDelete  = const id  -- TODO: audit 
    }

materialArchiveSource :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> ConduitT () MaterialFile (YesodDB UniWorX) ()
materialArchiveSource tid ssh csh mnm = (.| C.map entityVal) . E.selectSource . E.from $
  \(course `E.InnerJoin` material `E.InnerJoin` materialFile) -> do
    E.on $ material E.^. MaterialId     E.==. materialFile E.^. MaterialFileMaterial
    E.on $ material E.^. MaterialCourse E.==. course       E.^. CourseId
    E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
        E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
        E.&&.  course   E.^. CourseShorthand E.==. E.val csh
        E.&&.  material E.^. MaterialName    E.==. E.val mnm
    return materialFile

-- | Serve all material-files
getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
getMArchiveR tid ssh csh mnm = do
  archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm

  let getMatQuery = materialArchiveSource tid ssh csh mnm
  serveSomeFiles archiveName getMatQuery
