module Handler.Material where import Import 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.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 (CourseId, Entity Material) fetchMaterial tid ssh csh mnm = do [(E.Value cid, 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 (course E.^. CourseId, material) return (cid, matEnt) getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR = error "unimplemented" -- TODO 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 _ <- runDB $ do (cid, matEnt) <- fetchMaterial tid ssh csh mnm let psValidator = def & defaultSortingByFileTitle 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 [ colFilePathSimple (view _1) matLink , colFileModification (view _2) ] , dbtProj = \row -> let dbrOutput = row ^. _dbrOutput fPath = dbrOutput ^. _1 . _Value in guardAuthorizedFor (matLink fPath) dbrOutput , dbtStyle = def , dbtParams = def , dbtFilter = mempty , dbtFilterUI = mempty , dbtIdent = "material-files" :: Text , dbtSorting = Map.fromList [ sortFilePath $ $(sqlIJproj 2 2) E.^. FileTitle , sortFileModification $ $(sqlIJproj 2 2) E.^. FileModified ] } -- DEAD CODE TO DELETE: -- (cid, Entity mid Material{..}, files) <- runDB $ do -- (cid, 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 (cid, matEnt, (Left . E.unValue) <$> fileIds) error "unimplemented" -- TODO getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMEditR = postMEditR postMEditR tid ssh csh mnm = do (cid, Entity mid Material{..}, files) <- runDB $ do (cid, 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 (cid, matEnt, (Left . E.unValue) <$> fileIds) let template = Just $ MaterialForm { mfName = materialName , mfType = materialType , mfDescription = materialDescription , mfVisibleFrom = materialVisibleFrom , mfFiles = Just $ yieldMany files } editWidget <- handleMaterialEdit tid ssh csh cid 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 (_cid, _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 } -}