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

Merge branch 'master' into 'live'

Browse Source 
Master

See merge request !94
This commit is contained in:
Gregor Kleen 2018-11-14 16:18:29 +01:00
commit 4bf70fbea4
26 changed files with 730 additions and 399 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.vscode/tasks.json vendored
View File

@ -28,7 +28,8 @@
"focus": false,
"panel": "dedicated",
"showReuseMessage": false
}
},
"problemMatcher": []
},
{
"label": "test",

92
README.md
View File

@ -3,72 +3,118 @@
The following Description applies to Ubuntu or similar.
## Clone repository
Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`.
Clone this repository and navigate into
```sh
$ git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git && cd UniWorX
```
## LDAP
install:
`sudo apt-get install slapd ldap-utils`
```sh
$ sudo apt-get install slapd ldap-utils
```
## PostgreSQL
install:
`sudo apt-get install postgresql`
```sh
$ sudo apt-get install postgresql
```
switch to user *postgres* (got created during installation):
`sudo -i -u postgres`
```sh
$ sudo -i -u postgres
```
add db user *uniworx*:
`createuser --interactive`
```sh
$ createuser --interactive
```
you'll get a prompt:
```
Enter name of role to add:` - [enter 'uniworx']
```sh
Enter name of role to add:` - uniworx
Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?]
Password: uniworx
...
```
create database *uniworx*:
`createdb uniworx`
```sh
$ createdb uniworx
```
to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*:
`sudo adduser uniworx`
after you added the database switch back to your own user with `Ctrl + D`.
to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*. when you get asked for a password enter *uniworx*.
```sh
$ sudo adduser uniworx
```
log-in as new user *uniworx*:
`sudo -i -u uniworx`
```sh
$ sudo -i -u uniworx
```
you can now use `psql uniworx` to execute SQL-commands and such.
you can now use
```sh
$ psql uniworx
```
to execute SQL-commands and such.
## stack
Install with:
`curl -sSL https://get.haskellstack.org/ | sh`
```sh
$ curl -sSL https://get.haskellstack.org/ | sh
```
setup stack and install dependencies:
`stack setup`
```sh
$ stack setup
```
During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using
`sudo apt-get install libsasl2-dev libldap2-dev`
```sh
$ sudo apt-get install libsasl2-dev libldap2-dev
```
If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*
Go ahead an install `libpq-dev` with
`sudo apt-get install libpq-dev`
```sh
$ sudo apt-get install libpq-dev
```
Other packages you might need to install during this process:
```sh
$ sudo apt-get install pkg-config
sudo apt-get install libsodium-dev
```
Build the app:
`stack build`
```sh
$ stack build
```
This might take a few minutes if not hours... be prepared.
install yesod:
`stack install yesod-bin --install-ghc`
```sh
$ stack install yesod-bin --install-ghc
```
## Add Dumy-Data and run the app
After building the app you can prepare the database and add some dummy data:
`./fill-db.hs`
```sh
$ ./db.sh -f
```
Run the app:
`./start.sh`
`Devel application launched: http://localhost:3000`
means you are good to go.
```sh
$ ./start.sh
...
Devel application launched: http://localhost:3000
```
If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login.

4
ghci.sh
View File

@ -7,11 +7,11 @@ export DUMMY_LOGIN=true
move-back() {
mv -v .stack-work .stack-work-ghci
[[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
}
if [[ -d .stack-work-ghci ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
mv -v .stack-work-ghci .stack-work
trap move-back EXIT
fi

32
messages/uniworx/de.msg
View File

@ -142,10 +142,13 @@ SubmissionGroupName: Gruppenname
CorrectionsTitle: Zugewiesene Korrekturen
CourseCorrectionsTitle: Korrekturen für diesen Kurs
CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
CorrectorAssignTitle: Korrektor zuweisen
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
@ -167,7 +170,9 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
EMail: E-Mail
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@ -189,6 +194,7 @@ CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Ante
DeleteRow: Zeile entfernen
ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorUpdated: Korrektor erfolgreich aktualisiert
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
CorrectorsPlaceholder: Korrektoren...
CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
@ -228,6 +234,7 @@ CorrAutoSetCorrector: Korrekturen verteilen
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
NoCorrector: Kein Korrektor
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
@ -299,6 +306,8 @@ 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).
NotificationSettings: Erwünschte Benachrichtigungen
ActiveAuthTags: Aktivierte Authorisierungsprädikate
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
IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren
@ -484,6 +493,7 @@ ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
ErrMsgHeading: Fehlermeldung entschlüsseln
ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten
InvalidRoute: Konnte URL nicht interpretieren
@ -516,3 +526,23 @@ MenuSheetEdit: Übungsblatt editieren
MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben bewerten
AuthPredsActive: Aktive Authorisierungsprädikate
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
AuthTagFree: Seite ist generell zugänglich
AuthTagAdmin: Nutzer ist Administrator
AuthTagDeprecated: Seite ist nicht überholt
AuthTagDevelopment: Seite ist nicht in Entwicklung
AuthTagLecturer: Nutzer ist Dozent
AuthTagCorrector: Nutzer ist Korrektor
AuthTagTime: Zeitliche Einschränkungen sind erfüllt
AuthTagRegistered: Nutzer ist Kursteilnehmer
AuthTagCapacity: Kapazität ist ausreichend
AuthTagMaterials: Kursmaterialien sind freigegeben
AuthTagOwner: Nutzer ist Besitzer
AuthTagRated: Korrektur ist bewertet
AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
AuthTagIsRead: Zugriff ist nur lesend
AuthTagIsWrite: Zugriff ist i.A. schreibend

2
models
View File

@ -15,7 +15,7 @@ User json
notificationSettings NotificationSettings
UniqueAuthentication ident
UniqueEmail email
deriving Show
deriving Show Eq
UserAdmin
user UserId
school SchoolId

1
package.yaml
View File

@ -107,6 +107,7 @@ dependencies:
- word24
- mmorph
- clientsession
- monad-memo
other-extensions:
- GeneralizedNewtypeDeriving

11
routes
View File

@ -40,8 +40,10 @@
/info VersionR GET !free
/help HelpR GET POST !free
/profile ProfileR GET POST !free !free
/profile/data ProfileDataR GET POST !free !free
/profile ProfileR GET POST !free
/profile/data ProfileDataR GET POST !free
/authpreds AuthPredsR GET POST !free
/term TermShowR GET !free
/term/current TermCurrentR GET !free
@ -77,9 +79,10 @@
/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
/subs/own SubmissionOwnR GET !free -- just redirect
/sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
/assign SAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner
/correctors SCorrR GET POST
/pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions

546
src/Foundation.hs
View File

@ -40,7 +40,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.List (foldr1)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map, (!?))
@ -58,12 +57,14 @@ import qualified Database.Esqueleto as E
import Control.Monad.Except (MonadError(..), runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Reader (runReader, mapReaderT)
import Control.Monad.Trans.Writer (WriterT(..))
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..))
import qualified Control.Monad.Catch as C
import Handler.Utils.StudyFeatures
import Control.Lens
import Handler.Utils.Templates
import Utils.Lens
import Utils.Form
import Utils.SystemMessage
@ -200,6 +201,7 @@ embedRenderMessage ''UniWorX ''SheetFileType id
embedRenderMessage ''UniWorX ''CorrectorState id
embedRenderMessage ''UniWorX ''RatingException id
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@ -300,264 +302,300 @@ data AccessPredicate
| APHandler (Route UniWorX -> Bool -> Handler AuthResult)
| APDB (Route UniWorX -> Bool -> DB AuthResult)
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
evalAccessPred aPred r w = liftHandlerT $ case aPred of
(APPure p) -> runReader (p r w) <$> getMsgRenderer
(APHandler p) -> p r w
(APDB p) -> runDB $ p r w
instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of
(APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer
(APHandler p) -> lift $ p r w
(APDB p) -> p r w
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
orAR _ Authorized _ = Authorized
orAR _ _ Authorized = Authorized
orAR _ AuthenticationRequired _ = AuthenticationRequired
orAR _ _ AuthenticationRequired = AuthenticationRequired
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
-- and
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
andAR _ reason@(Unauthorized _) _ = reason
andAR _ _ reason@(Unauthorized _) = reason
andAR _ Authorized other = other
andAR _ AuthenticationRequired _ = AuthenticationRequired
orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
orAP = liftAR orAR (== Authorized)
andAP = liftAR andAR (const False)
trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
trueAR = const Authorized
falseAR = Unauthorized . ($ MsgUnauthorized) . render
liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult)
-> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
-> AccessPredicate -> AccessPredicate -> AccessPredicate
-- Ensure to first evaluate Pure conditions, then Handler before DB
liftAR ops sc (APPure f) (APPure g) = APPure $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< ask
liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer
liftAR ops sc (APDB f) (APDB g) = APDB $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer
liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r w -> runReader (f r w) <$> getMsgRenderer) apg
liftAR ops sc apf apg@(APPure _) = liftAR ops sc apg apf
liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB $ \r w -> lift $ f r w) apdb
liftAR ops sc apdb apg@(APHandler _) = liftAR ops sc apg apdb
trueAP, falseAP :: AccessPredicate
trueAP = APPure . const . const $ trueAR <$> ask
falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
trueAP,falseAP :: AccessPredicate
trueAP = APPure . const . const $ return Authorized
falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead
adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
adminAP = APDB $ \route _ -> case route of
-- Courses: access only to school admins
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized
-- other routes: access to any admin is granted here
_other -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized)
return Authorized
knownTags :: Map (CI Text) AccessPredicate
knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId
[("free", trueAP)
,("deprecated", APHandler $ \r _ -> do
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
addMessageI Error MsgDeprecatedRoute
allow <- appAllowDeprecated . appSettings <$> getYesod
return $ bool (Unauthorized "Deprecated Route") Authorized allow
)
,("development", APHandler $ \r _ -> do
$logWarnS "AccessControl" ("route in development: " <> tshow r)
tagAccessPredicate :: AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP
tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
-- Courses: access only to school admins
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized
-- other routes: access to any admin is granted here
_other -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
return Authorized
tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
addMessageI Error MsgDeprecatedRoute
allow <- appAllowDeprecated . appSettings <$> getYesod
return $ bool (Unauthorized "Deprecated Route") Authorized allow
tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do
$logWarnS "AccessControl" ("route in development: " <> tshow r)
#ifdef DEVELOPMENT
return Authorized
return Authorized
#else
return $ Unauthorized "Route under development"
return $ Unauthorized "Route under development"
#endif
)
,("lecturer", APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
return Authorized
_ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
return Authorized
)
,("corrector", APDB $ \route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
return (course E.^. CourseId, sheet E.^. SheetId)
let
resMap :: Map CourseId (Set SheetId)
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
case route of
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
Submission{..} <- MaybeT . lift $ get sid
guard $ maybe False (== authId) submissionRatingBy
return Authorized
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
return Authorized
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
guard $ cid `Set.member` Map.keysSet resMap
return Authorized
_ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized
)
,("time", APDB $ \route _ -> case route of
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
cTime <- liftIO getCurrentTime
let
visible = NTop sheetVisibleFrom <= NTop (Just cTime)
active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
return Authorized
_ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
return Authorized
tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
return (course E.^. CourseId, sheet E.^. SheetId)
let
resMap :: Map CourseId (Set SheetId)
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
case route of
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
Submission{..} <- MaybeT . lift $ get sid
guard $ maybe False (== authId) submissionRatingBy
return Authorized
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
return Authorized
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
guard $ cid `Set.member` Map.keysSet resMap
return Authorized
_ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized
tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
cTime <- liftIO getCurrentTime
let
visible = NTop sheetVisibleFrom <= NTop (Just cTime)
active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
marking = cTime > sheetActiveTo
guard visible
guard visible
case subRoute of
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SubmissionNewR -> guard active
SubmissionR _ _ -> guard active
_ -> return ()
case subRoute of
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SubmissionNewR -> guard active
SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
SubmissionR _ _ -> guard active
_ -> return ()
return Authorized
return Authorized
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= cTime
return Authorized
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= cTime
return Authorized
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID
SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime
&& NTop systemMessageTo >= cTime
return Authorized
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID
SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime
&& NTop systemMessageTo >= cTime
return Authorized
r -> $unsupportedAuthPredicate "time" r
)
,("registered", APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
return Authorized
r -> $unsupportedAuthPredicate "registered" r
)
,("capacity", APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered)
return Authorized
r -> $unsupportedAuthPredicate "capacity" r
)
,("materials", APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree
return Authorized
r -> $unsupportedAuthPredicate "materials" r
)
,("owner", APDB $ \route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized
r -> $unsupportedAuthPredicate "owner" r
)
,("rated", APDB $ \route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid
guard $ submissionRatingDone sub
return Authorized
r -> $unsupportedAuthPredicate "rated" r
)
,("user-submissions", APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == UserSubmissions
return Authorized
r -> $unsupportedAuthPredicate "user-submissions" r
)
,("corrector-submissions", APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == CorrectorSubmissions
return Authorized
r -> $unsupportedAuthPredicate "corrector-submissions" r
)
,("authentication", APDB $ \route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- decrypt cID
SystemMessage{..} <- MaybeT $ get smId
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate "authentication" r
)
,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
]
r -> $unsupportedAuthPredicate "time" r
tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
return Authorized
r -> $unsupportedAuthPredicate "registered" r
tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered)
return Authorized
r -> $unsupportedAuthPredicate "capacity" r
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree
return Authorized
r -> $unsupportedAuthPredicate "materials" r
tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized
r -> $unsupportedAuthPredicate "owner" r
tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid
guard $ submissionRatingDone sub
return Authorized
r -> $unsupportedAuthPredicate "rated" r
tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == UserSubmissions
return Authorized
r -> $unsupportedAuthPredicate "user-submissions" r
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == CorrectorSubmissions
return Authorized
r -> $unsupportedAuthPredicate "corrector-submissions" r
tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- decrypt cID
SystemMessage{..} <- MaybeT $ get smId
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate "authentication" r
tagAccessPredicate AuthIsRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
tagAccessPredicate AuthIsWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
tag2ap :: Text -> AccessPredicate
tag2ap t = case Map.lookup (CI.mk t) knownTags of
(Just acp) -> acp
Nothing -> APHandler $ \_route _isWrite -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
$logWarnS "AccessControl" $ "'" <> t <> "' not known to access control"
unauthorizedI MsgUnauthorized
newtype InvalidAuthTag = InvalidAuthTag Text
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Exception InvalidAuthTag
route2ap :: Route UniWorX -> AccessPredicate
route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed)
type DNF a = Set (NonNull (Set a))
data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe SessionAuthTags
instance Finite SessionAuthTags
$(return [])
instance PathPiece SessionAuthTags where
toPathPiece = $(nullaryToPathPiece ''SessionAuthTags [intercalate "-" . map toLower . splitCamel])
fromPathPiece = finiteFromPathPiece
routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
-- ^ DNF up to entailment:
--
-- > (A_1 && A_2 && ...) OR' B OR' ...
--
-- > A OR' B := ((A |- B) ==> A) && (A || B)
routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs
where
attrsAND = map splitAND $ Set.toList $ routeAttrs r
splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
partition' prev t
| Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
= if
| oany (authTags `Set.isSubsetOf`) prev
-> Right prev
| otherwise
-> Right $ Set.insert authTags prev
| otherwise
= Left $ InvalidAuthTag t
evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of
(APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer
(APHandler p) -> lift $ p r w
(APDB p) -> p r w
evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
-- ^ `tell`s disabled predicates, identified as pivots
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite
= startEvalMemoT $ do
mr <- lift getMsgRenderer
let
authTagIsInactive = not . authTagIsActive
evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess r w = liftHandlerT $ case route2ap r of
(APPure p) -> runReader (p r w) <$> getMsgRenderer
(APHandler p) -> p r w
(APDB p) -> runDB $ p r w
evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
orAR' = shortCircuitM (is _Authorized) (orAR mr)
andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
evalDNF :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
result <- evalDNF $ filter (all authTagIsActive) authDNF
unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj ->
whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
let pivots = filter authTagIsInactive conj
whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
lift . tell $ Set.fromList pivots
return result
evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess route isWrite = do
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
dnf <- either throwM return $ routeAuthTags route
(result, (Set.toList -> deactivated)) <- runWriterT $ evalAuthTags tagActive dnf route isWrite
result <$ tellSessionJson SessionInactiveAuthTags deactivated
evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessDB = evalAccess
-- Please see the documentation for the Yesod typeclass. There are a number
@ -726,12 +764,6 @@ siteLayout headingOverride widget = do
isModal <- isJust <$> siteModalId
mmsgs <- if
| isModal -> return []
| otherwise -> do
applySystemMessages
getMessages
mcurrentRoute <- getCurrentRoute
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
@ -767,6 +799,14 @@ siteLayout headingOverride widget = do
items' <- forM items $ \i -> (i, ) <$> toTextUrl i
return (c, courseRoute, items')
mmsgs <- if
| isModal -> return []
| otherwise -> do
applySystemMessages
authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags
forM_ authTagPivots $ \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left AuthPredsR)
getMessages
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
navItems = map snd3 favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
@ -777,14 +817,12 @@ siteLayout headingOverride widget = do
favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])]
favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
let
navbar :: Widget
navbar = $(widgetFile "widgets/navbar")
asidenav :: Widget
@ -1226,6 +1264,14 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgCorrectorAssignTitle
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SAssignR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
]
pageActions (CSheetR tid ssh csh shn SCorrR) =
[ MenuItem
@ -1417,6 +1463,7 @@ routeNormalizers =
, ncSchool
, ncCourse
, ncSheet
, verifySubmission
]
where
normalizeRender route = route <$ do
@ -1454,6 +1501,15 @@ routeNormalizers =
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
hasChanged shn sheetName
return $ CSheetR tid ssh csh sheetName subRoute
verifySubmission = maybeOrig $ \route -> do
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
sId <- decrypt cID
Submission{submissionSheet} <- lift . lift $ get404 sId
Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
tell . Any $ route /= newRoute
return newRoute
-- How to run database actions.

