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