Merge branch 'master' into initial_thoughts_on_frontend

.gitignore

@@ -18,7 +18,8 @@ cabal.sandbox.config
 *.swp
 *.keter
 *~
-\#*
+**/\#*
+**/.\#*
 uniworx.cabal
 uniworx.nix
 .gup/
@@ -26,4 +27,4 @@ uniworx.nix
 *.kate-swp
 src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
-
+*.orig

Datenschutznotizen.txt

@@ -0,0 +1,27 @@
+* Datensparsamkeit: nur Speichern was notwendig ist; Dokumentieren, warum was gespeichert wird!
+* Verfügbarkeit: Backup / aktuelles System; nicht nur eine Person, Anfragen werden organisiert beantwortet
+* Integrität: Konsistenzcheck bei Datenübertragen (z.B. LDAP), Sicherheit vor bösen Absichten, Änderungen protokolliert
+* Vertraulichkeit: Jeder Benutzer sollte nur auf das zugreifen was unbedingt nötig ist; Backup Verschlüsselung
+* Nichtverkettbarkeit: (eher irrelevant für unseren Anwendungsfall)
+* Transparenz: User weiß was über ihn gespeichert wird; Dokumentation; Vorfälle schnell melden?
+* Intervenierbarkeit: Korrektur/Löschpflichten - auch im Backup; z.B. Korrekturen bei Einspielen des Backups einpflegen; Backup Verschlüsselung; Bei Löschanforderungen muss teilweise gelöscht werden (nur was Notenrelevant muss aufgehoben werden, Hausaufgaben werden gelöscht; Anzeige gelöschter Teilnehmer)
+* Wer ist Datenschutzverantwortlicher? Steffen!?!
+  => Sofort anzeigen, wenn etwas schiefläuft. 
+
+  
+Fragen: 
+ - Was ist mit Abschreiber-Flags: Keine Flags, sondern protokollieren: bei Überschreiten einer Schwelle sollte jemand mit entsprechender Befugnis benachrichtigt werden, Student sollte die Eintragungen sehen, Assistenten nicht
+
+ 
+Aktionen:
+ - Felder für Aufbewahrungsfristen zu jedem Datensatz
+ - List gelöschter Kennungen
+ - Zugangsberechtigungen für Vorlesungen/Übungen
+ - Regularien für Prozess; Aufbewahrungsfristen, Verwaltungsrechtliche Fragen, Bayrisches E-Goverment Gesetz, Daten signierbar/verifizieren;
+ 
+ -> Aktuelle Archivierung von prüfungsrelevanten Daten (Klausur-Lagerung) ist nicht Gesetz-Konform; da Papier-Lagerung nicht konform ist.
+ 
+ 
+ 
+ 
+  

fill-db.hs

@@ -0,0 +1,71 @@
+#!/usr/bin/env stack
+-- stack runghc
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+import "uniworx" Import
+import "uniworx" Application (db)
+
+import Data.Time
+
+main :: IO ()
+main = db $ do
+  now <- liftIO getCurrentTime
+  let
+    winter2017 = TermIdentifier 2017 Winter
+    summer2018 = TermIdentifier 2018 Summer
+  gkleen <- insert User
+    { userPlugin = "LDAP"
+    , userIdent  = "G.Kleen@campus.lmu.de"
+    , userMatrikelnummer = Nothing
+    , userEmail  = "G.Kleen@campus.lmu.de"
+    , userDisplayName = "Gregor Kleen"
+    }
+  void . insert $ Term
+    { termName     = winter2017
+    , termStart    = fromGregorian 2017 10 16
+    , termEnd      = fromGregorian 2018 02 10
+    , termHolidays = [fromGregorian 2017 12 24..fromGregorian 2018 01 06]
+    , termLectureStart = fromGregorian 2017 10 16
+    , termLectureEnd   = fromGregorian 2018 02 10
+    , termActive       = True
+    }
+  void . insert $ Term
+    { termName     = summer2018
+    , termStart    = fromGregorian 2018 04 09
+    , termEnd      = fromGregorian 2018 07 14
+    , termHolidays = []
+    , termLectureStart = fromGregorian 2018 04 09
+    , termLectureEnd   = fromGregorian 2018 07 14
+    , termActive       = True
+    }
+  ifi <- insert $ School "Institut für Informatik" "IfI"
+  mi <- insert $ School "Institut für Mathematik" "MI"
+  void . insert $ UserAdmin gkleen ifi
+  void . insert $ UserAdmin gkleen mi
+  void . insert $ UserLecturer gkleen ifi
+  ifiBsc <- insert $ Degree "Bachelor Informatik" ifi
+  ifiMsc <- insert $ Degree "Master Informatik" ifi
+  ffp <- insert Course
+    { courseName = "Fortgeschrittene Funktionale Programmierung"
+    , courseDescription = Nothing
+    , courseLinkExternal = Nothing
+    , courseShorthand = "ffp"
+    , courseTermId = TermKey summer2018
+    , courseSchoolId = ifi
+    , courseCapacity = Just 20
+    , courseCreated = now
+    , courseChanged = now
+    , courseCreatedBy = gkleen
+    , courseChangedBy = gkleen
+    , courseHasRegistration = True
+    , courseRegisterFrom = Just now
+    , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
+    }
+  void . insert $ DegreeCourse ifiBsc ffp
+  void . insert $ DegreeCourse ifiMsc ffp
+  void . insert $ Lecturer gkleen ffp
+  void . insert $ Corrector gkleen ffp (ByProportion 1)
+  void . insert $ Sheet ffp "Blatt 1" Nothing NotGraded Nothing now now Nothing Nothing now now gkleen gkleen

ghci.sh

@@ -0,0 +1,8 @@
+#!/usr/bin/env bash
+
+unset HOST
+export DETAILED_LOGGING=true
+export LOG_ALL=true
+export DUMMY_LOGIN=true
+
+exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only

models

@@ -37,8 +37,8 @@ Term json
     lectureStart  Day 
     lectureEnd    Day 
     active        Bool    
-    Primary name
+    Primary name       -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
-    deriving Show
+    deriving Show      -- type TermId = Key Term
 School json
     name          Text 
     shorthand     Text
@@ -94,8 +94,9 @@ CourseParticipant
 Sheet
     courseId        CourseId
     name            Text
+    description     Html Maybe
     type            SheetType
-    markingText     Text Maybe
+    markingText     Html Maybe
     activeFrom      UTCTime
     activeTo        UTCTime
     hintFrom        UTCTime Maybe
@@ -104,6 +105,7 @@ Sheet
     changed         UTCTime
     createdBy       UserId
     changedBy       UserId    
+    CourseSheet courseId name
 SheetFile
     sheetId         SheetId
     fileId          FileId
@@ -200,6 +202,6 @@ Exam
 ExamUser
     userId              UserId
     examId              ExamId
-    -- CONTINUE HERE: Inlcude rating in this table or seperatly?
+    -- CONTINUE HERE: Include rating in this table or separately?
     UniqueExamUser userId examId
  -- By default this file is used in Model.hs (which is imported by Foundation.hs)

package.yaml

@@ -10,6 +10,7 @@ dependencies:
 # version 1.0 had a bug in reexporting Handler, causing trouble
 - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
 
+- foreign-store
 - yesod >=1.4.3 && <1.5
 - yesod-core >=1.4.30 && <1.5
 - yesod-auth >=1.4.0 && <1.5
@@ -64,6 +65,7 @@ dependencies:
 - filepath-crypto
 - cryptoids-types
 - cryptoids
+- cryptoids-class
 - binary
 - mtl
 - sandi
@@ -75,6 +77,8 @@ dependencies:
 - yesod-auth-ldap
 - LDAP
 - parsec
