From 4946a7df63552a91161db1b3d0cb5fa0762a22f6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 13 Jan 2018 22:56:32 +0100 Subject: [PATCH 01/26] Improve start.sh --- start.sh | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/start.sh b/start.sh index 25209b024..b02b27636 100755 --- a/start.sh +++ b/start.sh @@ -1,2 +1,8 @@ -#!/bin/bash -env DUMMY_LOGIN=true stack exec -- yesod devel +#!/usr/bin/env bash + +env \ + -u HOST \ + DETAILED_LOGGING=true \ + LOG_ALL=true \ + DUMMY_LOGIN=true \ + stack exec -- yesod devel From b8d3855daddbc591c4556468e86e1a82fde8fddc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 13 Jan 2018 23:02:08 +0100 Subject: [PATCH 02/26] Cleanup --- start.sh | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/start.sh b/start.sh index b02b27636..dc2f16a96 100755 --- a/start.sh +++ b/start.sh @@ -1,8 +1,8 @@ #!/usr/bin/env bash -env \ - -u HOST \ - DETAILED_LOGGING=true \ - LOG_ALL=true \ - 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 From 7536af9bdc2b4f7769aa6e7274f31461bd96f6d2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 23 Jan 2018 09:43:50 +0000 Subject: [PATCH 03/26] Ignore more temporary files --- .gitignore | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitignore b/.gitignore index 932688139..f4c2d62c0 100644 --- a/.gitignore +++ b/.gitignore @@ -18,12 +18,12 @@ cabal.sandbox.config *.swp *.keter *~ -\#* +**/\#* +**/.\#* uniworx.cabal uniworx.nix .gup/ .dbsettings.yml *.kate-swp src/Handler/Assist.bak -src/Handler/Course.SnapCustom.hs - +src/Handler/Course.SnapCustom.hs \ No newline at end of file From 7d9dc39da4d3f02d38113e76273d631457e5af04 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jan 2018 10:30:06 +0100 Subject: [PATCH 04/26] Start work on fill-db.hs --- fill-db.hs | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100755 fill-db.hs diff --git a/fill-db.hs b/fill-db.hs new file mode 100755 index 000000000..deec4e5e9 --- /dev/null +++ b/fill-db.hs @@ -0,0 +1,70 @@ +#!/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 = False + } + 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) From 324c78c7fb6bafe7a09424b32f1ba165a3180d3a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 30 Jan 2018 14:51:50 +0100 Subject: [PATCH 05/26] Add sheet --- fill-db.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/fill-db.hs b/fill-db.hs index deec4e5e9..8810d6aa5 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -68,3 +68,4 @@ main = db $ do void . insert $ DegreeCourse ifiMsc ffp void . insert $ Lecturer gkleen ffp void . insert $ Corrector gkleen ffp (ByProportion 1) + void . insert $ Sheet ffp "Blatt 1" NotGraded Nothing now now Nothing Nothing now now gkleen gkleen From 3c12f0bb31ab2d435d4d34eebaecaa330c3d3a52 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 30 Jan 2018 15:09:44 +0100 Subject: [PATCH 06/26] Fix build on Nix --- shell.nix | 13 +++++++++---- stack.nix | 6 ++++-- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/shell.nix b/shell.nix index df2997a61..c5b561eaa 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import {}, compiler ? null }: +{ nixpkgs ? import {}, compiler ? "ghc802" }: 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 ]) ++ (with haskellPackages; [ stack yesod-bin ]); shellHook = '' ${oldAttrs.shellHook} export PROMPT_INFO="${oldAttrs.name}" @@ -44,5 +44,10 @@ let 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 diff --git a/stack.nix b/stack.nix index 6c8243ee9..720dc860f 100644 --- a/stack.nix +++ b/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 + ]); } From db92528884d6b8b310470fc0f94ef46d3157682e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Jan 2018 01:17:31 +0100 Subject: [PATCH 07/26] Framework & dispatch submissions --- package.yaml | 1 + routes | 2 ++ src/Application.hs | 1 + src/Foundation.hs | 1 + src/Handler/CryptoIDDispatch.hs | 50 +++++++++++++++++++++++++++++++++ src/Import/NoFoundation.hs | 1 + 6 files changed, 56 insertions(+) create mode 100644 src/Handler/CryptoIDDispatch.hs diff --git a/package.yaml b/package.yaml index 9d3b509b1..99ef36dd0 100644 --- a/package.yaml +++ b/package.yaml @@ -75,6 +75,7 @@ dependencies: - yesod-auth-ldap - LDAP - parsec +- uuid # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index 4085fd935..835f50270 100644 --- a/routes +++ b/routes @@ -29,5 +29,7 @@ !/submission/archive/#FilePath SubmissionDownloadArchiveR GET !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET +!/#UUID CryptoUUIDDispatchR GET + -- For demonstration /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET diff --git a/src/Application.hs b/src/Application.hs index 403bf072c..4b558617d 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -46,6 +46,7 @@ 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index ae0b849bb..954a132e0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -133,6 +133,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 diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs new file mode 100644 index 000000000..450f6944e --- /dev/null +++ b/src/Handler/CryptoIDDispatch.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NoImplicitPrelude + , DataKinds + , KindSignatures + , TypeFamilies + , FlexibleInstances + , TypeOperators + , RankNTypes + , PolyKinds + , RecordWildCards + , MultiParamTypeClasses + , ScopedTypeVariables + #-} + +module Handler.CryptoIDDispatch + ( getCryptoUUIDDispatchR + ) where + +import GHC.TypeLits +import Import hiding (Proxy) + +import Data.Proxy + + +class KnownSymbol namespace => CryptoRoute ciphertext namespace where + cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX) + +instance CryptoRoute UUID "Submission" where + cryptoIDRoute = return . SubmissionR + + +class Dispatch ciphertext (x :: [Symbol]) where + dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX)) + +instance Dispatch ciphertext '[] where + dispatchID _ _ = return Nothing + +instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch ciphertext (namespace ': ns) where + dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail + where + headID :: CryptoID namespace ciphertext + headID = CryptoID{..} + dispatchHead = (Just <$> cryptoIDRoute headID) `catchAny` (\_ -> return Nothing) + dispatchTail = dispatchID (Proxy :: Proxy ns) ciphertext + + +getCryptoUUIDDispatchR :: UUID -> Handler () +getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound redirect + where + p :: Proxy '["Submission"] + p = Proxy diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 324a88840..9b688de60 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -14,3 +14,4 @@ import Yesod.Default.Config2 as Import import Data.Fixed as Import import CryptoID as Import +import Data.UUID as Import (UUID) From 6bf0f321cf41cd536aac3987a9fd2598da844bcf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Jan 2018 01:37:01 +0100 Subject: [PATCH 08/26] Check decryption before redirecting (as was intended) --- src/Handler/CryptoIDDispatch.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 450f6944e..7666225f7 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -20,12 +20,18 @@ import Import hiding (Proxy) import Data.Proxy +import qualified Data.UUID.Cryptographic as UUID + class KnownSymbol namespace => CryptoRoute ciphertext namespace where cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX) instance CryptoRoute UUID "Submission" where - cryptoIDRoute = return . SubmissionR + cryptoIDRoute cID = do + cIDKey <- getsYesod appCryptoIDKey + sId <- UUID.decrypt cIDKey cID + + return $ SubmissionR cID class Dispatch ciphertext (x :: [Symbol]) where From 7c5c12dc6bbca3c77f39246be97754ac69129545 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Jan 2018 02:30:12 +0100 Subject: [PATCH 09/26] Fix type error --- src/Handler/CryptoIDDispatch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 7666225f7..04fe31baf 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -29,7 +29,7 @@ class KnownSymbol namespace => CryptoRoute ciphertext namespace where instance CryptoRoute UUID "Submission" where cryptoIDRoute cID = do cIDKey <- getsYesod appCryptoIDKey - sId <- UUID.decrypt cIDKey cID + (_ :: SubmissionId) <- UUID.decrypt cIDKey cID return $ SubmissionR cID From d37ee331f68004e97fb458cb70449c81f4d929af Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Jan 2018 02:30:21 +0100 Subject: [PATCH 10/26] Use correct status header --- src/Handler/CryptoIDDispatch.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 04fe31baf..68890b823 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -50,7 +50,7 @@ instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch getCryptoUUIDDispatchR :: UUID -> Handler () -getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound redirect +getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) where p :: Proxy '["Submission"] p = Proxy From b6dbd27eb0fe550c0d3689c5f041438348fa69b1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 20 Jan 2018 09:42:26 +0100 Subject: [PATCH 11/26] Cleanup --- package.yaml | 1 + src/Handler/CryptoIDDispatch.hs | 15 +++++++++++++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 99ef36dd0..767109324 100644 --- a/package.yaml +++ b/package.yaml @@ -76,6 +76,7 @@ dependencies: - LDAP - parsec - uuid +- exceptions # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 68890b823..eb76377ac 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -22,6 +22,10 @@ import Data.Proxy import qualified Data.UUID.Cryptographic as UUID +import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) + +import qualified Control.Monad.Catch as E (Handler(..)) + class KnownSymbol namespace => CryptoRoute ciphertext namespace where cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX) @@ -45,12 +49,19 @@ instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch where headID :: CryptoID namespace ciphertext headID = CryptoID{..} - dispatchHead = (Just <$> cryptoIDRoute headID) `catchAny` (\_ -> return Nothing) + dispatchHead = (Just <$> cryptoIDRoute headID) `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 ns) ciphertext getCryptoUUIDDispatchR :: UUID -> Handler () getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) where - p :: Proxy '["Submission"] + p :: Proxy '[ "Submission" + ] p = Proxy From fddd8bef4c8173baaaee3e3e13a40f4db6226b93 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 9 Feb 2018 14:22:01 +0100 Subject: [PATCH 12/26] Make CryptoIDKey implicit using new cryptoids-class --- ghci.sh | 8 ++++++ package.yaml | 2 ++ src/CryptoID.hs | 20 +++++++------- src/CryptoID/TH.hs | 48 +++++++++++++++++---------------- src/Foundation.hs | 14 +++++----- src/Handler/CryptoIDDispatch.hs | 27 ++++++++----------- src/Handler/Submission.hs | 30 +++++++-------------- stack.yaml | 8 +++--- 8 files changed, 78 insertions(+), 79 deletions(-) create mode 100755 ghci.sh diff --git a/ghci.sh b/ghci.sh new file mode 100755 index 000000000..64adc58eb --- /dev/null +++ b/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 diff --git a/package.yaml b/package.yaml index 767109324..aa46feb3e 100644 --- a/package.yaml +++ b/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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9eecc80a0..b8889ebac 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -7,8 +7,9 @@ module CryptoID ( module CryptoID - , module Data.UUID.Cryptographic - , module Data.CryptoID.Poly + , module Data.CryptoID.Poly.ImplicitNamespace + , 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 hiding (encrypt, decrypt) +import Data.CryptoID.Poly.ImplicitNamespace +import Data.UUID.Cryptographic.ImplicitNamespace +import System.FilePath.Cryptographic.ImplicitNamespace -import Data.UUID.Cryptographic import Data.UUID.Types import Web.PathPieces @@ -28,10 +29,7 @@ instance PathPiece UUID where fromPathPiece = fromString . unpack toPathPiece = pack . toString -decKeysBinary [ ''SubmissionId - , ''CourseId - ] -decTypeAliases [ "Submission" - , "Course" - ] +decCryptoIDs [ ''SubmissionId + , ''CourseId + ] diff --git a/src/CryptoID/TH.hs b/src/CryptoID/TH.hs index 20073bb85..23122dadf 100644 --- a/src/CryptoID/TH.hs +++ b/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] -decTypeAliases = return . concatMap decTypeAliases' +decCryptoIDs :: [Name] -> DecsQ +decCryptoIDs = fmap concat . mapM decCryptoID where - decTypeAliases' :: String -> [Dec] - decTypeAliases' n - = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n) - , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID - , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` (ConT ''CI `AppT` ConT ''FilePath) + decCryptoID :: Name -> DecsQ + decCryptoID n@(conT -> t) = do + instances <- [d| + instance Binary $(t) where + 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 - cryptoUUIDn = mkName $ "CryptoUUID" ++ n - 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 - |] + ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n + cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t diff --git a/src/Foundation.hs b/src/Foundation.hs index 954a132e0..fde407991 100644 --- a/src/Foundation.hs +++ b/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 -- | The foundation datatype for your application. This can be a good place to @@ -187,16 +186,14 @@ isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseEditR _ = lecturerAccess Nothing isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c) isAuthorizedDB (CourseEditExistIDR cID) _ = do - cIDKey <- getsYesod appCryptoIDKey - courseId <- UUID.decrypt cIDKey cID + 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 - cIDKey <- getsYesod appCryptoIDKey - submissionId <- either (FilePath.decrypt cIDKey) (UUID.decrypt cIDKey) cID + submissionId <- either decrypt decrypt cID Submission{..} <- get404 submissionId submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] [] let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy @@ -428,6 +425,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: diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index eb76377ac..0eff808f2 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -9,59 +9,54 @@ , RecordWildCards , MultiParamTypeClasses , ScopedTypeVariables + , ViewPatterns #-} module Handler.CryptoIDDispatch ( getCryptoUUIDDispatchR ) where -import GHC.TypeLits import Import hiding (Proxy) import Data.Proxy -import qualified Data.UUID.Cryptographic as UUID - import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import qualified Control.Monad.Catch as E (Handler(..)) -class KnownSymbol namespace => CryptoRoute ciphertext namespace where - cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX) +class CryptoRoute ciphertext plaintext where + cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX) -instance CryptoRoute UUID "Submission" where - cryptoIDRoute cID = do - cIDKey <- getsYesod appCryptoIDKey - (_ :: SubmissionId) <- UUID.decrypt cIDKey cID +instance CryptoRoute UUID SubmissionId where + cryptoIDRoute _ (CryptoID -> cID) = do + (_ :: SubmissionId) <- decrypt cID return $ SubmissionR cID -class Dispatch ciphertext (x :: [Symbol]) where +class Dispatch ciphertext (x :: [*]) where dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX)) instance Dispatch ciphertext '[] where dispatchID _ _ = return Nothing -instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch ciphertext (namespace ': ns) where +instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch ciphertext (plaintext ': ps) where dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail where - headID :: CryptoID namespace ciphertext - headID = CryptoID{..} - dispatchHead = (Just <$> cryptoIDRoute headID) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ] + 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 ns) ciphertext + dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext getCryptoUUIDDispatchR :: UUID -> Handler () getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) where - p :: Proxy '[ "Submission" + p :: Proxy '[ SubmissionId ] p = Proxy diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 87e760998..ee5b54e5e 100644 --- a/src/Handler/Submission.hs +++ b/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,9 +49,8 @@ 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 @@ -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 @@ -106,8 +102,7 @@ postSubmissionListR = do (Left f@File{..}) -> case splitDirectories fileTitle of (cID:rest) | not (null rest) -> do - cIDKey <- getsYesod appCryptoIDKey - sId <- FilePath.decrypt cIDKey (CryptoID $ CI.mk cID :: CryptoFileNameSubmission) + sId <- decrypt (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 <- UUID.decrypt cIDKey cID - cID' <- FilePath.encrypt cIDKey submissionID + submissionID <- decrypt cID + cID' <- encrypt 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 - cIDKey <- getsYesod appCryptoIDKey - FilePath.encrypt cIDKey submissionID + cID <- encrypt 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 <- FilePath.decrypt cIDKey cID - cUUID <- UUID.encrypt cIDKey submissionID + submissionID <- decrypt cID + cUUID <- encrypt 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 <- UUID.decrypt cIDKey cID + submissionId <- decrypt 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" diff --git a/stack.yaml b/stack.yaml index 4ffa5300f..8cb20da7f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -26,13 +26,15 @@ extra-deps: - yesod-colonnade-1.1.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 +- uuid-crypto-1.4.0.0 +- filepath-crypto-0.1.0.0 +- cryptoids-0.5.0.0 - cryptoids-types-0.0.0 +- cryptoids-class-0.0.0 - encoding-0.8.2 - regex-compat-0.93.1 - LDAP-0.6.11 resolver: lts-9.3 +allow-newer: true From 272bc7f6c576a98f55485aae0a79d1e4256602d1 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 19 Feb 2018 16:54:10 +0100 Subject: [PATCH 13/26] schoolField & termField in Utils --- models | 2 +- src/Handler/Course.hs | 9 ++------- src/Handler/Utils/Form.hs | 14 +++++++++----- src/Handler/Utils/Term.hs | 18 +++++------------- src/Import/NoFoundation.hs | 1 + src/Model/Types.hs | 7 +++++++ 6 files changed, 25 insertions(+), 26 deletions(-) diff --git a/models b/models index 8ec481079..fa564bc26 100644 --- a/models +++ b/models @@ -200,6 +200,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) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 56190ce78..aaf4f97c5 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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 (selectField schools) (fsb "Institut") (cfSchool <$> template) + <*> areq termActiveField (fsb "Semester") (cfTerm <$> 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) @@ -302,11 +302,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do 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{..}) = diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index da0c56050..fde3533b5 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -218,9 +218,12 @@ 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 :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m SchoolId -schoolField = undefined -- TODO +schoolField :: Field Handler SchoolId +schoolField = selectField schools + where + schools = optionsPersistKey [] [Asc SchoolName] schoolName utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing) @@ -229,19 +232,20 @@ utcTimeField = Field , fieldView = \theId name attrs val isReq -> [whamlet| $newline never - + |] , 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) diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs index 73f705330..b3c9c4f9d 100644 --- a/src/Handler/Utils/Term.hs +++ b/src/Handler/Utils/Term.hs @@ -13,15 +13,11 @@ import Model.Types -- import Data.Maybe -termExistsField :: Field Handler TermIdentifier -termExistsField = termField True - -- TODO: Change this to an option list of active terms +termActiveField :: Field Handler TermIdentifier +termActiveField = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName termNewField :: Field Handler TermIdentifier -termNewField = termField False - -termField :: Bool -> Field Handler TermIdentifier -termField mustexist = checkMMap checkTerm termToText textField +termNewField = checkMMap checkTerm termToText textField where errTextParse :: Text errTextParse = "Semester: S oder W gefolgt von Jahreszahl" @@ -31,12 +27,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 - res@(Right ti) -> do - term <- runDB $ get $ TermKey ti -- TODO: membershiptest instead? - return $ if mustexist && isNothing term - then Left $ errTextFreigabe ti - else res + Left _ -> return $ Left errTextParse + res@(Right _) -> return res validateTerm :: Term -> [Text] validateTerm (Term{..}) = diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9b688de60..1cc175101 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -11,6 +11,7 @@ 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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index ee5048292..38274f64f 100644 --- a/src/Model/Types.hs +++ b/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 @@ -113,6 +117,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 From 9bad1b42ecce6ad1fd2dfc84642eb0cce236109b Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 13 Dec 2017 16:02:10 +0100 Subject: [PATCH 14/26] Forgotten minor bugfixes that belong to master, but slipped into this branch. --- src/Foundation.hs | 4 ++-- src/Handler/Sheet.hs | 6 +++++- src/Handler/Submission.hs | 2 +- src/Handler/Utils/Submission.hs | 2 +- 4 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index fde407991..68a196b09 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -188,7 +188,7 @@ isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< g isAuthorizedDB (CourseEditExistIDR cID) _ = do courseId <- decrypt 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 @@ -384,7 +384,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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index a3f3afa4d..63cdb036f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -28,7 +28,11 @@ import Handler.Utils getSheetListR :: TermIdentifier -> Text -> Handler Html -getSheetListR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO +getSheetListR tid csh = do +-- mbAid <- maybeAuthId +-- _ <- runDB $ do +-- courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh + defaultLayout [whamlet| Under Construction !!! |] -- TODO getSheetNewR :: TermIdentifier -> Text -> Handler Html getSheetNewR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index ee5b54e5e..c46cc5727 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -100,7 +100,7 @@ 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 sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission) lift . feed sId $ Left f{ fileTitle = joinPath rest } diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 2713994ba..fad44f370 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 ] From 2f47f12832ad42d7003babddf16397e4b9cef167 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 20 Dec 2017 17:58:37 +0100 Subject: [PATCH 15/26] User Overview page added, no user-editing yet --- routes | 1 + src/Application.hs | 1 + src/Foundation.hs | 6 ++++++ src/Handler/Users.hs | 44 ++++++++++++++++++++++++++++++++++++++++++ src/Handler/Utils.hs | 11 +++++++++++ templates/home.hamlet | 12 +++++++++--- templates/users.hamlet | 8 ++++++++ 7 files changed, 80 insertions(+), 3 deletions(-) create mode 100644 src/Handler/Users.hs create mode 100644 templates/users.hamlet diff --git a/routes b/routes index 835f50270..c1344548d 100644 --- a/routes +++ b/routes @@ -6,6 +6,7 @@ / HomeR GET POST /profile ProfileR GET +/users UsersR GET /term TermShowR GET /term/edit TermEditR GET POST diff --git a/src/Application.hs b/src/Application.hs index 4b558617d..33a3fd07b 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -42,6 +42,7 @@ 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 68a196b09..4af75fead 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -178,6 +178,7 @@ 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 @@ -266,6 +267,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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs new file mode 100644 index 000000000..4b7fb55ad --- /dev/null +++ b/src/Handler/Users.hs @@ -0,0 +1,44 @@ +{-# 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 <- runDB $ + (selectList [] [Asc UserDisplayName]) + >>= (mapM (\usr -> (,,) + <$> (pure usr) + <*> (selectList [UserAdminUser ==. (entityKey usr)] [Asc UserAdminSchool]) + <*> (selectList [UserLecturerUser ==. (entityKey usr)] [Asc UserLecturerSchool]) + )) + schools <- runDB $ 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) + ] + defaultLayout $ do + setTitle "Comprehensive User List" + let userList = encodeHeadedWidgetTable tableDefault colonnadeUsers users + $(widgetFile "users") diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 277310908..10127afa0 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} module Handler.Utils ( module Handler.Utils @@ -19,6 +20,8 @@ import Handler.Utils.Submission as Handler.Utils import Text.Blaze (Markup) +import Data.Map (Map) +import qualified Data.Map as Map tickmark :: IsString a => a tickmark = fromString "✔" @@ -26,3 +29,11 @@ tickmark = fromString "✔" 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) + +entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record +entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty + +text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => + Text -> WidgetT site m () +text2widget t = [whamlet|#{t}|] + diff --git a/templates/home.hamlet b/templates/home.hamlet index 0d20c2862..2e274b4e1 100644 --- a/templates/home.hamlet +++ b/templates/home.hamlet @@ -48,10 +48,13 @@
-

Teilweise funktionierende Abschnitte +

Teilweise funktionierende Abschnitte