fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix hlint

Browse Source
This commit is contained in:
Gregor Kleen 2019-05-04 18:25:06 +02:00
parent 4d7d3f43a5
commit 95298f856e
4 changed files with 15 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/Handler/Material.hs
View File

@ -48,10 +48,10 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
previouslyUsed <- liftHandlerT . runDB $ previouslyUsed <- liftHandlerT . runDB $
E.select $ E.from $ \material -> E.select $ E.from $ \material ->
E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
E.where_ $ (material E.^. MaterialCourse E.==. E.val cid) E.where_ $ material E.^. MaterialCourse E.==. E.val cid
E.&&. (E.not_ $ E.isNothing $ material E.^. MaterialType) E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
return $ material E.^. MaterialType return $ material E.^. MaterialType
return $ defaults <> (Set.fromList $ mapMaybe E.unValue previouslyUsed) return $ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed)
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
flip (renderAForm FormStandard) html $ MaterialForm flip (renderAForm FormStandard) html $ MaterialForm
@ -88,7 +88,7 @@ getMaterialListR tid ssh csh = do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let row2material = entityVal . dbrOutput -- no inner join, just Entity Material let row2material = entityVal . dbrOutput -- no inner join, just Entity Material
psValidator = def & defaultSorting [SortDescBy "last-edit"] psValidator = def & defaultSorting [SortDescBy "last-edit"]
table <- dbTableWidget' psValidator DBTable dbTableWidget' psValidator DBTable
{ dbtIdent = "material-list" :: Text { dbtIdent = "material-list" :: Text
, dbtStyle = def , dbtStyle = def
, dbtParams = def , dbtParams = def
@ -120,10 +120,9 @@ getMaterialListR tid ssh csh = do
, dbtFilter = mempty , dbtFilter = mempty
, dbtFilterUI = mempty , dbtFilterUI = mempty
} }
return table
let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialListHeading let headingLong = prependCourseTitle tid ssh csh MsgMaterialListHeading
headingShort = prependCourseTitle tid ssh csh $ MsgMaterialListHeading headingShort = prependCourseTitle tid ssh csh MsgMaterialListHeading
siteLayoutMsg headingLong $ do siteLayoutMsg headingLong $ do
setTitleI headingShort setTitleI headingShort
$(widgetFile "material-list") $(widgetFile "material-list")
@ -152,7 +151,7 @@ getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Ht
getMShowR tid ssh csh mnm = do getMShowR tid ssh csh mnm = do
let matLink :: FilePath -> Route UniWorX let matLink :: FilePath -> Route UniWorX
matLink = CourseR tid ssh csh . MaterialR mnm . MFileR matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
( (Entity _mid material@Material{materialType, materialDescription}) ( Entity _mid material@Material{materialType, materialDescription}
, (Any hasFiles,fileTable)) <- runDB $ do , (Any hasFiles,fileTable)) <- runDB $ do
matEnt <- fetchMaterial tid ssh csh mnm matEnt <- fetchMaterial tid ssh csh mnm
let psValidator = def & defaultSortingByFileTitle let psValidator = def & defaultSortingByFileTitle
@ -182,7 +181,7 @@ getMShowR tid ssh csh mnm = do
return (matEnt,fileTable') return (matEnt,fileTable')
let matVisFro = materialVisibleFrom material let matVisFro = materialVisibleFrom material
now <- liftIO $ getCurrentTime now <- liftIO getCurrentTime
materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material
materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro
when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $ when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $
@ -206,7 +205,7 @@ postMEditR tid ssh csh mnm = do
return $ file E.^. FileId return $ file E.^. FileId
return (matEnt, (Left . E.unValue) <$> fileIds) return (matEnt, (Left . E.unValue) <$> fileIds)
-- let cid = materialCourse -- let cid = materialCourse
let template = Just $ MaterialForm let template = Just MaterialForm
{ mfName = materialName { mfName = materialName
, mfType = materialType , mfType = materialType
, mfDescription = materialDescription , mfDescription = materialDescription
@ -274,7 +273,7 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
return $ file E.^. FileId return $ file E.^. FileId
let oldFileIds = setFromList $ map E.unValue oldFileIdVals let oldFileIds = setFromList $ map E.unValue oldFileIdVals
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId) mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
where where
finsert (Left fileId) = tell $ singleton fileId finsert (Left fileId) = tell $ singleton fileId
finsert (Right file) = lift $ do finsert (Right file) = lift $ do
@ -299,4 +298,4 @@ postMDelR tid ssh csh mnm = do
, drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR , drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR
, drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR , drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
} }
-} -}

2
src/Handler/Utils.hs
View File

@ -52,7 +52,7 @@ serveOneFile :: DB [Entity File] -> Handler TypedContent
serveOneFile query = do serveOneFile query = do
results <- runDB query results <- runDB query
case results of case results of
[(Entity _fileId File{fileTitle, fileContent})] [Entity _fileId File{fileTitle, fileContent}]
| Just fileContent' <- fileContent -> do | Just fileContent' <- fileContent -> do
whenM downloadFiles $ whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]

4
src/Handler/Utils/DateTime.hs
View File

@ -203,5 +203,5 @@ ceilingMinuteBy margin roundto utct = addUTCTime bonus utct
oldTime = localTimeOfDay $ utcToLocalTime utct oldTime = localTimeOfDay $ utcToLocalTime utct
oldMin = todMin oldTime oldMin = todMin oldTime
newMin = roundToNearestMultiple roundto $ oldMin + margin newMin = roundToNearestMultiple roundto $ oldMin + margin
newTime = oldTime { todMin = newMin, todSec = 0} -- might be invalid, but correctly treated by `timeOfDayToTime` newTime = oldTime { todMin = newMin, todSec = 0 } -- might be invalid, but correctly treated by `timeOfDayToTime`
bonus = realToFrac $ (timeOfDayToTime newTime) - (timeOfDayToTime oldTime) bonus = realToFrac $ timeOfDayToTime newTime - timeOfDayToTime oldTime

2
src/Handler/Utils/Table/Cells.hs
View File

@ -55,7 +55,7 @@ sqlCell act = mempty & cellContents .~ lift act
markCell :: (IsDBTable m a) => (a -> Bool) -> (a -> DBCell m a) -> a -> DBCell m a markCell :: (IsDBTable m a) => (a -> Bool) -> (a -> DBCell m a) -> a -> DBCell m a
markCell condition normal x markCell condition normal x
| condition x = (normal x) <> (cell $ isVisibleWidget False) | condition x = normal x <> cell (isVisibleWidget False)
| otherwise = normal x | otherwise = normal x