+- uuid
+- exceptions
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
@@ -87,7 +91,6 @@ library:
       - -Wall
       - -fwarn-tabs
       - -O0
-      - -ddump-splices
       cpp-options: -DDEVELOPMENT
     else:
       ghc-options:

routes

@@ -6,22 +6,24 @@
 
 /        HomeR    GET POST
 /profile ProfileR GET
+/users   UsersR   GET
 
 /term                       TermShowR         GET 
 /term/edit                  TermEditR         GET POST
-/term/#TermIdentifier/edit  TermEditExistR    GET
+/term/#TermId/edit          TermEditExistR    GET
 
 /course/                    CourseListR       GET
 !/course/new                CourseEditR       GET POST
-!/course/#TermIdentifier    CourseListTermR   GET
+!/course/#TermId    CourseListTermR           GET
-/course/#TermIdentifier/#Text/edit CourseEditExistR GET
+/course/#TermId/#Text/edit CourseEditExistR   GET
-/course/#TermIdentifier/#Text/show CourseShowR GET POST
+/course/#TermId/#Text/show CourseShowR        GET POST
-
-/course/#TermIdentifier/#Text/sheet/              SheetListR  GET
-/course/#TermIdentifier/#Text/sheet/new           SheetNewR   GET
-/course/#TermIdentifier/#Text/sheet/#SheetId/show SheetShowR  GET
-/course/#TermIdentifier/#Text/sheet/#SheetId/edit SheetEditR  GET
 
+/course/#TermId/#Text/sheet/                SheetListR   GET
+/course/#TermId/#Text/sheet/#Text/show      SheetShowR   GET
+/course/#TermId/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR  GET
+/course/#TermId/#Text/sheet/new             SheetNewR   GET POST
+/course/#TermId/#Text/sheet/#SheetId/edit   SheetEditR  GET POST
+/course/#TermId/#Text/sheet/#SheetId/delete SheetDelR   GET POST
 
 /submission                 SubmissionListR GET POST
 /submission/#CryptoUUIDSubmission SubmissionR GET POST
@@ -29,5 +31,7 @@
 !/submission/archive/#FilePath SubmissionDownloadArchiveR GET
 !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
 
+!/#UUID CryptoUUIDDispatchR GET
+
 -- For demonstration
 /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

shell.nix

@@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? null }:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc822" }:
 
 let
   inherit (nixpkgs) pkgs;
@@ -22,7 +22,7 @@ let
   '';
 
   override = oldAttrs: {
-    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack stack-run yesod-bin ]);
+    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]);
     shellHook = ''
       ${oldAttrs.shellHook}
       export PROMPT_INFO="${oldAttrs.name}"
@@ -36,13 +36,18 @@ let
       psql -f ${postgresSchema} postgres
       printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir}
 
-      env --unset=shellHook zsh
+      cleanup() {
-      ret=$?
+          pg_ctl stop -D ''${pgDir}
+          rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
+      }
 
-      pg_ctl stop -D ''${pgDir}
+      trap cleanup EXIT
-      rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
-      exit ''${ret}
     '';
   };
-in
+
-  pkgs.stdenv.lib.overrideDerivation drv.env override
+  dummy = pkgs.stdenv.mkDerivation {
+    name = "interactive-uniworx-environment";
+    shellHook = "";
+  };
+in pkgs.stdenv.lib.overrideDerivation dummy override
+  #pkgs.stdenv.lib.overrideDerivation drv.env override

src/Application.hs

@@ -42,10 +42,12 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
 import Handler.Common
 import Handler.Home
 import Handler.Profile
+import Handler.Users
 import Handler.Term
 import Handler.Course
 import Handler.Sheet
 import Handler.Submission
+import Handler.CryptoIDDispatch
 
 
 -- This line actually creates our YesodDispatch instance. It is the second half

src/CryptoID.hs

@@ -7,8 +7,9 @@
 
 module CryptoID
   ( module CryptoID
-  , module Data.UUID.Cryptographic
+  , module Data.CryptoID.Poly.ImplicitNamespace
-  , module Data.CryptoID.Poly
+  , module Data.UUID.Cryptographic.ImplicitNamespace
+  , module System.FilePath.Cryptographic.ImplicitNamespace
   ) where
 
 import CryptoID.TH
@@ -16,10 +17,10 @@ import CryptoID.TH
 import ClassyPrelude hiding (fromString)
 import Model
 
-import Data.CryptoID
+import Data.CryptoID.Poly.ImplicitNamespace
-import Data.CryptoID.Poly hiding (encrypt, decrypt)
+import Data.UUID.Cryptographic.ImplicitNamespace
+import System.FilePath.Cryptographic.ImplicitNamespace
 
-import Data.UUID.Cryptographic
 import Data.UUID.Types
 import Web.PathPieces
 
@@ -28,10 +29,10 @@ instance PathPiece UUID where
   fromPathPiece = fromString . unpack
   toPathPiece = pack . toString
 
-decKeysBinary [ ''SubmissionId
-              , ''CourseId
-              ]
 
-decTypeAliases [ "Submission"
+-- Generates CryptoUUID... Datatypes
-               , "Course"
+decCryptoIDs [ ''SubmissionId
-               ]
+             , ''CourseId
+             , ''SheetId
+             ]
+{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}

src/CryptoID/TH.hs

@@ -8,7 +8,7 @@ import ClassyPrelude
 
 import Language.Haskell.TH
 
-import Data.CryptoID (CryptoID)
+import Data.CryptoID.Class.ImplicitNamespace
 import Data.UUID.Types (UUID)
 import Data.Binary (Binary(..))
 import Data.Binary.SerializationLength
@@ -19,28 +19,30 @@ import System.FilePath (FilePath)
 import Database.Persist.Sql (toSqlKey, fromSqlKey)
 
 
-decTypeAliases :: [String] -> Q [Dec]
+decCryptoIDs :: [Name] -> DecsQ
-decTypeAliases = return . concatMap decTypeAliases'
+decCryptoIDs = fmap concat . mapM decCryptoID
   where