84
src/Handler/Corrections.hs
View File

@ -83,11 +83,7 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
let tid = course ^. _3
ssh = course ^. _4
csh = course ^. _2
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
$ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
@ -306,8 +302,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
unless (null unassigned) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
(unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
unless (null unassignedUnauth) $ do
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
unless (null unassignedAuth) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassignedAuth]
[ SubmissionRatingBy =. Just uid
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
]
@ -319,15 +320,15 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
return (E.countRows :: E.SqlExpr (E.Value Int64))
when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
redirect currentRoute
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections
subs <- mapM decrypt $ Set.toList subs'
runDB $ do
num <- updateWhereCount [SubmissionId <-. subs]
[ SubmissionRatingPoints =. Nothing
, SubmissionRatingComment =. Nothing
, SubmissionRatingBy =. Nothing
[ SubmissionRatingBy =. Nothing
, SubmissionRatingAssigned =. Nothing
, SubmissionRatingTime =. Nothing
-- , SubmissionRatingPoints =. Nothing -- Kept for easy reassignment by 2nd corrector
-- , SubmissionRatingComment =. Nothing -- Kept for easy reassignment by 2nd corrector
]
addMessageI Success $ MsgRemovedCorrections num
redirect currentRoute
@ -340,8 +341,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
unless (null unassigned) $ do
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
(unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
unless (null unassignedUnauth) $ do
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
unless (null unassignedAuth) $ do
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth)
unless (null assigned) $
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
unless (null stillUnassigned) $ do
@ -353,7 +359,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections")
where
authorizedToAssign :: SubmissionId -> DB Bool
authorizedToAssign sId = do
[(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <-
E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ submission E.^. SubmissionId E.==. E.val sId
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName)
cID <- encrypt sId
let route = CSubmissionR tid ssh csh shn cID SAssignR
(== Authorized) <$> evalAccessDB route True
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
@ -366,13 +383,13 @@ assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector
, wFormToAForm $ do
correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
return user
E.distinct $ return user
mr <- getMessageRender
@ -762,3 +779,36 @@ postCorrectionsGradeR = do
defaultLayout $
$(widgetFile "corrections-grade")
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSAssignR = postSAssignR
postSAssignR tid ssh csh shn cID = do
let actionUrl = CSubmissionR tid ssh csh shn cID SAssignR
sId <- decrypt cID
(currentCorrector, sheetCorrectors) <- runDB $ do
Submission{submissionRatingBy, submissionSheet} <- get404 sId
sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
userCorrector <- traverse getJustEntity submissionRatingBy
return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)
$logDebugS "SAssignR" $ tshow currentCorrector
let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
((corrResult, corrForm), corrEncoding) <- runFormPost . renderAForm FormStandard $
aopt correctorField (fslI MsgCorrector) (Just currentCorrector)
<* submitButton
formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
now <- liftIO getCurrentTime
update sId [ SubmissionRatingBy =. mbUserId
, SubmissionRatingAssigned =. (now <$ mbUserId)
]
addMessageI Success MsgCorrectorUpdated
redirect actionUrl
defaultLayout $ do
setTitleI MsgCorrectorAssignTitle
$(widgetFile "submission-assign")

20
src/Handler/Home.hs
View File

@ -295,3 +295,23 @@ postHelpR = do
$(widgetFile "help")
getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
AuthTagActive{..} <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagIsActive authTag)
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
$ AuthTagActive
<$> funcForm taForm (fslI MsgActiveAuthTags) True
<* submitButton
formResult authActiveRes $ \authTagActive -> do
setSessionJson SessionActiveAuthTags authTagActive
addMessageI Success MsgAuthPredsActiveChanged
redirect AuthPredsR
defaultLayout $ do
setTitleI MsgAuthPredsActive
$(widgetFile "authpreds")

