diff --git a/src/CryptoID.hs b/src/CryptoID.hs index c7b8618cc..02ec64b11 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -15,9 +15,9 @@ import Model import CryptoID.TH import qualified Data.CryptoID as E -import Data.CryptoID.Poly.ImplicitNamespace -import Data.UUID.Cryptographic.ImplicitNamespace -import System.FilePath.Cryptographic.ImplicitNamespace +import Data.CryptoID.Poly.ImplicitNamespace hiding (decrypt, encrypt) +import Data.UUID.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt) +import System.FilePath.Cryptographic.ImplicitNamespace hiding (decrypt, encrypt) import qualified Data.Text as Text @@ -28,6 +28,28 @@ import Data.Aeson.Encoding (text) import Text.Blaze (ToMarkup(..)) +import qualified Data.CryptoID.Class.ImplicitNamespace as I + + +encrypt :: forall plaintext ciphertext m. + ( I.HasCryptoID ciphertext plaintext m + , KnownSymbol (CryptoIDNamespace ciphertext plaintext) + , MonadHandler m + , Typeable ciphertext + , PathPiece plaintext + ) + => plaintext -> m (I.CryptoID ciphertext plaintext) +encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain + +decrypt :: forall plaintext ciphertext m. + ( I.HasCryptoID ciphertext plaintext m + , MonadHandler m + , Typeable plaintext + , PathPiece ciphertext + ) + => I.CryptoID ciphertext plaintext -> m plaintext +decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher + instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey diff --git a/src/Foundation.hs b/src/Foundation.hs index 6596c912c..fc6b5c51f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -58,7 +58,7 @@ import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -import Control.Monad.Except (MonadError(..), ExceptT) +import Control.Monad.Except (MonadError(..)) import Control.Monad.Trans.State (execStateT) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Memo.Class (MonadMemo(..), for4) @@ -448,11 +448,11 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ lift . validateToken mAuthId route isWrite =<< askTokenUnsafe tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of - AdminHijackUserR cID -> exceptT return return $ do + AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do myUid <- maybeExceptT AuthenticationRequired $ return mAuthId uid <- decrypt cID - otherSchoolsFunctions <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] [] - mySchools <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] [] + otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] [] + mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] [] guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) return Authorized r -> $unsupportedAuthPredicate AuthNoEscalation r @@ -509,7 +509,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of return Authorized tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- $cachedHereBinary (mAuthId) . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId @@ -536,9 +536,9 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> exceptT return return $ do + CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isCorrector <- $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do + isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId E.&&. examCorrector E.^. ExamCorrectorUser E.==. E.val authId E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId @@ -1036,14 +1036,14 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from -- participant is currently registered - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant has at least one submission - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -1052,7 +1052,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is member of a submissionGroup - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant @@ -1060,7 +1060,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a sheet corrector - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant @@ -1068,7 +1068,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a tutorial user - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant @@ -1076,7 +1076,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is tutor for this course - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutor E.^. TutorUser E.==. E.val participant @@ -1084,7 +1084,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is lecturer for this course - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid @@ -1419,7 +1419,7 @@ instance Finite (ButtonClass UniWorX) instance PathPiece (ButtonClass UniWorX) where toPathPiece BCIsButton = "btn" toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass - fromPathPiece = finiteFromPathPiece + fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF embedRenderMessage ''UniWorX ''ButtonSubmit id instance Button UniWorX ButtonSubmit where diff --git a/src/Handler/Admin/ErrorMessage.hs b/src/Handler/Admin/ErrorMessage.hs index 5de72e683..64d0d538c 100644 --- a/src/Handler/Admin/ErrorMessage.hs +++ b/src/Handler/Admin/ErrorMessage.hs @@ -6,8 +6,6 @@ import Import import Handler.Utils import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) -import Control.Monad.Trans.Except - getAdminErrMsgR, postAdminErrMsgR :: Handler Html getAdminErrMsgR = postAdminErrMsgR diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 40abe8d14..6c705a102 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -137,7 +137,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) mkRoute = do cid <- mkCid return $ CSubmissionR tid ssh csh shn cid SubShowR - in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|]) + in anchorCellCM $cacheIdentHere mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|]) colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId @@ -149,14 +149,14 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB ssh = course ^. _4 link cid = CourseR tid ssh csh $ CUserR cid protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) -> - anchorCellM (link <$> encrypt userId) $ case mPseudo of + anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of Nothing -> nameWidget userDisplayName userSurname Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|] in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let - protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer) + protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellCM $cacheIdentHere (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer) in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary)) @@ -171,7 +171,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E return $ CSubmissionR tid ssh csh sheetName cid CorrectionR mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this in mconcat - [ anchorCellM mkRoute $(widgetFile "widgets/rating/rating") + [ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating") , writerCell $ do let summary :: SheetTypeSummary diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index a59370ac0..e3abfe205 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -264,13 +264,13 @@ postCApplicationsR tid ssh csh = do allocationLink :: Allocation -> SomeRoute UniWorX allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR - participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX) - participantLink uid = do + participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX) + participantLink uid = liftHandler $ do cID <- encrypt uid return . SomeRoute . CourseR tid ssh csh $ CUserR cID - applicationLink :: MonadCrypto m => CourseApplicationId -> m (SomeRoute UniWorX) - applicationLink appId = do + applicationLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseApplicationId -> m (SomeRoute UniWorX) + applicationLink appId = liftHandler $ do cID <- encrypt appId return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 64d3b78bd..31ccea8c4 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -204,8 +204,8 @@ postEGradesR tid ssh csh examn = do userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] [] let - participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX) - participantLink partId = do + participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX) + participantLink partId = liftHandler $ do cID <- encrypt partId return . SomeRoute . CourseR tid ssh csh $ CUserR cID diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index dcc7329fd..2292320a0 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -30,8 +30,6 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -- import qualified Database.Esqueleto.Internal.Sql as E -import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE) - import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 197f795d5..88560a5c3 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -56,7 +56,8 @@ instance PathPiece RecipientCategory where toPathPiece RecipientCustom = "custom" toPathPiece (RecipientGroup g) = toPathPiece g - fromPathPiece = finiteFromPathPiece + fromPathPiece "custom" = Just RecipientCustom + fromPathPiece t = RecipientGroup <$> fromPathPiece t instance RenderMessage UniWorX RecipientCategory where renderMessage foundation ls = \case diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index b192a1c4f..97090b54f 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -36,8 +36,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A -import Control.Monad.Except (ExceptT) - import Handler.Utils.DateTime import Data.Time.Format (iso8601DateFormat) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index fb68b9105..8fd03620d 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -38,7 +38,6 @@ import qualified Data.Set as Set import Data.Map ((!)) import qualified Data.Map as Map -import Control.Monad.Trans.Except (throwE, runExceptT) import Control.Monad.Writer.Class import Control.Monad.Error.Class (MonadError(..)) @@ -1083,6 +1082,8 @@ optionsPersistCryptoId :: forall site backend a msg. ( YesodPersist site , PersistQueryRead backend , HasCryptoUUID (Key a) (HandlerFor site) + , KnownSymbol (CryptoIDNamespace UUID (Key a)) + , PathPiece (Key a) , RenderMessage site msg , YesodPersistBackend site ~ backend , PersistRecordBackend a backend diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a967a9347..ab8e8ec95 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -35,6 +35,7 @@ module Handler.Utils.Table.Pagination , anchorCell, anchorCell', anchorCellM, anchorCellM' , linkEitherCell, linkEitherCellM, linkEitherCellM' , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' + , anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM' , cellTooltip , listCell , formCell, DBFormResult(..), getDBFormResult @@ -153,14 +154,8 @@ data SortDirection = SortAsc | SortDesc instance Universe SortDirection instance Finite SortDirection -instance PathPiece SortDirection where - toPathPiece SortAsc = "asc" - toPathPiece SortDesc = "desc" - fromPathPiece = finiteFromPathPiece - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''SortDirection +nullaryPathPiece ''SortDirection $ camelToPathPiece' 1 +pathPieceJSON ''SortDirection sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy] sqlSortDirection t (SortColumn e , SortAsc ) = pure . E.asc $ e t @@ -1291,6 +1286,7 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
_{msg} |] + -- | Always display widget; maybe a link if user is Authorized. -- Also see variant `linkEmptyCell` anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a @@ -1308,8 +1304,14 @@ anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val) anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a anchorCellM routeM widget = anchorCellM' routeM id (const widget) +anchorCellCM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX url -> wgt -> DBCell m a +anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget) + anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget) + +anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a +anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget) maybeAnchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) url -> wgt -> DBCell m a maybeAnchorCellM routeM widget = maybeAnchorCellM' routeM id (const widget) @@ -1333,6 +1335,16 @@ linkEitherCellM' :: forall m url wgt wgt' a x. => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellM' (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust) +linkEitherCellCM' :: forall m url wgt wgt' a x cache. + ( HasRoute UniWorX url + , ToWidget UniWorX wgt + , ToWidget UniWorX wgt' + , IsDBTable m a + , Binary cache + ) + => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a +linkEitherCellCM' cache xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellCM' (Just . toStrict $ B.encode cache) (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust) + maybeLinkEitherCellM' :: forall m url wgt wgt' a x. ( HasRoute UniWorX url , ToWidget UniWorX wgt @@ -1340,7 +1352,16 @@ maybeLinkEitherCellM' :: forall m url wgt wgt' a x. , IsDBTable m a ) => MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a -maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do +maybeLinkEitherCellM' = maybeLinkEitherCellCM' Nothing + +maybeLinkEitherCellCM' :: forall m url wgt wgt' a x. + ( HasRoute UniWorX url + , ToWidget UniWorX wgt + , ToWidget UniWorX wgt' + , IsDBTable m a + ) + => Maybe ByteString -> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a +maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do x' <- runMaybeT xM case x' of Just x -> do @@ -1348,17 +1369,15 @@ maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do widget, widgetUnauth :: Widget widget = toWidget $ x2widgetAuth x widgetUnauth = toWidget . x2widgetUnauth $ Just x - authResult <- liftHandler $ isAuthorized (urlRoute route) False + authResult <- liftHandler . maybe id $cachedHereBinary mCache . hasReadAccessTo $ urlRoute route linkUrl <- toTextUrl route - case authResult of - Authorized -> $(widgetFile "table/cell/link") -- show allowed link - _otherwise -> widgetUnauth -- show alternative widget + if + | authResult -> $(widgetFile "table/cell/link") -- show allowed link + | otherwise -> widgetUnauth _otherwise -> do toWidget $ x2widgetUnauth Nothing - - listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a listCell xs mkCell = review dbCell . ([], ) $ do cells <- forM xs $ diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 04d714ef3..ce0cdbadd 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -90,6 +90,10 @@ import Control.Monad.Trans.Writer.Lazy as Import ( writer, Writer, runWriter, mapWriter, execWriter , WriterT(..), mapWriterT, execWriterT ) +import Control.Monad.Trans.Except as Import + ( except, Except, runExcept, mapExcept + , ExceptT(..), runExceptT, mapExceptT, throwE + ) import Control.Monad.Base as Import import Control.Monad.Catch as Import hiding (Handler(..)) import Control.Monad.Trans.Control as Import hiding (embed) @@ -167,6 +171,8 @@ import Control.Arrow as Import (Kleisli(..)) import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString) import Data.Encoding.UTF8 as Import (UTF8(UTF8)) +import GHC.TypeLits as Import (KnownSymbol) + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 69226bf76..23f4e6a17 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -10,6 +10,7 @@ import qualified Model as Current import qualified Model.Types.TH.JSON as Current import Data.Universe +import Data.Universe.TH data SheetType @@ -32,16 +33,8 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool } deriveJSON defaultOptions ''UploadMode Current.derivePersistFieldJSON ''UploadMode -instance Universe UploadMode where - universe = NoUpload : (Upload <$> universe) -instance Finite UploadMode - -instance PathPiece UploadMode where - toPathPiece = \case - NoUpload -> "no-upload" - Upload True -> "unpack" - Upload False -> "no-unpack" - fromPathPiece = finiteFromPathPiece +deriveFinite ''UploadMode +finitePathPiece ''UploadMode ["no-upload", "no-unpack", "unpack"] data SheetSubmissionMode = NoSubmissions | CorrectorSubmissions diff --git a/src/Model/Tokens.hs b/src/Model/Tokens.hs index 613e5ce0d..11ed99a4b 100644 --- a/src/Model/Tokens.hs +++ b/src/Model/Tokens.hs @@ -39,6 +39,8 @@ import Data.Time.Clock.POSIX import Data.Binary (Binary) +import qualified Data.CryptoID.Class.ImplicitNamespace as I + -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token @@ -96,7 +98,7 @@ tokenToJSON :: forall m. -- -- Monadic context is needed because `AuthId`s are encrypted during encoding tokenToJSON BearerToken{..} = do - cID <- either (return . Left) (fmap Right . encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m)))) + cID <- either (return . Left) (fmap Right . I.encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m)))) let stdPayload = Jose.JwtClaims { jwtIss = Just $ toPathPiece tokenIssuedBy , jwtSub = Nothing @@ -128,7 +130,7 @@ tokenParseJSON :: forall site. -- It's usually easier to use `Utils.Tokens.tokenParseJSON'` tokenParseJSON v@(Object o) = do tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site))) - tokenAuthority <- either (return . Left) (fmap Right . decrypt) tokenAuthority' + tokenAuthority <- either (return . Left) (fmap Right . I.decrypt) tokenAuthority' tokenRoutes <- lift $ o .:? "routes" tokenAddAuth <- lift $ o .:? "add-auth" diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 26e4bb291..fb602feb0 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -157,12 +157,7 @@ derivePersistField "SheetFileType" instance Universe SheetFileType instance Finite SheetFileType -instance PathPiece SheetFileType where - toPathPiece SheetExercise = "file" - toPathPiece SheetHint = "hint" - toPathPiece SheetSolution = "solution" - toPathPiece SheetMarking = "marking" - fromPathPiece = finiteFromPathPiece +finitePathPiece ''SheetFileType ["file", "hint", "solution", "marking"] sheetFile2markup :: SheetFileType -> Markup sheetFile2markup SheetExercise = iconSFTQuestion diff --git a/src/Utils.hs b/src/Utils.hs index 97e13c70a..1b8569546 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -56,6 +56,7 @@ import Control.Monad.Morph (hoist) import Language.Haskell.TH import Language.Haskell.TH.Instances () import Instances.TH.Lift () +import qualified Language.Haskell.TH.Syntax as TH (Lift(..)) import Text.Shakespeare.Text (st) @@ -916,6 +917,9 @@ encodedSecretBoxOpen ciphertext = do cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b cachedByBinary k = cachedBy (toStrict $ Binary.encode k) +cacheIdentHere :: Q Exp +cacheIdentHere = TH.lift =<< location + cachedHere :: Q Exp cachedHere = do loc <- location diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 1ce2b0a94..1f75de545 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -1,6 +1,5 @@ module Utils.PathPiece - ( finiteFromPathPiece - , nullaryToPathPiece + ( nullaryToPathPiece , nullaryPathPiece, finitePathPiece , splitCamel , camelToPathPiece, camelToPathPiece' @@ -17,9 +16,11 @@ import Data.Universe import qualified Data.Text as Text import qualified Data.Char as Char -import Data.Map ((!), (!?)) +import Data.Map ((!)) import qualified Data.Map as Map +import qualified Data.HashMap.Strict as HashMap + import Numeric.Natural import Data.List (foldl) @@ -30,10 +31,17 @@ import qualified Data.Aeson.Types as Aeson import Control.Monad.Fail -finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a -finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of - [x] -> Just x - _xs -> Nothing +mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp) +mkFiniteFromPathPiece finiteType = do + mapName <- newName $ "pathPieceMap" <> nameBase finiteType + let + decs = sequence + [ pragInlD mapName NoInline FunLike AllPhases + , sigD mapName [t|HashMap Text $(conT finiteType)|] + , funD mapName + [ clause [] (normalB [e|HashMap.fromList $ map (toPathPiece &&& id) universeF|]) [] ] + ] + (,) <$> decs <*> [e|flip HashMap.lookup $(varE mapName)|] nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do @@ -46,22 +54,26 @@ nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do letE [helperDec] $ varE helperName nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ -nullaryPathPiece nullaryType mangle = - pure <$> instanceD (cxt []) [t|PathPiece $(conT nullaryType)|] - [ funD 'toPathPiece - [ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ] - , funD 'fromPathPiece - [ clause [] (normalB [e|finiteFromPathPiece|]) [] ] - ] +nullaryPathPiece nullaryType mangle = do + (finDecs, finExp) <- mkFiniteFromPathPiece nullaryType + sequence . (map return finDecs ++) . pure $ + instanceD (cxt []) [t|PathPiece $(conT nullaryType)|] + [ funD 'toPathPiece + [ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ] + , funD 'fromPathPiece + [ clause [] (normalB $ return finExp) [] ] + ] finitePathPiece :: Name -> [Text] -> DecsQ -finitePathPiece finiteType verbs = - pure <$> instanceD (cxt []) [t|PathPiece $(conT finiteType)|] - [ funD 'toPathPiece - [ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ] - , funD 'fromPathPiece - [ clause [] (normalB [e|(Map.fromList (zip verbs universeF) !?)|]) [] ] - ] +finitePathPiece finiteType verbs = do + (finDecs, finExp) <- mkFiniteFromPathPiece finiteType + sequence . (map return finDecs ++) . pure $ + instanceD (cxt []) [t|PathPiece $(conT finiteType)|] + [ funD 'toPathPiece + [ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ] + , funD 'fromPathPiece + [ clause [] (normalB $ return finExp) [] ] + ] splitCamel :: Textual t => t -> [t] diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 928f92b18..d4638331f 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -935,7 +935,7 @@ fillDb = do void . insertMany $ do uid <- manyUsers return $ CourseParticipant bs uid now Nothing Nothing - forM_ [1..5] $ \shNr -> do + forM_ [1..14] $ \shNr -> do shId <- insert Sheet { sheetCourse = bs , sheetName = CI.mk [st|Blatt #{tshow shNr}|]