-    decTypeAliases' :: String -> [Dec]
+    decCryptoID :: Name -> DecsQ
-    decTypeAliases' n
+    decCryptoID n@(conT -> t) = do
-      = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n)
+      instances <- [d|
-        , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID
+          instance Binary $(t) where
-        , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` (ConT ''CI `AppT` ConT ''FilePath)
+            get = $(varE 'toSqlKey) <$> get
+            put = put . $(varE 'fromSqlKey)
+          instance HasFixedSerializationLength $(t) where
+            type SerializationLength $(t) = SerializationLength Int64
+
+          type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns)
+        |]
+
+      synonyms <- mapM cryptoIDSyn
+        [ (ConT ''UUID, "UUID")
+        , (ConT ''CI `AppT` ConT ''FilePath, "FileName")
+        ]
+
+      return $ concat
+        [ instances
+        , synonyms
         ]
       where
-        cryptoIDn = mkName $ "CryptoID" ++ n
+        ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n
-        cryptoUUIDn = mkName $ "CryptoUUID" ++ n
+        cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t
-        cryptoBase32n = mkName $ "CryptoFileName" ++ n
-
-decKeysBinary :: [Name] -> DecsQ
-decKeysBinary = fmap concat . mapM decKeyBinary
-  where
-    decKeyBinary :: Name -> DecsQ
-    decKeyBinary (conT -> t)
-      = [d| instance Binary $(t) where
-              get = $(varE 'toSqlKey) <$> get
-              put = put . $(varE 'fromSqlKey)
-            instance HasFixedSerializationLength $(t) where
-              type SerializationLength $(t) = SerializationLength Int64
-          |]

src/Foundation.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 
 module Foundation where
 
@@ -48,8 +49,6 @@ import Data.Conduit.List (sourceList)
 import Control.Monad.Except (MonadError(..), runExceptT)
 import Handler.Utils.StudyFeatures
 
-import qualified Data.UUID.Cryptographic as UUID
-import qualified System.FilePath.Cryptographic as FilePath
 import System.FilePath
 
 import Handler.Utils.Templates
@@ -78,7 +77,7 @@ data UniWorX = UniWorX
 --
 -- This function also generates the following type synonyms:
 -- type Handler = HandlerT UniWorX IO
--- type Widget = WidgetT UniWorX IO ()
+-- type Widget  = WidgetT  UniWorX IO ()
 mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
 data MenuItem = MenuItem
@@ -135,6 +134,7 @@ instance Yesod UniWorX where
     isAuthorized  CourseListR        _ = return Authorized
     isAuthorized (CourseListTermR _) _ = return Authorized
     isAuthorized (CourseShowR _ _)   _ = return Authorized
+    isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized
     isAuthorized  SubmissionListR    _ = isAuthenticated
     isAuthorized  SubmissionDownloadMultiArchiveR _ = isAuthenticated
 --     isAuthorized  TestR        _ = return Authorized
@@ -180,24 +180,24 @@ instance Yesod UniWorX where
     makeLogger = return . appLogger
 
 isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult
+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 CourseEditR            _ = lecturerAccess Nothing
-isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c)
+isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (SheetNewR t c) _        = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (CourseEditExistIDR cID) _ = do
-  cIDKey <- getsYesod appCryptoIDKey
+  courseId <- decrypt cID
-  courseId <- UUID.decrypt cIDKey cID
   courseLecturerAccess courseId
-isAuthorizedDB route isWrite = return  $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!
+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
-  cIDKey <- getsYesod appCryptoIDKey
+  submissionId <- either decrypt decrypt cID
-  submissionId <- either (FilePath.decrypt cIDKey) (UUID.decrypt cIDKey) cID
   Submission{..} <- get404 submissionId
   submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] []
   let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy
@@ -244,11 +244,14 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
 
   breadcrumb CourseListR = return ("Kurs", Just HomeR)
-  breadcrumb (CourseListTermR term) = return (termToText term, Just TermShowR)
+  breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR)
   breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term)
   breadcrumb CourseEditR = return ("Neu", Just CourseListR)
   breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR)
 
+  breadcrumb (SheetListR tid csh) = return ("Kurs", Just $ CourseShowR tid csh)
+  breadcrumb (SheetShowR tid csh _shn) = return ("Übungen", Just $ SheetListR tid csh)
+
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
   breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
 
@@ -270,6 +273,11 @@ defaultLinks = -- Define the menu items of the header.
       , menuItemRoute = CourseListR
       , menuItemAccessCallback = return True
       }
+  , NavbarRight $ MenuItem
+      { menuItemLabel = "Users"
+      , menuItemRoute = UsersR
+      , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
+      }
   , NavbarRight $ MenuItem
       { menuItemLabel = "Profile"
       , menuItemRoute = ProfileR
@@ -393,7 +401,7 @@ instance YesodAuth UniWorX where
     authHttpManager = getHttpManager
 
 ldapConfig :: UniWorX -> LDAPConfig
-ldapConfig app@(appSettings -> settings) = LDAPConfig
+ldapConfig _app@(appSettings -> settings) = LDAPConfig
   { usernameFilter = \u -> principalName <> "=" <> u
   , identifierModifier
   , ldapUri = appLDAPURI settings
@@ -434,6 +442,11 @@ instance HasHttpManager UniWorX where
 unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
+
+instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
+  type MonadCryptoKey m = CryptoIDKey
+  cryptoIDKey f = getsYesod appCryptoIDKey >>= f
+
 -- Note: Some functionality previously present in the scaffolding has been
 -- moved to documentation in the Wiki. Following are some hopefully helpful
 -- links:

src/Handler/Course.hs

@@ -26,20 +26,20 @@ import qualified Data.UUID.Cryptographic as UUID
 getCourseListR :: Handler TypedContent
 getCourseListR = redirect TermShowR  
 
-getCourseListTermR :: TermIdentifier -> Handler Html
+getCourseListTermR :: TermId -> Handler Html
 getCourseListTermR tidini = do
   (term,courses) <- runDB $ (,) 
-      <$> get (TermKey tidini) 
+      <$> get tidini
-      <*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand] 
+      <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand]
   when (isNothing term) $ do
-    addMessage "warning" [shamlet| Semester #{termToText tidini} nicht gefunden. |]
+    addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |]
     redirect TermShowR
   -- TODO: several runDBs per TableRow are probably too inefficient!    
   let colonnadeTerms = mconcat 
         [ headed "Kürzel" $ (\ckv -> 
             let c   = entityVal ckv
                 shd = courseShorthand c  
-                tid = unTermKey $ courseTermId c
+                tid = courseTermId c
             in [whamlet| <a href=@{CourseShowR tid shd}>#{shd} |] )                      
 --         , headed "Institut" $ [shamlet| #{course} |]
         , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
@@ -52,7 +52,7 @@ getCourseListTermR tidini = do
         , headed " " $ (\ckv -> 
             let c   = entityVal ckv
                 shd = courseShorthand c  
-                tid = unTermKey $ courseTermId c
+                tid = courseTermId c
             in do
               adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False
               -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else ""
@@ -74,13 +74,13 @@ getCourseListTermR tidini = do
 --   defaultLayout $ do
     setTitle "Semesterkurse"  
     linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR
-    encodeHeadedWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses)
+    encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses)
 
-getCourseShowR :: TermIdentifier -> Text -> Handler Html
+getCourseShowR :: TermId -> Text -> Handler Html
 getCourseShowR tid csh = do
   mbAid <- maybeAuthId
   (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
-      courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
+      courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
       dependent <- (,,) 
           <$> get (courseSchoolId course)               -- join
           <*> count [CourseParticipantCourseId ==. cid] -- join 
@@ -93,7 +93,7 @@ getCourseShowR tid csh = do
   let course = entityVal courseEnt  
   (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered      
   defaultLayout $ do
-    setTitle $ [shamlet| #{termToText tid} - #{csh}|]
+    setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")
       
 registerButton :: Bool -> Form ()
@@ -104,11 +104,11 @@ registerButton registered =
     msg    = if registered then "Abmelden" else "Anmelden"
     regMsg = msg :: BootstrapSubmit Text
     
-postCourseShowR :: TermIdentifier -> Text -> Handler Html
+postCourseShowR :: TermId -> Text -> Handler Html
 postCourseShowR tid csh = do
   aid <- requireAuthId
   (cid, registered) <- runDB $ do
-      (Entity cid _) <- getBy404 $ CourseTermShort (TermKey tid) csh
+      (Entity cid _) <- getBy404 $ CourseTermShort tid csh
       registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid)
       return (cid, registered)
   ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered      
@@ -133,9 +133,9 @@ getCourseEditR = do
 postCourseEditR :: Handler Html
 postCourseEditR = courseEditHandler Nothing
   
-getCourseEditExistR :: TermIdentifier -> Text -> Handler Html  
+getCourseEditExistR :: TermId -> Text -> Handler Html
 getCourseEditExistR tid csh = do  
-  course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh
+  course <- runDB $ getBy $ CourseTermShort tid csh
   courseEditHandler course
 
 getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html
@@ -155,12 +155,12 @@ courseEditHandler course = do
         | fAct == formActionDelete
         , Just cid <- cfCourseId res -> do 
             runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
-            let cti = termToText $ cfTerm res
+            let cti = toPathPiece $ cfTerm res
             addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
             redirect $ CourseListTermR $ cfTerm res
         | fAct == formActionSave 
         , Just cid <- cfCourseId res -> do 
-            let tid   = TermKey $ cfTerm  res            
+            let tid = cfTerm  res
             actTime <- liftIO getCurrentTime
             updateokay <- runDB $ do
               exists <- getBy $ CourseTermShort tid $ cfShort res 
@@ -179,7 +179,7 @@ courseEditHandler course = do
                 , CourseChanged      =. actTime
                 ]
               return upokay
-            let cti = termToText $ cfTerm res
+            let cti = toPathPiece $ cfTerm res
             if updateokay 
               then do 
                 addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |]
@@ -195,7 +195,7 @@ courseEditHandler course = do
                 , courseDescription     = cfDesc     res
                 , courseLinkExternal    = cfLink     res
                 , courseShorthand       = cfShort    res
-                , courseTermId          = TermKey $ cfTerm res
+                , courseTermId          = cfTerm     res
                 , courseSchoolId        = cfSchool   res
                 , courseCapacity        = cfCapacity res
                 , courseHasRegistration = cfHasReg   res
@@ -209,11 +209,11 @@ courseEditHandler course = do
             case insertOkay of 
                 (Just cid) -> do
                   runDB $ insert_ $ Lecturer aid cid 
-                  let cti = termToText $ cfTerm res
+                  let cti = toPathPiece $ cfTerm res
                   addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|]
                   redirect $ CourseListTermR $ cfTerm res
                 Nothing -> do
-                  let cti = termToText $ cfTerm res
+                  let cti = toPathPiece $ cfTerm res
                   addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|]      
       (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren."            
       _other -> return ()
@@ -231,7 +231,7 @@ data CourseForm = CourseForm
         , cfDesc     :: Maybe Html
         , cfLink     :: Maybe Text 
         , cfShort    :: Text 
-        , cfTerm     :: TermIdentifier
+        , cfTerm     :: TermId
         , cfSchool   :: SchoolId
         , cfCapacity :: Maybe Int 
         , cfHasReg   :: Bool
@@ -250,7 +250,7 @@ courseToForm cEntity = CourseForm
         , cfDesc     = courseDescription        course
         , cfLink     = courseLinkExternal       course
         , cfShort    = courseShorthand          course
-        , cfTerm     = unTermKey $ courseTermId course
+        , cfTerm     = courseTermId             course
         , cfSchool   = courseSchoolId           course
         , cfCapacity = courseCapacity           course
         , cfHasReg   = courseHasRegistration    course
@@ -277,8 +277,8 @@ newCourseForm template = identForm FIDcourse $ \html -> do
             -- & addAttr "disabled" "disabled"
             & setTooltip "Muss innerhalb des Semesters eindeutig sein")
                                                 (cfShort  <$> template)
-      <*> areq termExistsField        (fsb "Semester")       (cfTerm     <$> template)
+      <*> areq termActiveField        (fsb "Semester")       (cfTerm     <$> template)
-      <*> areq (selectField schools)  (fsb "Institut")       (cfSchool   <$> template)
+      <*> areq schoolField            (fsb "Institut")       (cfSchool   <$> template)
       <*> aopt (natField "Kapazität") (fsb "Kapazität")      (cfCapacity <$> template)
       <*> areq checkBoxField          (fsb "Anmeldung")      (cfHasReg   <$> template)
       <*> aopt utcTimeField           (fsb "Anmeldung von:") (cfRegFrom  <$> template)
@@ -299,15 +299,11 @@ newCourseForm template = identForm FIDcourse $ \html -> do
                 |]
               )        
       _ -> (result, widget)
-  where     
+--  where
 --     cid :: Maybe CourseId    
 --     cid = join $ cfCourseId <$> template
---     
+
---     schools :: GHandler UniWorX UniWorX (OptionList SchoolId)
+
-    schools = do
-        entities <- runDB $ selectList [] [Asc SchoolShorthand]
-        optionsPairs $ map (\school -> (schoolShorthand $ entityVal school, entityKey school)) entities
-                           
 validateCourse :: CourseForm -> [Text]
 validateCourse (CourseForm{..}) = 
   [ msg | (False, msg) <-

src/Handler/CryptoIDDispatch.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE NoImplicitPrelude
+           , DataKinds
+           , KindSignatures
+           , TypeFamilies
+           , FlexibleInstances
+           , TypeOperators
+           , RankNTypes
+           , PolyKinds
+           , RecordWildCards
+           , MultiParamTypeClasses
+           , ScopedTypeVariables
+           , ViewPatterns
+  #-}
+
+module Handler.CryptoIDDispatch
+  ( getCryptoUUIDDispatchR
+  ) where
+
+import Import hiding (Proxy)
+
+import Data.Proxy
+
+import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
+
+import qualified Control.Monad.Catch as E (Handler(..))
+
+
+class CryptoRoute ciphertext plaintext where
+  cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX)
+
+instance CryptoRoute UUID SubmissionId where
+  cryptoIDRoute _ (CryptoID -> cID) = do
+    (_ :: SubmissionId) <- decrypt cID
+    
+    return $ SubmissionR cID
+
+
+class Dispatch ciphertext (x :: [*]) where
+  dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
+
+instance Dispatch ciphertext '[] where
+  dispatchID _ _ = return Nothing
+
+instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch ciphertext (plaintext ': ps) where
+  dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail
+    where
+      dispatchHead = (Just <$> cryptoIDRoute (Proxy :: Proxy plaintext) ciphertext) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ]
+        where
+          handleHCError :: HandlerContents -> Handler (Maybe a)
+          handleHCError (HCError NotFound) = return Nothing
+          handleHCError e = throwM e
+          handleCryptoID :: CryptoIDError -> Handler (Maybe a)
+          handleCryptoID _ = return Nothing
+      dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext
+  
+
+getCryptoUUIDDispatchR :: UUID -> Handler ()
+getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
+  where
+    p :: Proxy '[ SubmissionId
+                ]
+    p = Proxy

src/Handler/Home.bak

@@ -1,67 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-module Handler.Home where
-
-import Import
-import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
-import Text.Julius (RawJS (..))
-
--- Define our data that will be used for creating the form.
-data FileForm = FileForm
-    { fileInfo :: FileInfo
-    , fileDescription :: Text
-    }
-
--- This is a handler function for the GET request method on the HomeR
--- resource pattern. All of your resource patterns are defined in
--- config/routes
---
--- The majority of the code you will write in Yesod lives in these handler
--- functions. You can spread them across multiple files if you are so
--- inclined, or create a single monolithic file.
-getHomeR :: Handler Html
-getHomeR = do
-    (formWidget, formEnctype) <- generateFormPost sampleForm
-    let submission = Nothing :: Maybe FileForm
-        handlerName = "getHomeR" :: Text
-    defaultLayout $ do
-        let (commentFormId, commentTextareaId, commentListId) = commentIds
-        aDomId <- newIdent
-        setTitle "Welcome To Yesod!"
-        $(widgetFile "homepage")
-
-postHomeR :: Handler Html
-postHomeR = do
-    ((result, formWidget), formEnctype) <- runFormPost sampleForm
-    let handlerName = "postHomeR" :: Text
-        submission = case result of
-            FormSuccess res -> Just res
-            _ -> Nothing
-
-    defaultLayout $ do
-        let (commentFormId, commentTextareaId, commentListId) = commentIds
-        aDomId <- newIdent
-        setTitle "Welcome To Yesod!"
-        $(widgetFile "homepage")
-
-sampleForm :: Form FileForm
-sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
-    <$> fileAFormReq "Choose a file"
-    <*> areq textField textSettings Nothing
-    -- Add attributes like the placeholder and CSS classes.
-    where textSettings = FieldSettings
-            { fsLabel = "What's on the file?"
-            , fsTooltip = Nothing
-            , fsId = Nothing
-            , fsName = Nothing
-            , fsAttrs =
-                [ ("class", "form-control")
-                , ("placeholder", "File description")
-                ]
-            }
-
-commentIds :: (Text, Text, Text)
-commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")

src/Handler/Sheet.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -8,17 +11,23 @@ module Handler.Sheet where
 
 import Import 
 import Handler.Utils
+import Handler.Utils.Zip
+
 
 -- import Data.Time
--- import qualified Data.Text as T
+import qualified Data.Text as T
 -- import Data.Function ((&))
--- import Yesod.Form.Bootstrap3 
+import Yesod.Form.Bootstrap3
 -- 
--- import Colonnade hiding (fromMaybe)
+import Colonnade  -- hiding (fromMaybe)
--- import Yesod.Colonnade 
+import Yesod.Colonnade
 -- 
--- import qualified Data.UUID.Cryptographic as UUID
+import qualified Data.UUID.Cryptographic as UUID
+import qualified Data.Conduit.List as C
 
+import qualified Database.Esqueleto as E
+
+import Network.Mime
 
 {-
   * Implement Handlers
@@ -26,23 +35,203 @@ import Handler.Utils
   * Implement Access in Foundation
 -}
 
+data SheetForm = SheetForm
+      { sfName         :: Text
+      , sfComment      :: Maybe Html
+      , sfType         :: SheetType
+      , sfMarkingText  :: Maybe Html
+      , sfActiveFrom   :: UTCTime
+      , sfActiveTo     :: UTCTime
+      , sfSheetF       :: Maybe FileInfo
+      , sfHintFrom     :: Maybe UTCTime
+      , sfHintF        :: Maybe FileInfo
+      , sfSolutionFrom :: Maybe UTCTime
+      , sfSolutionF    :: Maybe FileInfo
+      }
 
-getSheetListR :: TermIdentifier -> Text -> Handler Html
-getSheetListR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
 
-getSheetNewR :: TermIdentifier -> Text -> Handler Html
+makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm
-getSheetNewR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+makeSheetForm cid template = identForm FIDsheet $ \html -> do
+    -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
+    -- Erstmal nur mit ZIP arbeiten
+    (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm
+      <$> areq textField    (fsb "Name")        (sfName <$> template)
+      <*> aopt htmlField    (fsb "Hinweise für Teilnehmer")  (sfMarkingText <$> template)
+      <*> sheetTypeAFormReq (fsb "Bewertung")   (sfType <$> template)
+      --TODO: SICHTBARKEIT hinzunehmen
+      <*> aopt htmlField    (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
+      <*> areq utcTimeField (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
+      <*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo     <$> template)
+      <*> fileAFormOpt      (fsb "Aufgaben")
+      <*> aopt utcTimeField (fsb "Hinweis ab")  (sfHintFrom     <$> template)
+      <*> fileAFormOpt      (fsb "Hinweis")
+      <*> aopt utcTimeField (fsb "Lösung ab")   (sfSolutionFrom <$> template)
+      <*> fileAFormOpt      (fsb "Lösung")
+    return $ case result of
+      FormSuccess sheetResult
+        | errorMsgs <- validateSheet sheetResult
+        , not $ null errorMsgs ->
+            (FormFailure errorMsgs,
+                  [whamlet|
+                    <div class="alert alert-danger">
+                      <h4> Fehler:
+                      <ul>
+                        $forall errmsg <- errorMsgs
+                          <li> #{errmsg}
+                    ^{widget}
+                  |]
+                )
+      _ -> (result, widget)
+  where
+    validateSheet _ = [] -- TODO
 
-getSheetShowR :: TermIdentifier -> Text -> SheetId -> Handler Html
-getSheetShowR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
 
-getSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html
+fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
+fetchSheet tid csh shn = do
+    -- TODO: More efficient with Esquleto?
+    (Entity cid _course) <- getBy404 $ CourseTermShort tid csh
+    getBy404 $ CourseSheet cid shn
+
+-- List Sheets
+getSheetListCID :: CourseId -> Handler Html
+getSheetListCID cid = getSheetList =<<
+  (Entity cid) <$> (runDB $ get404 cid)
+
+getSheetListR :: TermId -> Text -> Handler Html
+getSheetListR tid csh = getSheetList =<<
+  (runDB $ getBy404 $ CourseTermShort tid csh)
+
+getSheetList :: Entity Course -> Handler Html
+getSheetList courseEnt = do
+  -- mbAid <- maybeAuthId
+  let cid    = entityKey courseEnt
+  let course = entityVal courseEnt
+  let csh    = courseShorthand course
+  let tid    = courseTermId course
+  sheets <- runDB $ do
+    rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom]
+    forM rawSheets $ \(Entity sid sheet) -> do
+        let sheetsub = [SubmissionSheetId ==. sid]
+        submissions <- count sheetsub
+        rated       <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
+        return (sid, sheet, (submissions, rated))
+  let colSheets = mconcat
+       [ headed "Blatt"       $ toWgt . sheetName . snd3
+       , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
+       , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
+       , headed "Bewertung"   $ toWgt . show . sheetType . snd3
+       , headed "Korrigiert"  $ toWgt . snd . trd3
+       , headed "Eingereicht" $ toWgt . fst . trd3
+       -- TODO: only show edit button for allowed course assistants
+       , headed ""            $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s
+       ]
+  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 = getSheetShow =<<
+  (runDB $ fetchSheet tid csh shn)
+
+{- Nur per UUID
+getSheetIdShowR :: SheetId -> Handler Html
+getSheetIdShowR sheetId = getSheetShow =<<
+  (Entity sheetId) <$> (runDB $ get404 sheetId)\
+-}{-
+getSheetUUIDShowR :: CryptoUUIDSheet -> Handler Html
+getSheetUUIDShowR sUUID = do
+  cIDKey <- getsYesod appCryptoIDKey
+  sheetId <- UUID.decrypt cIDKey sUUID
+  sheetEnt <- runDB $ get404 sheetId
+  getSheetShow $ Entity sheetId sheetEnt
+-}
+
+getSheetShow :: (Entity Sheet) -> Handler Html
+getSheetShow entSheet = do
+  let sheet = entityVal entSheet
+  defaultLayout $ do
+    setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
+    [whamlet| Under Construction !!! |] -- TODO
+    $(widgetFile "sheetAdmin")
+
+getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
+getSheetFileR 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)
+      -- 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  )
+        )
+      -- return desired columns
+      return $ file E.^. FileContent
+  let mimeType = defaultMimeLookup $ pack title
+  case content of
+    [E.Value (Just nochmalContent)] -> do
+      addHeader "Content-Disposition" "attachment"
+      respond mimeType nochmalContent
+    []     -> notFound
+    _other -> error "Multiple matching files found."
+
+getSheetNewR :: TermId -> Text -> Handler Html
+getSheetNewR tid csh = do
+  (Entity cid course) <- runDB $ getBy404 $ CourseTermShort tid csh
+  let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
+  ((res,wdgt), enc) <- runFormPost $ makeSheetForm cid template
+
+  case res of
+    (FormSuccess SheetForm{..}) -> do
+
+
+      let sid   = undefined -- TODO after first insert
+      let sname = undefined -- TODO after first insert
+
+      -- Prüfe, das FileTitle innerhalb des Sheets eindeutig ist für diesen SheetFileTpye
+      whenIsJust sfSheetF $ \sinfo -> do
+        let sheetInsert file = do
+              fid <- insert file
+              void . insert $ SheetFile sid fid SheetExercise
+        runDB . runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
+
+
+
+      addMessage "info" "Blatt angelegt"
+      redirect $ SheetShowR tid csh sname
+    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
+    _ -> return ()
+  defaultLayout $ do
+    $(widgetFile "newSheet")
+
+postSheetNewR :: TermId -> Text -> Handler Html
+postSheetNewR = getSheetNewR
+
+getSheetEditR :: TermId -> Text -> SheetId -> Handler Html
 getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
 
+postSheetEditR :: TermId -> Text -> SheetId -> Handler Html
+postSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+
+
+getSheetDelR :: TermId -> Text -> SheetId -> Handler Html
+getSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+  -- Sicherheitsabfrage
+
+postSheetDelR :: TermId -> Text -> SheetId -> Handler Html
+postSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+  -- Tatsächlich löschen
 
 
 {-
-getCourseShowR :: TermIdentifier -> Text -> Handler Html
+getCourseShowR :: TermId -> Text -> Handler Html
 getCourseShowR tid csh = do
   mbAid <- maybeAuthId
   (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do

src/Handler/Submission.hs

@@ -27,8 +27,6 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.CaseInsensitive as CI
 
-import qualified Data.UUID.Cryptographic as UUID
-
 import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
@@ -38,7 +36,6 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 
 import System.FilePath
-import qualified System.FilePath.Cryptographic as FilePath (decrypt, encrypt)
 
 import Colonnade
 import Yesod.Colonnade
@@ -52,12 +49,11 @@ submissionTable = do
 
     return (sub, sheet, course)
 
-  cIDKey <- getsYesod appCryptoIDKey
   cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
-    (,,) <$> FilePath.encrypt cIDKey submissionId <*> UUID.encrypt cIDKey submissionId <*> pure s
+    (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
 
   let
-    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand
+    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR courseTermId courseShorthand
     courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
     anchorSubmission (_, cUUID, _) = SubmissionR cUUID
     submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
@@ -69,7 +65,7 @@ submissionTable = do
     toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
     toExternal (_, cID, _) = return cID
     fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId
-    fromExternal = UUID.decrypt cIDKey
+    fromExternal = decrypt
   headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
 
 
@@ -104,10 +100,9 @@ postSubmissionListR = do
               sinks <- execStateC Map.empty . awaitForever $ \case
                 v@(Right (sId, _)) -> lift $ feed sId v
                 (Left f@File{..})  -> case splitDirectories fileTitle of
-                  (cID:rest)
+                  (cID:rest) 
                     | not (null rest) -> do
-                        cIDKey <- getsYesod appCryptoIDKey
+                        sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
-                        sId <- FilePath.decrypt cIDKey (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
                         lift . feed sId $ Left f{ fileTitle = joinPath rest }
                     | otherwise -> return ()
                   [] -> invalidArgs ["Encountered file/directory with empty name"]
@@ -121,9 +116,8 @@ postSubmissionListR = do
 
 getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
 getSubmissionDownloadSingleR cID path = do
-  cIDKey <- getsYesod appCryptoIDKey
+  submissionID <- decrypt cID
-  submissionID <- UUID.decrypt cIDKey cID
+  cID' <- encrypt submissionID
-  cID' <- FilePath.encrypt cIDKey submissionID
 
   runDB $ do
     isRating <- maybe False (== submissionID) <$> isRatingFile path
@@ -172,9 +166,7 @@ postSubmissionDownloadMultiArchiveR = do
         let
           fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
           fileEntitySource' (rating, Entity submissionID Submission{..}) = do
-            cID <- lift $ do
+            cID <- encrypt submissionID
-              cIDKey <- getsYesod appCryptoIDKey
-              FilePath.encrypt cIDKey submissionID
 
             let
               directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
@@ -202,9 +194,8 @@ getSubmissionDownloadArchiveR path = do
       cID :: CryptoFileNameSubmission
       cID = CryptoID $ CI.mk baseName
   unless (ext == ".zip") notFound
-  cIDKey <- getsYesod appCryptoIDKey
+  submissionID <- decrypt cID
-  submissionID <- FilePath.decrypt cIDKey cID
+  cUUID <- encrypt submissionID
-  cUUID <- UUID.encrypt cIDKey submissionID
   respondSourceDB "application/zip" $ do
     rating <- lift $ getRating submissionID
     case rating of
@@ -218,8 +209,7 @@ getSubmissionDownloadArchiveR path = do
 getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
 getSubmissionR = postSubmissionR
 postSubmissionR cID = do
-  cIDKey <- getsYesod appCryptoIDKey
+  submissionId <- decrypt cID
-  submissionId <- UUID.decrypt cIDKey cID
   
   ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
     <$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False)
@@ -260,7 +250,7 @@ postSubmissionR cID = do
       , ratingTime = submissionRatingTime submission
       }
 
-  cID' <- FilePath.encrypt cIDKey submissionId
+  cID' <- encrypt submissionId
   let
     archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
     archiveName = archiveBaseName <.> "zip"

src/Handler/Term.hs

@@ -39,12 +39,12 @@ getTermShowR = do
     provideRep $ return $ toJSON $ map fst termData
     provideRep $ do      
       let colonnadeTerms = mconcat 
-            [ headed "Kürzel" $ \(Entity _ Term{..},_) -> do
+            [ headed "Kürzel" $ \(Entity tid Term{..},_) -> do
                 -- Scrap this if to slow, create term edit page instead
-                adminLink <- handlerToWidget $ isAuthorized (TermEditExistR termName) False
+                adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
                 [whamlet| 
                   $if adminLink == Authorized
-                    <a href=@{TermEditExistR termName}>
+                    <a href=@{TermEditExistR tid}>
                       #{termToText termName}
                   $else 
                       #{termToText termName}
@@ -55,9 +55,9 @@ getTermShowR = do
                 fromString $ formatTimeGerWD termLectureEnd
             , headed "Aktiv" $ \(Entity _ Term{..},_) -> 
                 bool "" tickmark termActive
-            , headed "Kursliste" $ \(Entity _ Term{..}, E.Value numCourses) -> 
+            , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
                 [whamlet|
-                  <a href=@{CourseListTermR termName}> 
+                  <a href=@{CourseListTermR tid}>
                     #{show numCourses} Kurse
                 |] 
             , headed "Semesteranfang" $ \(Entity _ Term{..},_) ->
@@ -69,7 +69,7 @@ getTermShowR = do
             ]  
       defaultLayout $ do
         setTitle "Freigeschaltete Semester"            
-        encodeHeadedWidgetTable tableDefault colonnadeTerms termData
+        encodeWidgetTable tableDefault colonnadeTerms termData
 
     
 getTermEditR :: Handler Html
@@ -80,9 +80,9 @@ getTermEditR = do
 postTermEditR :: Handler Html
 postTermEditR = termEditHandler Nothing
   
-getTermEditExistR :: TermIdentifier -> Handler Html  
+getTermEditExistR :: TermId -> Handler Html
 getTermEditExistR tid = do
-  term <- runDB $ get $ TermKey tid
+  term <- runDB $ get tid
   termEditHandler term
 
      

src/Handler/Users.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Handler.Users where
+
+import Import
+-- import Data.Text
+import Handler.Utils
+
+import Colonnade hiding (fromMaybe)
+import Yesod.Colonnade
+
+-- import qualified Database.Esqueleto as E
+-- import           Database.Esqueleto      ((^.))
+
+
+getUsersR :: Handler Html
+getUsersR = do
+  -- TODO: Esqueleto, combine the two queries into one
+  (users,schools) <- runDB $ (,)
+    <$> (selectList [] [Asc UserDisplayName]
+        >>= mapM (\usr -> (,,)
+          <$> pure usr
+          <*> selectList [UserAdminUser    ==. entityKey usr] [Asc UserAdminSchool]
+          <*> selectList [UserLecturerUser ==. entityKey usr] [Asc UserLecturerSchool]
+        ))
+    <*> selectList [] [Asc SchoolShorthand]
+  let schoolnames = entities2map schools
+  let getSchoolname = \sid ->
+        case lookup sid schoolnames of
+          Nothing -> "???"
+          (Just school) -> schoolShorthand school
+  let colonnadeUsers = mconcat $
+        [ headed "User" $ text2widget.userDisplayName.entityVal.fst3
+        , headed "Admin for Schools"   $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool   .entityVal) $ snd3 u)
+        , headed "Lecturer at Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u)
+        ]
+        -- ++  map (\school -> headed (text2widget $ schoolName $ entityVal school) (\u -> "xx")) schools
+  defaultLayout $ do
+    setTitle "Comprehensive User List"
+    let userList = encodeWidgetTable tableDefault colonnadeUsers users
+    $(widgetFile "users")

src/Handler/Utils.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Handler.Utils
   ( module Handler.Utils
@@ -18,12 +20,44 @@ import Handler.Utils.Rating as Handler.Utils
 import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Templates as Handler.Utils
 
-import Text.Blaze (Markup)
+import Text.Blaze (Markup, ToMarkup)
 
+import Data.Map (Map)
+import qualified Data.Map as Map
 
 tickmark :: IsString a => a
 tickmark = fromString "✔"
 
+text2Html :: Text -> Html
+text2Html = toHtml -- prevents ambiguous types
+
+toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+  a -> WidgetT site m ()
+toWgt = toWidget . toHtml
+
+text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+                Text -> WidgetT site m ()
+text2widget t = [whamlet|#{t}|]
+
+str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+                String -> WidgetT site m ()
+str2widget s = [whamlet|#{s}|]
+
+
 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)
+
+-----------
+-- Maybe --
+-----------
+whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenIsJust (Just x) f = f x
+whenIsJust Nothing  _ = return ()
+
+----------
+-- Maps --
+----------
+entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
+entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
+

src/Handler/Utils/Form.hs

@@ -28,7 +28,7 @@ import Web.PathPieces (showToPathPiece, readFromPathPiece)
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse
+data FormIdentifier = FIDcourse | FIDsheet
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 
@@ -219,8 +219,25 @@ minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormM
 minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
 
 
-schoolField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m SchoolId
+--termField: see Utils.Term
-schoolField = undefined -- TODO
+
+schoolField :: Field Handler SchoolId
+schoolField = selectField schools
+  where
+    schools = optionsPersistKey [] [Asc SchoolName] schoolName
+
+schoolEntField :: Field Handler (Entity School)
+schoolEntField = selectField schools
+  where
+    schools = optionsPersist [] [Asc SchoolName] schoolName
+
+sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+sheetTypeAFormReq d Nothing =
+  -- TODO, offer options to choose between Normal/Bonus/Pass
+  (Normal . toPoints) <$> areq (natField "Punkte") d Nothing
+sheetTypeAFormReq d (Just (Normal p)) =
+  -- TODO, offer options to choose between Normal/Bonus/Pass
+  (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
 
 utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
 -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
@@ -229,19 +246,20 @@ utcTimeField = Field
     , fieldView = \theId name attrs val isReq ->
         [whamlet|
           $newline never
-          <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id showTime val}">
+          <input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{either id showTime val}">
         |]
     , fieldEnctype = UrlEncoded
     }
   where 
     fieldTimeFormat :: String
-    fieldTimeFormat = "%e.%m.%y %k:%M"
+    --fieldTimeFormat = "%e.%m.%y %k:%M"
+    fieldTimeFormat = "%Y-%m-%eT%H:%M"
     
     readTime :: Text -> Either FormMessage UTCTime
     readTime t = 
       case parseTimeM True germanTimeLocale fieldTimeFormat (T.unpack t) of
         (Just time) -> Right time
-        Nothing -> Left $ MsgInvalidEntry "Datum/Zeit Format: tt.mm.yy hh:mm"
+        Nothing -> Left $ MsgInvalidEntry $ "Datum/Zeit Format: tt.mm.yy hh:mm " ++ t
         
     showTime :: UTCTime -> Text 
     showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)

src/Handler/Utils/Submission.hs

@@ -109,7 +109,7 @@ sinkSubmission sheetId userId mExists = do
               | not (null collidingFiles)  = any (/~ file) [ f | (Entity _ f, _) <- collidingFiles ]
               | otherwise                  = True
             matchesUnderlying
-              | not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ sf) <- underlyingFiles ]
+              | not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ _sf) <- underlyingFiles ]
               | otherwise                  = False
             undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ]
   

src/Handler/Utils/Table.hs

@@ -36,7 +36,7 @@ pairColonnade a b = mconcat [ lmap fst a, lmap snd b]
 -- Table Modification
 encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
 encodeHeadedWidgetTableNumbered attrs colo tdata =
-    encodeHeadedWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
+    encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
   where
     numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ())
     numberCol = headed "Nr" (fromString.show.fst)    
@@ -86,5 +86,5 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
     collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs
 
   return ( catMaybes <$> collectResult selectionResults
-         , encodeHeadedCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
+         , encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
          )

src/Handler/Utils/Term.hs

@@ -13,15 +13,14 @@ import Model.Types
 -- import Data.Maybe
 
 
-termExistsField :: Field Handler TermIdentifier
+termActiveField :: Field Handler TermId
-termExistsField = termField True
+termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
-  -- TODO: Change this to an option list of active terms
+
+termActiveOld :: Field Handler TermIdentifier
+termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
 
 termNewField :: Field Handler TermIdentifier
-termNewField = termField False 
+termNewField = checkMMap checkTerm termToText textField
-
-termField :: Bool -> Field Handler TermIdentifier
-termField mustexist = checkMMap checkTerm termToText textField
   where 
     errTextParse :: Text
     errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
@@ -31,12 +30,8 @@ termField mustexist = checkMMap checkTerm termToText textField
     
     checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
     checkTerm t = case termFromText t of
-      Left  _        -> return $ Left errTextParse
+      Left  _       -> return $ Left errTextParse
-      res@(Right ti) -> do
+      res@(Right _) -> return res
-        term <- runDB $ get $ TermKey ti -- TODO: membershiptest instead?
-        return $ if mustexist && isNothing term 
-          then Left $ errTextFreigabe ti
-          else res 
 
 validateTerm :: Term -> [Text]        
 validateTerm (Term{..}) = 

src/Handler/Utils/Zip.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -10,6 +11,7 @@ module Handler.Utils.Zip
   , produceZip
   , consumeZip
   , modifyFileTitle
+  , sourceFiles
   ) where
 
 import Import
@@ -29,6 +31,8 @@ import Data.Time
 
 import Data.List (dropWhileEnd)
 
+import Network.Mime
+
 
 instance Default ZipInfo where
   def = ZipInfo
@@ -93,3 +97,16 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
 
 modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
 modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
+
+-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
+sourceFiles :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
+sourceFiles fInfo
+    | mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
+    | otherwise = do
+        let fileTitle = unpack $ fileName fInfo
+        fileModified <- liftIO getCurrentTime
+        yieldM $ do
+          fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
+          return File{..}
+  where
+    mimeType = defaultMimeLookup (fileName fInfo)

src/Import/NoFoundation.hs

@@ -11,6 +11,8 @@ import Yesod.Auth            as Import
 import Yesod.Core.Types      as Import (loggerSet)
 import Yesod.Default.Config2 as Import
 
+
 import Data.Fixed            as Import
 
 import CryptoID              as Import
+import Data.UUID             as Import (UUID)

src/Model/Types.hs

@@ -4,6 +4,9 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
+
 module Model.Types where
 
 import ClassyPrelude
@@ -22,6 +25,7 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 
 import Text.Read (readMaybe)
+import Text.Shakespeare.I18N
 
 -- import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
@@ -36,6 +40,12 @@ import Data.Typeable (Typeable)
 
 type Points = Centi
 
+toPoints :: Integral a => a -> Points
+toPoints = MkFixed . fromIntegral
+
+fromPoints :: Integral a => Points -> a
+fromPoints = error "TODO: Types.fromPoints not yet implemented"
+
 data SheetType
   = Bonus  { maxPoints :: Points }
   | Normal { maxPoints :: Points }
@@ -53,6 +63,16 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "SheetFileType"
 
+instance PathPiece SheetFileType where
+  toPathPiece SheetExercise = "file"
+  toPathPiece SheetHint     = "hint"
+  toPathPiece SheetSolution = "solution"
+  toPathPiece SheetMarking  = "marking"
+  fromPathPiece t =
+    lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
+
+
+
 data Load = ByTutorial | ByProportion Double
   deriving (Show, Read, Eq)
 derivePersistField "Load"
@@ -113,6 +133,9 @@ instance ToJSON TermIdentifier where
 instance FromJSON TermIdentifier where
   parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
   
+instance RenderMessage site TermIdentifier where -- TODO: I18N
+  renderMessage _ _ = termToText
+
 {- Must be defined in a later module:
 termField :: Field (HandlerT UniWorX IO) TermIdentifier
 termField = checkMMap (return . termFromText) termToText textField

stack.nix

@@ -5,7 +5,9 @@ let
 in haskell.lib.buildStackProject {
   inherit ghc;
   name = "stackenv";
-  buildInputs = with pkgs;
+  buildInputs = (with pkgs;
     [ postgresql zlib openldap cyrus_sasl.dev
-    ];
+    ]) ++ (with haskell.packages."ghc${builtins.replaceStrings ["."] [""] ghc.version}";
+    [ yesod-bin
+    ]);
 }

stack.yaml

@@ -1,4 +1,5 @@
 flags: {}
+
 docker:
   enable: false
   image: uniworx
@@ -6,33 +7,40 @@ nix:
   packages: []
   pure: false
   shell-file: ./stack.nix
+
 extra-package-dbs: []
+
 packages:
-- .
+  - .
-- location:
+  - location:
-    git: https://github.com/pngwjpgh/zip-stream.git
+      git: https://github.com/pngwjpgh/zip-stream.git
-    commit: 9272bbed000928d500febad1cdc98d1da29d399e
+      commit: 9272bbed000928d500febad1cdc98d1da29d399e
-  extra-dep: true
+    extra-dep: true
-- location:
+  - location:
-    git: https://github.com/mlitchard/yesod-auth-ldap.git
+      git: https://github.com/mlitchard/yesod-auth-ldap.git
-    commit: 69e08ef687ab96df3352ff4267562135453c6f02
+      commit: 69e08ef687ab96df3352ff4267562135453c6f02
-  extra-dep: true
+    extra-dep: true
-- location:
+  - location:
-    git: https://github.com/mlitchard/authenticate-ldap.git
+      git: https://github.com/mlitchard/authenticate-ldap.git
-    commit: cc2770024766a8fa29d3086688df60aaf65fb954
+      commit: cc2770024766a8fa29d3086688df60aaf65fb954
-  extra-dep: true
+    extra-dep: true
+  - location:
+      git: https://github.com/pngwjpgh/encoding.git
+      commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
+    extra-dep: true
+
 extra-deps:
-- colonnade-1.1.1
+  - colonnade-1.2.0
-- yesod-colonnade-1.1.0
+  - yesod-colonnade-1.2.0
-# - zip-stream-0.1.0.1
-- conduit-resumablesink-0.2
-- uuid-crypto-1.3.1.0
-- filepath-crypto-0.0.0.0
-- cryptoids-0.4.0.0
-- cryptoids-types-0.0.0
 
-- encoding-0.8.2
+  - conduit-resumablesink-0.2
-- regex-compat-0.93.1
 
-- LDAP-0.6.11
+  - uuid-crypto-1.4.0.0
-resolver: lts-9.3
+  - filepath-crypto-0.1.0.0
+  - cryptoids-0.5.0.0
+  - cryptoids-types-0.0.0
+  - cryptoids-class-0.0.0
+
+  - LDAP-0.6.11
+
+resolver: lts-10.5

start.sh

@@ -1,2 +1,8 @@
-#!/bin/bash
+#!/usr/bin/env bash
-env DUMMY_LOGIN=true stack exec -- yesod devel
+
+unset HOST
+export DETAILED_LOGGING=true
+export LOG_ALL=true
+export DUMMY_LOGIN=true
+
+exec -- stack exec -- yesod devel

templates/course.hamlet

@@ -24,6 +24,11 @@
                 #{participants}
                 $maybe capacity <- courseCapacity course
                   \ von #{capacity}
+                <br>
+                $maybe regFrom <- courseRegisterFrom course
+                  Anmeldezeitraum: #{formatTimeGerWD regFrom}
+                  $maybe regTo   <- courseRegisterTo   course
+                    \ bis #{formatTimeGerWD regTo}
                 <form method=post action=@{CourseShowR tid csh} enctype=#{regEnctype}>
                   ^{regWidget}
                 

templates/home.hamlet

@@ -27,16 +27,23 @@
   <h2>Teilweise funktionierende Abschnitte
 
   <ul>
-    <li>
+    <li .list-group-item>
+      <a href=@{UsersR}>Benutzer Verwaltung
+
+    <li .list-group-item>
       <a href=@{TermShowR}>Semester Verwaltung
-    <li>
+
+    <li .list-group-item>
       <a href=@{CourseEditR}>Kurse anlegen, editieren und anzeigen
 
+    <li .list-group-item>
+      <a href=@{SubmissionListR}>Dateien hochladen und abrufen
+
 <div>
   <h2>Funktionen zum Testen
 
   <ul>
     <li>
-      Institut einmalig in Datenbank einfügen:
+      Knopf-Test:
         <form .form-inline method=post action=@{HomeR} enctype=#{btnEnctype}>
           ^{btnWdgt}

templates/newSheet.hamlet

@@ -0,0 +1,20 @@
+<div .container>
+    <div .bs-docs-section>
+        <div .row>
+            <div .col-lg-12>
+                <div .page-header>
+                    <h1 #forms>Neuen Blatt anlegen:
+
+                    <p>
+                        Bitte alles ausfüllen!
+
+        <div .row>
+            <div .col-lg-6>
+                <div .bs-callout bs-callout-info well>
+                    <form .form-horizontal method=post #forms enctype=#{enc}>
+                        ^{wdgt}
+
+                        <button .btn.btn-primary type="submit">
+                            Blatt anlegen
+
+

templates/sheetAdmin.hamlet

@@ -0,0 +1,30 @@
+<div .masthead>
+    <div .container>
+        <div .row>
+            <h1 .header>
+              #{sheetName sheet}
+<div .container>
+    <div .bs-docs-section>
+        <div .row>
+            <div .col-lg-12>
+                <div .page-header>                    
+
+                    $maybe descr <- sheetDescription sheet
+                      <h2 #description>Hinweise
+                      <p> #{descr}
+                    <h3>Bewertung
+                    <p> #{show $ sheetType sheet}
+                      $maybe marking <- sheetMarkingText sheet
+                        <p> #{marking}
+                    <br>
+                    Freigeschaltet ab:
+                    \  #{formatTimeGerWD $ sheetActiveFrom sheet}
+                    \ Abgabe bis:
+                    \  #{formatTimeGerWD $ sheetActiveTo sheet}
+
+        <div .row>
+            <div .col-lg-12>     
+                <h2>Abgaben
+
+    <hr>
+

templates/users.hamlet

@@ -0,0 +1,8 @@
+<div .ui.container>
+
+    <p .bg-danger>
+      This page is only for development purposes.
+
+    <h1>
+      User list
+    ^{userList}