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

minor gitignore

Browse Source
This commit is contained in:
SJost 2018-08-08 11:47:00 +02:00
commit a908492957
32 changed files with 609 additions and 378 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -29,4 +29,5 @@ uniworx.nix
src/Handler/Assist.bak
src/Handler/Course.SnapCustom.hs
*.orig
.stack-work-*
.directory

4
ChangeLog.md
View File

@ -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

56
config/settings.yml
View File

@ -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

74
db.hs
View File

@ -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"

13
ghci.sh
View File

@ -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

2
messages/uniworx/de.msg
View File

@ -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

1
models
View File

@ -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

2
package.yaml
View File

@ -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.

36
src/Foundation.hs
View File

@ -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

4
src/Handler/Course.hs
View File

@ -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")

8
src/Handler/Home.hs
View File

@ -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, _, _) }

12
src/Handler/Profile.hs
View File

@ -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

25
src/Handler/Sheet.hs
View File

@ -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

7
src/Handler/Submission.hs
View File

@ -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

2
src/Handler/Term.hs
View File

@ -78,7 +78,7 @@ getTermShowR = do
-- #{termToText termName}
-- |]
-- ]
table <- dbTable def $ DBTable
((), table) <- dbTable def $ DBTable
{ dbtSQLQuery = termData
, dbtColonnade = colonnadeTerms
, dbtProj = return . dbrOutput

58
src/Handler/Users.hs
View File

@ -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|
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}
|]
}
, sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty
{ dbCellContents = do
schools <- E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
E.orderBy [E.asc $ school E.^. SchoolShorthand]
return $ school E.^. SchoolShorthand
return [whamlet|
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}
|]
}
, sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
schools <- lift . 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|
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}
|]
, sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
E.orderBy [E.asc $ school E.^. SchoolShorthand]
return $ school E.^. SchoolShorthand
return [whamlet|
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}
|]
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
cID <- encrypt uid
@ -77,9 +75,9 @@ getUsersR = do
psValidator = def
& defaultSorting [("display-name", SortAsc)]
userList <- dbTable psValidator $ DBTable
((), userList) <- dbTable psValidator $ DBTable
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
, dbtColonnade = colonnadeUsers
, dbtColonnade
, dbtProj = return
, dbtSorting = Map.fromList
[ ( "display-name"

13
src/Handler/Utils.hs
View File

@ -2,13 +2,14 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Handler.Utils
( module Handler.Utils
) where
import Import
import Handler.Utils.DateTime as Handler.Utils
import Handler.Utils.Term as Handler.Utils
@ -21,3 +22,13 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Templates as Handler.Utils
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
downloadFiles = do
mauth <- liftHandlerT maybeAuth
case mauth of
Just (Entity _ User{..}) -> return userDownloadFiles
Nothing -> do
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
return userDefaultDownloadFiles

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

@ -57,7 +57,7 @@ getTimeLocale = getTimeLocale' <$> languages
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
getDateTimeFormat sel = do
mauth <- liftHandlerT maybeAuth
AppSettings{..} <- getsYesod appSettings
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
let
fmt
| Just (Entity _ User{..}) <- mauth
@ -67,9 +67,9 @@ getDateTimeFormat sel = do
SelFormatTime -> userTimeFormat
| otherwise
= case sel of
SelFormatDateTime -> appDefaultDateTimeFormat
SelFormatDate -> appDefaultDateFormat
SelFormatTime -> appDefaultTimeFormat
SelFormatDateTime -> userDefaultDateTimeFormat
SelFormatDate -> userDefaultDateFormat
SelFormatTime -> userDefaultTimeFormat
return fmt
validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat

215
src/Handler/Utils/Table/Pagination.hs
View File

@ -40,6 +40,7 @@ module Handler.Utils.Table.Pagination
, dbRow, dbSelect
, (&)
, module Control.Monad.Trans.Maybe
, module Colonnade
) where
import Handler.Utils.Table.Pagination.Types
@ -124,6 +125,86 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
| otherwise = go (acc, is' . (i:)) is
data PaginationSettings = PaginationSettings
{ psSorting :: [(CI Text, SortDirection)]
, psFilter :: Map (CI Text) [Text]
, psLimit :: Int64
, psPage :: Int64
, psShortcircuit :: Bool
}
makeClassy_ ''PaginationSettings
instance Default PaginationSettings where
def = PaginationSettings
{ psSorting = []
, psFilter = Map.empty
, psLimit = 50
, psPage = 0
, psShortcircuit = False
}
data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)]
, piFilter :: Maybe (Map (CI Text) [Text])
, piLimit :: Maybe Int64
, piPage :: Maybe Int64
, piShortcircuit :: Bool
}
makeClassy_ ''PaginationInput
piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and
[ isNothing piSorting
, isNothing piFilter
, isNothing piLimit
, isNothing piPage
, not piShortcircuit
]
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
instance Default (PSValidator m x) where
def = PSValidator $ \DBTable{..} -> \case
Nothing -> def
Just pi -> swap . (\act -> execRWS act pi def) $ do
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
l <- asks piLimit
case l of
Just l'
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
| otherwise -> modify $ \ps -> ps { psLimit = l' }
Nothing -> return ()
asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
where
injectDefault x = case x >>= piFilter of
Just _ -> id
Nothing -> set (_2._psFilter) psFilter
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
where
injectDefault x = case x >>= piSorting of
Just _ -> id
Nothing -> set (_2._psSorting) psSorting
restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
where
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
where
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
data DBRow r = DBRow
{ dbrOutput :: r
@ -173,82 +254,6 @@ data DBTable m x = forall a r r' h i t.
, dbtIdent :: i
}
data PaginationSettings = PaginationSettings
{ psSorting :: [(CI Text, SortDirection)]
, psFilter :: Map (CI Text) [Text]
, psLimit :: Int64
, psPage :: Int64
, psShortcircuit :: Bool
}
instance Default PaginationSettings where
def = PaginationSettings
{ psSorting = []
, psFilter = Map.empty
, psLimit = 50
, psPage = 0
, psShortcircuit = False
}
data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)]
, piFilter :: Maybe (Map (CI Text) [Text])
, piLimit :: Maybe Int64
, piPage :: Maybe Int64
, piShortcircuit :: Bool
}
piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and
[ isNothing piSorting
, isNothing piFilter
, isNothing piLimit
, isNothing piPage
, not piShortcircuit
]
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
instance Default (PSValidator m x) where
def = PSValidator $ \DBTable{..} -> \case
Nothing -> def
Just pi -> swap . (\act -> execRWS act pi def) $ do
asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
l <- asks piLimit
case l of
Just l'
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
| otherwise -> modify $ \ps -> ps { psLimit = l' }
Nothing -> return ()
asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
defaultFilter psFilter (runPSValidator -> f) = PSValidator g
where
g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing
g dbTable x = f dbTable x
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator g
where
g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing
g dbTable x = f dbTable x
restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
where
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
where
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
type DBResult m x :: *
-- type DBResult' m x :: *
@ -267,46 +272,46 @@ cellAttrs = dbCell . _1
cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2
instance IsDBTable (WidgetT UniWorX IO) () where
type DBResult (WidgetT UniWorX IO) () = Widget
instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-- type DBResult' (WidgetT UniWorX IO) () = ()
data DBCell (WidgetT UniWorX IO) () = WidgetCell
data DBCell (HandlerT UniWorX IO) x = WidgetCell
{ wgtCellAttrs :: [(Text, Text)]
, wgtCellContents :: Widget
, wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget
}
dbCell = iso
(\WidgetCell{..} -> (wgtCellAttrs, return wgtCellContents))
(\(attrs, mkWidget) -> WidgetCell attrs . join . fmap fst $ runWriterT mkWidget)
(\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
(\(attrs, mkWidget) -> WidgetCell attrs mkWidget)
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ = return
dbHandler _ f x = return $ f x
runDBTable = return . join . fmap (view _2)
dbWidget _ = return . snd
dbHandler _ f = return . over _2 f
runDBTable act = liftHandlerT act
instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
mempty = WidgetCell mempty mempty
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c')
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
mempty = WidgetCell mempty $ return mempty
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) () = Widget
instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) () = DBCell
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
{ dbCellAttrs :: [(Text, Text)]
, dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget
, dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget
}
dbCell = iso
(\DBCell{..} -> (dbCellAttrs, lift dbCellContents))
(\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget)
(\DBCell{..} -> (dbCellAttrs, dbCellContents))
(\(attrs, mkWidget) -> DBCell attrs mkWidget)
dbWidget _ = return
dbHandler _ f x = return $ f x
dbWidget _ = return . snd
dbHandler _ f = return . over _2 f
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
runDBTable = fmap snd . mapReaderT liftHandlerT
runDBTable = mapReaderT liftHandlerT
instance Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) where
instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
mempty = DBCell mempty $ return mempty
(DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
@ -368,7 +373,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
psResult <- runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
<*> ((\m -> m <$ guard (not $ Map.null m)) . Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> iopt intField (wIdent "pagesize")
<*> iopt intField (wIdent "page")
<*> ireq checkBoxField (wIdent "table-only")
@ -450,9 +455,9 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
--- DBCell utility functions
widgetColonnade :: Headedness h
=> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
-> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
widgetColonnade :: (Headedness h, Monoid x)
=> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
-> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
widgetColonnade = id
formColonnade :: (Headedness h, Monoid a)
@ -460,9 +465,9 @@ formColonnade :: (Headedness h, Monoid a)
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
formColonnade = id
dbColonnade :: Headedness h
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
dbColonnade :: (Headedness h, Monoid x)
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
dbColonnade = id
cell :: IsDBTable m a => Widget -> DBCell m a

2
src/Import/NoFoundation.hs
View File

@ -21,3 +21,5 @@ import Data.UUID as Import (UUID)
import Text.Lucius as Import
import Text.Shakespeare.Text as Import hiding (text, stext)
import Data.Universe as Import

126
src/Model/Types.hs
View File

@ -16,11 +16,15 @@ import ClassyPrelude
import Utils
import Control.Lens
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Fixed
import Data.Monoid (Sum(..))
import Data.Maybe (fromJust)
import Data.Universe
import Data.Universe.Helpers
import Text.Read (readMaybe)
import Database.Persist.TH
import Database.Persist.Class
@ -31,17 +35,17 @@ import Web.HttpApiData
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Text.Read (readMaybe,readsPrec)
import qualified Data.Text.Lens as Text
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Yesod.Core.Dispatch (PathPiece(..))
import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
import Data.Aeson.TH (deriveJSON, defaultOptions)
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..))
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault)
import Data.Typeable (Typeable)
import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..))
@ -77,29 +81,24 @@ deriveJSON defaultOptions ''SheetType
derivePersistFieldJSON "SheetType"
data SheetTypeSummary = SheetTypeSummary
{ sumBonusPoints :: Points
, sumNormalPoints :: Points
, numPassSheets :: Int
, numNotGraded :: Int
, achievedBonus :: Maybe Points
, achievedNormal :: Maybe Points
, achievedPasses :: Maybe Int
}
{ sumBonusPoints :: Sum Points
, sumNormalPoints :: Sum Points
, numPassSheets :: Sum Int
, numNotGraded :: Sum Int
, achievedBonus :: Maybe (Sum Points)
, achievedNormal :: Maybe (Sum Points)
, achievedPasses :: Maybe (Sum Int)
} deriving (Generic)
instance Monoid SheetTypeSummary where
mempty = gmemptydefault
mappend = gmappenddefault
emptySheetTypeSummary :: SheetTypeSummary
emptySheetTypeSummary = SheetTypeSummary 0 0 0 0 Nothing Nothing Nothing
-- TODO: refactor with lenses!
sumSheetTypes :: SheetTypeSummary -> (SheetType, Maybe Points) -> SheetTypeSummary
sumSheetTypes sts@(SheetTypeSummary {..}) (Bonus {..}, achieved)
= sts{ sumBonusPoints =sumBonusPoints +maxPoints, achievedBonus = maybeAdd achievedBonus achieved }
sumSheetTypes sts@(SheetTypeSummary {..}) (Normal {..}, achieved)
= sts{ sumNormalPoints=sumNormalPoints+maxPoints, achievedNormal = maybeAdd achievedNormal achieved }
sumSheetTypes sts@(SheetTypeSummary {..}) (Pass {..}, achieved)
= sts{ numPassSheets=numPassSheets+1, achievedPasses = maybeAdd achievedPasses (bool 0 1 <$> (passingPoints <=) <$> achieved) }
sumSheetTypes sts@(SheetTypeSummary {..}) (NotGraded, _achieved)
= sts{ numNotGraded=numNotGraded+1 }
sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved }
sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved }
sheetTypeSum (Pass{..}, achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved}
sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 }
data SheetGroup
@ -110,19 +109,19 @@ data SheetGroup
deriveJSON defaultOptions ''SheetGroup
derivePersistFieldJSON "SheetGroup"
enumFromPathPiece :: (PathPiece a, Enum a, Bounded a) => Text -> Maybe a
enumFromPathPiece t = lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "SheetFileType"
instance Universe SheetFileType where universe = universeDef
instance Finite SheetFileType
instance PathPiece SheetFileType where
toPathPiece SheetExercise = "file"
toPathPiece SheetHint = "hint"
toPathPiece SheetSolution = "solution"
toPathPiece SheetMarking = "marking"
fromPathPiece = enumFromPathPiece
fromPathPiece = finiteFromPathPiece
-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
@ -151,6 +150,9 @@ partitionFileType fts =
data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance Universe SubmissionFileType where universe = universeDef
instance Finite SubmissionFileType
submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
submissionFileTypeIsUpdate SubmissionOriginal = False
submissionFileTypeIsUpdate SubmissionCorrected = True
@ -162,7 +164,7 @@ isUpdateSubmissionFileType True = SubmissionCorrected
instance PathPiece SubmissionFileType where
toPathPiece SubmissionOriginal = "original"
toPathPiece SubmissionCorrected = "corrected"
fromPathPiece = enumFromPathPiece
fromPathPiece = finiteFromPathPiece
instance DisplayAble SubmissionFileType where
display SubmissionOriginal = "Abgabe"
@ -322,38 +324,43 @@ data StudyFieldType = FieldPrimary | FieldSecondary
deriving (Eq, Ord, Enum, Show, Read, Bounded)
derivePersistField "StudyFieldType"
data Theme
= ThemeDefault
| ThemeLavender
| ThemeNeutralBlue
| ThemeAberdeenReds
| ThemeMossGreen
| ThemeSkyLove
deriving (Eq, Ord, Bounded, Enum, Show, Read)
-- Skins / Themes
data Theme --Simply add Themes to this type only. CamelCase will be converted to "-lower"
= Default
| Lavender
| NeutralBlue
| AberdeenReds -- e.g. turned into "theme--aberdeen-reds"
| MossGreen
| SkyLove
deriving (Eq,Ord,Bounded,Enum)
deriveJSON defaultOptions
{ constructorTagModifier = fromJust . stripPrefix "Theme"
} ''Theme
$(deriveJSON defaultOptions ''Theme)
$(deriveShowWith uncamel ''Theme) -- show for internal use in css/js
$(deriveSimpleWith ''DisplayAble 'display camelSpace ''Theme) -- display to display at user
instance Universe Theme where universe = universeDef
instance Finite Theme
allThemes :: [Theme]
allThemes = [minBound..maxBound]
instance PathPiece Theme where
toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
fromPathPiece = finiteFromPathPiece
readTheme :: Map String Theme
readTheme = Map.fromList [ (show t,t) | t <- allThemes ]
$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
-- derivePersistFieldJSON "Theme" -- Preferred Version
-- Backwards-compatibility until database versioning is implemented (#120):
instance PersistField Theme where
toPersistValue = PersistText . ("theme--" <>) . toPathPiece
fromPersistValue (PersistText t) = do
pp <- case Text.stripPrefix "theme--" t of
Just pp -> return pp
Nothing -> Left "Expected 'theme--'-Prefix"
case fromPathPiece pp of
Just th -> return th
Nothing -> Left "Could not parse PathPiece"
fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
instance Read Theme where -- generic Read-Instance for Show/Bounded
readsPrec _ s
| (Just t) <- (Map.lookup s readTheme) = [(t,"")]
| otherwise = [(Default,"")] -- read shall always succeed
{-
instance Default Theme where
def = Default
-}
derivePersistField "Theme"
instance PersistFieldSql Theme where
sqlType _ = SqlString
newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
@ -383,6 +390,9 @@ instance PersistField (CI String) where
instance PersistFieldSql (CI Text) where
sqlType _ = SqlOther "citext"
instance PersistFieldSql (CI String) where
sqlType _ = SqlOther "citext"
instance ToJSON a => ToJSON (CI a) where
toJSON = toJSON . CI.original

72
src/Settings.hs
View File

@ -31,6 +31,12 @@ import qualified Data.Text.Encoding as Text
import qualified Ldap.Client as Ldap
import Utils
import Control.Lens
import Data.Maybe (fromJust)
import qualified Data.Char as Char
import Model
-- | Runtime settings to configure this application. These settings can be
@ -42,6 +48,7 @@ data AppSettings = AppSettings
, appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database.
, appLdapConf :: Maybe LdapConf
-- ^ Configuration settings for accessing the LDAP-directory
, appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers.
@ -63,29 +70,37 @@ data AppSettings = AppSettings
-- ^ Assume that files in the static dir may change after compilation
, appSkipCombining :: Bool
-- ^ Perform no stylesheet/script combining
, appDefaultTheme :: Theme
, appDefaultMaxFavourites :: Int
, appDefaultDateTimeFormat :: DateTimeFormat
, appDefaultDateFormat :: DateTimeFormat
, appDefaultTimeFormat :: DateTimeFormat
-- Example app-specific configuration values.
, appCopyright :: Text
-- ^ Copyright text to appear in the footer of the page
, appAnalytics :: Maybe Text
-- ^ Google Analytics code
, appCryptoIDKeyFile :: FilePath
, appAuthDummyLogin :: Bool
-- ^ Indicate if auth dummy login should be enabled.
, appAuthPWFile :: Maybe FilePath
-- ^ If set authenticate against a local password file
, appAllowDeprecated :: Bool
-- ^ Indicate if deprecated routes are accessible for everyone
, appAuthPWFile :: Maybe FilePath
-- ^ If set authenticate against a local password file
, appMinimumLogLevel :: LogLevel
, appUserDefaults :: UserDefaultConf
, appCryptoIDKeyFile :: FilePath
}
data UserDefaultConf = UserDefaultConf
{ userDefaultTheme :: Theme
, userDefaultMaxFavourites :: Int
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
, userDefaultDownloadFiles :: Bool
}
instance FromJSON UserDefaultConf where
parseJSON = withObject "UserDefaultConf" $ \o -> do
userDefaultTheme <- o .: "theme"
userDefaultMaxFavourites <- o .: "favourites"
userDefaultDateTimeFormat <- o .: "date-time-format"
userDefaultDateFormat <- o .: "date-format"
userDefaultTimeFormat <- o .: "time-format"
userDefaultDownloadFiles <- o .: "download-files"
return UserDefaultConf{..}
data LdapConf = LdapConf
{ ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
, ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
@ -115,6 +130,13 @@ instance FromJSON LdapConf where
ldapTimeout <- o .: "timeout"
return LdapConf{..}
deriveFromJSON
defaultOptions
{ constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
, sumEncoding = UntaggedValue
}
''LogLevel
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
let defaultDev =
@ -128,7 +150,7 @@ instance FromJSON AppSettings where
let nonEmptyHost LdapConf{..} = case ldapHost of
Ldap.Tls host _ -> not $ null host
Ldap.Plain host -> not $ null host
appLdapConf <- (>>= (\c -> c <$ guard (nonEmptyHost c))) <$> o .:? "ldap"
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"
@ -136,24 +158,18 @@ instance FromJSON AppSettings where
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
appMinimumLogLevel <- o .: "minimum-log-level"
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
appMutableStatic <- o .:? "mutable-static" .!= defaultDev
appSkipCombining <- o .:? "skip-combining" .!= defaultDev
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
appAuthPWFile <- assertM (not . null) <$> o .:? "auth-pwfile"
appDefaultMaxFavourites <- o .: "default-favourites"
appDefaultTheme <- o .: "default-theme"
appDefaultDateTimeFormat <- o .: "default-date-time-format"
appDefaultDateFormat <- o .: "default-date-format"
appDefaultTimeFormat <- o .: "default-time-format"
appUserDefaults <- o .: "user-defaults"
appCopyright <- o .: "copyright"
appAnalytics <- o .:? "analytics"
appCryptoIDKeyFile <- o .: "cryptoid-keyfile"
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAuthPWFile <- ((\f -> f <$ guard (not $ null f)) =<<) <$> o .:? "auth-pwfile"
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and

25
src/Utils.hs
View File

@ -25,6 +25,7 @@ import qualified Data.CaseInsensitive as CI
import Utils.DB as Utils
import Utils.Common as Utils
import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Text.Blaze (Markup, ToMarkup)
@ -109,24 +110,6 @@ withFragment :: ( Monad m
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "camel-case-thing"
uncamel = ("theme-" ++) . reverse . foldl helper []
where
helper _ '.' = []
helper acc c
| Char.isSpace c = acc
| Char.isUpper c = Char.toLower c : '-' : acc
| otherwise = c : acc
camelSpace :: String -> String -- "Model.Theme.CamelCaseThing" -> "Camel Case Thing"
camelSpace = reverse . foldl helper []
where
helper _ '.' = []
helper acc c
| Char.isSpace c = acc
| Char.isUpper c = c : ' ' : acc
| otherwise = c : acc
-- Convert anything to Text, and I don't care how
class DisplayAble a where
display :: a -> Text
@ -302,6 +285,12 @@ shortCircuitM sc mx my op = do
guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f
assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
assertM' f x = x <$ guard (f x)
-- Some Utility Functions from Agda.Utils.Monad
-- | Monadic if-then-else.
ifM :: Monad m => m Bool -> m a -> m a -> m a

2
src/Utils/Common.hs
View File

@ -73,7 +73,7 @@ deriveSimpleWith cls fun strOp ty = do
genClause :: Con -> Q Clause
genClause (NormalC name []) =
let pats = [ConP name []]
body = NormalB $ LitE $ StringL $ strOp $ show $ name
body = NormalB $ LitE $ StringL $ strOp $ nameBase name
in return $ Clause pats body []
genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"

51
src/Utils/PathPiece.hs Normal file
View File

@ -0,0 +1,51 @@
{-# LANGUAGE NoImplicitPrelude
#-}
module Utils.PathPiece
( finiteFromPathPiece
, nullaryToPathPiece
, splitCamel
) where
import ClassyPrelude.Yesod
import Language.Haskell.TH
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
import Data.Universe
import qualified Data.Text as Text
import qualified Data.Char as Char
import Data.Monoid (Endo(..))
finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
[x] -> Just x
_xs -> Nothing
nullaryToPathPiece :: Name -> [Text -> Text] -> ExpQ
nullaryToPathPiece nullaryType manglers = do
TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType
helperName <- newName "helper"
let
toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift . mangle $ nameBase cName) []
toClause con = fail $ "Unsupported constructor: " ++ show con
helperDec = funD helperName $ map toClause constructors
letE [helperDec] $ varE helperName
where
mangle = appEndo (foldMap Endo manglers) . Text.pack
splitCamel :: Text -> [Text]
splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
where
helper hadChange words thisWord [] = reverse thisWord : words
helper hadChange words [] (c:cs) = helper True words [c] cs
helper hadChange words ws@(w:ws') (c:cs)
| sameCategory w c
, null ws' = helper False words (c:ws) cs
| sameCategory w c = helper hadChange words (c:ws) cs
| null ws' = helper True words (c:ws) cs
| not hadChange = helper True (reverse ws':words) [c,w] cs
| otherwise = helper True (reverse ws:words) [c] cs
sameCategory = (==) `on` Char.generalCategory

13
start.sh
View File

@ -7,4 +7,15 @@ export DUMMY_LOGIN=true
export ALLOW_DEPRECATED=true
export PWFILE=users.yml
exec -- stack exec -- yesod devel
move-back() {
mv -v .stack-work .stack-work-run
[[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work
}
if [[ -d .stack-work-run ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci
mv -v .stack-work-run .stack-work
trap move-back EXIT
fi
stack exec -- yesod devel

14
templates/default-layout-wrapper.hamlet
View File

@ -39,21 +39,9 @@ $newline never
}
<body .no-js .#{currentTheme} :isAuth:.logged-in>
<body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in>
<!-- removes no-js class from body if client supports javascript -->
<script>
document.body.classList.remove('no-js');
^{pageBody pc}
$maybe analytics <- appAnalytics $ appSettings master
<script>
if(!window.location.href.match(/localhost/)){
(function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){
(i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o),
m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)
})(window,document,'script','https://www.google-analytics.com/analytics.js','ga');
ga('create', '#{analytics}', 'auto');
ga('send', 'pageview');
}

6
templates/profile.julius
View File

@ -1,6 +1,6 @@
document.addEventListener('DOMContentLoaded', function () {
var themeSelector = document.querySelector('[placeholder="theme-select"]');
var themeSelector = document.querySelector('#theme-select');
themeSelector.addEventListener('change', function() {
// get rid of old themes on body
var options = Array.from(themeSelector.options)
@ -8,10 +8,10 @@ document.addEventListener('DOMContentLoaded', function () {
document.body.classList.remove(optionToTheme(option));
});
// add newly selected theme
document.body.classList.add(optionToTheme(themeSelector.options[themeSelector.value - 1]));
document.body.classList.add(optionToTheme(themeSelector.selectedOptions[0]));
});
function optionToTheme(option) {
return optionValue = 'theme--' + option.innerText.toLowerCase().trim().replace(/\s/g, '-');
return optionValue = 'theme--' + option.value;
}
});

26
templates/widgets/sheetTypeSummary.hamlet
View File

@ -1,23 +1,23 @@
<div>
$if 0 < sumNormalPoints sheetTypeSummary
Gesamtpunktzahl #{display (sumNormalPoints sheetTypeSummary)}
$maybe nPts <- (maybeAdd (achievedNormal sheetTypeSummary) (achievedBonus sheetTypeSummary))
$if 0 < getSum sumNormalPoints
Gesamtpunktzahl #{display (getSum sumNormalPoints)}
$maybe nPts <- (maybeAdd (getSum <$> achievedNormal) (getSum <$> achievedBonus))
\ davon #{display nPts} erreicht
$maybe bPts <- achievedBonus sheetTypeSummary
$maybe bPts <- getSum <$> achievedBonus
\ (inklusive #{display bPts} #
$if 0 < sumBonusPoints sheetTypeSummary
von #{display $ sumBonusPoints sheetTypeSummary} erreichbaren #
$if 0 < getSum sumBonusPoints
von #{display $ getSum sumBonusPoints} erreichbaren #
Bonuspunkten)
\ #{textPercent $ realToFrac $ nPts / (sumNormalPoints sheetTypeSummary)}
\ #{textPercent $ realToFrac $ nPts / (getSum sumNormalPoints)}
<div>
$if 0 < numPassSheets sheetTypeSummary
Blätter zum Bestehen: #{display (numPassSheets sheetTypeSummary)}
$maybe passed <- achievedPasses sheetTypeSummary
\ davon #{display (achievedPasses sheetTypeSummary)} bestanden.
$if 0 < getSum numPassSheets
Blätter zum Bestehen: #{display (getSum numPassSheets)}
$maybe passed <- getSum <$> achievedPasses
\ davon #{display passed} bestanden.
<div>
$if 0 < numNotGraded sheetTypeSummary
Unbewertet: #{display (numNotGraded sheetTypeSummary)} Blätter
$if 0 < getSum numNotGraded
Unbewertet: #{display (getSum numNotGraded)} Blätter

25
testdata/H10-2.hs vendored Normal file
View File

@ -0,0 +1,25 @@
{- Übung H10-2 zur Vorlesung "Programmierung und Modellierung"
Lehrstuhl für theoretische Informatik, LMU München
Steffen Jost, Leah Neukirchen
-}
import Control.Monad
chainAction1 :: Monad m => a -> [(a -> m a)] -> m a
chainAction1 = undefined -- !!! TODO !!!
chainAction2 :: Monad m => a -> [(a -> m a)] -> m a
chainAction2 = undefined -- !!! TODO !!!
chainAction3 :: Monad m => a-> [(a -> m a)] -> m a
chainAction3 = undefined -- !!! TODO !!!
tellOp :: (Show a, Show b) => (a -> b) -> a -> IO b
tellOp f x = let fx = f x in do
putStrLn $ (show x) ++ " -> " ++ (show fx)
return fx
test1 :: [Int -> IO Int]
test1 = map tellOp [(*3),(+1),(`mod` 7),(+5),(*2)]

84
testdata/H10-3.hs vendored Normal file
View File

@ -0,0 +1,84 @@
{- Übung H10-3 zur Vorlesung "Programmierung und Modellierung"
Lehrstuhl für theoretische Informatik, LMU München
Steffen Jost, Leah Neukirchen
Bitte nur die Zeilen mit
error "TODO" -- TODO: Ihre Aufgabe !!!
bearbeiten.
(Sie dürfen an diesen Stellen auch beliebig
viele neue Zeilen einfügen.)
Entweder mit ghc kompilieren und ausführen oder
einfach in ghci laden und main auswerten.
-}
import Control.Monad.Trans.State
type Wetter = String
data Welt = Welt { zeit :: Int, wetter :: Wetter }
deriving Show
main =
let startState = Welt { zeit=0, wetter="Regen" }
(result,finalState) = runState actions startState
in do
putStrLn "Zustand Welt bei Start ist: "
print startState
putStrLn "Zustand Welt bei Ende ist: "
print finalState
putStrLn "Ergebnis der Aktion ist: "
print result
actions :: State Welt [(String,Int)]
actions = do
tick
tick
tick
tick
wetter1 <- swapWetter "Sonne"
zeit1 <- gets zeit
let r1 = (wetter1, zeit1)
tick
tick
wetter2 <- swapWetter "Sturm"
zeit2 <- zeit <$> get
let r2 = (wetter2, zeit2)
tick
return [r1,r2]
--- !!! NUR AB HIER BEARBEITEN !!!
tick :: State Welt ()
tick =
error "TODO: tick noch nicht implementiert!" -- TODO: Ihre Aufgabe !!!
swapWetter :: Wetter -> State Welt Wetter
swapWetter =
error "TODO: swapWetter noch nicht implementiert!" -- TODO: Ihre Aufgabe !!!

BIN
testdata/ProMo_Uebung10.pdf vendored Normal file
View File

Binary file not shown.