20
src/Handler/Profile.hs
View File

@ -10,8 +10,6 @@ import Utils.Lens
-- import Yesod.Colonnade
import Data.Monoid (Any(..))
import qualified Data.Map as Map
import Data.Map ((!))
import qualified Data.Set as Set
-- import qualified Data.Set as Set
import qualified Database.Esqueleto as E
-- import Database.Esqueleto ((^.))
@ -42,25 +40,11 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
<*> areq checkBoxField (fslI MsgDownloadFiles
& setTooltip MsgDownloadFilesTip
) (stgDownloadFiles <$> template)
<*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty)
<*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
<* submitButton
return (result, widget) -- no validation required here
where
nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt ->
areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template)
nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX])
nsFieldView (res, fvInput) = do
mr <- getMessageRender
let fvLabel = toHtml $ mr MsgNotificationSettings
fvTooltip = mempty
fvRequired = True
fvErrors
| FormFailure (err:_) <- res = Just $ toHtml err
| otherwise = Nothing
fvId <- newIdent
return (res, pure FieldView{..})
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
getProfileR, postProfileR :: Handler Html

29
src/Handler/Utils/Form.hs
View File

@ -30,8 +30,9 @@ import qualified Data.Conduit.List as C
import qualified Database.Esqueleto as E
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import Data.Map (Map, (!))
import qualified Data.Map as Map
import Control.Monad.Writer.Class
@ -488,6 +489,32 @@ langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) .
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
funcForm :: forall k v m.
( Finite k, Ord k
, MonadHandler m
, HandlerSite m ~ UniWorX
)
=> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
where
funcForm' :: AForm m (k -> v)
funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
funcFieldView (res, fvInput) = do
mr <- getMessageRender
let fvLabel = toHtml $ mr fsLabel
fvTooltip = fmap (toHtml . mr) fsTooltip
fvRequired = isRequired
fvErrors
| FormFailure (err:_) <- res = Just $ toHtml err
| otherwise = Nothing
fvId <- maybe newIdent return fsId
return (res, pure FieldView{..})
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
fsm = bfs -- TODO: get rid of Bootstrap

