diff --git a/.gitignore b/.gitignore index 8187c8e52..7f6bcdce0 100644 --- a/.gitignore +++ b/.gitignore @@ -29,4 +29,5 @@ uniworx.nix src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs *.orig +.stack-work-* .directory diff --git a/ChangeLog.md b/ChangeLog.md index c0392847e..e8491a064 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 06.08.2016 + + Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen + * Version 01.08.2018 Verbesserter Campus-Login diff --git a/config/settings.yml b/config/settings.yml index 1b0913f6f..72965a276 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,29 +1,26 @@ # Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable. # See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables +# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'") +# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings static-dir: "_env:STATIC_DIR:static" host: "_env:HOST:*4" # any IPv4 host -port: "_env:PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line. +port: "_env:PORT:3000" ip-from-header: "_env:IP_FROM_HEADER:false" - -# Default behavior: determine the application root from the request headers. -# Uncomment to set an explicit approot approot: "_env:APPROOT:http://localhost:3000" +detailed-logging: "_env:DETAILED_LOGGING:false" +should-log-all: "_env:LOG_ALL:false" +minimum-log-level: "_env:LOGLEVEL:warn" +auth-dummy-login: "_env:DUMMY_LOGIN:false" +auth-pwfile: "_env:PWFILE:" +allow-deprecated: "_env:ALLOW_DEPRECATED:false" + # Optional values with the following production defaults. -# In development, they default to the inverse. -# -detailed-logging: "_env:DETAILED_LOGGING:false" -should-log-all: "_env:LOG_ALL:false" +# In development, they default to true. # reload-templates: false # mutable-static: false # skip-combining: false -auth-dummy-login: "_env:DUMMY_LOGIN:false" -auth-pwfile: "_env:PWFILE:" -allow-deprecated: "_env:ALLOW_DEPRECATED:false" - -# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'") -# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings database: user: "_env:PGUSER:uniworx" @@ -35,22 +32,21 @@ database: poolsize: "_env:PGPOOLSIZE:10" ldap: - host: "_env:LDAPHOST:" - tls: "_env:LDAPTLS:" - port: "_env:LDAPPORT:389" - user: "_env:LDAPUSER:" - pass: "_env:LDAPPASS:" - baseDN: "_env:LDAPBASE:" - scope: "_env:LDAPSCOPE:WholeSubtree" - timeout: "_env:LDAPTIMEOUT:5" + host: "_env:LDAPHOST:" + tls: "_env:LDAPTLS:" + port: "_env:LDAPPORT:389" + user: "_env:LDAPUSER:" + pass: "_env:LDAPPASS:" + baseDN: "_env:LDAPBASE:" + scope: "_env:LDAPSCOPE:WholeSubtree" + timeout: "_env:LDAPTIMEOUT:5" -default-favourites: 12 -default-theme: Default -default-date-time-format: "%a %d %b %Y %R" -default-date-format: "%d.%m.%Y" -default-time-format: "%R" +user-defaults: + favourites: 12 + theme: Default + date-time-format: "%a %d %b %Y %R" + date-format: "%d.%m.%Y" + time-format: "%R" + download-files: false cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf" - -copyright: ©Institute for Informatics, LMU Munich -#analytics: UA-YOURCODE diff --git a/db.hs b/db.hs index 6db5f2188..54f0466f4 100755 --- a/db.hs +++ b/db.hs @@ -18,6 +18,8 @@ import System.Console.GetOpt import System.Exit (exitWith, ExitCode(..)) import System.IO (hPutStrLn, stderr) +import qualified Data.ByteString as BS + import Data.Time @@ -46,9 +48,15 @@ main = do hPutStrLn stderr $ usageInfo "db.hs" argsDescr exitWith $ ExitFailure 2 +insertFile :: FilePath -> DB FileId +insertFile fileTitle = do + fileContent <- liftIO $ Just <$> BS.readFile ("testdata/" <> fileTitle) + fileModified <- liftIO getCurrentTime + insert File{..} + fillDb :: DB () fillDb = do - AppSettings{..} <- getsYesod appSettings + AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings now <- liftIO getCurrentTime let summer2017 = TermIdentifier 2017 Summer @@ -61,10 +69,11 @@ fillDb = do , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" , userMaxFavourites = 6 - , userTheme = Default - , userDateTimeFormat = appDefaultDateTimeFormat - , userDateFormat = appDefaultDateFormat - , userTimeFormat = appDefaultTimeFormat + , userTheme = ThemeDefault + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles } fhamann <- insert User { userPlugin = "LDAP" @@ -72,11 +81,12 @@ fillDb = do , userMatrikelnummer = Nothing , userEmail = "felix.hamann@campus.lmu.de" , userDisplayName = "Felix Hamann" - , userMaxFavourites = appDefaultMaxFavourites - , userTheme = Default - , userDateTimeFormat = appDefaultDateTimeFormat - , userDateFormat = appDefaultDateFormat - , userTimeFormat = appDefaultTimeFormat + , userMaxFavourites = userDefaultMaxFavourites + , userTheme = ThemeDefault + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles } jost <- insert User { userPlugin = "LDAP" @@ -85,10 +95,11 @@ fillDb = do , userEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" , userMaxFavourites = 14 - , userTheme = MossGreen - , userDateTimeFormat = appDefaultDateTimeFormat - , userDateFormat = appDefaultDateFormat - , userTimeFormat = appDefaultTimeFormat + , userTheme = ThemeMossGreen + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles } void . insert $ User { userPlugin = "LDAP" @@ -97,10 +108,11 @@ fillDb = do , userEmail = "max@campus.lmu.de" , userDisplayName = "Max Musterstudent" , userMaxFavourites = 7 - , userTheme = AberdeenReds - , userDateTimeFormat = appDefaultDateTimeFormat - , userDateFormat = appDefaultDateFormat - , userTimeFormat = appDefaultTimeFormat + , userTheme = ThemeAberdeenReds + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles } void . insert $ Term { termName = summer2017 @@ -229,10 +241,10 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "ProMo" - , courseTerm = TermKey summer2017 + , courseTerm = TermKey summer2018 , courseSchool = ifi , courseCapacity = Just 50 - , courseRegisterFrom = Nothing + , courseRegisterFrom = Just now , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing @@ -241,6 +253,28 @@ fillDb = do insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo + sh1 <- insert Sheet + { sheetCourse = pmo + , sheetName = "Blatt 1" + , sheetDescription = Nothing + , sheetType = Normal 6 + , sheetGrouping = Arbitrary 3 + , sheetMarkingText = Nothing + , sheetVisibleFrom = Just now + , sheetActiveFrom = now + , sheetActiveTo = (14 * nominalDay) `addUTCTime` now + , sheetHintFrom = Nothing + , sheetSolutionFrom = Nothing + } + void . insert $ SheetEdit jost now sh1 + void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) + void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) + h102 <- insertFile "H10-2.hs" + h103 <- insertFile "H10-3.hs" + pdf10 <- insertFile "ProMo_Uebung10.pdf" + void . insert $ SheetFile sh1 h102 SheetHint + void . insert $ SheetFile sh1 h103 SheetSolution + void . insert $ SheetFile sh1 pdf10 SheetExercise -- datenbanksysteme dbs <- insert Course { courseName = "Datenbanksysteme" diff --git a/ghci.sh b/ghci.sh index 64adc58eb..5139c7c72 100755 --- a/ghci.sh +++ b/ghci.sh @@ -5,4 +5,15 @@ export DETAILED_LOGGING=true export LOG_ALL=true export DUMMY_LOGIN=true -exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only +move-back() { + mv -v .stack-work .stack-work-ghci + [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work +} + +if [[ -d .stack-work-ghci ]]; then + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run + mv -v .stack-work-ghci .stack-work + trap move-back EXIT +fi + +stack ghci --flag uniworx:dev --flag uniworx:library-only diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 941e705f0..411cdb696 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -248,6 +248,8 @@ UserListTitle: Komprehensive Benutzerliste DateTimeFormat: Datums- und Uhrzeitformat DateFormat: Datumsformat TimeFormat: Uhrzeitformat +DownloadFiles: Dateien automatisch herunterladen +DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren diff --git a/models b/models index e68c47c43..d146f2f5b 100644 --- a/models +++ b/models @@ -9,6 +9,7 @@ User json dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" dateFormat DateTimeFormat "default='%d.%m.%Y'" timeFormat DateTimeFormat "default='%R'" + downloadFiles Bool default=false UniqueAuthentication plugin ident UniqueEmail email deriving Show diff --git a/package.yaml b/package.yaml index 74bb7bf3c..60cff14a5 100644 --- a/package.yaml +++ b/package.yaml @@ -88,6 +88,8 @@ dependencies: - Glob - ldap-client - connection +- universe +- universe-base # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Foundation.hs b/src/Foundation.hs index 58414a529..e94b8950e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -352,15 +352,6 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req _ -> return () return Authorized - - let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime) - case subRoute of - SFileR SheetExercise _ -> guard started - SFileR SheetMarking _ -> mzero -- only for correctors and lecturers - SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo - SubmissionR _ _ -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo - _ -> guard started - return Authorized CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh @@ -515,6 +506,7 @@ instance Yesod UniWorX where defaultLayout widget = do master <- getYesod + let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master mmsgs <- getMessages mcurrentRoute <- getCurrentRoute @@ -534,10 +526,10 @@ instance Yesod UniWorX where isAuth <- isJust <$> maybeAuthId -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! - (favourites',show -> currentTheme) <- do + (favourites', currentTheme) <- do muid <- maybeAuthPair case muid of - Nothing -> return ([],Default) + Nothing -> return ([],userDefaultTheme) (Just (uid,user)) -> do favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) @@ -644,10 +636,7 @@ instance Yesod UniWorX where -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog app _source level = - appShouldLogAll (appSettings app) - || level == LevelWarn - || level == LevelError + shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app) makeLogger = return . appLogger @@ -1120,7 +1109,7 @@ instance YesodAuth UniWorX where acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth $logDebugS "auth" $ tshow Creds{..} - AppSettings{..} <- getsYesod appSettings + AppSettings{ appUserDefaults = UserDefaultConf{..}, ..} <- getsYesod appSettings flip catches excHandlers $ case appLdapConf of Just ldapConf -> fmap (either id id) . runExceptT $ do @@ -1154,12 +1143,15 @@ instance YesodAuth UniWorX where -> throwError $ ServerError "Could not decode user matriculation" let - userMaxFavourites = appDefaultMaxFavourites - userTheme = appDefaultTheme - userDateTimeFormat = appDefaultDateTimeFormat - userDateFormat = appDefaultDateFormat - userTimeFormat = appDefaultTimeFormat - newUser = User{..} + newUser = User + { userMaxFavourites = userDefaultMaxFavourites + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , .. + } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer , UserDisplayName =. userDisplayName , UserEmail =. userEmail diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 269c07d97..05ae4e04b 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -187,7 +187,7 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! whereClause = const $ E.val True validator = def & defaultSorting [("course", SortAsc), ("term", SortDesc)] - coursesTable <- makeCourseTable whereClause colonnade validator + ((), coursesTable) <- makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO @@ -217,7 +217,7 @@ getTermCourseListR tid = do whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid validator = def & defaultSorting [("cshort", SortAsc)] - coursesTable <- makeCourseTable whereClause colonnade validator + ((), coursesTable) <- makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 960ff2757..adca2c28a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -65,7 +65,7 @@ homeAnonymous = do E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime))) return course - colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ()) + colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ()) colonnade = mconcat [ -- dbRow sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do @@ -77,7 +77,7 @@ homeAnonymous = do , sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] - courseTable <- dbTable def $ DBTable + ((), courseTable) <- dbTable def $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade , dbtProj = return @@ -144,7 +144,7 @@ homeUser uid = do , E.Value UTCTime , E.Value (Maybe SubmissionId) )) - (DBCell (WidgetT UniWorX IO) ()) + (DBCell (HandlerT UniWorX IO) ()) colonnade = mconcat [ -- dbRow sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _, _) } -> @@ -162,7 +162,7 @@ homeUser uid = do tickmark ] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] - sheetTable <- dbTable validator $ DBTable + ((), sheetTable) <- dbTable validator $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade , dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) } diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index c5d92dc48..f869efc37 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -25,19 +25,23 @@ data SettingsForm = SettingsForm , stgDateTime :: DateTimeFormat , stgDate :: DateTimeFormat , stgTime :: DateTimeFormat + , stgDownloadFiles :: Bool } makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template = identForm FIDsettings $ \html -> do - let themeList = [(display t,t) | t <- allThemes] + let themeList = [Option (display t) t (toPathPiece t) | t <- universeF] (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) - <*> areq (selectFieldList themeList) - (fslpI MsgTheme "theme-select" ) (stgTheme <$> template) -- TODO: pass theme-select as id-attribute or similar. + <*> areq (selectField . return $ mkOptionList themeList) + (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) + <*> areq checkBoxField (fslI MsgDownloadFiles + & setTooltip MsgDownloadFilesTip + ) (stgDownloadFiles <$> template) <* submitButton return (result, widget) -- no validation required here @@ -52,6 +56,7 @@ getProfileR = do , stgDateTime = userDateTimeFormat , stgDate = userDateFormat , stgTime = userTimeFormat + , stgDownloadFiles = userDownloadFiles } ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate case res of @@ -62,6 +67,7 @@ getProfileR = do , UserDateTimeFormat =. stgDateTime , UserDateFormat =. stgDate , UserTimeFormat =. stgTime + , UserDownloadFiles =. stgDownloadFiles ] when (stgMaxFavourties < userMaxFavourites) $ do -- prune Favourites to user-defined size diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 8284164c1..c27ee142a 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -56,6 +56,8 @@ import qualified Data.Map as Map import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map +import Data.Monoid (Sum(..)) + import Control.Lens import Utils.Lens @@ -199,7 +201,8 @@ getSheetListR tid csh = do mkRoute = do cid <- mkCid return $ CSubmissionR tid csh sheetName cid CorrectionR - in anchorCellM mkRoute $(widgetFile "widgets/rating") + protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") + in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of @@ -214,7 +217,7 @@ getSheetListR tid csh = do ] psValidator = def & defaultSorting [("submission-since", SortAsc)] - table <- dbTable psValidator $ DBTable + (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable { dbtSQLQuery = sheetData , dbtColonnade = sheetCol , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } @@ -248,19 +251,6 @@ getSheetListR tid csh = do , dbtStyle = def , dbtIdent = "sheets" :: Text } - cTime <- Just <$> liftIO getCurrentTime -- TODO: HACK - remove me and the 2 next TODOs, see issue #142 - rawStats <- runDB $ do -- compute the values of the table once again, since dbTable does not provide a list of raw values for summation/statistics - E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do - E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission - E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet - E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - E.&&. (E.not_ $ E.isNothing $ sheet E.^. SheetVisibleFrom) -- TODO see above #142 - E.&&. sheet E.^. SheetVisibleFrom E.<=. E.val cTime -- TODO see above #142 - return $ (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) - - let sheetTypeSummary = foldl' sumSheetTypes emptySheetTypeSummary - $ map (\(st,mp) -> (E.unValue st, join $ E.unValue mp)) rawStats defaultLayout $ do $(widgetFile "sheetList") $(widgetFile "widgets/sheetTypeSummary") @@ -301,7 +291,7 @@ getSShowR tid csh shn = do ] let psValidator = def & defaultSorting [("type", SortAsc), ("path", SortAsc)] - fileTable <- dbTable psValidator $ DBTable + ((), fileTable) <- dbTable psValidator $ DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } @@ -357,7 +347,8 @@ getSFileR tid csh shn typ title = do case results of [(E.Value fileTitle, E.Value fileContent)] | Just fileContent' <- fileContent -> do - addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] + whenM downloadFiles $ + addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise -> sendResponseStatus noContent204 () [] -> notFound diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 73f68f988..8c1987bf5 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -246,7 +246,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- Maybe construct a table to display uploaded archive files - let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ()) + let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ()) colonnadeFiles cid = mconcat [ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) @@ -299,7 +299,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do ] , dbtFilter = [] } - mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid + mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid csh shn @@ -335,7 +335,8 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = let fileName = Text.pack $ takeFileName path case results of [Entity _ File{ fileContent = Just c, fileTitle }] -> do - addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] + whenM downloadFiles $ + addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () other -> do diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 20f12eaa3..27e66a957 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -78,7 +78,7 @@ getTermShowR = do -- #{termToText termName} -- |] -- ] - table <- dbTable def $ DBTable + ((), table) <- dbTable def $ DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms , dbtProj = return . dbrOutput diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ef9d012e1..ae6e07c64 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -4,7 +4,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} module Handler.Users where @@ -12,6 +12,8 @@ import Import -- import Data.Text import Handler.Utils +import Utils.Lens + import qualified Data.Map as Map import qualified Data.Set as Set @@ -29,7 +31,7 @@ hijackUserForm uid csrf = do getUsersR :: Handler Html getUsersR = do let - colonnadeUsers = dbColonnade . mconcat $ + dbtColonnade = dbColonnade . mconcat $ [ dbRow , sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) @@ -40,32 +42,28 @@ getUsersR = do -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) - , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty - { dbCellContents = do - schools <- E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do - E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid - E.orderBy [E.asc $ school E.^. SchoolShorthand] - return $ school E.^. SchoolShorthand - return [whamlet| -