248 lines
11 KiB
Haskell
248 lines
11 KiB
Haskell
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
|
|
}
|
|
-} |