2
src/Import/NoFoundation.hs
View File

@ -3,7 +3,7 @@ module Import.NoFoundation
, MForm
) where
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy)
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM)
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import

65
src/Model/Types.hs
View File

@ -564,6 +564,8 @@ instance ToBackendKey SqlBackend record => Hashable (Key record) where
derivePersistFieldJSON ''MailLanguages
type PseudonymWord = CI Text
newtype Pseudonym = Pseudonym Word24
deriving (Eq, Ord, Read, Show, Generic, Data)
deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix)
@ -642,9 +644,68 @@ pseudonymText = iso tFromWords tToWords . pseudonymWords
tToWords = Text.unwords . map CI.original
-- Type synonyms
data AuthTag
= AuthFree
| AuthAdmin
| AuthDeprecated
| AuthDevelopment
| AuthLecturer
| AuthCorrector
| AuthTime
| AuthRegistered
| AuthCapacity
| AuthMaterials
| AuthOwner
| AuthRated
| AuthUserSubmissions
| AuthCorrectorSubmissions
| AuthAuthentication
| AuthIsRead
| AuthIsWrite
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
type PseudonymWord = CI Text
instance Universe AuthTag
instance Finite AuthTag
instance Hashable AuthTag
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
} ''AuthTag
instance PathPiece AuthTag where
toPathPiece = $(nullaryToPathPiece ''AuthTag [Text.intercalate "-" . map toLower . drop 1 . splitCamel])
fromPathPiece = finiteFromPathPiece
instance ToJSONKey AuthTag where
toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
instance FromJSONKey AuthTag where
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
deriving (Read, Show, Generic)
deriving newtype (Eq, Ord)
instance Default AuthTagActive where
def = AuthTagActive $ \case
AuthAdmin -> False
_ -> True
instance ToJSON AuthTagActive where
toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
instance FromJSON AuthTagActive where
parseJSON = withObject "AuthTagActive" $ \o -> do
o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
return . AuthTagActive $ \n -> case HashMap.lookup n o' of
Nothing -> authTagIsActive def n
Just b -> b
derivePersistFieldJSON ''AuthTagActive
-- Type synonyms
type Email = Text

