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 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) ctime <- ceilingQuarterHour <$> liftIO getCurrentTime 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 MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) <*> aopt (multiFileField oldFileIds) (fslI MsgMaterialFiles) (mfFiles <$> template) 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 now <- liftIO getCurrentTime table <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let row2material = entityVal . dbrOutput -- no inner join, just Entity Material 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 return material , 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 (Just "visible-from") (i18nCell MsgAccessibleSince) $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material , sortable (Just "last-edit") (i18nCell MsgFileModified) $ dateTimeCell . materialLastEdit . 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 where fileQuery = E.select $ 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 ( Entity _mid material@Material{materialType, materialDescription} , (Any hasFiles,fileTable)) <- runDB $ do matEnt <- fetchMaterial tid ssh csh mnm 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 , colFileModification (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 matVisFro = materialVisibleFrom material now <- liftIO getCurrentTime materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $ maybe MsgMaterialInvisible MsgMaterialInvisibleUntil materialVisibleFrom 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 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 error "todo" -- CONTINUE HERE {- deleteR DeleteRoute { drRecords = Set.singleton $ entityKey matEnt , drGetInfo = error "todo" , drUnjoin = error "todo" , drRenderRecord = error "todo" , drRecordConfirmString = error "todo" , drCaption = SomeMessage MsgMaterialDeleteQuestion , drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm , drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR , drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR } -}