module Handler.Material where import Import import Data.Monoid (Any(..)) import Data.Set (Set) 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 as E import Database.Esqueleto.Utils.TH import Utils.Lens import Utils.Form import Handler.Utils import Handler.Utils.Delete import Handler.Utils.Table.Cells import Handler.Utils.Table.Columns import Control.Monad.Writer (MonadWriter(..), execWriterT) data MaterialForm = MaterialForm { mfName :: MaterialName , mfType :: Maybe Text , mfDescription :: Maybe Html , mfVisibleFrom :: Maybe UTCTime , mfFiles :: Maybe (Source Handler (Either FileId File)) } makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do MsgRenderer mr <- getMsgRenderer let setIds :: Either FileId File -> Set FileId setIds = either Set.singleton $ const Set.empty oldFileIds | Just source <- template >>= mfFiles = runConduit $ source .| C.foldMap setIds | otherwise = return Set.empty typeOptions :: WidgetT UniWorX IO (Set Text) typeOptions = do let defaults = Set.fromList $ map mr [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample] previouslyUsed <- liftHandlerT . 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 $ 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 ciField (fslI MsgMaterialName) (mfName <$> template) <*> aopt (textField & addDatalist typeOptions) (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder) (mfType <$> template) <*> aopt htmlField (fslpI MsgMaterialDescription "Html") (mfDescription <$> template) <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) <*> aopt (multiFileField oldFileIds) (fslI MsgMaterialFiles) (mfFiles <$> template) getMaterialKeyBy404 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Key Material) getMaterialKeyBy404 tid ssh csh mnm = do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh getKeyBy404 $ UniqueMaterial cid mnm fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) fetchMaterial tid ssh csh mnm = do [matEnt] <- 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 return matEnt 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 -> Route UniWorX filesLink = CourseR tid ssh csh . flip MaterialR 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 table <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let row2material = view $ _dbrOutput . _1 . _entityVal psValidator = def & defaultSorting [SortDescBy "last-edit"] dbTableWidget' psValidator DBTable { dbtIdent = "material-list" :: Text , dbtStyle = def , dbtParams = def , dbtSQLQuery = \material -> do E.where_ $ material E.^. MaterialCourse E.==. E.val cid let filesNum = E.sub_select . E.from $ \materialFile -> do E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64)) return (material, filesNum) , dbtRowKey = (E.^. MaterialId) -- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr , dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->) , dbtColonnade = widgetColonnade $ mconcat [ -- dbRow, sortable (Just "type") (i18nCell MsgMaterialType) $ foldMap textCell . materialType . row2material , sortable (Just "name") (i18nCell MsgMaterialName) $ liftA2 anchorCell matLink toWgt . materialName . row2material , sortable (toNothingS "description") mempty $ foldMap modalCell . materialDescription . row2material , sortable (toNothingS "zip-archive") mempty $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if | fileNum == 0 -> mempty | otherwise -> fileCell $ filesLink materialName , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material , sortable (Just "last-edit") (i18nCell MsgFileModified) $ 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 = mempty , dbtFilterUI = mempty } 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 `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile) E.on (matFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId) E.on (material E.^. MaterialCourse E.==. course E.^. CourseId) -- filter to requested file E.where_ ((file E.^. FileTitle 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 file getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMShowR tid ssh csh mnm = do let matLink :: FilePath -> Route UniWorX matLink = CourseR tid ssh csh . MaterialR mnm . MFileR zipLink :: Route UniWorX zipLink = CMaterialR tid ssh csh mnm MArchiveR 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)) <- runDB $ do 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 `E.InnerJoin` file) -> do E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories return (file E.^. FileTitle, file E.^. FileModified) , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId , dbtColonnade = widgetColonnade $ mconcat [ dbRowIndicator -- important: contains writer to indicate that the tables is not empty , colFilePathSimple (view $ _dbrOutput . _1) matLink , materialModDateCol (view $ _dbrOutput . _2) ] , dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr , dbtStyle = def , dbtParams = def , dbtFilter = mempty , dbtFilterUI = mempty , dbtIdent = "material-files" :: Text , dbtSorting = Map.fromList [ sortFilePath $(sqlIJproj 2 2) , sortFileModification $(sqlIJproj 2 2) ] } return (matEnt,fileTable') 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 fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) return $ file E.^. FileId return (matEnt, (Left . E.unValue) <$> fileIds) -- let cid = materialCourse let template = Just MaterialForm { mfName = materialName , mfType = materialType , mfDescription = materialDescription , mfVisibleFrom = materialVisibleFrom , mfFiles = Just $ yieldMany 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 $(i18nWidgetFile "html-input") 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 whenIsJust mfFiles $ insertMaterialFile' mid 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 -> Source Handler (Either FileId File) -> DB () insertMaterialFile' mid fs = do oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid return $ file E.^. FileId let oldFileIds = setFromList $ map E.unValue oldFileIdVals 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 $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step 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.sub_select . E.from $ \matfile -> do E.where_ $ matfile E.^. MaterialFileMaterial E.==. material E.^. MaterialId return (E.countRows :: E.SqlExpr (E.Value Int64)) 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  _{SomeMessage $ MsgMaterialDelHasFiles fileCount} $if isPublished  _{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 , drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR , drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR } -- | Serve all material-files getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery where archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip" getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $ \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile 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 file