62
src/Utils.hs
View File

@ -4,10 +4,11 @@ module Utils
( module Utils
) where
import ClassyPrelude.Yesod
import ClassyPrelude.Yesod hiding (foldlM)
-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import Data.Foldable as Fold hiding (length)
import qualified Data.Foldable as Fold
import Data.Foldable as Utils (foldlM, foldrM)
import Data.Monoid (Sum(..))
import Data.CaseInsensitive (CI)
@ -200,7 +201,6 @@ stepTextCounter text
-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)"
-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"]
------------
-- Tuples --
------------
@ -395,12 +395,12 @@ catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
-- Monads --
------------
shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
shortCircuitM sc mx my bop = do
shortCircuitM :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a
shortCircuitM sc binOp mx my = do
x <- mx
if
| sc x -> return x
| otherwise -> bop <$> pure x <*> my
| otherwise -> binOp <$> pure x <*> my
guardM :: MonadPlus m => m Bool -> m ()
@ -423,26 +423,40 @@ ifM c m m' =
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM c = flip $ ifM c
-- | Lazy monadic conjunction.
and2M :: Monad m => m Bool -> m Bool -> m Bool
and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
and2M ma mb = ifM ma mb (return False)
andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM = Fold.foldr and2M (return True)
allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM xs f = andM $ fmap f xs
-- | Lazy monadic disjunction.
or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M ma = ifM ma (return True)
orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM = Fold.foldr and2M (return True)
orM = Fold.foldr or2M (return False)
anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM xs f = andM $ fmap f xs
anyM xs f = orM $ fmap f xs
ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono)
ofoldr1M f (otoList -> x:xs) = foldrM f x xs
ofoldr1M _ _ = error "otoList of NonNull is empty"
ofoldl1M f (otoList -> x:xs) = foldlM f x xs
ofoldl1M _ _ = error "otoList of NonNull is empty"
partitionM :: forall mono m .
( MonoFoldable mono
, Monoid mono
, MonoPointed mono
, Monad m)
=> (Element mono -> m Bool) -> mono -> m (mono, mono)
partitionM crit = ofoldlM dist mempty
where
dist :: (mono,mono) -> Element mono -> m (mono,mono)
dist acc x = do
okay <- crit x
return $ if
| okay -> acc `mappend` (opoint x, mempty)
| otherwise -> acc `mappend` (mempty, opoint x)
--------------
-- Sessions --
--------------
@ -452,3 +466,13 @@ setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSe
lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key
modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m ()
modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f
tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty
getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
-- ^ `lookupSessionJson` followed by `deleteSession`
getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)

