diff --git a/FragenSJ.txt b/FragenSJ.txt index c2219f2c1..6ddd8de2b 100644 --- a/FragenSJ.txt +++ b/FragenSJ.txt @@ -1,7 +1,7 @@ ** Sicherheitsabfragen? - Verschlüsselung des Zugriffs? - - SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage + - SDelR tid csh sn : GET zeigt Sicherheitsabfrage POST löscht. Ist das so sinnvoll? Sicherheitsabfrage als PopUpMessage? @@ -9,7 +9,7 @@ - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq? (Sheet.hs -> fetchSheet) - - Handler.Sheet.postSheetDelR: deleteCascade für Files? Klappt das? + - Handler.Sheet.postSDelR: deleteCascade für Files? Klappt das? Kann man abfragen, was bei deleteCascade alles gelöscht wird? @@ -19,7 +19,7 @@ Links -> MenuItems verwenden wie bisher Page Titles -> setTitleI Buttons? -> Kann leicht geändert werden! - Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel? + Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getTermCourseListR, Zeile 66 "pageActions" für menuItemLabel? ** Page pageActions - Berechtigungen prüfen? => Eigener Constructor statt NavbarLeft/Right?! diff --git a/README.md b/README.md index cf42dc5da..be734df7b 100644 --- a/README.md +++ b/README.md @@ -109,7 +109,7 @@ TABLE "user"; DROP TABLE "course" CASCADE; -- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer) -INSERT INTO "user_lecturer" (id,"user",school) VALUES (27,5,1); +INSERT INTO "user_lecturer" (id,"user","school") VALUES (27,5,1); -- Beenden: \q diff --git a/fill-db.hs b/fill-db.hs index 4cc894464..12301d0d8 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -89,8 +89,8 @@ main = db $ do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "ffp" - , courseTermId = TermKey summer2018 - , courseSchoolId = ifi + , courseTerm = TermKey summer2018 + , courseSchool = ifi , courseCapacity = Just 20 , courseHasRegistration = True , courseRegisterFrom = Just now @@ -104,8 +104,11 @@ main = db $ do void . insert $ DegreeCourse ffp sdMst sdInf void . insert $ Lecturer jost ffp void . insert $ Lecturer gkleen ffp - insert_ $ Corrector gkleen ffp (ByProportion 1) - sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing + sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing + insert_ $ SheetEdit gkleen now sheetkey + sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing + insert_ $ SheetEdit gkleen now sheetkey + sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing insert_ $ SheetEdit gkleen now sheetkey -- EIP eip <- insert Course @@ -113,8 +116,8 @@ main = db $ do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "eip" - , courseTermId = TermKey summer2017 - , courseSchoolId = ifi + , courseTerm = TermKey summer2017 + , courseSchool = ifi , courseCapacity = Just 20 , courseHasRegistration = False , courseRegisterFrom = Nothing @@ -132,8 +135,8 @@ main = db $ do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "ixd" - , courseTermId = TermKey summer2018 - , courseSchoolId = ifi + , courseTerm = TermKey summer2018 + , courseSchool = ifi , courseCapacity = Just 20 , courseHasRegistration = True , courseRegisterFrom = Just now @@ -151,8 +154,8 @@ main = db $ do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "ux3" - , courseTermId = TermKey winter2017 - , courseSchoolId = ifi + , courseTerm = TermKey winter2017 + , courseSchool = ifi , courseCapacity = Just 30 , courseHasRegistration = False , courseRegisterFrom = Nothing @@ -170,8 +173,8 @@ main = db $ do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "pmo" - , courseTermId = TermKey summer2017 - , courseSchoolId = ifi + , courseTerm = TermKey summer2017 + , courseSchool = ifi , courseCapacity = Just 50 , courseHasRegistration = False , courseRegisterFrom = Nothing @@ -189,8 +192,8 @@ main = db $ do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "dbs" - , courseTermId = TermKey summer2018 - , courseSchoolId = ifi + , courseTerm = TermKey summer2018 + , courseSchool = ifi , courseCapacity = Just 50 , courseHasRegistration = False , courseRegisterFrom = Nothing diff --git a/messages/de.msg b/messages/de.msg index fb15e4fea..fec6874c8 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -1,15 +1,17 @@ SummerTerm year@Integer: Sommersemester #{tshow year} WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year} PSLimitNonPositive: “pagesize” muss größer als null sein -Page n@Int64 num@Int64: Seite #{tshow n} von #{tshow num} +Page n@Int64: #{tshow n} TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert. TermNewTitle: Semester editiere/anlegen. InvalidInput: Eingaben bitte korrigieren. + CourseNewOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt. CourseEditOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert. CourseNewDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. FFSheetName: Name + SheetNewOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt. SheetTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName} SheetTitleNew tid@TermIdentifier courseShortHand@Text : #{termToText tid}-#{courseShortHand}: Neues Übungsblatt @@ -18,9 +20,37 @@ SheetNameDup tid@TermIdentifier courseShortHand@Text sheetName@Text: Es gi SheetDelTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{termToText tid}-#{courseShortHand} herauslöschen? SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben. SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. + +Unauthorized: Sie haben hierfür keine explizite Berechtigung. +UnauthorizedAnd l@Text r@Text: "#{l}" und "#{r}" +UnauthorizedOr l@Text r@Text: "#{l}" oder "#{r}" 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. UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen. +UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen. +UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen. UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. -OnlyUploadOneFile: Bitte nur eine Datei hochladen. \ No newline at end of file +UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. +UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. +UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. +OnlyUploadOneFile: Bitte nur eine Datei hochladen. +DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. +UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben. +UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung + +SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. +SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. +SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen +SubmissionMember g@Int: Mitabgebende(r) ##{tshow g} +SubmissionArchive: Zip-Archiv der Abgabedatei(en) +SubmissionFile: Datei zur Abgabe +SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt. + +EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer. +NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs #{termToText tid}-#{csh} angemeldet. + +HomeHeading: Startseite +TermsHeading: Semesterübersicht + +NumCourses n@Int64: #{tshow n} Kurse \ No newline at end of file diff --git a/models b/models index de3c17b88..31f089285 100644 --- a/models +++ b/models @@ -1,11 +1,12 @@ User - plugin Text - ident Text + plugin Text + ident Text matrikelnummer Text Maybe - email Text - displayName Text - maxFavourites Int default=12 + email Text + displayName Text + maxFavourites Int default=12 UniqueAuthentication plugin ident + UniqueEmail email UserAdmin user UserId school SchoolId @@ -51,20 +52,20 @@ DegreeCourse json terms StudyTermsId UniqueDegreeCourse course degree terms Course - name Text - description Html Maybe - linkExternal Text Maybe - shorthand Text - termId TermId - schoolId SchoolId - capacity Int Maybe + name Text + description Html Maybe + linkExternal Text Maybe + shorthand Text + term TermId + school SchoolId + capacity Int Maybe hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo registerFrom UTCTime Maybe registerTo UTCTime Maybe deregisterUntil UTCTime Maybe registerSecret Text Maybe -- Falls ein Passwort erforderlich ist materialFree Bool default=true - CourseTermShort termId shorthand + CourseTermShort term shorthand CourseEdit user UserId time UTCTime @@ -75,29 +76,28 @@ CourseFavourite course CourseId UniqueCourseFavourite user course Lecturer - userId UserId - courseId CourseId - UniqueLecturer userId courseId -Corrector - userId UserId - courseId CourseId + user UserId + course CourseId + UniqueLecturer user course +Corrector -- deprecated + user UserId + course CourseId load Load -- SELECT submissionID FROM Tutorial, TutorialUser, Submission, Sheet -- WHERE ( tutorialTutor = correctorUserId -- && tutorialCourse = correctorCourseId -- && tutorialUserTutorial = tutorialId -- && submissionUser = tutorialUserUser - -- && sheetId = submissionSheetId + -- && sheetId = SubmissionSheet -- && sheetCourse = correctorCourseId -- ) - UniqueCorrector userId courseId CourseParticipant - courseId CourseId - userId UserId + course CourseId + user UserId registration UTCTime - UniqueParticipant userId courseId + UniqueParticipant user course Sheet - courseId CourseId + course CourseId name Text description Html Maybe type SheetType @@ -108,23 +108,28 @@ Sheet activeTo UTCTime hintFrom UTCTime Maybe solutionFrom UTCTime Maybe - CourseSheet courseId name + CourseSheet course name SheetEdit user UserId time UTCTime sheet SheetId +SheetCorrector + user UserId + sheet SheetId + load Load + UniqueSheetCorrector user sheet SheetFile - sheetId SheetId - fileId FileId + sheet SheetId + file FileId type SheetFileType - UniqueSheetFile fileId sheetId type + UniqueSheetFile file sheet type File title FilePath content ByteString Maybe -- Nothing iff this is a directory modified UTCTime deriving Show Eq Submission - sheetId SheetId + sheet SheetId ratingPoints Points Maybe ratingComment Text Maybe ratingBy UserId Maybe @@ -135,37 +140,37 @@ SubmissionEdit time UTCTime submission SubmissionId SubmissionFile - submissionId SubmissionId - fileId FileId - isUpdate Bool - isDeletion Bool - UniqueSubmissionFile fileId submissionId isUpdate + submission SubmissionId + file FileId + isUpdate Bool -- is this the file updated by a corrector (original will always be retained) + isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector + UniqueSubmissionFile file submission isUpdate deriving Show SubmissionUser - userId UserId - submissionId SubmissionId - UniqueSubmissionUser userId submissionId + user UserId + submission SubmissionId + UniqueSubmissionUser user submission SubmissionGroup - courseId CourseId - name Text + course CourseId + name Text Maybe SubmissionGroupEdit user UserId time UTCTime submissionGroup SubmissionGroupId SubmissionGroupUser - submissionGroupId SubmissionGroupId - userId UserId - UniqueSubmissionGroupUser submissionGroupId userId + submissionGroup SubmissionGroupId + user UserId + UniqueSubmissionGroupUser submissionGroup user Tutorial json name Text - tutor UserId + tutor UserId course CourseId TutorialUser - userId UserId - tutorialId TutorialId - UniqueTutorialUser userId tutorialId + user UserId + tutorial TutorialId + UniqueTutorialUser user tutorial Booking - termId TermId + term TermId begin UTCTime end UTCTime weekly Bool @@ -182,17 +187,17 @@ Room building Text Maybe -- BookingRoom -- subject RoomForId --- roomId RoomId --- bookingId BookingId --- UniqueRoomCourse subject roomId bookingId +-- room RoomId +-- booking BookingId +-- UniqueRoomCourse subject room booking +RoomFor - courseId CourseId - tutorialId TutorialId - examId ExamId --- data RoomFor = RoomForCourseIdSum CourseId | RoomForTutorialIdSum TutorialId ... + course CourseId + tutorial TutorialId + exam ExamId +-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... -- EXAMS ARE TODO: Exam - courseId CourseId + course CourseId name Text description Text begin UTCTime @@ -207,8 +212,8 @@ Exam -- time UTCTime -- exam ExamId --ExamUser --- userId UserId +-- user UserId -- examId ExamId -- -- CONTINUE HERE: Include rating in this table or separately? --- UniqueExamUser userId examId +-- UniqueExamUser user examId -- By default this file is used in Model.hs (which is imported by Foundation.hs) diff --git a/package.yaml b/package.yaml index fb495c5a8..bb217ec2b 100644 --- a/package.yaml +++ b/package.yaml @@ -79,6 +79,8 @@ dependencies: - parsec - uuid - exceptions +- lens +- MonadRandom # The library contains all of our application code. The executable # defined below is just a thin wrapper. @@ -91,6 +93,7 @@ library: - -Wall - -fwarn-tabs - -O0 + - -ddump-splices cpp-options: -DDEVELOPMENT else: ghc-options: diff --git a/routes b/routes index 075a60fd4..37e2ebecb 100644 --- a/routes +++ b/routes @@ -1,41 +1,69 @@ -/static StaticR Static appStatic -/auth AuthR Auth getAuth +-- +-- Accesss granted via tags; default is no accesss. +-- Permission must be explicitly granted. +-- +-- Access permission is the disjunction of permit tags +-- Tags are split on "AND" to encode conjunction. +-- +-- Note that nested routes automatically inherit all tags from the parent. +-- +-- Admins always have access to entities within their assigned schools. +-- +-- Access Tags: +-- !free -- free for all +-- !lecturer -- lecturer for this course (or the school, if route is not connected to a course) +-- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) +-- !registered -- participant for this course (no effect outside of courses) +-- !owner -- part of the group of owners of this submission +-- +-- !materials -- only if course allows all materials to be free (no meaning outside of courses) +-- !time -- access depends on time somehow +-- !isRead -- only if it is read-only access (i.e. GET but not POST) +-- !isWrite -- only if it is write access (i.e. POST only) why needed??? +-- +-- !deprecated -- like free, but logs and gives a warning +-- -/favicon.ico FaviconR GET -/robots.txt RobotsR GET +/static StaticR Static appStatic !free +/auth AuthR Auth getAuth !free -/ HomeR GET POST -/profile ProfileR GET -/users UsersR GET !adminAny +/favicon.ico FaviconR GET !free +/robots.txt RobotsR GET !free -/term TermShowR GET -/term/edit TermEditR GET POST !adminAny -/term/#TermId/edit TermEditExistR GET !adminAny +/ HomeR GET POST !free +/profile ProfileR GET !free +/users UsersR GET -- no tags, i.e. admins only -/course/ CourseListR GET -!/course/new CourseNewR GET POST !lecturerAny -!/course/#TermId CourseListTermR GET -/course/#TermId/#Text CourseR !updateFavourite: - /show CourseShowR GET POST - /edit CourseEditR GET POST !lecturer +/terms TermShowR GET !free +/terms/current TermCurrentR GET !free +/terms/edit TermEditR GET POST +/terms/#TermId/edit TermEditExistR GET +!/terms/#TermId TermCourseListR GET !free - /ex SheetR !registered: - / SheetListR GET - /#Text/show SheetShowR GET !time - /#Text/#SheetFileType/#FilePath SheetFileR GET !time - /new SheetNewR GET POST !lecturer - /#Text/edit SheetEditR GET POST !lecturer - /#Text/delete SheetDelR GET POST !lecturer +-- For Pattern Synonyms see Foundation +/course/ CourseListR GET !free +!/course/new CourseNewR GET POST !lecturer +/course/#TermId/#Text CourseR !lecturer: + /show CShowR GET POST !free + /edit CEditR GET POST + /ex SheetListR GET !registered !materials + !/ex/new SheetNewR GET POST + /ex/#Text SheetR: + /show SShowR GET !timeANDregistered !timeANDmaterials !corrector + /#SheetFileType/#FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector + /edit SEditR GET POST + /delete SDelR GET POST + !/sub/new SubmissionNewR GET POST !timeANDregistered + !/sub/own SubmissionOwnR GET !free + !/sub/#CryptoUUIDSubmission SubmissionR GET POST !owner !corrector +!/#UUID CryptoUUIDDispatchR GET !free -- just redirect + -- TODO below -/submission SubmissionListR GET POST -/submission/#CryptoUUIDSubmission SubmissionR GET POST -/submissions.zip SubmissionDownloadMultiArchiveR POST -!/submission/archive/#FilePath SubmissionDownloadArchiveR GET -!/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET +!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated +!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated -!/#UUID CryptoUUIDDispatchR GET - --- For demonstration -/course/#CryptoUUIDCourse/edit CourseEditIDR GET +/submission SubmissionListR GET !deprecated +/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated +/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated diff --git a/shell.nix b/shell.nix index 3c37a979e..5185715fd 100644 --- a/shell.nix +++ b/shell.nix @@ -24,13 +24,12 @@ let override = oldAttrs: { nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]); shellHook = '' - ${oldAttrs.shellHook} export PROMPT_INFO="${oldAttrs.name}" pgDir=$(mktemp -d) pgSockDir=$(mktemp -d) pgLogFile=$(mktemp) - pg_ctl init -D ''${pgDir} + initdb --no-locale -D ''${pgDir} pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700" export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} psql -f ${postgresSchema} postgres @@ -42,6 +41,8 @@ let } trap cleanup EXIT + + ${oldAttrs.shellHook} ''; }; diff --git a/src/CryptoID.hs b/src/CryptoID.hs index ed2864eab..d13e98425 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -1,8 +1,11 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module CryptoID @@ -24,6 +27,9 @@ import System.FilePath.Cryptographic.ImplicitNamespace import Data.UUID.Types import Web.PathPieces +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + instance PathPiece UUID where fromPathPiece = fromString . unpack @@ -35,5 +41,33 @@ decCryptoIDs [ ''SubmissionId , ''CourseId , ''SheetId , ''FileId + , ''UserId ] {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -} + + + +newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission) + deriving (Show, Read, Eq) + +pattern NewSubmission :: SubmissionMode +pattern NewSubmission = SubmissionMode Nothing +pattern ExistingSubmission :: CryptoUUIDSubmission -> SubmissionMode +pattern ExistingSubmission cID = SubmissionMode (Just cID) + +instance PathPiece SubmissionMode where + fromPathPiece "new" = Just $ SubmissionMode Nothing + fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s + + toPathPiece (SubmissionMode Nothing) = "new" + toPathPiece (SubmissionMode (Just x)) = toPathPiece x + +newtype ZIPArchiveName objID = ZIPArchiveName (CryptoID (CI FilePath) objID) + deriving (Show, Read, Eq) + +instance PathPiece (ZIPArchiveName objID) where + fromPathPiece (map CI.mk . unpack -> s) + | Just s' <- stripSuffix (map CI.mk ".zip") s = Just . ZIPArchiveName . CryptoID . CI.mk $ map CI.original s' + | otherwise = Nothing + + toPathPiece (ZIPArchiveName CryptoID{..}) = pack (CI.foldedCase ciphertext) <> ".zip" diff --git a/src/Foundation.hs b/src/Foundation.hs index cdac53232..95033a6d4 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,14 +1,17 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Foundation where @@ -29,6 +32,7 @@ import LDAP.Search (LDAPEntry(..)) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE @@ -44,6 +48,13 @@ 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, (!?)) +import qualified Data.Map as Map + + import Data.Conduit (($$)) import Data.Conduit.List (sourceList) @@ -51,12 +62,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) import System.FilePath import Handler.Utils.Templates import Handler.Utils.StudyFeatures - +import Control.Lens +import Utils.Lens -- infixl 9 :$: -- pattern a :$: b = a b @@ -88,17 +101,29 @@ data UniWorX = UniWorX -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") +-- | Convenient Type Synonyms: +type DB a = YesodDB UniWorX a +type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) +type MsgRenderer = MsgRendererS UniWorX -- see Utils + -- Pattern Synonyms for convenience -pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn) +pattern CSheetR tid csh shn ptn + = CourseR tid csh (SheetR shn ptn) +-- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX - , menuItemAccessCallback :: Handler Bool + , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) } +menuItemAccessCallback :: MenuItem -> Handler Bool +menuItemAccessCallback MenuItem{..} = (&&) <$> ((==) Authorized <$> authCheck) <*> menuItemAccessCallback' + where + authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized menuItemRoute False + data MenuTypes -- Semantische Rolle: = NavbarAside { menuItem :: MenuItem } -- TODO | NavbarExtra { menuItem :: MenuItem } -- TODO @@ -107,10 +132,7 @@ data MenuTypes -- Semantische Rolle: | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten --- | Convenient Type Synonyms: -type DB a = YesodDB UniWorX a -type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) - +-- Messages mkMessage "UniWorX" "messages" "de" -- This instance is required to use forms. You can modify renderMessage to @@ -125,6 +147,217 @@ instance RenderMessage UniWorX TermIdentifier where where renderMessage' = renderMessage foundation ls +-- Access Control +data AccessPredicate + = APPure (Route UniWorX -> Reader MsgRenderer AuthResult) + | APHandler (Route UniWorX -> Handler AuthResult) + | APDB (Route UniWorX -> DB AuthResult) + +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 +-- and +andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y +andAR _ reason@(Unauthorized x) _ = reason +andAR _ _ reason@(Unauthorized x) = reason +andAR _ Authorized other = other +andAR _ AuthenticationRequired _ = AuthenticationRequired + +orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate +orAP = liftAR orAR (== Authorized) +andAP = liftAR andAR (const False) + +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 op sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . op =<< ask +liftAR op sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer +liftAR op sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer +liftAR op sc (APPure f) apg = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg +liftAR op sc apf apg@(APPure _) = liftAR op sc apg apf +liftAR op sc (APHandler f) apdb = liftAR op sc (APDB $ lift . f) apdb +liftAR op sc apdb apg@(APHandler _) = liftAR op sc apg apdb + + +trueAP,falseAP :: AccessPredicate +trueAP = APPure . const $ return Authorized +falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask +-- TODO: I believe falseAP := adminAP + +adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes) +adminAP = APDB $ \case + -- Courses: access only to school admins + CourseR tid 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.^. 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 = -- 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 + return Authorized + ) + ,("lecturer", APDB $ \case + CourseR tid 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.^. 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 + CSheetR _ _ _ (SubmissionR 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 csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn + guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) + return Authorized + CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + guard $ cid `Set.member` Map.keysSet resMap + return Authorized + _ -> do + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) + return Authorized + ) + ,("time", APDB $ \case + CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do + Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh + Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn + cTime <- liftIO getCurrentTime + case subRoute of + SFileR SheetExercise _ -> guard $ maybe False (<= cTime) sheetVisibleFrom + SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom + SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom + SFileR SheetMarking _ -> mzero -- only for correctors and lecturers + SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo + _ -> guard $ maybe False (<= cTime) sheetVisibleFrom + return Authorized + r -> do + $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r + unauthorizedI MsgUnauthorized + ) + ,("registered", APDB $ \case + CourseR tid 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.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) + return Authorized + r -> do + $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r + unauthorizedI MsgUnauthorized + ) + ,("materials", APDB $ \case + CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do + Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + guard courseMaterialFree + return Authorized + r -> do + $logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r + unauthorizedI MsgUnauthorized + ) + ,("owner", APDB $ \case + CSheetR _ _ _ (SubmissionR 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 + CSheetR _ _ _ SubmissionNewR -> unauthorizedI MsgUnauthorizedSubmissionOwner + r -> do + $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r + unauthorizedI MsgUnauthorized + ) + ,("isRead", APHandler $ \route -> + bool <$> return Authorized + <*> unauthorizedI MsgUnauthorizedWrite + <*> isWriteRequest route + ) + ,("isWrite", APHandler $ \route -> do + write <- isWriteRequest route + if write + then return Authorized + else unauthorizedI MsgUnauthorized + ) + ] + + +tag2ap :: Text -> AccessPredicate +tag2ap t = case Map.lookup (CI.mk t) knownTags of + (Just acp) -> acp + Nothing -> APHandler $ \_route -> 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 + +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) + where + attrsAND = map splitAND $ Set.toList $ routeAttrs r + splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" + +evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise +evalAccessDB r = case route2ap r of + (APPure p) -> lift $ runReader (p r) <$> getMsgRenderer + (APHandler p) -> lift $ p r + (APDB p) -> p r + +evalAccess :: Route UniWorX -> Handler AuthResult +evalAccess r = case route2ap r of + (APPure p) -> runReader (p r) <$> getMsgRenderer + (APHandler p) -> p r + (APDB p) -> runDB $ p r + +-- TODO: isAuthorized = evalAccess' + + + + -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod UniWorX where @@ -151,9 +384,9 @@ instance Yesod UniWorX where yesodMiddleware handler = do res <- defaultYesodMiddleware handler void . runMaybeT $ do - route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute - case route of - CourseR tid csh _ | "updateFavourite" `elem` attrs -> do + route <- MaybeT getCurrentRoute + case route of -- update Course Favourites here + CourseR tid csh _ -> do uid <- MaybeT maybeAuthId $(logDebug) "Favourites save" now <- liftIO $ getCurrentTime @@ -161,7 +394,7 @@ instance Yesod UniWorX where cid <- MaybeT . getKeyBy $ CourseTermShort tid csh user <- MaybeT $ get uid -- update Favourites - lift $ upsertBy + void . lift $ upsertBy (UniqueCourseFavourite uid cid) (CourseFavourite uid now cid) [CourseFavouriteTime =. now] @@ -176,26 +409,84 @@ instance Yesod UniWorX where _other -> return () return res - defaultLayout = defaultLinkLayout [] + defaultLayout widget = do + master <- getYesod + mmsgs <- getMessages + + mcurrentRoute <- getCurrentRoute + + -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. + (title, parents) <- breadcrumbs + + let + menu = defaultLinks ++ maybe [] pageActions mcurrentRoute + + menuTypes <- filterM (menuItemAccessCallback . menuItem) menu + + -- Lookup Favourites if possible + favourites' <- do + muid <- maybeAuthId + case muid of + Nothing -> return [] + (Just uid) -> runDB . E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do + E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) + E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) + E.orderBy [ E.asc $ course E.^. CourseShorthand ] + return course + + favourites <- forM favourites' $ \(Entity _ c@Course{..}) + -> let + courseRoute = CourseR courseTerm courseShorthand CShowR + in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) + + -- 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 + asidenav = $(widgetFile "widgets/asidenav") + contentHeadline :: Maybe Widget + contentHeadline = pageHeading =<< mcurrentRoute + breadcrumbs :: Widget + breadcrumbs = $(widgetFile "widgets/breadcrumbs") + pageactionprime :: Widget + pageactionprime = $(widgetFile "widgets/pageactionprime") + -- functions to determine if there are page-actions + isPageActionPrime :: MenuTypes -> Bool + isPageActionPrime (PageActionPrime _) = True + isPageActionPrime _ = False + hasPageActions :: Bool + hasPageActions = any isPageActionPrime menuTypes + + pc <- widgetToPageContent $ do + addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900" + addScript $ StaticR js_zepto_js + addScript $ StaticR js_fetchPolyfill_js + addScript $ StaticR js_urlPolyfill_js + addScript $ StaticR js_featureChecker_js + addScript $ StaticR js_flatpickr_js + addScript $ StaticR js_tabber_js + addStylesheet $ StaticR css_flatpickr_css + addStylesheet $ StaticR css_tabber_css + addStylesheet $ StaticR css_fonts_css + addStylesheet $ StaticR css_icons_css + $(widgetFile "default-layout") + $(widgetFile "standalone/modal") + $(widgetFile "standalone/showHide") + $(widgetFile "standalone/inputs") + $(widgetFile "standalone/tabber") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - isAuthorized (AuthR _) _ = return Authorized - isAuthorized HomeR _ = return Authorized - isAuthorized FaviconR _ = return Authorized - isAuthorized RobotsR _ = return Authorized - isAuthorized (StaticR _) _ = return Authorized - isAuthorized ProfileR _ = isAuthenticated - isAuthorized TermShowR _ = return Authorized - isAuthorized CourseListR _ = return Authorized - isAuthorized (CourseListTermR _) _ = return Authorized - isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized - isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized - isAuthorized SubmissionListR _ = isAuthenticated - isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated --- isAuthorized TestR _ = return Authorized - isAuthorized route isWrite = runDB $ isAuthorizedDB route isWrite + isAuthorized route _isWrite = evalAccess route -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows @@ -236,92 +527,8 @@ instance Yesod UniWorX where makeLogger = return . appLogger -isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult -isAuthorizedDB route@(routeAttrs -> attrs) writeable - | "adminAny" `member` attrs = adminAccess Nothing - | "lecturerAny" `member` attrs = lecturerAccess Nothing - -isAuthorizedDB UsersR _ = adminAccess Nothing -isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID -isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID -isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName -isAuthorizedDB TermEditR _ = adminAccess Nothing -isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing -isAuthorizedDB CourseNewR _ = lecturerAccess Nothing -isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized -- -isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor -isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor -isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseEditIDR cID) _ = do - courseId <- decrypt cID - courseLecturerAccess courseId -isAuthorizedDB _route _isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop! - -submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult -submissionAccess cID = do - authId <- lift requireAuthId - submissionId <- either decrypt decrypt cID - Submission{..} <- get404 submissionId - submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] [] - let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy - return $ case auth of - True -> Authorized - False -> Unauthorized "No access to this submission" - -adminAccess :: Maybe SchoolId -- ^ If @Just@, matched exactly against 'userAdminSchool' - -> YesodDB UniWorX AuthResult -adminAccess school = do - authId <- lift requireAuthId - adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) [] - return $ if (not $ null adrights) - then Authorized - else Unauthorized "No admin access" -- TODO internationalize - -lecturerAccess :: Maybe SchoolId - -> YesodDB UniWorX AuthResult -lecturerAccess school = do - authId <- lift requireAuthId - lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) [] - return $ if (not $ null lecrights) - then Authorized - else Unauthorized "No lecturer access" -- TODO internationalize - -lecturerAccess' :: SchoolId -> YesodDB UniWorX AuthResult -lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLecturer - -courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult -courseLecturerAccess = authorizedFor UniqueLecturer MsgUnauthorizedLecturer - -courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult -courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrector - -courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult -courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant - -authorizedFor :: ( PersistEntityBackend record ~ BaseBackend backend - , PersistEntity record, PersistUniqueRead backend - , YesodAuth master, RenderMessage master msg - ) - => (AuthId master -> t -> Unique record) -> msg -> t -> ReaderT backend (HandlerT master IO) AuthResult -authorizedFor authType msg courseId = do - authId <- lift requireAuthId - access <- getBy $ authType authId courseId - case access of - (Just _) -> return Authorized - Nothing -> unauthorizedI msg - -isAuthorizedDB' :: Route UniWorX -> Bool -> YesodDB UniWorX Bool -isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite - -isAuthorized' :: Route UniWorX -> Bool -> Handler Bool -isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite - -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where breadcrumb TermShowR = return ("Semester", Just HomeR) @@ -329,25 +536,89 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) breadcrumb CourseListR = return ("Kurs", Just HomeR) - breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) - breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term) + breadcrumb (TermCourseListR term) = return (toPathPiece term, Just TermShowR) + breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term) breadcrumb CourseNewR = return ("Neu", Just CourseListR) - breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR) + breadcrumb (CourseR _ _ CEditR) = return ("Editieren", Just CourseListR) - breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR) - breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR) - breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR) - breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) - breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) + breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR) + breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) + breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR) + breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) + breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) + breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) - breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) - breadcrumb HomeR = return ("UniworkY", Nothing) + + breadcrumb HomeR = return ("Uniworky", Nothing) breadcrumb (AuthR _) = return ("Login", Just HomeR) breadcrumb ProfileR = return ("Profile", Just HomeR) breadcrumb _ = return ("home", Nothing) +pageActions :: Route UniWorX -> [MenuTypes] +pageActions (CourseR tid csh CShowR) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Übungsblätter" + , menuItemIcon = Nothing + , menuItemRoute = CourseR tid csh SheetListR + , menuItemAccessCallback' = return True + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Kurs Editieren" + , menuItemIcon = Nothing + , menuItemRoute = CourseR tid csh CEditR + , menuItemAccessCallback' = return True + } + ] +pageActions (CourseR tid csh SheetListR) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Neues Übungsblatt" + , menuItemIcon = Nothing + , menuItemRoute = CourseR tid csh SheetNewR + , menuItemAccessCallback' = return True + } + ] +pageActions (CSheetR tid csh shn SShowR) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Abgabe anlegen" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh shn SubmissionNewR + , menuItemAccessCallback' = return True -- TODO: check that no submission already exists + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgabe" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh shn SubmissionOwnR + , menuItemAccessCallback' = return True -- TODO: check that a submission already exists + } + ] +pageActions TermShowR = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Neues Semester" + , menuItemIcon = Nothing + , menuItemRoute = TermEditR + , menuItemAccessCallback' = return True + } + ] +pageActions (TermCourseListR _) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Neuer Kurs" + , menuItemIcon = Just "book" + , menuItemRoute = CourseNewR + , menuItemAccessCallback' = return True + } + ] + +pageActions _ = [] + +pageHeading :: Route UniWorX -> Maybe Widget +pageHeading HomeR + = Just [whamlet|_{MsgHomeHeading}|] +pageHeading TermShowR + = Just [whamlet|_{MsgTermsHeading}|] +pageHeading _ + = Nothing defaultLinks :: [MenuTypes] defaultLinks = -- Define the menu items of the header. @@ -355,114 +626,46 @@ defaultLinks = -- Define the menu items of the header. { menuItemLabel = "Home" , menuItemIcon = Just "home" , menuItemRoute = HomeR - , menuItemAccessCallback = return True + , menuItemAccessCallback' = return True } , NavbarRight $ MenuItem { menuItemLabel = "Profile" , menuItemIcon = Just "profile" , menuItemRoute = ProfileR - , menuItemAccessCallback = isJust <$> maybeAuthPair + , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Login" , menuItemIcon = Just "login" , menuItemRoute = AuthR LoginR - , menuItemAccessCallback = isNothing <$> maybeAuthPair + , menuItemAccessCallback' = isNothing <$> maybeAuthPair } , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" , menuItemIcon = Just "logout" , menuItemRoute = AuthR LogoutR - , menuItemAccessCallback = isJust <$> maybeAuthPair - } - , NavbarAside $ MenuItem - { menuItemLabel = "Aktuelle Veranstaltungen" - , menuItemIcon = Just "book" - , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future - , menuItemAccessCallback = return True - } - , NavbarAside $ MenuItem - { menuItemLabel = "Alte Veranstaltungen" - , menuItemIcon = Just "book" - , menuItemRoute = CourseListR -- should be CourseListInactiveR or similar in the future - , menuItemAccessCallback = return True + , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarAside $ MenuItem { menuItemLabel = "Veranstaltungen" , menuItemIcon = Just "book" - , menuItemRoute = CourseListR - , menuItemAccessCallback = return True + , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future + , menuItemAccessCallback' = return True + } + , NavbarAside $ MenuItem + { menuItemLabel = "Semester" + , menuItemIcon = Nothing + , menuItemRoute = CourseListR -- should be TermListR ,,, + , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Benutzer" , menuItemIcon = Just "user" , menuItemRoute = UsersR - , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False + , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } ] -defaultLinkLayout :: [MenuTypes] -> Widget -> Handler Html -defaultLinkLayout = defaultMenuLayout . (defaultLinks ++) - -defaultMenuLayout :: [MenuTypes] -> Widget -> Handler Html -defaultMenuLayout menu widget = do - master <- getYesod - mmsgs <- getMessages - - mcurrentRoute <- getCurrentRoute - - -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. - (title, parents) <- breadcrumbs - - menuTypes <- filterM (menuItemAccessCallback . menuItem) menu - - -- Lookup Favourites if possible - favourites <- do - muid <- maybeAuthId - case muid of - Nothing -> return [] - (Just uid) -> runDB . E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do - E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) - E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) - E.orderBy [ E.asc $ course E.^. CourseShorthand ] - return course - - -- 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 - asidenav = $(widgetFile "widgets/asidenav") - breadcrumbs :: Widget - breadcrumbs = $(widgetFile "widgets/breadcrumbs") - pageactionprime :: Widget - pageactionprime = $(widgetFile "widgets/pageactionprime") - -- functions to determine if there are page-actions - isPageActionPrime :: MenuTypes -> Bool - isPageActionPrime (PageActionPrime _) = True - isPageActionPrime _ = False - hasPageActions :: Bool - hasPageActions = any isPageActionPrime menuTypes - - pc <- widgetToPageContent $ do - addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900" - addScript $ StaticR js_featureChecker_js - addScript $ StaticR js_flatpickr_js - addStylesheet $ StaticR css_fonts_css - addStylesheet $ StaticR css_icons_css - addStylesheet $ StaticR css_flatpickr_css - $(widgetFile "default-layout") - $(widgetFile "standalone/modal") - $(widgetFile "standalone/showHide") - $(widgetFile "standalone/sortable") - $(widgetFile "standalone/inputs") - withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - -- How to run database actions. instance YesodPersist UniWorX where type YesodPersistBackend UniWorX = SqlBackend diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 1d22bc287..776d4e03b 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -26,11 +27,18 @@ import qualified Data.UUID.Cryptographic as UUID getCourseListR :: Handler TypedContent getCourseListR = redirect TermShowR -getCourseListTermR :: TermId -> Handler Html -getCourseListTermR tidini = do +getTermCurrentR :: Handler Html +getTermCurrentR = do + termIds <- runDB $ selectKeysList [TermActive ==. True] [] -- [Desc TermName] does not work, since database representation has wrong ordering + case fromNullable termIds of + Nothing -> notFound + (Just (maximum -> tid)) -> getTermCourseListR tid + +getTermCourseListR :: TermId -> Handler Html +getTermCourseListR tidini = do (term,courses) <- runDB $ (,) <$> get tidini - <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand] + <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand] when (isNothing term) $ do addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |] redirect TermShowR @@ -39,51 +47,43 @@ getCourseListTermR tidini = do [ headed "Kürzel" $ (\ckv -> let c = entityVal ckv shd = courseShorthand c - tid = courseTermId c - in [whamlet| #{shd} |] ) + tid = courseTerm c + in [whamlet| #{shd} |] ) -- , headed "Institut" $ [shamlet| #{course} |] , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal , headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal , headed "Teilnehmer" $ (\ckv -> do let cid = entityKey ckv - partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourseId ==. cid] + partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourse ==. cid] [whamlet| #{show partiNum} |] ) , headed " " $ (\ckv -> let c = entityVal ckv shd = courseShorthand c - tid = courseTermId c + tid = courseTerm c in do - adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False - -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else "" + adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False + -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else "" [whamlet| $if adminLink == Authorized - + editieren |] ) ] - let pageLinks = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Neuer Kurs" - , menuItemIcon = Just "book" - , menuItemRoute = CourseNewR - , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False - } - ] let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses - defaultLinkLayout pageLinks $ do + defaultLayout $ do setTitle "Semesterkurse" $(widgetFile "courses") -getCourseShowR :: TermId -> Text -> Handler Html -getCourseShowR tid csh = do +getCShowR :: TermId -> Text -> Handler Html +getCShowR tid csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh dependent <- (,,) - <$> get (courseSchoolId course) -- join - <*> count [CourseParticipantCourseId ==. cid] -- join + <$> get (courseSchool course) -- join + <*> count [CourseParticipantCourse ==. cid] -- join <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! Nothing -> return False (Just aid) -> do @@ -92,15 +92,7 @@ getCourseShowR tid csh = do return $ (courseEnt,dependent) let course = entityVal courseEnt (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered - let pageActions = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Übungsblätter" - , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh SheetListR - , menuItemAccessCallback = (== Authorized) <$> isAuthorized (CSheetR tid csh SheetListR) False - } - ] - defaultLinkLayout pageActions $ do + defaultLayout $ do setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") @@ -111,8 +103,8 @@ registerButton registered = renderAForm FormStandard $ msg = if registered then "Abmelden" else "Anmelden" regMsg = msg :: BootstrapSubmit Text -postCourseShowR :: TermId -> Text -> Handler Html -postCourseShowR tid csh = do +postCShowR :: TermId -> Text -> Handler Html +postCShowR tid csh = do aid <- requireAuthId (cid, registered) <- runDB $ do (Entity cid _) <- getBy404 $ CourseTermShort tid csh @@ -130,7 +122,7 @@ postCourseShowR tid csh = do when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" (_other) -> return () -- TODO check this! -- redirect or not?! I guess not, since we want GET now - getCourseShowR tid csh + getCShowR tid csh getCourseNewR :: Handler Html getCourseNewR = do @@ -140,13 +132,13 @@ getCourseNewR = do postCourseNewR :: Handler Html postCourseNewR = courseEditHandler Nothing -getCourseEditR :: TermId -> Text -> Handler Html -getCourseEditR tid csh = do +getCEditR :: TermId -> Text -> Handler Html +getCEditR tid csh = do course <- runDB $ getBy $ CourseTermShort tid csh courseEditHandler course -postCourseEditR :: TermId -> Text -> Handler Html -postCourseEditR = getCourseEditR +postCEditR :: TermId -> Text -> Handler Html +postCEditR = getCEditR getCourseEditIDR :: CryptoUUIDCourse -> Handler Html getCourseEditIDR cID = do @@ -163,7 +155,7 @@ courseDeleteHandler = undefined runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! let cti = toPathPiece $ cfTerm res addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] - redirect $ CourseListTermR $ cfTerm res + redirect $ TermCourseListR $ cfTerm res -} courseEditHandler :: Maybe (Entity Course) -> Handler Html @@ -183,8 +175,8 @@ courseEditHandler course = do , courseDescription = cfDesc res , courseLinkExternal = cfLink res , courseShorthand = cfShort res - , courseTermId = cfTerm res - , courseSchoolId = cfSchool res + , courseTerm = cfTerm res + , courseSchool = cfSchool res , courseCapacity = cfCapacity res , courseHasRegistration = cfHasReg res , courseRegisterFrom = cfRegFrom res @@ -199,7 +191,7 @@ courseEditHandler course = do insert_ $ CourseEdit aid now cid insert_ $ Lecturer aid cid addMessageI "info" $ MsgCourseNewOk tident csh - redirect $ CourseListTermR tid + redirect $ TermCourseListR tid Nothing -> addMessageI "danger" $ MsgCourseNewDupShort tident csh @@ -226,8 +218,8 @@ courseEditHandler course = do -- , CourseDescription =. cfDesc res -- , CourseLinkExternal =. cfLink res -- , CourseShorthand =. cfShort res -- TODO: change here should generate a warning, or only allowed for Admins?! --- , CourseTermId =. tid -- TODO: change here should generate a warning, or only allowed for Admins?! --- , CourseSchoolId =. cfSchool res +-- , CourseTerm =. tid -- TODO: change here should generate a warning, or only allowed for Admins?! +-- , CourseSchool =. cfSchool res -- , CourseCapacity =. cfCapacity res -- , CourseRegisterFrom =. cfRegFrom res -- , CourseRegisterTo =. cfRegTo res @@ -239,8 +231,8 @@ courseEditHandler course = do , courseDescription = cfDesc res , courseLinkExternal = cfLink res , courseShorthand = cfShort res - , courseTermId = cfTerm res - , courseSchoolId = cfSchool res + , courseTerm = cfTerm res + , courseSchool = cfSchool res , courseCapacity = cfCapacity res , courseHasRegistration = cfHasReg res , courseRegisterFrom = cfRegFrom res @@ -254,7 +246,7 @@ courseEditHandler course = do -- if (isNothing updOkay) -- then do addMessageI "info" $ MsgCourseEditOk tident csh - -- redirect $ CourseListTermR tid + -- redirect $ TermCourseListR tid -- else addMessageI "danger" $ MsgCourseEditDupShort tident csh (FormFailure _) -> addMessageI "warning" MsgInvalidInput @@ -291,8 +283,8 @@ courseToForm cEntity = CourseForm , cfDesc = courseDescription course , cfLink = courseLinkExternal course , cfShort = courseShorthand course - , cfTerm = courseTermId course - , cfSchool = courseSchoolId course + , cfTerm = courseTerm course + , cfSchool = courseSchool course , cfCapacity = courseCapacity course , cfHasReg = courseHasRegistration course , cfRegFrom = courseRegisterFrom course diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 0eff808f2..da31ab516 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -20,6 +20,8 @@ import Import hiding (Proxy) import Data.Proxy +import Handler.Utils + import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import qualified Control.Monad.Catch as E (Handler(..)) @@ -30,9 +32,13 @@ class CryptoRoute ciphertext plaintext where instance CryptoRoute UUID SubmissionId where cryptoIDRoute _ (CryptoID -> cID) = do - (_ :: SubmissionId) <- decrypt cID - - return $ SubmissionR cID + (smid :: SubmissionId) <- decrypt cID + (tid,csh,shn) <- runDB $ do + shid <- submissionSheet <$> get404 smid + Sheet{..} <- get404 shid + Course{..} <- get404 sheetCourse + return (courseTerm, courseShorthand, sheetName) + return $ CSheetR tid csh shn $ SubmissionR cID class Dispatch ciphertext (x :: [*]) where diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index bce3b39da..9a08c934b 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -43,7 +43,7 @@ getHomeR :: Handler Html getHomeR = do (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton) defaultLayout $ do - setTitle "Willkommen zum UniworkY Test!" + setTitle "Willkommen zum Uniworky Test!" $(widgetFile "home") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index a7f672cc7..57e1caa16 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} @@ -7,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} module Handler.Sheet where @@ -61,6 +63,7 @@ data SheetForm = SheetForm , sfSolutionFrom :: Maybe UTCTime , sfSolutionF :: Maybe FileInfo -- Keine SheetId im Formular! + , sfCorrectors :: [(UserId,Load)] } @@ -68,8 +71,8 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm makeSheetForm msId template = identForm FIDsheet $ \html -> do let oldFileIds fType | Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do - E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId - E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sId + E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile + E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId E.&&. sheetFile E.^. SheetFileType E.==. E.val fType return (file E.^. FileId) | otherwise = return Set.empty @@ -88,7 +91,8 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do <*> fileAFormOpt (fsb "Hinweis") <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template) <*> fileAFormOpt (fsb "Lösung") - <* submitButton + <*> formToAForm (correctorForm msId (maybe [] sfCorrectors template)) + -- <* submitButton return $ case result of FormSuccess sheetResult | errorMsgs <- validateSheet sheetResult @@ -117,36 +121,15 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do -- TODO: continue validation here!!! ] ] +correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX]) +correctorForm _msid templates = return mempty -- TODO deprecated + -- Datenbank UserId -> UserName + -- Eingabelist für Colonnade + -- enthält die benötigten Felder + -- FormResult konstruieren + -- Eingabebox für Korrektor hinzufügen + -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen -fetchSheetAux :: ( BaseBackend backend ~ SqlBackend - , E.SqlSelect b a - , Typeable a, MonadHandler m, IsPersistBackend backend - , PersistQueryRead backend, PersistUniqueRead backend - ) - => (E.SqlExpr (Entity Sheet) -> b) - -> Key Term -> Text -> Text -> ReaderT backend m a -fetchSheetAux prj tid csh shn = - let cachId = encodeUtf8 $ tshow (tid,csh,shn) - in cachedBy cachId $ do - -- Mit Yesod: - -- cid <- getKeyBy404 $ CourseTermShort tid csh - -- getBy404 $ CourseSheet cid shn - -- Mit Esqueleto: - sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId - E.where_ $ course E.^. CourseTermId E.==. E.val tid - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. sheet E.^. SheetName E.==. E.val shn - return $ prj sheet - case sheetList of - [sheet] -> return sheet - _other -> notFound - -fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet) -fetchSheet = fetchSheetAux id - -fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet) -fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn -- List Sheets getSheetListCID :: CourseId -> Handler Html @@ -163,16 +146,16 @@ getSheetList courseEnt = do let cid = entityKey courseEnt let course = entityVal courseEnt let csh = courseShorthand course - let tid = courseTermId course + let tid = courseTerm course sheets <- runDB $ do - rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom] + rawSheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] forM rawSheets $ \(Entity sid sheet) -> do - let sheetsub = [SubmissionSheetId ==. sid] + let sheetsub = [SubmissionSheet ==. sid] submissions <- count sheetsub rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub return (sid, sheet, (submissions, rated)) let colBase = mconcat - [ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet + [ headed "Blatt" $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR , headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3 , headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3 , headed "Bewertung" $ toWgt . show . sheetType . snd3 @@ -180,69 +163,93 @@ getSheetList courseEnt = do let colAdmin = mconcat -- only show edit button for allowed course assistants [ headed "Korrigiert" $ toWgt . snd . trd3 , headed "Eingereicht" $ toWgt . fst . trd3 - , headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s - , headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s + , headed "" $ \s -> simpleLink "Edit" $ CSheetR tid csh (sheetName $ snd3 s) SEditR + , headed "" $ \s -> simpleLink "Delete" $ CSheetR tid csh (sheetName $ snd3 s) SDelR ] showAdmin <- case sheets of ((_,firstSheet,_):_) -> do setUltDestCurrent - (Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False + (Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False _otherwise -> return False let colSheets = if showAdmin then colBase `mappend` colAdmin else colBase - let pageActions = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Neues Übungsblatt" - , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh SheetNewR - , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False - } - ] - defaultLinkLayout pageActions $ do + defaultLayout $ do setTitle $ toHtml $ T.append "Übungsblätter " csh if null sheets then [whamlet|Es wurden noch keine Übungsblätter angelegt.|] else encodeWidgetTable tableDefault colSheets sheets + -- Show single sheet -getSheetShowR :: TermId -> Text -> Text -> Handler Html -getSheetShowR tid csh shn = do +getSShowR :: TermId -> Text -> Text -> Handler Html +getSShowR tid csh shn = do entSheet <- runDB $ fetchSheet tid csh shn let sheet = entityVal entSheet sid = entityKey entSheet - -- - fileNameTypes <- runDB $ E.select $ E.from $ - \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do - -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId) - E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId) - -- filter to requested file - E.where_ (sheet E.^. SheetId E.==. E.val sid ) - -- return desired columns - return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType) - let fileLinks = map (\(E.Value fName, E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) fileNameTypes + -- without Colonnade +-- fileNameTypes <- runDB $ E.select $ E.from $ +-- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do +-- -- Restrict to consistent rows that correspond to each other +-- E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) +-- E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) +-- -- filter to requested file +-- E.where_ (sheet E.^. SheetId E.==. E.val sid ) +-- -- return desired columns +-- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) +-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid csh (SheetFileR shn fType fName),modified)) fileNameTypes + -- with Colonnade + let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do + -- Restrict to consistent rows that correspond to each other + E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) + E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) + -- filter to requested file + E.where_ $ sheet E.^. SheetId E.==. E.val sid + E.&&. E.not_ (E.isNothing $ file E.^. FileContent) + -- return desired columns + return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) + let colonnadeFiles = mconcat + [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype + , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) + (\(E.Value fName,_,_) -> str2widget fName) + , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime) + ] + fileTable <- dbTable def $ DBTable + { dbtSQLQuery = fileData + , dbtColonnade = colonnadeFiles + , dbtAttrs = tableDefault + , dbtIdent = "files" :: Text + , dbtSorting = [ ( "type" + , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType + ) + , ( "path" + , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle + ) + , ( "time" + , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified + ) + ] + } defaultLayout $ do setTitle $ toHtml $ T.append "Übung " $ sheetName sheet $(widgetFile "sheetShow") [whamlet| Under Construction !!! |] -- TODO - -getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent -getSheetFileR tid csh shn typ title = do +getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent +getSFileR tid csh shn typ title = do content <- runDB $ E.select $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId) - E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId) - E.on (sheet E.^. SheetCourseId E.==. course E.^. CourseId) + E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) + E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) + E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) -- filter to requested file E.where_ ((file E.^. FileTitle E.==. E.val title) E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.&&. (course E.^. CourseShorthand E.==. E.val csh ) - E.&&. (course E.^. CourseTermId E.==. E.val tid ) + E.&&. (course E.^. CourseTerm E.==. E.val tid ) ) -- return desired columns return $ file E.^. FileContent @@ -266,13 +273,13 @@ postSheetNewR :: TermId -> Text -> Handler Html postSheetNewR = getSheetNewR -getSheetEditR :: TermId -> Text -> Text -> Handler Html -getSheetEditR tid csh shn = do +getSEditR :: TermId -> Text -> Text -> Handler Html +getSEditR tid csh shn = do (sheetEnt, sheetFileIds) <- runDB $ do ent <- fetchSheet tid csh shn fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do - E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId - E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val (entityKey ent) + E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile + E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent) E.&&. sheetFile E.^. SheetFileType E.==. E.val SheetExercise return (file E.^. FileId) return (ent, fIds) @@ -292,6 +299,7 @@ getSheetEditR tid csh shn = do , sfHintF = Nothing -- TODO , sfSolutionFrom = sheetSolutionFrom , sfSolutionF = Nothing -- TODO + , sfCorrectors = [] -- TODO read correctors from list } let action newSheet = do replaceRes <- myReplaceUnique sid $ newSheet @@ -300,8 +308,8 @@ getSheetEditR tid csh shn = do (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here handleSheetEdit tid csh (Just sid) template action -postSheetEditR :: TermId -> Text -> Text -> Handler Html -postSheetEditR = getSheetEditR +postSEditR :: TermId -> Text -> Text -> Handler Html +postSEditR = getSEditR handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit tid csh msId template dbAction = do @@ -315,7 +323,7 @@ handleSheetEdit tid csh msId template dbAction = do actTime <- liftIO getCurrentTime cid <- getKeyBy404 $ CourseTermShort tid csh let newSheet = Sheet - { sheetCourseId = cid + { sheetCourse = cid , sheetName = sfName , sheetDescription = sfDescription , sheetType = sfType @@ -337,44 +345,44 @@ handleSheetEdit tid csh msId template dbAction = do insert_ $ SheetEdit aid actTime sid addMessageI "info" $ MsgSheetEditOk tident csh sfName return True - when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB + when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml _ -> return () let pageTitle = maybe (MsgSheetTitleNew tident csh) (MsgSheetTitle tident csh) mbshn let formTitle = pageTitle let formText = Nothing :: Maybe UniWorXMessage - actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute + actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") -getSheetDelR :: TermId -> Text -> Text -> Handler Html -getSheetDelR tid csh shn = do +getSDelR :: TermId -> Text -> Text -> Handler Html +getSDelR tid csh shn = do let tident = unTermKey tid ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) case result of - (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn + (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR (FormSuccess BtnDelete) -> do runDB $ fetchSheetId tid csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! - setMessageI $ MsgSheetDelOk tident csh shn - redirect $ CSheetR tid csh SheetListR + addMessageI "info" $ MsgSheetDelOk tident csh shn + redirect $ CourseR tid csh SheetListR _other -> do submissionno <- runDB $ do sid <- fetchSheetId tid csh shn - count [SubmissionSheetId ==. sid] + count [SubmissionSheet ==. sid] let formTitle = MsgSheetDelTitle tident csh shn let formText = Just $ MsgSheetDelText submissionno - let actionUrl = CSheetR tid csh $ SheetDelR shn + let actionUrl = CSheetR tid csh shn SDelR defaultLayout $ do setTitleI $ MsgSheetTitle tident csh shn $(widgetFile "formPageI18n") -postSheetDelR :: TermId -> Text -> Text -> Handler Html -postSheetDelR = getSheetDelR +postSDelR :: TermId -> Text -> Text -> Handler Html +postSDelR = getSDelR @@ -389,8 +397,8 @@ insertSheetFile sid ftype finfo = do insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX () insertSheetFile' sid ftype fs = do oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do - E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId - E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sid + E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile + E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype return (file E.^. FileId) keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 3e2160d28..3d738fe32 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -1,6 +1,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,6 +11,8 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeOperators #-} module Handler.Submission where @@ -24,8 +28,11 @@ import Control.Monad.Trans.Maybe import Control.Monad.State.Class import Control.Monad.Trans.State.Strict (StateT) +import qualified Data.Maybe import qualified Data.Text as Text import qualified Data.Text.Encoding as Text + +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E @@ -33,20 +40,310 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.List as Conduit import Data.Conduit.ResumableSink +import Data.Set (Set) +import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map +import Data.Bifunctor import System.FilePath -import Colonnade +import Colonnade hiding (bool) import Yesod.Colonnade import qualified Text.Blaze.Html5.Attributes as HA + +numberOfSubmissionEditDates :: Int64 +numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. + + +makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form (Maybe (Source Handler File), [Text]) +makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do + flip (renderAForm FormStandard) html $ (,) + <$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing + <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fsm $ MsgSubmissionMember g) buddy + | g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile + | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies + ]) + <* submitButton + where + (groupNr, editableBuddies) + | Arbitrary{..} <- grouping = (pred maxParticipants, True) -- pred to account for the person submitting + | otherwise = (0, False) + + aforced' f fs (Just (Just v)) = Just <$> aforced f fs v + aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" + +getSubmissionNewR, postSubmissionNewR :: TermId -> Text -> Text -> Handler Html +getSubmissionNewR = postSubmissionNewR +postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission + + +getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoUUIDSubmission -> Handler Html +getSubmissionR = postSubmissionR +postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid + +getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html +getSubmissionOwnR tid csh shn = do + authId <- requireAuthId + sid <- runDB $ do + shid <- fetchSheetId tid csh shn + submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do + E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + return $ submission E.^. SubmissionId + case submissions of + ((E.Value sid):_) -> return sid + [] -> notFound + cID <- encrypt sid + redirect . CourseR tid csh . SheetR shn $ SubmissionR cID + +submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html +submissionHelper tid csh shn (SubmissionMode mcid) = do + uid <- requireAuthId + msmid <- traverse decrypt mcid + (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do + sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn + case msmid of + Nothing -> do + submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do + E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + return $ submission E.^. SubmissionId + -- $logDebugS "Submission.DUPLICATENEW" (tshow submissions) + case submissions of + [] -> do + -- fetch buddies from previous submission in this course + buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) + let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser `E.InnerJoin` submissionEdit) -> do + E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId) + E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) + E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet) + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid + E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse + E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] + E.limit 1 + return $ submission E.^. SubmissionId + E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids + E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid + E.orderBy [E.asc $ user E.^. UserEmail] + return $ user E.^. UserEmail + return (sheet,buddies,[]) + (E.Value smid:_) -> do + cID <- encrypt smid + addMessageI "info" $ MsgSubmissionAlreadyExists + redirect $ CSheetR tid csh shn $ SubmissionR cID + (Just smid) -> do + shid' <- submissionSheet <$> get404 smid + when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] + -- fetch buddies from current submission + buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid + E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid + E.orderBy [E.asc $ user E.^. UserEmail] + return $ user E.^. UserEmail + -- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime] + lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do + E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) + E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid + E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] + E.limit numberOfSubmissionEditDates + return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime) + let lastEdits = map (bimap E.unValue E.unValue) lastEditValues + return (sheet,buddies,lastEdits) + let unpackZips = True -- undefined -- TODO + ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies + mCID <- runDB $ do + res' <- case res of + (FormMissing ) -> return $ FormMissing + (FormFailure failmsgs) -> return $ FormFailure failmsgs + (FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change + (FormSuccess (mFiles, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members + | (Arbitrary {..}) <- sheetGrouping + , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for + let gemails = map CI.foldedCase gEMails + prep :: [(E.Value Text, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool)) + prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(CI.mk m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] + participants <- fmap prep . E.select . E.from $ \user -> do + E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails + let + isParticipant = E.sub_select . E.from $ \courseParticipant -> do + E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse + return $ E.countRows E.>. E.val (0 :: Int64) + hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + return $ E.countRows E.>. E.val (0 :: Int64) + return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) + $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants + mr <- getMessageRender + + let failmsgs = flip Map.foldMapWithKey participants $ \email -> \case + Nothing -> [mr $ MsgEMailUnknown $ CI.original email] + (Just (_,False,_)) -> [mr $ MsgNotAParticipant (CI.original email) (unTermKey tid) csh] + (Just (_,_, True)) -> [mr $ MsgSubmissionAlreadyExistsFor (CI.original email)] + _other -> mempty + return $ if null failmsgs + then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants) + else FormFailure failmsgs + + | otherwise -> return $ FormFailure ["Mismatching number of group participants"] + + + case res' of + (FormSuccess (mFiles,(setFromList -> adhocIds))) -> do + now <- liftIO $ getCurrentTime + smid <- do + smid <- case (mFiles, msmid) of + (Nothing, Just smid) -- no new files, existing submission partners updated + -> return smid + (Just files, _) -- new files + -> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission shid uid ((,False) <$> msmid) + _ -> error "Impossible, because of definition of `makeSubmissionForm`" + -- Determine members of pre-registered group + groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup + E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid + E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse + return $ submissionGroupUser' E.^. SubmissionGroupUserUser + -- SubmissionUser for all group members (pre-registered & ad-hoc) + let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds + -- remove obsolete old entries + deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers] + -- maybe add current users + forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid + return smid + cID <- encrypt smid + return $ Just cID + (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml) + _other -> return Nothing + + case mCID of + Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR cID + Nothing -> return () + + mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid + + let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn + let formTitle = pageTitle + let formText = Nothing :: Maybe UniWorXMessage + actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute + -- Maybe construct a table to display uploaded archive files + let colonnadeFiles cid = mconcat + -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype + [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle) + (\(Entity _ File{..}) -> str2widget fileTitle) + , sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified + ] + smid2ArchiveTable (smid,cid) = DBTable + { dbtSQLQuery = submissionFileQuery smid + , dbtColonnade = colonnadeFiles cid + , dbtAttrs = tableDefault + , dbtIdent = "files" :: Text + , dbtSorting = [ ( "path" + , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileTitle + ) + , ( "time" + , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified + ) + ] + , dbtFilter = [] + } + mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid + + defaultLayout $ do + setTitleI pageTitle + $(widgetFile "formPageI18n") + [whamlet| + $maybe arCid <- mArCid + + + Archiv + $forall (name,time) <- lastEdits + last edited by #{name} at #{formatTimeGerDTlong time} + $maybe fileTable <- mFileTable + Enthaltene Dateien: + ^{fileTable} + |] + + + + + +submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) +submissionFileSource = E.selectSource . E.from . submissionFileQuery + +submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File) + -> E.SqlQuery (E.SqlExpr (Entity File)) +submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do + E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID + E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor + E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first + return f + +getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent +getSubmissionDownloadSingleR cID path = do + submissionID <- decrypt cID + cID' <- encrypt submissionID + + runDB $ do + isRating <- maybe False (== submissionID) <$> isRatingFile path + case isRating of + True -> do + file <- runMaybeT $ lift . ratingFile cID' =<< MaybeT (getRating submissionID) + maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file + False -> do + results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do + E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) + E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionID) + E.where_ (f E.^. FileTitle E.==. E.val path) + E.where_ . E.not_ . E.isNothing $ f E.^. FileContent + E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion + E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] + return f + + let fileName = Text.pack $ takeFileName path + case results of + [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c) + _ -> notFound + +getSubmissionDownloadArchiveR :: ZIPArchiveName SubmissionId -> Handler TypedContent +getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do + submissionID <- decrypt cID + cUUID <- encrypt submissionID + respondSourceDB "application/zip" $ do + rating <- lift $ getRating submissionID + case rating of + Nothing -> lift notFound + Just rating' -> do + let fileEntitySource' :: Source (YesodDB UniWorX) File + fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') + info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) } + fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder + + + + + + + +----------------------------------------------------------------------------------------------- +------------------------- DEMO BELOW + + submissionTable :: MForm Handler (FormResult [SubmissionId], Widget) submissionTable = do subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId - E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheetId + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet return (sub, sheet, course) @@ -54,9 +351,9 @@ submissionTable = do (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s let - anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR + anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName - anchorSubmission (_, cUUID, _) = SubmissionR cUUID + anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID colonnade = mconcat [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText @@ -91,7 +388,7 @@ postSubmissionListR = do Just sink -> return sink Nothing -> do Submission{..} <- lift $ get404 sId - return . newResumableSink $ sinkSubmission submissionSheetId userId (Just (sId, isUpdate)) + return . newResumableSink $ sinkSubmission submissionSheet userId (Just (sId, isUpdate)) sink' <- lift $ yield val ++$$ sink case sink' of Left _ -> error "sinkSubmission returned prematurely" @@ -115,39 +412,7 @@ postSubmissionListR = do defaultLayout $(widgetFile "submission-list") -getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent -getSubmissionDownloadSingleR cID path = do - submissionID <- decrypt cID - cID' <- encrypt submissionID - runDB $ do - isRating <- maybe False (== submissionID) <$> isRatingFile path - case isRating of - True -> do - file <- runMaybeT $ lift . ratingFile cID' =<< MaybeT (getRating submissionID) - maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file - False -> do - results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do - E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) - E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID) - E.where_ (f E.^. FileTitle E.==. E.val path) - E.where_ . E.not_ . E.isNothing $ f E.^. FileContent - E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion - E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] - return f - - let fileName = Text.pack $ takeFileName path - case results of - [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c) - _ -> notFound - -submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) -submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do - E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) - E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID - E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion - E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] - return f postSubmissionDownloadMultiArchiveR :: Handler TypedContent postSubmissionDownloadMultiArchiveR = do @@ -193,27 +458,12 @@ postSubmissionDownloadMultiArchiveR = do mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder -getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent -getSubmissionDownloadArchiveR path = do - let (baseName, ext) = splitExtension path - cID :: CryptoFileNameSubmission - cID = CryptoID $ CI.mk baseName - unless (ext == ".zip") notFound - submissionID <- decrypt cID - cUUID <- encrypt submissionID - respondSourceDB "application/zip" $ do - rating <- lift $ getRating submissionID - case rating of - Nothing -> lift notFound - Just rating' -> do - let fileEntitySource' :: Source (YesodDB UniWorX) File - fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') - info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) } - fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder -getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html -getSubmissionR = postSubmissionR -postSubmissionR cID = do + + +getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html +getSubmissionDemoR = postSubmissionDemoR +postSubmissionDemoR cID = do submissionId <- decrypt cID ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,) @@ -238,12 +488,12 @@ postSubmissionR cID = do yieldM $ do fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC) return File{..} - submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheetId userId (Just (submissionId, isUpdate)) + submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheet userId (Just (submissionId, isUpdate)) get404 submissionId' files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do - E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) - E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId) + E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) + E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionId) E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return (f, sf) return (submission, files) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 9d85edbee..a6942d85f 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude + , OverloadedStrings + , OverloadedLists + , RecordWildCards + , TemplateHaskell + , QuasiQuotes + , MultiParamTypeClasses + , TypeFamilies + , FlexibleContexts + #-} module Handler.Term where @@ -29,18 +31,18 @@ getTermShowR = do -- return term -- let - termData = E.from $ \term -> do + termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64)) + termData term = do -- E.orderBy [E.desc $ term E.^. TermStart ] - let courseCount :: E.SqlExpr (E.Value Int) - courseCount = E.sub_select . E.from $ \course -> do - E.where_ $ term E.^. TermId E.==. course E.^. CourseTermId + let courseCount = E.sub_select . E.from $ \course -> do + E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm return E.countRows return (term, courseCount) selectRep $ do - provideRep $ toJSON . map fst <$> runDB (E.select termData) + provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ do let colonnadeTerms = mconcat - [ headed "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do + [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do -- Scrap this if to slow, create term edit page instead adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False [whamlet| @@ -50,40 +52,46 @@ getTermShowR = do $else #{termToText termName} |] - , headed "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> + , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termLectureStart - , headed "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> + , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termLectureEnd - , headed "Aktiv" $ \(Entity _ Term{..},_) -> + , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) -> textCell $ bool "" tickmark termActive - , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) -> - cell [whamlet| - - #{show numCourses} Kurse - |] - , headed "Semesteranfang" $ \(Entity _ Term{..},_) -> + , sortable Nothing "Kursliste" $ anchorCell + (\(Entity tid _, _) -> TermCourseListR tid) + (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|]) + , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termStart - , headed "Semesterende" $ \(Entity _ Term{..},_) -> + , sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termEnd - , headed "Feiertage im Semester" $ \(Entity _ Term{..},_) -> + , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) -> stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays ] table <- dbTable def $ DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms - , dbtSorting = mempty + , dbtSorting = [ ( "start" + , SortColumn $ \term -> term E.^. TermStart + ) + , ( "end" + , SortColumn $ \term -> term E.^. TermEnd + ) + , ( "lecture-start" + , SortColumn $ \term -> term E.^. TermLectureStart + ) + , ( "lecture-end" + , SortColumn $ \term -> term E.^. TermLectureEnd + ) + ] + , dbtFilter = [ ( "active" + , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool)) + ) + ] , dbtAttrs = tableDefault , dbtIdent = "terms" :: Text } - let pageActions = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Neues Semester" - , menuItemIcon = Nothing - , menuItemRoute = TermEditR - , menuItemAccessCallback = (== Authorized) <$> isAuthorized TermEditR True - } - ] - defaultLinkLayout pageActions $ do + defaultLayout $ do setTitle "Freigeschaltete Semester" $(widgetFile "terms") diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 33fc5f0f4..72a833f48 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -16,7 +16,8 @@ import Handler.Utils.Form as Handler.Utils import Handler.Utils.Table as Handler.Utils import Handler.Utils.Table.Pagination as Handler.Utils -import Handler.Utils.Zip as Handler.Utils -import Handler.Utils.Rating as Handler.Utils +import Handler.Utils.Zip as Handler.Utils +import Handler.Utils.Rating as Handler.Utils import Handler.Utils.Submission as Handler.Utils -import Handler.Utils.Templates as Handler.Utils +import Handler.Utils.Sheet as Handler.Utils +import Handler.Utils.Templates as Handler.Utils diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 1936769ee..c4ab73a96 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -15,9 +15,11 @@ module Handler.Utils.Form where import Handler.Utils.Form.Types + +import Handler.Utils.DateTime + import Import import qualified Data.Char as Char -import Handler.Utils.DateTime import Data.String (IsString(..)) import qualified Data.Foldable as Foldable @@ -40,11 +42,13 @@ import qualified Database.Esqueleto.Internal.Sql as E import qualified Data.Set as Set +import Control.Monad.Writer.Class + ------------------------------------------------ -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ -data FormIdentifier = FIDcourse | FIDsheet +data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission deriving (Enum, Eq, Ord, Bounded, Read, Show) @@ -131,6 +135,8 @@ linkButton lbl cls url = [whamlet| +simpleLink :: Widget -> Route UniWorX -> Widget +simpleLink lbl url = [whamlet| ^{lbl} |] buttonField :: Button a => a -> Field Handler a buttonField btn = Field {fieldParse, fieldView, fieldEnctype} @@ -232,7 +238,6 @@ posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField - --termField: see Utils.Term schoolField :: Field Handler SchoolId @@ -327,6 +332,25 @@ sheetGroupAFormReq d _other = -- TODO -- TODO, offer options to choose between Arbitrary/Registered/NoGroups Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1) +{- +dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime +dayTimeField fs mutc = do + let (mbDay,mbTime) = case mutcs of + Nothing -> return (Nothing,Nothing) + (Just utc) -> + + (dayResult, dayView) <- mreq dayField fs + + (result, view) <- (,) <$> dayField <*> timeField + where + (mbDay,mbTime) + | (Just utc) <- mutc = + let lt = utcToLocalTime ??? utcs + in (Just $ localDay lt, Just $ localTimeOfDay lt) + | otherwise = (Nothing,Nothing) +-} + + utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing) -- TODO: Verify whether this is UTC or local time from Browser @@ -355,7 +379,7 @@ utcTimeField = Field fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -fsm = bfs +fsm = bfs -- TODO: get rid of Bootstrap fsb :: Text -> FieldSettings site fsb = bfs -- Just to avoid annoying Ambiguous Type Errors @@ -426,3 +450,26 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do , optionInternalValue = key , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs + +mforced :: (site ~ HandlerSite m, MonadHandler m) + => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site) +mforced Field{..} FieldSettings{..} val = do + tell fieldEnctype + name <- maybe newFormIdent return fsName + theId <- lift $ maybe newIdent return fsId + mr <- getMessageRender + let fsAttrs' = fsAttrs <> [("disabled", "")] + return ( FormSuccess val + , FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml <$> fmap mr fsTooltip + , fvId = theId + , fvInput = fieldView theId name fsAttrs' (Right val) False + , fvErrors = Nothing + , fvRequired = False + } + ) + +aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> a -> AForm m a +aforced field settings val = formToAForm $ second pure <$> mforced field settings val diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index e90c9501c..fe4c4b014 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -90,8 +90,8 @@ instance Exception RatingException getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) getRating submissionId = runMaybeT $ do let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs new file mode 100644 index 000000000..76fed4737 --- /dev/null +++ b/src/Handler/Utils/Sheet.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module Handler.Utils.Sheet where + +import Import + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E + + + + +fetchSheetAux :: ( BaseBackend backend ~ SqlBackend + , E.SqlSelect b a + , Typeable a, MonadHandler m, IsPersistBackend backend + , PersistQueryRead backend, PersistUniqueRead backend + ) + => (E.SqlExpr (Entity Sheet) -> b) + -> TermId -> Text -> Text -> ReaderT backend m a +fetchSheetAux prj tid csh shn = + let cachId = encodeUtf8 $ tshow (tid,csh,shn) + in cachedBy cachId $ do + -- Mit Yesod: + -- cid <- getKeyBy404 $ CourseTermShort tid csh + -- getBy404 $ CourseSheet cid shn + -- Mit Esqueleto: + sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. sheet E.^. SheetName E.==. E.val shn + return $ prj sheet + case sheetList of + [sheet] -> return sheet + _other -> notFound + +fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet) +fetchSheet = fetchSheetAux id + +fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet) +fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn + +fetchSheetIdCourseId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet, Key Course) +fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 6a100ab98..7cfc97f4e 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -15,13 +15,24 @@ module Handler.Utils.Submission , sinkSubmission ) where -import Import +import Import hiding ((.=)) + +import Control.Lens +import Control.Lens.Extras (is) +import Utils.Lens import Control.Monad.State hiding (forM_) +import qualified Control.Monad.Random as Rand +import Data.Maybe + +import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set - +import Data.Map (Map, (!?)) +import qualified Data.Map as Map + + import Data.Monoid (Monoid, Any(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) @@ -32,6 +43,70 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.List as Conduit +data AssignSubmissionException = NoCorrectorsByProportion + deriving (Typeable, Show) + +instance Exception AssignSubmissionException + +-- | Assigns all submissions according to sheet corrector loads +assignSubmissions :: + SheetId -- ^ Sheet do distribute to correction + -> YesodDB UniWorX (Set SubmissionId -- ^ assigned submissions + ,Set SubmissionId -- ^ unassigend submissions (no tutors by load) + ) +assignSubmissions sid = do + correctors <- selectList [SheetCorrectorSheet ==. sid] [] + let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto + let corrsProp = filter hasPositiveLoad correctors + let countsToLoad' :: UserId -> Bool + countsToLoad' uid = -- refactor by simply using Map.(!) + fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $ + Map.lookup uid loadMap + loadMap :: Map UserId Bool + loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsGroup] + + subs <- E.select . E.from $ \(submission `E.LeftOuterJoin` user) -> do + let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do + -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group + -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do + E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial) + E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser) + E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup)) + return $ tutorial E.^. TutorialTutor + E.on $ user E.?. UserId `E.in_` E.justList tutors + E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid + E.orderBy [E.rand] -- randomize for fair tutor distribution + return (submission E.^. SubmissionId, user) -- , listToMaybe tutors) + + queue <- liftIO . Rand.evalRandIO . sequence . repeat $ Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp] + + let subTutor' :: Map SubmissionId (Maybe UserId) + subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs + + subTutor <- fmap fst . flip execStateT (Map.empty, queue) . forM_ (Map.toList subTutor') $ \case + (smid, Just tutid) -> do + _1 %= Map.insert smid tutid + when (any ((== tutid) . sheetCorrectorUser . entityVal) corrsProp && countsToLoad' tutid) $ + _2 %= List.delete (Just tutid) + (smid, Nothing) -> do + (q:qs) <- use _2 + _2 .= qs + case q of + Just q -> _1 %= Map.insert smid q + Nothing -> return () -- NOTE: throwM NoCorrectorsByProportion + + forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid] + + let assignedSubmissions = Map.keysSet subTutor + unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions + return (assignedSubmissions, unassigendSubmissions) + where + hasPositiveLoad = (> 0) . byProportion . sheetCorrectorLoad . entityVal + hasTutorialLoad = isJust . byTutorial . sheetCorrectorLoad . entityVal + + + + data SubmissionSinkState = SubmissionSinkState { sinkSeenRating :: Any , sinkSubmissionTouched :: Any @@ -65,7 +140,7 @@ sinkSubmission :: SheetId sinkSubmission sheetId userId mExists = do now <- liftIO getCurrentTime let - submissionSheetId = sheetId + submissionSheet = sheetId submissionRatingPoints = Nothing submissionRatingComment = Nothing submissionRatingBy = Nothing @@ -90,8 +165,8 @@ sinkSubmission sheetId userId mExists = do tell $ mempty{ sinkFilenames = Set.singleton fileTitle } otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do - E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId - E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId + E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work return (f, sf) @@ -121,8 +196,8 @@ sinkSubmission sheetId userId mExists = do _ -> do fileId <- insert file insert_ $ SubmissionFile - { submissionFileSubmissionId = submissionId - , submissionFileFileId = fileId + { submissionFileSubmission = submissionId + , submissionFileFile = fileId , submissionFileIsUpdate = isUpdate , submissionFileIsDeletion = False } @@ -189,8 +264,8 @@ sinkSubmission sheetId userId mExists = do finalize :: SubmissionSinkState -> YesodDB UniWorX () finalize SubmissionSinkState{..} = do missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do - E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId - E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId + E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId when (not isUpdate) $ E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames) @@ -202,8 +277,8 @@ sinkSubmission sheetId userId mExists = do False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ] True -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do - E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId - E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId + E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate) E.where_ $ f E.^. FileTitle E.==. E.val fileTitle return $ f E.^. FileId @@ -212,13 +287,13 @@ sinkSubmission sheetId userId mExists = do ([], _) -> deleteCascade fileId (E.Value f:_, False) -> do insert_ $ SubmissionFile - { submissionFileSubmissionId = submissionId - , submissionFileFileId = f + { submissionFileSubmission = submissionId + , submissionFileFile = f , submissionFileIsUpdate = True , submissionFileIsDeletion = True } (E.Value f:_, True) -> do - update sfId [ SubmissionFileFileId =. f, SubmissionFileIsDeletion =. True ] + update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ] deleteCascade fileId when (isUpdate && not (getAny sinkSeenRating)) $ diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 28fcb1073..03b46992f 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -6,30 +6,50 @@ , QuasiQuotes , LambdaCase , ViewPatterns + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , TypeFamilies #-} module Handler.Utils.Table.Pagination ( SortColumn(..), SortDirection(..) + , FilterColumn(..), IsFilterColumn + , DBRow(..), DBOutput , DBTable(..) , PaginationSettings(..) , PSValidator(..) + , Sortable(..), sortable , dbTable ) where +import Handler.Utils.Table.Pagination.Types + import Import import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) +import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) +import qualified Database.Esqueleto.Internal.Language as E (From) import Text.Blaze (Attribute) import qualified Text.Blaze.Html5.Attributes as Html5 +import qualified Text.Blaze.Html5 as Html5 +import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..)) + +import qualified Data.Binary.Builder as Builder + +import qualified Network.Wai as Wai import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_) +import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_) import Data.Map (Map, (!)) +import qualified Data.Map as Map -import Colonnade hiding (bool, fromMaybe) +import Data.Profunctor (lmap) + +import Colonnade hiding (bool, fromMaybe, singleton) +import Colonnade.Encode import Yesod.Colonnade import Text.Hamlet (hamletFile) @@ -37,7 +57,7 @@ import Text.Hamlet (hamletFile) import Data.Ratio ((%)) -data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) } +data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) } data SortDirection = SortAsc | SortDesc deriving (Eq, Ord, Enum, Show, Read) @@ -49,24 +69,68 @@ instance PathPiece SortDirection where | t == "desc" = Just SortDesc | otherwise = Nothing -sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy -sqlSortDirection (SortColumn e, SortAsc ) = E.asc e -sqlSortDirection (SortColumn e, SortDesc) = E.desc e - -data DBTable = forall a r h i. - ( Headedness h - , E.SqlSelect a r +sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy +sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t +sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t + + +data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a + +filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool) +filterColumn (FilterColumn f) = filterColumn' f + +class IsFilterColumn t a where + filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool) + +instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where + filterColumn' fin _ _ = fin + +instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where + filterColumn' cont is t = filterColumn' (cont t) is t + +instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where + filterColumn' cont is t = filterColumn' (cont input) is' t + where + (input, ($ []) -> is') = go (mempty, id) is + go acc [] = acc + go (acc, is') (i:is) + | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is + | otherwise = go (acc, is' . (i:)) is + + +data DBRow r = DBRow + { dbrIndex, dbrCount :: Int64 + , dbrOutput :: r + } + +class DBOutput r r' where + dbProj :: r -> r' + +instance DBOutput r r where + dbProj = id +instance DBOutput (DBRow r) r where + dbProj = dbrOutput +instance DBOutput (DBRow r) (Int64, r) where + dbProj = (,) <$> dbrIndex <*> dbrOutput + + +data DBTable = forall a r r' h i t. + ( ToSortable h, Functor h + , E.SqlSelect a r, DBOutput (DBRow r) r' , PathPiece i + , E.From E.SqlQuery E.SqlExpr E.SqlBackend t ) => DBTable - { dbtSQLQuery :: E.SqlQuery a - , dbtColonnade :: Colonnade h r (Cell UniWorX) - , dbtSorting :: Map Text SortColumn + { dbtSQLQuery :: t -> E.SqlQuery a + , dbtColonnade :: Colonnade h r' (Cell UniWorX) + , dbtSorting :: Map Text (SortColumn t) + , dbtFilter :: Map Text (FilterColumn t) , dbtAttrs :: Attribute , dbtIdent :: i } data PaginationSettings = PaginationSettings { psSorting :: [(Text, SortDirection)] + , psFilter :: Map Text [Text] , psLimit :: Int64 , psPage :: Int64 , psShortcircuit :: Bool @@ -75,15 +139,16 @@ data PaginationSettings = PaginationSettings instance Default PaginationSettings where def = PaginationSettings { psSorting = [] + , psFilter = Map.empty , psLimit = 50 , psPage = 0 , psShortcircuit = False } -newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } +newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } instance Default PSValidator where - def = PSValidator $ \case + def = PSValidator $ \DBTable{..} -> \case Nothing -> def Just ps -> swap . (\act -> execRWS act () ps) $ do l <- gets psLimit @@ -91,8 +156,9 @@ instance Default PSValidator where modify $ \ps -> ps { psLimit = psLimit def } tell . pure $ SomeMessage MsgPSLimitNonPositive + dbTable :: PSValidator -> DBTable -> Handler Widget -dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do +dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do let sortingOptions = mkOptionList [ Option t' (t, d) t' @@ -100,46 +166,96 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do , d <- [SortAsc, SortDesc] , let t' = t <> "-" <> toPathPiece d ] - (_, defPS) = runPSValidator Nothing + (_, defPS) = runPSValidator dbtable Nothing wIdent n | not $ null dbtIdent = dbtIdent <> "-" <> n | otherwise = n dbtAttrs' | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs | otherwise = dbtAttrs + multiTextField = Field + { fieldParse = \ts _ -> return . Right $ Just ts + , fieldView = undefined + , fieldEnctype = UrlEncoded + } psResult <- runInputGetResult $ PaginationSettings - <$> ireq (multiSelectField $ return sortingOptions) (wIdent "sorting") + <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")) + <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField $ wIdent k) dbtFilter) <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize")) <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) <*> ireq checkBoxField (wIdent "table-only") - $(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult) - <*> (psLimit <$> psResult) - <*> (psPage <$> psResult) - <*> (psShortcircuit <$> psResult) + $(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult) + <*> (Map.keys . psFilter <$> psResult) + <*> (psLimit <$> psResult) + <*> (psPage <$> psResult) + <*> (psShortcircuit <$> psResult) let (errs, PaginationSettings{..}) = case psResult of - FormSuccess ps -> runPSValidator $ Just ps - FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing - FormMissing -> runPSValidator Nothing + FormSuccess ps -> runPSValidator dbtable $ Just ps + FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing + FormMissing -> runPSValidator dbtable Nothing psSorting' = map (first (dbtSorting !)) psSorting - sqlQuery' = dbtSQLQuery - <* E.orderBy (map sqlSortDirection psSorting') + sqlQuery' = E.from $ \t -> dbtSQLQuery t + <* E.orderBy (map (sqlSortDirection t) psSorting') <* E.limit psLimit <* E.offset (psPage * psLimit) + <* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter mapM_ (addMessageI "warning") errs - (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64))) + rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "row_number() OVER ()" :: E.SqlExpr (E.Value Int64), E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' + + let + rowCount + | ((_, E.Value n), _):_ <- rows' = n + | otherwise = 0 + rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows' bool return (sendResponse <=< tblLayout) psShortcircuit $ do - let table = encodeCellTable dbtAttrs' dbtColonnade rows + getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest + let table = $(widgetFile "table/colonnade") pageCount = max 1 . ceiling $ rowCount % psLimit - $(widgetFile "table-layout") + pageNumbers = [0..pred pageCount] + tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams + + withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell + { cellContents = $(widgetFile "table/sortable-header") + , cellAttrs = maybe mempty (const sortableAttr) sortableKey <> cellAttrs + } + where + directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] + sortableAttr = Html5.class_ . fromString . unwords $ "sortable" : foldMap toAttr directions + toAttr SortAsc = ["sorted-asc"] + toAttr SortDesc = ["sorted-desc"] + $(widgetFile "table/layout") where tblLayout :: Widget -> Handler Html tblLayout tbl' = do tbl <- widgetToPageContent tbl' - withUrlRenderer $(hamletFile "templates/table-layout-wrapper.hamlet") + withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet") + + setParam :: Text -> Maybe Text -> QueryText -> QueryText + setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ] + +widgetFromCell :: + (Attribute -> WidgetT site IO () -> WidgetT site IO ()) + -> Cell site + -> WidgetT site IO () +widgetFromCell f (Cell attrs contents) = + f attrs contents +td,th :: + Attribute -> WidgetT site IO () -> WidgetT site IO () + +td = liftParent Html5.td +th = liftParent Html5.th + +liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a +liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do + (a,gwd) <- f hdata + let Body bodyFunc = gwdBody gwd + newBodyFunc render = + el Html5.! attrs $ (bodyFunc render) + return (a,gwd { gwdBody = Body newBodyFunc }) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs new file mode 100644 index 000000000..1c0c883d6 --- /dev/null +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , RankNTypes + , RecordWildCards + #-} + +module Handler.Utils.Table.Pagination.Types where + +import Import hiding (singleton) + +import Colonnade +import Colonnade.Encode + +data Sortable a = Sortable + { sortableKey :: Maybe Text + , sortableContent :: a + } + +sortable :: Maybe Text -> c -> (a -> c) -> Colonnade Sortable a c +sortable k h = singleton (Sortable k h) + +instance Headedness Sortable where + headednessPure = Sortable Nothing + headednessExtract = Just $ \(Sortable _ x) -> x + headednessExtractForall = Just $ ExtractForall (\(Sortable _ x) -> x) + +instance Functor Sortable where + fmap f Sortable{..} = Sortable { sortableContent = f sortableContent, .. } + +newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a} + +class Headedness s => ToSortable s where + pSortable :: Maybe (SortableP s) + +instance ToSortable Sortable where + pSortable = Just $ SortableP id + +instance ToSortable Headed where + pSortable = Just $ SortableP (\(Headed x) -> Sortable Nothing x) + +instance ToSortable Headless where + pSortable = Nothing + diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 9aac70705..3ad4a0868 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -54,7 +54,7 @@ deriveJSON defaultOptions ''SheetType derivePersistFieldJSON "SheetType" data SheetGroup - = Arbitrary { maxParticipants :: Int } -- Distinguish Limited/Arbitrary + = Arbitrary { maxParticipants :: Int } | RegisteredGroups | NoGroups deriving (Show, Read, Eq) @@ -77,10 +77,33 @@ data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "ExamStatus" -data Load = ByTutorial | ByProportion Rational +-- | Specify a corrector's workload +data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } + = Load { byTutorial :: Maybe Bool -- ^ Just all from Tutorial, True if counting towards overall workload + , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders + } deriving (Show, Read, Eq) derivePersistField "Load" +instance Semigroup Load where + (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') + where + byTut'' + | Nothing <- byTut = byTut' + | Nothing <- byTut' = byTut + | Just a <- byTut + , Just b <- byTut' = Just $ a || b + +instance Monoid Load where + mempty = Load Nothing 0 + mappend = (<>) + +{- Use (is _ByTutorial) instead of this unneeded definition: + isByTutorial :: Load -> Bool + isByTutorial (ByTutorial {}) = True + isByTutorial _ = False +-} + data Season = Summer | Winter deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) @@ -158,3 +181,6 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded) derivePersistField "StudyFieldType" + + + diff --git a/src/Utils.hs b/src/Utils.hs index a1816cb71..e753dcbf2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE QuasiQuotes #-} @@ -14,10 +16,30 @@ import Utils.Common as Utils import Text.Blaze (Markup, ToMarkup) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.List as List +-- import Data.Map (Map) +-- import qualified Data.Map as Map +-- import qualified Data.List as List +import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Catch + + +----------- +-- Yesod -- +----------- + +newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) } + +getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site) +getMsgRenderer = do + mr <- getMessageRender + return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text) + + +--------------------- +-- Text and String -- +--------------------- tickmark :: IsString a => a tickmark = fromString "✔" @@ -42,6 +64,16 @@ withFragment :: ( Monad m ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) + +------------ +-- Tuples -- +------------ + +---------- +-- Maps -- +---------- + + ----------- -- Maybe -- ----------- @@ -49,8 +81,48 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () +maybeT :: Monad m => m a -> MaybeT m a -> m a +maybeT x m = runMaybeT m >>= maybe x return + +catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a +catchIfMaybeT p act = catchIf p (lift act) (const mzero) + +--------------- +-- Exception -- +--------------- + +maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b +maybeExceptT err act = lift act >>= maybe (throwE err) return + +maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b +maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return + +whenExceptT :: Monad m => Bool -> e -> ExceptT e m () +whenExceptT b err = when b $ throwE err + +whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m () +whenMExceptT b err = when b $ lift err >>= throwE + +guardExceptT :: Monad m => Bool -> e -> ExceptT e m () +guardExceptT b err = unless b $ throwE err + +guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m () +guardMExceptT b err = unless b $ lift err >>= throwE + +exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b +exceptT f g = either f g <=< runExceptT + +catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a +catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err) ----------- --- Maps -- ----------- +------------ +-- Monads -- +------------ + +shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a +shortCircuitM sc mx my op = do + x <- mx + case sc x of + True -> return x + False -> op <$> pure x <*> my diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 7ef941d4d..3a2e6c804 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/Common.hs @@ -5,7 +5,10 @@ module Utils.Common where -- Common Utility Functions import Language.Haskell.TH - +-- import Control.Monad +-- import Control.Monad.Trans.Class +-- import Control.Monad.Trans.Maybe +-- import Control.Monad.Trans.Except ------------ -- Tuples -- @@ -50,3 +53,4 @@ altFun perm = lamE pat rhs ps = [ xs !! (j-1) | j <- perm ] fn = mkName "fn" + diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs new file mode 100644 index 000000000..c57898cba --- /dev/null +++ b/src/Utils/Lens.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +module Utils.Lens where + +import Import.NoFoundation +import Control.Lens + +makeClassy_ ''Entity + +makeClassy_ ''SheetCorrector + +-- makeClassy_ ''Load diff --git a/static/css/icons.css b/static/css/icons.css index b836de6e3..e5fdd191d 100644 --- a/static/css/icons.css +++ b/static/css/icons.css @@ -32,3 +32,6 @@ .glyphicon--logout::before { content: '\e163'; } +.glyphicon--none::before { + content: ''; +} diff --git a/static/css/tabber.css b/static/css/tabber.css new file mode 100644 index 000000000..6f823b410 --- /dev/null +++ b/static/css/tabber.css @@ -0,0 +1,39 @@ +.tab-group { + border-top: 2px solid #dcdcdc; + padding-top: 30px; +} + +.tab-group-openers { + display: flex; + justify-content: stretch; + line-height: 40px; + font-size: 14px; + margin-bottom: 40px; +} + +.tab-opener { + display: inline-block; + flex: 1; + text-align: center; + padding: 0 13px; + margin: 0 2px; + background-color: #b3b7c1; + color: white; + font-size: 16px; + text-transform: uppercase; + font-weight: 600; + transition: all .1s ease; + border-bottom: 5px solid rgba(100, 100, 100, 0.2); +} +.tab-opener:not(.tab-visible):hover { + cursor: pointer; + background-color: transparent; + color: rgb(52, 48, 58); + border-bottom-color: grey; +} + +.tab-opener.tab-visible { + background-color: transparent; + color: rgb(52, 48, 58); + border-bottom-color: #5F98C2; +} diff --git a/static/js/featureChecker.js b/static/js/featureChecker.js index a3a21e663..ad8e26303 100644 --- a/static/js/featureChecker.js +++ b/static/js/featureChecker.js @@ -1,7 +1,4 @@ window.addEventListener('touchstart', function onFirstTouch() { - // we could use a class document.body.classList.add('touch-supported'); - - // we only need to know once that a human touched the screen, so we can stop listening now window.removeEventListener('touchstart', onFirstTouch, false); }, false); diff --git a/static/js/fetchPolyfill.js b/static/js/fetchPolyfill.js new file mode 100644 index 000000000..ac9a4fd87 --- /dev/null +++ b/static/js/fetchPolyfill.js @@ -0,0 +1,466 @@ +(function(self) { + 'use strict'; + + if (self.fetch) { + return + } + + var support = { + searchParams: 'URLSearchParams' in self, + iterable: 'Symbol' in self && 'iterator' in Symbol, + blob: 'FileReader' in self && 'Blob' in self && (function() { + try { + new Blob() + return true + } catch(e) { + return false + } + })(), + formData: 'FormData' in self, + arrayBuffer: 'ArrayBuffer' in self + } + + if (support.arrayBuffer) { + var viewClasses = [ + '[object Int8Array]', + '[object Uint8Array]', + '[object Uint8ClampedArray]', + '[object Int16Array]', + '[object Uint16Array]', + '[object Int32Array]', + '[object Uint32Array]', + '[object Float32Array]', + '[object Float64Array]' + ] + + var isDataView = function(obj) { + return obj && DataView.prototype.isPrototypeOf(obj) + } + + var isArrayBufferView = ArrayBuffer.isView || function(obj) { + return obj && viewClasses.indexOf(Object.prototype.toString.call(obj)) > -1 + } + } + + function normalizeName(name) { + if (typeof name !== 'string') { + name = String(name) + } + if (/[^a-z0-9\-#$%&'*+.\^_`|~]/i.test(name)) { + throw new TypeError('Invalid character in header field name') + } + return name.toLowerCase() + } + + function normalizeValue(value) { + if (typeof value !== 'string') { + value = String(value) + } + return value + } + + // Build a destructive iterator for the value list + function iteratorFor(items) { + var iterator = { + next: function() { + var value = items.shift() + return {done: value === undefined, value: value} + } + } + + if (support.iterable) { + iterator[Symbol.iterator] = function() { + return iterator + } + } + + return iterator + } + + function Headers(headers) { + this.map = {} + + if (headers instanceof Headers) { + headers.forEach(function(value, name) { + this.append(name, value) + }, this) + } else if (Array.isArray(headers)) { + headers.forEach(function(header) { + this.append(header[0], header[1]) + }, this) + } else if (headers) { + Object.getOwnPropertyNames(headers).forEach(function(name) { + this.append(name, headers[name]) + }, this) + } + } + + Headers.prototype.append = function(name, value) { + name = normalizeName(name) + value = normalizeValue(value) + var oldValue = this.map[name] + this.map[name] = oldValue ? oldValue+','+value : value + } + + Headers.prototype['delete'] = function(name) { + delete this.map[normalizeName(name)] + } + + Headers.prototype.get = function(name) { + name = normalizeName(name) + return this.has(name) ? this.map[name] : null + } + + Headers.prototype.has = function(name) { + return this.map.hasOwnProperty(normalizeName(name)) + } + + Headers.prototype.set = function(name, value) { + this.map[normalizeName(name)] = normalizeValue(value) + } + + Headers.prototype.forEach = function(callback, thisArg) { + for (var name in this.map) { + if (this.map.hasOwnProperty(name)) { + callback.call(thisArg, this.map[name], name, this) + } + } + } + + Headers.prototype.keys = function() { + var items = [] + this.forEach(function(value, name) { items.push(name) }) + return iteratorFor(items) + } + + Headers.prototype.values = function() { + var items = [] + this.forEach(function(value) { items.push(value) }) + return iteratorFor(items) + } + + Headers.prototype.entries = function() { + var items = [] + this.forEach(function(value, name) { items.push([name, value]) }) + return iteratorFor(items) + } + + if (support.iterable) { + Headers.prototype[Symbol.iterator] = Headers.prototype.entries + } + + function consumed(body) { + if (body.bodyUsed) { + return Promise.reject(new TypeError('Already read')) + } + body.bodyUsed = true + } + + function fileReaderReady(reader) { + return new Promise(function(resolve, reject) { + reader.onload = function() { + resolve(reader.result) + } + reader.onerror = function() { + reject(reader.error) + } + }) + } + + function readBlobAsArrayBuffer(blob) { + var reader = new FileReader() + var promise = fileReaderReady(reader) + reader.readAsArrayBuffer(blob) + return promise + } + + function readBlobAsText(blob) { + var reader = new FileReader() + var promise = fileReaderReady(reader) + reader.readAsText(blob) + return promise + } + + function readArrayBufferAsText(buf) { + var view = new Uint8Array(buf) + var chars = new Array(view.length) + + for (var i = 0; i < view.length; i++) { + chars[i] = String.fromCharCode(view[i]) + } + return chars.join('') + } + + function bufferClone(buf) { + if (buf.slice) { + return buf.slice(0) + } else { + var view = new Uint8Array(buf.byteLength) + view.set(new Uint8Array(buf)) + return view.buffer + } + } + + function Body() { + this.bodyUsed = false + + this._initBody = function(body) { + this._bodyInit = body + if (!body) { + this._bodyText = '' + } else if (typeof body === 'string') { + this._bodyText = body + } else if (support.blob && Blob.prototype.isPrototypeOf(body)) { + this._bodyBlob = body + } else if (support.formData && FormData.prototype.isPrototypeOf(body)) { + this._bodyFormData = body + } else if (support.searchParams && URLSearchParams.prototype.isPrototypeOf(body)) { + this._bodyText = body.toString() + } else if (support.arrayBuffer && support.blob && isDataView(body)) { + this._bodyArrayBuffer = bufferClone(body.buffer) + // IE 10-11 can't handle a DataView body. + this._bodyInit = new Blob([this._bodyArrayBuffer]) + } else if (support.arrayBuffer && (ArrayBuffer.prototype.isPrototypeOf(body) || isArrayBufferView(body))) { + this._bodyArrayBuffer = bufferClone(body) + } else { + throw new Error('unsupported BodyInit type') + } + + if (!this.headers.get('content-type')) { + if (typeof body === 'string') { + this.headers.set('content-type', 'text/plain;charset=UTF-8') + } else if (this._bodyBlob && this._bodyBlob.type) { + this.headers.set('content-type', this._bodyBlob.type) + } else if (support.searchParams && URLSearchParams.prototype.isPrototypeOf(body)) { + this.headers.set('content-type', 'application/x-www-form-urlencoded;charset=UTF-8') + } + } + } + + if (support.blob) { + this.blob = function() { + var rejected = consumed(this) + if (rejected) { + return rejected + } + + if (this._bodyBlob) { + return Promise.resolve(this._bodyBlob) + } else if (this._bodyArrayBuffer) { + return Promise.resolve(new Blob([this._bodyArrayBuffer])) + } else if (this._bodyFormData) { + throw new Error('could not read FormData body as blob') + } else { + return Promise.resolve(new Blob([this._bodyText])) + } + } + + this.arrayBuffer = function() { + if (this._bodyArrayBuffer) { + return consumed(this) || Promise.resolve(this._bodyArrayBuffer) + } else { + return this.blob().then(readBlobAsArrayBuffer) + } + } + } + + this.text = function() { + var rejected = consumed(this) + if (rejected) { + return rejected + } + + if (this._bodyBlob) { + return readBlobAsText(this._bodyBlob) + } else if (this._bodyArrayBuffer) { + return Promise.resolve(readArrayBufferAsText(this._bodyArrayBuffer)) + } else if (this._bodyFormData) { + throw new Error('could not read FormData body as text') + } else { + return Promise.resolve(this._bodyText) + } + } + + if (support.formData) { + this.formData = function() { + return this.text().then(decode) + } + } + + this.json = function() { + return this.text().then(JSON.parse) + } + + return this + } + + // HTTP methods whose capitalization should be normalized + var methods = ['DELETE', 'GET', 'HEAD', 'OPTIONS', 'POST', 'PUT'] + + function normalizeMethod(method) { + var upcased = method.toUpperCase() + return (methods.indexOf(upcased) > -1) ? upcased : method + } + + function Request(input, options) { + options = options || {} + var body = options.body + + if (input instanceof Request) { + if (input.bodyUsed) { + throw new TypeError('Already read') + } + this.url = input.url + this.credentials = input.credentials + if (!options.headers) { + this.headers = new Headers(input.headers) + } + this.method = input.method + this.mode = input.mode + if (!body && input._bodyInit != null) { + body = input._bodyInit + input.bodyUsed = true + } + } else { + this.url = String(input) + } + + this.credentials = options.credentials || this.credentials || 'omit' + if (options.headers || !this.headers) { + this.headers = new Headers(options.headers) + } + this.method = normalizeMethod(options.method || this.method || 'GET') + this.mode = options.mode || this.mode || null + this.referrer = null + + if ((this.method === 'GET' || this.method === 'HEAD') && body) { + throw new TypeError('Body not allowed for GET or HEAD requests') + } + this._initBody(body) + } + + Request.prototype.clone = function() { + return new Request(this, { body: this._bodyInit }) + } + + function decode(body) { + var form = new FormData() + body.trim().split('&').forEach(function(bytes) { + if (bytes) { + var split = bytes.split('=') + var name = split.shift().replace(/\+/g, ' ') + var value = split.join('=').replace(/\+/g, ' ') + form.append(decodeURIComponent(name), decodeURIComponent(value)) + } + }) + return form + } + + function parseHeaders(rawHeaders) { + var headers = new Headers() + // Replace instances of \r\n and \n followed by at least one space or horizontal tab with a space + // https://tools.ietf.org/html/rfc7230#section-3.2 + var preProcessedHeaders = rawHeaders.replace(/\r?\n[\t ]+/g, ' ') + preProcessedHeaders.split(/\r?\n/).forEach(function(line) { + var parts = line.split(':') + var key = parts.shift().trim() + if (key) { + var value = parts.join(':').trim() + headers.append(key, value) + } + }) + return headers + } + + Body.call(Request.prototype) + + function Response(bodyInit, options) { + if (!options) { + options = {} + } + + this.type = 'default' + this.status = options.status === undefined ? 200 : options.status + this.ok = this.status >= 200 && this.status < 300 + this.statusText = 'statusText' in options ? options.statusText : 'OK' + this.headers = new Headers(options.headers) + this.url = options.url || '' + this._initBody(bodyInit) + } + + Body.call(Response.prototype) + + Response.prototype.clone = function() { + return new Response(this._bodyInit, { + status: this.status, + statusText: this.statusText, + headers: new Headers(this.headers), + url: this.url + }) + } + + Response.error = function() { + var response = new Response(null, {status: 0, statusText: ''}) + response.type = 'error' + return response + } + + var redirectStatuses = [301, 302, 303, 307, 308] + + Response.redirect = function(url, status) { + if (redirectStatuses.indexOf(status) === -1) { + throw new RangeError('Invalid status code') + } + + return new Response(null, {status: status, headers: {location: url}}) + } + + self.Headers = Headers + self.Request = Request + self.Response = Response + + self.fetch = function(input, init) { + return new Promise(function(resolve, reject) { + var request = new Request(input, init) + var xhr = new XMLHttpRequest() + + xhr.onload = function() { + var options = { + status: xhr.status, + statusText: xhr.statusText, + headers: parseHeaders(xhr.getAllResponseHeaders() || '') + } + options.url = 'responseURL' in xhr ? xhr.responseURL : options.headers.get('X-Request-URL') + var body = 'response' in xhr ? xhr.response : xhr.responseText + resolve(new Response(body, options)) + } + + xhr.onerror = function() { + reject(new TypeError('Network request failed')) + } + + xhr.ontimeout = function() { + reject(new TypeError('Network request failed')) + } + + xhr.open(request.method, request.url, true) + + if (request.credentials === 'include') { + xhr.withCredentials = true + } else if (request.credentials === 'omit') { + xhr.withCredentials = false + } + + if ('responseType' in xhr && support.blob) { + xhr.responseType = 'blob' + } + + request.headers.forEach(function(value, name) { + xhr.setRequestHeader(name, value) + }) + + xhr.send(typeof request._bodyInit === 'undefined' ? null : request._bodyInit) + }) + } + self.fetch.polyfill = true +})(typeof self !== 'undefined' ? self : this); \ No newline at end of file diff --git a/static/js/tabber.js b/static/js/tabber.js new file mode 100644 index 000000000..cad12b1aa --- /dev/null +++ b/static/js/tabber.js @@ -0,0 +1,88 @@ +(function($) { + + document.addEventListener('DOMContentLoaded', function() { + 'use strict'; + + // define plugin + $.fn.tabgroup = function() { + + var $this = $(this); + var $openers = $(''); + $this.prepend($openers); + + var openedByDefault = $this.data('tab-open') || 0; + var tabs = []; + var currentTab = {}; + + $this.find('.tab').each(function(i, t) { + var tab = $(t); + tab.data('tab-index', i); + var tabName = tab.data('tab-name') || 'Tab '+i; + var tabFile = tab.data('tab-file') || false; + var $opener = makeOpener(tabName, i); + $openers.append($opener); + if (tab.find('.tab-title')) { + tab.find('.tab-title').remove(); + } + tab.hide(); + var loaded = false; + tabs.push({index: i, name: tabName, file: tabFile, dom: tab, opener: $opener, loaded: false}); + }); + + $this.on('click', 'a[href^="#"]', function(event) { + var $target = $(event.currentTarget); + var tab = getTabByName($target.attr('href').replace('#', '')); + if ( tab ) { + showTab(tab.index); + } + event.preventDefault(); + }); + + function getTabByName(name) { + var it = -1; + $.each(tabs, function(i, t) { + if ( t.name.toLowerCase() === name.toLowerCase() ) { + it = i; + } + }); + if ( it >= 0 ) { + return tabs[it]; + } else { + return false; + } + } + + function makeOpener(tabName, i) { + return $(''+tabName+''). + on('click', function() { + showTab(i); + }); + } + + function showTab(i) { + tabs.forEach(function(t) { + t.dom.hide(); + t.opener.removeClass('tab-visible'); + }); + currentTab = tabs[i]; + if ( !currentTab.loaded && currentTab.file ){ + $.get(currentTab.file, function(res) { + currentTab.dom.html(res); + currentTab.loaded = true; + }); + } + currentTab.opener.addClass('tab-visible'); + currentTab.dom.show(); + } + + showTab(openedByDefault); + currentTab = tabs[openedByDefault]; + + }; + + // apply plugin to all available tab-groups + $('.tab-group').each(function(i, t) { + $(t).tabgroup(); + }) + }); +})($); diff --git a/static/js/urlPolyfill.js b/static/js/urlPolyfill.js new file mode 100644 index 000000000..e38c12021 --- /dev/null +++ b/static/js/urlPolyfill.js @@ -0,0 +1,348 @@ +(function(global) { + /** + * Polyfill URLSearchParams + * + * Inspired from : https://github.com/WebReflection/url-search-params/blob/master/src/url-search-params.js + */ + + var checkIfIteratorIsSupported = function() { + try { + return !!Symbol.iterator; + } catch(error) { + return false; + } + }; + + + var iteratorSupported = checkIfIteratorIsSupported(); + + var createIterator = function(items) { + var iterator = { + next: function() { + var value = items.shift(); + return { done: value === void 0, value: value }; + } + }; + + if(iteratorSupported) { + iterator[Symbol.iterator] = function() { + return iterator; + }; + } + + return iterator; + }; + + /** + * Search param name and values should be encoded according to https://url.spec.whatwg.org/#urlencoded-serializing + * encodeURIComponent() produces the same result except encoding spaces as `%20` instead of `+`. + */ + var serializeParam = function(value) { + return encodeURIComponent(value).replace(/%20/g, '+'); + }; + + var deserializeParam = function(value) { + return decodeURIComponent(value).replace(/\+/g, ' '); + }; + + var polyfillURLSearchParams= function() { + + var URLSearchParams = function(searchString) { + Object.defineProperty(this, '_entries', { value: {} }); + + if(typeof searchString === 'string') { + if(searchString !== '') { + searchString = searchString.replace(/^\?/, ''); + var attributes = searchString.split('&'); + var attribute; + for(var i = 0; i < attributes.length; i++) { + attribute = attributes[i].split('='); + this.append( + deserializeParam(attribute[0]), + (attribute.length > 1) ? deserializeParam(attribute[1]) : '' + ); + } + } + } else if(searchString instanceof URLSearchParams) { + var _this = this; + searchString.forEach(function(value, name) { + _this.append(value, name); + }); + } + }; + + var proto = URLSearchParams.prototype; + + proto.append = function(name, value) { + if(name in this._entries) { + this._entries[name].push(value.toString()); + } else { + this._entries[name] = [value.toString()]; + } + }; + + proto.delete = function(name) { + delete this._entries[name]; + }; + + proto.get = function(name) { + return (name in this._entries) ? this._entries[name][0] : null; + }; + + proto.getAll = function(name) { + return (name in this._entries) ? this._entries[name].slice(0) : []; + }; + + proto.has = function(name) { + return (name in this._entries); + }; + + proto.set = function(name, value) { + this._entries[name] = [value.toString()]; + }; + + proto.forEach = function(callback, thisArg) { + var entries; + for(var name in this._entries) { + if(this._entries.hasOwnProperty(name)) { + entries = this._entries[name]; + for(var i = 0; i < entries.length; i++) { + callback.call(thisArg, entries[i], name, this); + } + } + } + }; + + proto.keys = function() { + var items = []; + this.forEach(function(value, name) { items.push(name); }); + return createIterator(items); + }; + + proto.values = function() { + var items = []; + this.forEach(function(value) { items.push(value); }); + return createIterator(items); + }; + + proto.entries = function() { + var items = []; + this.forEach(function(value, name) { items.push([name, value]); }); + return createIterator(items); + }; + + if(iteratorSupported) { + proto[Symbol.iterator] = proto.entries; + } + + proto.toString = function() { + var searchString = ''; + this.forEach(function(value, name) { + if(searchString.length > 0) searchString+= '&'; + searchString += serializeParam(name) + '=' + serializeParam(value); + }); + return searchString; + }; + + global.URLSearchParams = URLSearchParams; + }; + + if(!('URLSearchParams' in global) || (new URLSearchParams('?a=1').toString() !== 'a=1')) { + polyfillURLSearchParams(); + } + + // HTMLAnchorElement + +})( + (typeof global !== 'undefined') ? global + : ((typeof window !== 'undefined') ? window + : ((typeof self !== 'undefined') ? self : this)) +); + +(function(global) { + /** + * Polyfill URL + * + * Inspired from : https://github.com/arv/DOM-URL-Polyfill/blob/master/src/url.js + */ + + var checkIfURLIsSupported = function() { + try { + var u = new URL('b', 'http://a'); + u.pathname = 'c%20d'; + return (u.href === 'http://a/c%20d') && u.searchParams; + } catch(e) { + return false; + } + }; + + + var polyfillURL = function() { + var _URL = global.URL; + + var URL = function(url, base) { + if(typeof url !== 'string') url = String(url); + + var doc = document.implementation.createHTMLDocument(''); + window.doc = doc; + if(base) { + var baseElement = doc.createElement('base'); + baseElement.href = base; + doc.head.appendChild(baseElement); + } + + var anchorElement = doc.createElement('a'); + anchorElement.href = url; + doc.body.appendChild(anchorElement); + anchorElement.href = anchorElement.href; // force href to refresh + + if(anchorElement.protocol === ':' || !/:/.test(anchorElement.href)) { + throw new TypeError('Invalid URL'); + } + + Object.defineProperty(this, '_anchorElement', { + value: anchorElement + }); + }; + + var proto = URL.prototype; + + var linkURLWithAnchorAttribute = function(attributeName) { + Object.defineProperty(proto, attributeName, { + get: function() { + return this._anchorElement[attributeName]; + }, + set: function(value) { + this._anchorElement[attributeName] = value; + }, + enumerable: true + }); + }; + + ['hash', 'host', 'hostname', 'port', 'protocol', 'search'] + .forEach(function(attributeName) { + linkURLWithAnchorAttribute(attributeName); + }); + + Object.defineProperties(proto, { + + 'toString': { + get: function() { + var _this = this; + return function() { + return _this.href; + }; + } + }, + + 'href' : { + get: function() { + return this._anchorElement.href.replace(/\?$/,''); + }, + set: function(value) { + this._anchorElement.href = value; + }, + enumerable: true + }, + + 'pathname' : { + get: function() { + return this._anchorElement.pathname.replace(/(^\/?)/,'/'); + }, + set: function(value) { + this._anchorElement.pathname = value; + }, + enumerable: true + }, + + 'origin': { + get: function() { + // get expected port from protocol + var expectedPort = {'http:': 80, 'https:': 443, 'ftp:': 21}[this._anchorElement.protocol]; + // add port to origin if, expected port is different than actual port + // and it is not empty f.e http://foo:8080 + // 8080 != 80 && 8080 != '' + var addPortToOrigin = this._anchorElement.port != expectedPort && + this._anchorElement.port !== '' + + return this._anchorElement.protocol + + '//' + + this._anchorElement.hostname + + (addPortToOrigin ? (':' + this._anchorElement.port) : ''); + }, + enumerable: true + }, + + 'password': { // TODO + get: function() { + return ''; + }, + set: function(value) { + }, + enumerable: true + }, + + 'username': { // TODO + get: function() { + return ''; + }, + set: function(value) { + }, + enumerable: true + }, + + 'searchParams': { + get: function() { + var searchParams = new URLSearchParams(this.search); + var _this = this; + ['append', 'delete', 'set'].forEach(function(methodName) { + var method = searchParams[methodName]; + searchParams[methodName] = function() { + method.apply(searchParams, arguments); + _this.search = searchParams.toString(); + }; + }); + return searchParams; + }, + enumerable: true + } + }); + + URL.createObjectURL = function(blob) { + return _URL.createObjectURL.apply(_URL, arguments); + }; + + URL.revokeObjectURL = function(url) { + return _URL.revokeObjectURL.apply(_URL, arguments); + }; + + global.URL = URL; + + }; + + if(!checkIfURLIsSupported()) { + polyfillURL(); + } + + if((global.location !== void 0) && !('origin' in global.location)) { + var getOrigin = function() { + return global.location.protocol + '//' + global.location.hostname + (global.location.port ? (':' + global.location.port) : ''); + }; + + try { + Object.defineProperty(global.location, 'origin', { + get: getOrigin, + enumerable: true + }); + } catch(e) { + setInterval(function() { + global.location.origin = getOrigin(); + }, 100); + } + } + +})( + (typeof global !== 'undefined') ? global + : ((typeof window !== 'undefined') ? window + : ((typeof self !== 'undefined') ? self : this)) +); diff --git a/static/js/zepto.js b/static/js/zepto.js new file mode 100644 index 000000000..18b3ada79 --- /dev/null +++ b/static/js/zepto.js @@ -0,0 +1,1650 @@ +/* Zepto v1.2.0 - zepto event ajax form ie - zeptojs.com/license */ +(function(global, factory) { + if (typeof define === 'function' && define.amd) + define(function() { return factory(global) }) + else + factory(global) +}(this, function(window) { + var Zepto = (function() { + var undefined, key, $, classList, emptyArray = [], concat = emptyArray.concat, filter = emptyArray.filter, slice = emptyArray.slice, + document = window.document, + elementDisplay = {}, classCache = {}, + cssNumber = { 'column-count': 1, 'columns': 1, 'font-weight': 1, 'line-height': 1,'opacity': 1, 'z-index': 1, 'zoom': 1 }, + fragmentRE = /^\s*<(\w+|!)[^>]*>/, + singleTagRE = /^<(\w+)\s*\/?>(?:<\/\1>|)$/, + tagExpanderRE = /<(?!area|br|col|embed|hr|img|input|link|meta|param)(([\w:]+)[^>]*)\/>/ig, + rootNodeRE = /^(?:body|html)$/i, + capitalRE = /([A-Z])/g, + + // special attributes that should be get/set via method calls + methodAttributes = ['val', 'css', 'html', 'text', 'data', 'width', 'height', 'offset'], + + adjacencyOperators = [ 'after', 'prepend', 'before', 'append' ], + table = document.createElement('table'), + tableRow = document.createElement('tr'), + containers = { + 'tr': document.createElement('tbody'), + 'tbody': table, 'thead': table, 'tfoot': table, + 'td': tableRow, 'th': tableRow, + '*': document.createElement('div') + }, + readyRE = /complete|loaded|interactive/, + simpleSelectorRE = /^[\w-]*$/, + class2type = {}, + toString = class2type.toString, + zepto = {}, + camelize, uniq, + tempParent = document.createElement('div'), + propMap = { + 'tabindex': 'tabIndex', + 'readonly': 'readOnly', + 'for': 'htmlFor', + 'class': 'className', + 'maxlength': 'maxLength', + 'cellspacing': 'cellSpacing', + 'cellpadding': 'cellPadding', + 'rowspan': 'rowSpan', + 'colspan': 'colSpan', + 'usemap': 'useMap', + 'frameborder': 'frameBorder', + 'contenteditable': 'contentEditable' + }, + isArray = Array.isArray || + function(object){ return object instanceof Array } + + zepto.matches = function(element, selector) { + if (!selector || !element || element.nodeType !== 1) return false + var matchesSelector = element.matches || element.webkitMatchesSelector || + element.mozMatchesSelector || element.oMatchesSelector || + element.matchesSelector + if (matchesSelector) return matchesSelector.call(element, selector) + // fall back to performing a selector: + var match, parent = element.parentNode, temp = !parent + if (temp) (parent = tempParent).appendChild(element) + match = ~zepto.qsa(parent, selector).indexOf(element) + temp && tempParent.removeChild(element) + return match + } + + function type(obj) { + return obj == null ? String(obj) : + class2type[toString.call(obj)] || "object" + } + + function isFunction(value) { return type(value) == "function" } + function isWindow(obj) { return obj != null && obj == obj.window } + function isDocument(obj) { return obj != null && obj.nodeType == obj.DOCUMENT_NODE } + function isObject(obj) { return type(obj) == "object" } + function isPlainObject(obj) { + return isObject(obj) && !isWindow(obj) && Object.getPrototypeOf(obj) == Object.prototype + } + + function likeArray(obj) { + var length = !!obj && 'length' in obj && obj.length, + type = $.type(obj) + + return 'function' != type && !isWindow(obj) && ( + 'array' == type || length === 0 || + (typeof length == 'number' && length > 0 && (length - 1) in obj) + ) + } + + function compact(array) { return filter.call(array, function(item){ return item != null }) } + function flatten(array) { return array.length > 0 ? $.fn.concat.apply([], array) : array } + camelize = function(str){ return str.replace(/-+(.)?/g, function(match, chr){ return chr ? chr.toUpperCase() : '' }) } + function dasherize(str) { + return str.replace(/::/g, '/') + .replace(/([A-Z]+)([A-Z][a-z])/g, '$1_$2') + .replace(/([a-z\d])([A-Z])/g, '$1_$2') + .replace(/_/g, '-') + .toLowerCase() + } + uniq = function(array){ return filter.call(array, function(item, idx){ return array.indexOf(item) == idx }) } + + function classRE(name) { + return name in classCache ? + classCache[name] : (classCache[name] = new RegExp('(^|\\s)' + name + '(\\s|$)')) + } + + function maybeAddPx(name, value) { + return (typeof value == "number" && !cssNumber[dasherize(name)]) ? value + "px" : value + } + + function defaultDisplay(nodeName) { + var element, display + if (!elementDisplay[nodeName]) { + element = document.createElement(nodeName) + document.body.appendChild(element) + display = getComputedStyle(element, '').getPropertyValue("display") + element.parentNode.removeChild(element) + display == "none" && (display = "block") + elementDisplay[nodeName] = display + } + return elementDisplay[nodeName] + } + + function children(element) { + return 'children' in element ? + slice.call(element.children) : + $.map(element.childNodes, function(node){ if (node.nodeType == 1) return node }) + } + + function Z(dom, selector) { + var i, len = dom ? dom.length : 0 + for (i = 0; i < len; i++) this[i] = dom[i] + this.length = len + this.selector = selector || '' + } + + // `$.zepto.fragment` takes a html string and an optional tag name + // to generate DOM nodes from the given html string. + // The generated DOM nodes are returned as an array. + // This function can be overridden in plugins for example to make + // it compatible with browsers that don't support the DOM fully. + zepto.fragment = function(html, name, properties) { + var dom, nodes, container + + // A special case optimization for a single tag + if (singleTagRE.test(html)) dom = $(document.createElement(RegExp.$1)) + + if (!dom) { + if (html.replace) html = html.replace(tagExpanderRE, "<$1>$2>") + if (name === undefined) name = fragmentRE.test(html) && RegExp.$1 + if (!(name in containers)) name = '*' + + container = containers[name] + container.innerHTML = '' + html + dom = $.each(slice.call(container.childNodes), function(){ + container.removeChild(this) + }) + } + + if (isPlainObject(properties)) { + nodes = $(dom) + $.each(properties, function(key, value) { + if (methodAttributes.indexOf(key) > -1) nodes[key](value) + else nodes.attr(key, value) + }) + } + + return dom + } + + // `$.zepto.Z` swaps out the prototype of the given `dom` array + // of nodes with `$.fn` and thus supplying all the Zepto functions + // to the array. This method can be overridden in plugins. + zepto.Z = function(dom, selector) { + return new Z(dom, selector) + } + + // `$.zepto.isZ` should return `true` if the given object is a Zepto + // collection. This method can be overridden in plugins. + zepto.isZ = function(object) { + return object instanceof zepto.Z + } + + // `$.zepto.init` is Zepto's counterpart to jQuery's `$.fn.init` and + // takes a CSS selector and an optional context (and handles various + // special cases). + // This method can be overridden in plugins. + zepto.init = function(selector, context) { + var dom + // If nothing given, return an empty Zepto collection + if (!selector) return zepto.Z() + // Optimize for string selectors + else if (typeof selector == 'string') { + selector = selector.trim() + // If it's a html fragment, create nodes from it + // Note: In both Chrome 21 and Firefox 15, DOM error 12 + // is thrown if the fragment doesn't begin with < + if (selector[0] == '<' && fragmentRE.test(selector)) + dom = zepto.fragment(selector, RegExp.$1, context), selector = null + // If there's a context, create a collection on that context first, and select + // nodes from there + else if (context !== undefined) return $(context).find(selector) + // If it's a CSS selector, use it to select nodes. + else dom = zepto.qsa(document, selector) + } + // If a function is given, call it when the DOM is ready + else if (isFunction(selector)) return $(document).ready(selector) + // If a Zepto collection is given, just return it + else if (zepto.isZ(selector)) return selector + else { + // normalize array if an array of nodes is given + if (isArray(selector)) dom = compact(selector) + // Wrap DOM nodes. + else if (isObject(selector)) + dom = [selector], selector = null + // If it's a html fragment, create nodes from it + else if (fragmentRE.test(selector)) + dom = zepto.fragment(selector.trim(), RegExp.$1, context), selector = null + // If there's a context, create a collection on that context first, and select + // nodes from there + else if (context !== undefined) return $(context).find(selector) + // And last but no least, if it's a CSS selector, use it to select nodes. + else dom = zepto.qsa(document, selector) + } + // create a new Zepto collection from the nodes found + return zepto.Z(dom, selector) + } + + // `$` will be the base `Zepto` object. When calling this + // function just call `$.zepto.init, which makes the implementation + // details of selecting nodes and creating Zepto collections + // patchable in plugins. + $ = function(selector, context){ + return zepto.init(selector, context) + } + + function extend(target, source, deep) { + for (key in source) + if (deep && (isPlainObject(source[key]) || isArray(source[key]))) { + if (isPlainObject(source[key]) && !isPlainObject(target[key])) + target[key] = {} + if (isArray(source[key]) && !isArray(target[key])) + target[key] = [] + extend(target[key], source[key], deep) + } + else if (source[key] !== undefined) target[key] = source[key] + } + + // Copy all but undefined properties from one or more + // objects to the `target` object. + $.extend = function(target){ + var deep, args = slice.call(arguments, 1) + if (typeof target == 'boolean') { + deep = target + target = args.shift() + } + args.forEach(function(arg){ extend(target, arg, deep) }) + return target + } + + // `$.zepto.qsa` is Zepto's CSS selector implementation which + // uses `document.querySelectorAll` and optimizes for some special cases, like `#id`. + // This method can be overridden in plugins. + zepto.qsa = function(element, selector){ + var found, + maybeID = selector[0] == '#', + maybeClass = !maybeID && selector[0] == '.', + nameOnly = maybeID || maybeClass ? selector.slice(1) : selector, // Ensure that a 1 char tag name still gets checked + isSimple = simpleSelectorRE.test(nameOnly) + return (element.getElementById && isSimple && maybeID) ? // Safari DocumentFragment doesn't have getElementById + ( (found = element.getElementById(nameOnly)) ? [found] : [] ) : + (element.nodeType !== 1 && element.nodeType !== 9 && element.nodeType !== 11) ? [] : + slice.call( + isSimple && !maybeID && element.getElementsByClassName ? // DocumentFragment doesn't have getElementsByClassName/TagName + maybeClass ? element.getElementsByClassName(nameOnly) : // If it's simple, it could be a class + element.getElementsByTagName(selector) : // Or a tag + element.querySelectorAll(selector) // Or it's not simple, and we need to query all + ) + } + + function filtered(nodes, selector) { + return selector == null ? $(nodes) : $(nodes).filter(selector) + } + + $.contains = document.documentElement.contains ? + function(parent, node) { + return parent !== node && parent.contains(node) + } : + function(parent, node) { + while (node && (node = node.parentNode)) + if (node === parent) return true + return false + } + + function funcArg(context, arg, idx, payload) { + return isFunction(arg) ? arg.call(context, idx, payload) : arg + } + + function setAttribute(node, name, value) { + value == null ? node.removeAttribute(name) : node.setAttribute(name, value) + } + + // access className property while respecting SVGAnimatedString + function className(node, value){ + var klass = node.className || '', + svg = klass && klass.baseVal !== undefined + + if (value === undefined) return svg ? klass.baseVal : klass + svg ? (klass.baseVal = value) : (node.className = value) + } + + // "true" => true + // "false" => false + // "null" => null + // "42" => 42 + // "42.5" => 42.5 + // "08" => "08" + // JSON => parse if valid + // String => self + function deserializeValue(value) { + try { + return value ? + value == "true" || + ( value == "false" ? false : + value == "null" ? null : + +value + "" == value ? +value : + /^[\[\{]/.test(value) ? $.parseJSON(value) : + value ) + : value + } catch(e) { + return value + } + } + + $.type = type + $.isFunction = isFunction + $.isWindow = isWindow + $.isArray = isArray + $.isPlainObject = isPlainObject + + $.isEmptyObject = function(obj) { + var name + for (name in obj) return false + return true + } + + $.isNumeric = function(val) { + var num = Number(val), type = typeof val + return val != null && type != 'boolean' && + (type != 'string' || val.length) && + !isNaN(num) && isFinite(num) || false + } + + $.inArray = function(elem, array, i){ + return emptyArray.indexOf.call(array, elem, i) + } + + $.camelCase = camelize + $.trim = function(str) { + return str == null ? "" : String.prototype.trim.call(str) + } + + // plugin compatibility + $.uuid = 0 + $.support = { } + $.expr = { } + $.noop = function() {} + + $.map = function(elements, callback){ + var value, values = [], i, key + if (likeArray(elements)) + for (i = 0; i < elements.length; i++) { + value = callback(elements[i], i) + if (value != null) values.push(value) + } + else + for (key in elements) { + value = callback(elements[key], key) + if (value != null) values.push(value) + } + return flatten(values) + } + + $.each = function(elements, callback){ + var i, key + if (likeArray(elements)) { + for (i = 0; i < elements.length; i++) + if (callback.call(elements[i], i, elements[i]) === false) return elements + } else { + for (key in elements) + if (callback.call(elements[key], key, elements[key]) === false) return elements + } + + return elements + } + + $.grep = function(elements, callback){ + return filter.call(elements, callback) + } + + if (window.JSON) $.parseJSON = JSON.parse + + // Populate the class2type map + $.each("Boolean Number String Function Array Date RegExp Object Error".split(" "), function(i, name) { + class2type[ "[object " + name + "]" ] = name.toLowerCase() + }) + + // Define methods that will be available on all + // Zepto collections + $.fn = { + constructor: zepto.Z, + length: 0, + + // Because a collection acts like an array + // copy over these useful array functions. + forEach: emptyArray.forEach, + reduce: emptyArray.reduce, + push: emptyArray.push, + sort: emptyArray.sort, + splice: emptyArray.splice, + indexOf: emptyArray.indexOf, + concat: function(){ + var i, value, args = [] + for (i = 0; i < arguments.length; i++) { + value = arguments[i] + args[i] = zepto.isZ(value) ? value.toArray() : value + } + return concat.apply(zepto.isZ(this) ? this.toArray() : this, args) + }, + + // `map` and `slice` in the jQuery API work differently + // from their array counterparts + map: function(fn){ + return $($.map(this, function(el, i){ return fn.call(el, i, el) })) + }, + slice: function(){ + return $(slice.apply(this, arguments)) + }, + + ready: function(callback){ + // need to check if document.body exists for IE as that browser reports + // document ready when it hasn't yet created the body element + if (readyRE.test(document.readyState) && document.body) callback($) + else document.addEventListener('DOMContentLoaded', function(){ callback($) }, false) + return this + }, + get: function(idx){ + return idx === undefined ? slice.call(this) : this[idx >= 0 ? idx : idx + this.length] + }, + toArray: function(){ return this.get() }, + size: function(){ + return this.length + }, + remove: function(){ + return this.each(function(){ + if (this.parentNode != null) + this.parentNode.removeChild(this) + }) + }, + each: function(callback){ + emptyArray.every.call(this, function(el, idx){ + return callback.call(el, idx, el) !== false + }) + return this + }, + filter: function(selector){ + if (isFunction(selector)) return this.not(this.not(selector)) + return $(filter.call(this, function(element){ + return zepto.matches(element, selector) + })) + }, + add: function(selector,context){ + return $(uniq(this.concat($(selector,context)))) + }, + is: function(selector){ + return this.length > 0 && zepto.matches(this[0], selector) + }, + not: function(selector){ + var nodes=[] + if (isFunction(selector) && selector.call !== undefined) + this.each(function(idx){ + if (!selector.call(this,idx)) nodes.push(this) + }) + else { + var excludes = typeof selector == 'string' ? this.filter(selector) : + (likeArray(selector) && isFunction(selector.item)) ? slice.call(selector) : $(selector) + this.forEach(function(el){ + if (excludes.indexOf(el) < 0) nodes.push(el) + }) + } + return $(nodes) + }, + has: function(selector){ + return this.filter(function(){ + return isObject(selector) ? + $.contains(this, selector) : + $(this).find(selector).size() + }) + }, + eq: function(idx){ + return idx === -1 ? this.slice(idx) : this.slice(idx, + idx + 1) + }, + first: function(){ + var el = this[0] + return el && !isObject(el) ? el : $(el) + }, + last: function(){ + var el = this[this.length - 1] + return el && !isObject(el) ? el : $(el) + }, + find: function(selector){ + var result, $this = this + if (!selector) result = $() + else if (typeof selector == 'object') + result = $(selector).filter(function(){ + var node = this + return emptyArray.some.call($this, function(parent){ + return $.contains(parent, node) + }) + }) + else if (this.length == 1) result = $(zepto.qsa(this[0], selector)) + else result = this.map(function(){ return zepto.qsa(this, selector) }) + return result + }, + closest: function(selector, context){ + var nodes = [], collection = typeof selector == 'object' && $(selector) + this.each(function(_, node){ + while (node && !(collection ? collection.indexOf(node) >= 0 : zepto.matches(node, selector))) + node = node !== context && !isDocument(node) && node.parentNode + if (node && nodes.indexOf(node) < 0) nodes.push(node) + }) + return $(nodes) + }, + parents: function(selector){ + var ancestors = [], nodes = this + while (nodes.length > 0) + nodes = $.map(nodes, function(node){ + if ((node = node.parentNode) && !isDocument(node) && ancestors.indexOf(node) < 0) { + ancestors.push(node) + return node + } + }) + return filtered(ancestors, selector) + }, + parent: function(selector){ + return filtered(uniq(this.pluck('parentNode')), selector) + }, + children: function(selector){ + return filtered(this.map(function(){ return children(this) }), selector) + }, + contents: function() { + return this.map(function() { return this.contentDocument || slice.call(this.childNodes) }) + }, + siblings: function(selector){ + return filtered(this.map(function(i, el){ + return filter.call(children(el.parentNode), function(child){ return child!==el }) + }), selector) + }, + empty: function(){ + return this.each(function(){ this.innerHTML = '' }) + }, + // `pluck` is borrowed from Prototype.js + pluck: function(property){ + return $.map(this, function(el){ return el[property] }) + }, + show: function(){ + return this.each(function(){ + this.style.display == "none" && (this.style.display = '') + if (getComputedStyle(this, '').getPropertyValue("display") == "none") + this.style.display = defaultDisplay(this.nodeName) + }) + }, + replaceWith: function(newContent){ + return this.before(newContent).remove() + }, + wrap: function(structure){ + var func = isFunction(structure) + if (this[0] && !func) + var dom = $(structure).get(0), + clone = dom.parentNode || this.length > 1 + + return this.each(function(index){ + $(this).wrapAll( + func ? structure.call(this, index) : + clone ? dom.cloneNode(true) : dom + ) + }) + }, + wrapAll: function(structure){ + if (this[0]) { + $(this[0]).before(structure = $(structure)) + var children + // drill down to the inmost element + while ((children = structure.children()).length) structure = children.first() + $(structure).append(this) + } + return this + }, + wrapInner: function(structure){ + var func = isFunction(structure) + return this.each(function(index){ + var self = $(this), contents = self.contents(), + dom = func ? structure.call(this, index) : structure + contents.length ? contents.wrapAll(dom) : self.append(dom) + }) + }, + unwrap: function(){ + this.parent().each(function(){ + $(this).replaceWith($(this).children()) + }) + return this + }, + clone: function(){ + return this.map(function(){ return this.cloneNode(true) }) + }, + hide: function(){ + return this.css("display", "none") + }, + toggle: function(setting){ + return this.each(function(){ + var el = $(this) + ;(setting === undefined ? el.css("display") == "none" : setting) ? el.show() : el.hide() + }) + }, + prev: function(selector){ return $(this.pluck('previousElementSibling')).filter(selector || '*') }, + next: function(selector){ return $(this.pluck('nextElementSibling')).filter(selector || '*') }, + html: function(html){ + return 0 in arguments ? + this.each(function(idx){ + var originHtml = this.innerHTML + $(this).empty().append( funcArg(this, html, idx, originHtml) ) + }) : + (0 in this ? this[0].innerHTML : null) + }, + text: function(text){ + return 0 in arguments ? + this.each(function(idx){ + var newText = funcArg(this, text, idx, this.textContent) + this.textContent = newText == null ? '' : ''+newText + }) : + (0 in this ? this.pluck('textContent').join("") : null) + }, + attr: function(name, value){ + var result + return (typeof name == 'string' && !(1 in arguments)) ? + (0 in this && this[0].nodeType == 1 && (result = this[0].getAttribute(name)) != null ? result : undefined) : + this.each(function(idx){ + if (this.nodeType !== 1) return + if (isObject(name)) for (key in name) setAttribute(this, key, name[key]) + else setAttribute(this, name, funcArg(this, value, idx, this.getAttribute(name))) + }) + }, + removeAttr: function(name){ + return this.each(function(){ this.nodeType === 1 && name.split(' ').forEach(function(attribute){ + setAttribute(this, attribute) + }, this)}) + }, + prop: function(name, value){ + name = propMap[name] || name + return (1 in arguments) ? + this.each(function(idx){ + this[name] = funcArg(this, value, idx, this[name]) + }) : + (this[0] && this[0][name]) + }, + removeProp: function(name){ + name = propMap[name] || name + return this.each(function(){ delete this[name] }) + }, + data: function(name, value){ + var attrName = 'data-' + name.replace(capitalRE, '-$1').toLowerCase() + + var data = (1 in arguments) ? + this.attr(attrName, value) : + this.attr(attrName) + + return data !== null ? deserializeValue(data) : undefined + }, + val: function(value){ + if (0 in arguments) { + if (value == null) value = "" + return this.each(function(idx){ + this.value = funcArg(this, value, idx, this.value) + }) + } else { + return this[0] && (this[0].multiple ? + $(this[0]).find('option').filter(function(){ return this.selected }).pluck('value') : + this[0].value) + } + }, + offset: function(coordinates){ + if (coordinates) return this.each(function(index){ + var $this = $(this), + coords = funcArg(this, coordinates, index, $this.offset()), + parentOffset = $this.offsetParent().offset(), + props = { + top: coords.top - parentOffset.top, + left: coords.left - parentOffset.left + } + + if ($this.css('position') == 'static') props['position'] = 'relative' + $this.css(props) + }) + if (!this.length) return null + if (document.documentElement !== this[0] && !$.contains(document.documentElement, this[0])) + return {top: 0, left: 0} + var obj = this[0].getBoundingClientRect() + return { + left: obj.left + window.pageXOffset, + top: obj.top + window.pageYOffset, + width: Math.round(obj.width), + height: Math.round(obj.height) + } + }, + css: function(property, value){ + if (arguments.length < 2) { + var element = this[0] + if (typeof property == 'string') { + if (!element) return + return element.style[camelize(property)] || getComputedStyle(element, '').getPropertyValue(property) + } else if (isArray(property)) { + if (!element) return + var props = {} + var computedStyle = getComputedStyle(element, '') + $.each(property, function(_, prop){ + props[prop] = (element.style[camelize(prop)] || computedStyle.getPropertyValue(prop)) + }) + return props + } + } + + var css = '' + if (type(property) == 'string') { + if (!value && value !== 0) + this.each(function(){ this.style.removeProperty(dasherize(property)) }) + else + css = dasherize(property) + ":" + maybeAddPx(property, value) + } else { + for (key in property) + if (!property[key] && property[key] !== 0) + this.each(function(){ this.style.removeProperty(dasherize(key)) }) + else + css += dasherize(key) + ':' + maybeAddPx(key, property[key]) + ';' + } + + return this.each(function(){ this.style.cssText += ';' + css }) + }, + index: function(element){ + return element ? this.indexOf($(element)[0]) : this.parent().children().indexOf(this[0]) + }, + hasClass: function(name){ + if (!name) return false + return emptyArray.some.call(this, function(el){ + return this.test(className(el)) + }, classRE(name)) + }, + addClass: function(name){ + if (!name) return this + return this.each(function(idx){ + if (!('className' in this)) return + classList = [] + var cls = className(this), newName = funcArg(this, name, idx, cls) + newName.split(/\s+/g).forEach(function(klass){ + if (!$(this).hasClass(klass)) classList.push(klass) + }, this) + classList.length && className(this, cls + (cls ? " " : "") + classList.join(" ")) + }) + }, + removeClass: function(name){ + return this.each(function(idx){ + if (!('className' in this)) return + if (name === undefined) return className(this, '') + classList = className(this) + funcArg(this, name, idx, classList).split(/\s+/g).forEach(function(klass){ + classList = classList.replace(classRE(klass), " ") + }) + className(this, classList.trim()) + }) + }, + toggleClass: function(name, when){ + if (!name) return this + return this.each(function(idx){ + var $this = $(this), names = funcArg(this, name, idx, className(this)) + names.split(/\s+/g).forEach(function(klass){ + (when === undefined ? !$this.hasClass(klass) : when) ? + $this.addClass(klass) : $this.removeClass(klass) + }) + }) + }, + scrollTop: function(value){ + if (!this.length) return + var hasScrollTop = 'scrollTop' in this[0] + if (value === undefined) return hasScrollTop ? this[0].scrollTop : this[0].pageYOffset + return this.each(hasScrollTop ? + function(){ this.scrollTop = value } : + function(){ this.scrollTo(this.scrollX, value) }) + }, + scrollLeft: function(value){ + if (!this.length) return + var hasScrollLeft = 'scrollLeft' in this[0] + if (value === undefined) return hasScrollLeft ? this[0].scrollLeft : this[0].pageXOffset + return this.each(hasScrollLeft ? + function(){ this.scrollLeft = value } : + function(){ this.scrollTo(value, this.scrollY) }) + }, + position: function() { + if (!this.length) return + + var elem = this[0], + // Get *real* offsetParent + offsetParent = this.offsetParent(), + // Get correct offsets + offset = this.offset(), + parentOffset = rootNodeRE.test(offsetParent[0].nodeName) ? { top: 0, left: 0 } : offsetParent.offset() + + // Subtract element margins + // note: when an element has margin: auto the offsetLeft and marginLeft + // are the same in Safari causing offset.left to incorrectly be 0 + offset.top -= parseFloat( $(elem).css('margin-top') ) || 0 + offset.left -= parseFloat( $(elem).css('margin-left') ) || 0 + + // Add offsetParent borders + parentOffset.top += parseFloat( $(offsetParent[0]).css('border-top-width') ) || 0 + parentOffset.left += parseFloat( $(offsetParent[0]).css('border-left-width') ) || 0 + + // Subtract the two offsets + return { + top: offset.top - parentOffset.top, + left: offset.left - parentOffset.left + } + }, + offsetParent: function() { + return this.map(function(){ + var parent = this.offsetParent || document.body + while (parent && !rootNodeRE.test(parent.nodeName) && $(parent).css("position") == "static") + parent = parent.offsetParent + return parent + }) + } + } + + // for now + $.fn.detach = $.fn.remove + + // Generate the `width` and `height` functions + ;['width', 'height'].forEach(function(dimension){ + var dimensionProperty = + dimension.replace(/./, function(m){ return m[0].toUpperCase() }) + + $.fn[dimension] = function(value){ + var offset, el = this[0] + if (value === undefined) return isWindow(el) ? el['inner' + dimensionProperty] : + isDocument(el) ? el.documentElement['scroll' + dimensionProperty] : + (offset = this.offset()) && offset[dimension] + else return this.each(function(idx){ + el = $(this) + el.css(dimension, funcArg(this, value, idx, el[dimension]())) + }) + } + }) + + function traverseNode(node, fun) { + fun(node) + for (var i = 0, len = node.childNodes.length; i < len; i++) + traverseNode(node.childNodes[i], fun) + } + + // Generate the `after`, `prepend`, `before`, `append`, + // `insertAfter`, `insertBefore`, `appendTo`, and `prependTo` methods. + adjacencyOperators.forEach(function(operator, operatorIndex) { + var inside = operatorIndex % 2 //=> prepend, append + + $.fn[operator] = function(){ + // arguments can be nodes, arrays of nodes, Zepto objects and HTML strings + var argType, nodes = $.map(arguments, function(arg) { + var arr = [] + argType = type(arg) + if (argType == "array") { + arg.forEach(function(el) { + if (el.nodeType !== undefined) return arr.push(el) + else if ($.zepto.isZ(el)) return arr = arr.concat(el.get()) + arr = arr.concat(zepto.fragment(el)) + }) + return arr + } + return argType == "object" || arg == null ? + arg : zepto.fragment(arg) + }), + parent, copyByClone = this.length > 1 + if (nodes.length < 1) return this + + return this.each(function(_, target){ + parent = inside ? target : target.parentNode + + // convert all methods to a "before" operation + target = operatorIndex == 0 ? target.nextSibling : + operatorIndex == 1 ? target.firstChild : + operatorIndex == 2 ? target : + null + + var parentInDocument = $.contains(document.documentElement, parent) + + nodes.forEach(function(node){ + if (copyByClone) node = node.cloneNode(true) + else if (!parent) return $(node).remove() + + parent.insertBefore(node, target) + if (parentInDocument) traverseNode(node, function(el){ + if (el.nodeName != null && el.nodeName.toUpperCase() === 'SCRIPT' && + (!el.type || el.type === 'text/javascript') && !el.src){ + var target = el.ownerDocument ? el.ownerDocument.defaultView : window + target['eval'].call(target, el.innerHTML) + } + }) + }) + }) + } + + // after => insertAfter + // prepend => prependTo + // before => insertBefore + // append => appendTo + $.fn[inside ? operator+'To' : 'insert'+(operatorIndex ? 'Before' : 'After')] = function(html){ + $(html)[operator](this) + return this + } + }) + + zepto.Z.prototype = Z.prototype = $.fn + + // Export internal API functions in the `$.zepto` namespace + zepto.uniq = uniq + zepto.deserializeValue = deserializeValue + $.zepto = zepto + + return $ +})() + +window.Zepto = Zepto +window.$ === undefined && (window.$ = Zepto) + +;(function($){ + var _zid = 1, undefined, + slice = Array.prototype.slice, + isFunction = $.isFunction, + isString = function(obj){ return typeof obj == 'string' }, + handlers = {}, + specialEvents={}, + focusinSupported = 'onfocusin' in window, + focus = { focus: 'focusin', blur: 'focusout' }, + hover = { mouseenter: 'mouseover', mouseleave: 'mouseout' } + + specialEvents.click = specialEvents.mousedown = specialEvents.mouseup = specialEvents.mousemove = 'MouseEvents' + + function zid(element) { + return element._zid || (element._zid = _zid++) + } + function findHandlers(element, event, fn, selector) { + event = parse(event) + if (event.ns) var matcher = matcherFor(event.ns) + return (handlers[zid(element)] || []).filter(function(handler) { + return handler + && (!event.e || handler.e == event.e) + && (!event.ns || matcher.test(handler.ns)) + && (!fn || zid(handler.fn) === zid(fn)) + && (!selector || handler.sel == selector) + }) + } + function parse(event) { + var parts = ('' + event).split('.') + return {e: parts[0], ns: parts.slice(1).sort().join(' ')} + } + function matcherFor(ns) { + return new RegExp('(?:^| )' + ns.replace(' ', ' .* ?') + '(?: |$)') + } + + function eventCapture(handler, captureSetting) { + return handler.del && + (!focusinSupported && (handler.e in focus)) || + !!captureSetting + } + + function realEvent(type) { + return hover[type] || (focusinSupported && focus[type]) || type + } + + function add(element, events, fn, data, selector, delegator, capture){ + var id = zid(element), set = (handlers[id] || (handlers[id] = [])) + events.split(/\s/).forEach(function(event){ + if (event == 'ready') return $(document).ready(fn) + var handler = parse(event) + handler.fn = fn + handler.sel = selector + // emulate mouseenter, mouseleave + if (handler.e in hover) fn = function(e){ + var related = e.relatedTarget + if (!related || (related !== this && !$.contains(this, related))) + return handler.fn.apply(this, arguments) + } + handler.del = delegator + var callback = delegator || fn + handler.proxy = function(e){ + e = compatible(e) + if (e.isImmediatePropagationStopped()) return + e.data = data + var result = callback.apply(element, e._args == undefined ? [e] : [e].concat(e._args)) + if (result === false) e.preventDefault(), e.stopPropagation() + return result + } + handler.i = set.length + set.push(handler) + if ('addEventListener' in element) + element.addEventListener(realEvent(handler.e), handler.proxy, eventCapture(handler, capture)) + }) + } + function remove(element, events, fn, selector, capture){ + var id = zid(element) + ;(events || '').split(/\s/).forEach(function(event){ + findHandlers(element, event, fn, selector).forEach(function(handler){ + delete handlers[id][handler.i] + if ('removeEventListener' in element) + element.removeEventListener(realEvent(handler.e), handler.proxy, eventCapture(handler, capture)) + }) + }) + } + + $.event = { add: add, remove: remove } + + $.proxy = function(fn, context) { + var args = (2 in arguments) && slice.call(arguments, 2) + if (isFunction(fn)) { + var proxyFn = function(){ return fn.apply(context, args ? args.concat(slice.call(arguments)) : arguments) } + proxyFn._zid = zid(fn) + return proxyFn + } else if (isString(context)) { + if (args) { + args.unshift(fn[context], fn) + return $.proxy.apply(null, args) + } else { + return $.proxy(fn[context], fn) + } + } else { + throw new TypeError("expected function") + } + } + + $.fn.bind = function(event, data, callback){ + return this.on(event, data, callback) + } + $.fn.unbind = function(event, callback){ + return this.off(event, callback) + } + $.fn.one = function(event, selector, data, callback){ + return this.on(event, selector, data, callback, 1) + } + + var returnTrue = function(){return true}, + returnFalse = function(){return false}, + ignoreProperties = /^([A-Z]|returnValue$|layer[XY]$|webkitMovement[XY]$)/, + eventMethods = { + preventDefault: 'isDefaultPrevented', + stopImmediatePropagation: 'isImmediatePropagationStopped', + stopPropagation: 'isPropagationStopped' + } + + function compatible(event, source) { + if (source || !event.isDefaultPrevented) { + source || (source = event) + + $.each(eventMethods, function(name, predicate) { + var sourceMethod = source[name] + event[name] = function(){ + this[predicate] = returnTrue + return sourceMethod && sourceMethod.apply(source, arguments) + } + event[predicate] = returnFalse + }) + + event.timeStamp || (event.timeStamp = Date.now()) + + if (source.defaultPrevented !== undefined ? source.defaultPrevented : + 'returnValue' in source ? source.returnValue === false : + source.getPreventDefault && source.getPreventDefault()) + event.isDefaultPrevented = returnTrue + } + return event + } + + function createProxy(event) { + var key, proxy = { originalEvent: event } + for (key in event) + if (!ignoreProperties.test(key) && event[key] !== undefined) proxy[key] = event[key] + + return compatible(proxy, event) + } + + $.fn.delegate = function(selector, event, callback){ + return this.on(event, selector, callback) + } + $.fn.undelegate = function(selector, event, callback){ + return this.off(event, selector, callback) + } + + $.fn.live = function(event, callback){ + $(document.body).delegate(this.selector, event, callback) + return this + } + $.fn.die = function(event, callback){ + $(document.body).undelegate(this.selector, event, callback) + return this + } + + $.fn.on = function(event, selector, data, callback, one){ + var autoRemove, delegator, $this = this + if (event && !isString(event)) { + $.each(event, function(type, fn){ + $this.on(type, selector, data, fn, one) + }) + return $this + } + + if (!isString(selector) && !isFunction(callback) && callback !== false) + callback = data, data = selector, selector = undefined + if (callback === undefined || data === false) + callback = data, data = undefined + + if (callback === false) callback = returnFalse + + return $this.each(function(_, element){ + if (one) autoRemove = function(e){ + remove(element, e.type, callback) + return callback.apply(this, arguments) + } + + if (selector) delegator = function(e){ + var evt, match = $(e.target).closest(selector, element).get(0) + if (match && match !== element) { + evt = $.extend(createProxy(e), {currentTarget: match, liveFired: element}) + return (autoRemove || callback).apply(match, [evt].concat(slice.call(arguments, 1))) + } + } + + add(element, event, callback, data, selector, delegator || autoRemove) + }) + } + $.fn.off = function(event, selector, callback){ + var $this = this + if (event && !isString(event)) { + $.each(event, function(type, fn){ + $this.off(type, selector, fn) + }) + return $this + } + + if (!isString(selector) && !isFunction(callback) && callback !== false) + callback = selector, selector = undefined + + if (callback === false) callback = returnFalse + + return $this.each(function(){ + remove(this, event, callback, selector) + }) + } + + $.fn.trigger = function(event, args){ + event = (isString(event) || $.isPlainObject(event)) ? $.Event(event) : compatible(event) + event._args = args + return this.each(function(){ + // handle focus(), blur() by calling them directly + if (event.type in focus && typeof this[event.type] == "function") this[event.type]() + // items in the collection might not be DOM elements + else if ('dispatchEvent' in this) this.dispatchEvent(event) + else $(this).triggerHandler(event, args) + }) + } + + // triggers event handlers on current element just as if an event occurred, + // doesn't trigger an actual event, doesn't bubble + $.fn.triggerHandler = function(event, args){ + var e, result + this.each(function(i, element){ + e = createProxy(isString(event) ? $.Event(event) : event) + e._args = args + e.target = element + $.each(findHandlers(element, event.type || event), function(i, handler){ + result = handler.proxy(e) + if (e.isImmediatePropagationStopped()) return false + }) + }) + return result + } + + // shortcut methods for `.bind(event, fn)` for each event type + ;('focusin focusout focus blur load resize scroll unload click dblclick '+ + 'mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave '+ + 'change select keydown keypress keyup error').split(' ').forEach(function(event) { + $.fn[event] = function(callback) { + return (0 in arguments) ? + this.bind(event, callback) : + this.trigger(event) + } + }) + + $.Event = function(type, props) { + if (!isString(type)) props = type, type = props.type + var event = document.createEvent(specialEvents[type] || 'Events'), bubbles = true + if (props) for (var name in props) (name == 'bubbles') ? (bubbles = !!props[name]) : (event[name] = props[name]) + event.initEvent(type, bubbles, true) + return compatible(event) + } + +})(Zepto) + +;(function($){ + var jsonpID = +new Date(), + document = window.document, + key, + name, + rscript = /