3
src/Utils/Lens.hs
View File

@ -2,6 +2,7 @@ module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation
import Control.Lens as Utils.Lens
import Control.Lens.Extras as Utils.Lens (is)
import Utils.Lens.TH as Utils.Lens (makeLenses_)
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
@ -28,6 +29,8 @@ makeLenses_ ''SheetGrading
makeLenses_ ''SheetType
makePrisms ''AuthResult
-- makeClassy_ ''Load

12
src/Utils/Message.hs
View File

@ -1,6 +1,6 @@
module Utils.Message
( MessageClass(..)
, addMessage, addMessageI, addMessageIHamlet, addMessageFile
, addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
) where
@ -53,3 +53,13 @@ addMessageIHamlet mc iHamlet = do
addMessageFile :: MessageClass -> FilePath -> ExpQ
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
addMessageWidget :: forall m site.
( MonadHandler m
, HandlerSite m ~ site
, Yesod site
) => MessageClass -> WidgetT site IO () -> m ()
-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
addMessageWidget mc wgt = do
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))

7
src/Yesod/Core/Instances.hs
View File

@ -13,6 +13,8 @@ import Data.ByteString.Builder (toLazyByteString)
import System.FilePath ((</>))
import Data.Aeson
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
fromPathPiece
@ -32,3 +34,8 @@ instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
. over (_2.traverse._2) (assertM' $ not . null)
. renderRoute
instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
toJSON = String . toPathPiece

4
start.sh
View File

@ -10,11 +10,11 @@ export PWFILE=users.yml
move-back() {
mv -v .stack-work .stack-work-run
[[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
}
if [[ -d .stack-work-run ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
mv -v .stack-work-run .stack-work
trap move-back EXIT
fi

2
templates/authpreds.hamlet Normal file
View File

@ -0,0 +1,2 @@
<form method=post action=@{AuthPredsR} enctype=#{authActiveEnctype}>
^{authActiveWidget}

2
templates/formPage.hamlet
View File

@ -1,2 +1,2 @@
<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
<form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
^{formWidget}

2
templates/formPageI18n.hamlet
View File

@ -1,5 +1,5 @@
$maybe text <- formText
<h3>
_{text}
<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
<form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
^{formWidget}

5
templates/messages/submissionsAssignUnauthorized.hamlet Normal file
View File

@ -0,0 +1,5 @@
_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
<ul>
$forall cID <- unassignedUnauth'
<li><pre>#{toPathPiece cID}

1
templates/standalone/inputs.lucius
View File

@ -91,7 +91,6 @@ input[type*="time"] {
input[type="number"] {
width: 100px;
text-align: right;
}
input[type*="date"],

2
templates/submission-assign.hamlet Normal file
View File

@ -0,0 +1,2 @@
<form method=post action=@{actionUrl} enctype=#{corrEncoding}>
^{corrForm}

4
test.sh
View File

@ -2,11 +2,11 @@
move-back() {
mv -v .stack-work .stack-work-test
[[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
}
if [[ -d .stack-work-test ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
mv -v .stack-work-test .stack-work
trap move-back EXIT
fi