From a40456f2cdc8b1896e724c10707ccaccd61dfe4e Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 26 Jun 2019 19:03:13 +0200 Subject: [PATCH] Removed DisplayAble instance for CryptoIDs --- src/Data/CryptoID/Instances.hs | 14 +++------ src/Foundation.hs | 44 +++++++++++---------------- src/Handler/Corrections.hs | 2 +- src/Handler/Sheet.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 2 +- templates/correction-user.hamlet | 2 +- templates/mail/submissionRated.hamlet | 2 +- 7 files changed, 27 insertions(+), 41 deletions(-) diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index e98207784..60b6e9081 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -4,15 +4,11 @@ module Data.CryptoID.Instances ( ) where --- import qualified Data.CryptoID as CID +import qualified Data.CryptoID as CID --- import Data.CaseInsensitive (CI) --- import qualified Data.CaseInsensitive as CI +import Text.Blaze (ToMarkup(..)) --- import Text.Blaze (ToMarkup(..)) +import ClassyPrelude --- import ClassyPrelude - --- TODO: markup instance for UUIDs --- instance ToMarkup c => ToMarkup (CID.CryptoID c s) where --- toMarkup = toMarkup . CID.ciphertext \ No newline at end of file +instance ToMarkup s => ToMarkup (CID.CryptoID c s) where + toMarkup = toMarkup . CID.ciphertext \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index ba7747040..20352f19a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -21,10 +21,7 @@ import qualified Network.Wai as W (pathInfo) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI - -import qualified Data.CryptoID as E +import Data.CaseInsensitive (original, mk) import Data.ByteArray (convert) import Crypto.Hash (Digest, SHAKE256, SHAKE128) @@ -91,20 +88,13 @@ import qualified Data.Aeson as JSON import Data.FileEmbed (embedFile) --- TODO: remove once CryptoID is an instance of ToMarkup -instance DisplayAble b => DisplayAble (E.CryptoID a b) where - display = display . ciphertext - -instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => DisplayAble (E.CryptoID namespace (CI FilePath)) where - display = toPathPiece - -- TODO: remove instance DisplayAble TermId where display = termToText . unTermKey -- TODO: remove instance DisplayAble SchoolId where - display = CI.original . unSchoolKey + display = original . unSchoolKey type SMTPPool = Pool SMTPConnection @@ -1451,11 +1441,11 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid) breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just CourseListR) - breadcrumb (TermSchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) + breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid) breadcrumb CourseListR = return ("Kurse" , Nothing) breadcrumb CourseNewR = return ("Neu" , Just CourseListR) - breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) + breadcrumb (CourseR tid ssh csh CShowR) = return (original csh, Just $ TermSchoolCourseListR tid ssh) -- (CourseR tid ssh csh CRegisterR) -- is POST only breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR) @@ -1472,12 +1462,12 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR) - breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) + breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR) breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR) breadcrumb (CTutorialR tid ssh csh tutn TCommR) = return ("Mitteilung", Just $ CTutorialR tid ssh csh tutn TUsersR) - breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) + breadcrumb (CSheetR tid ssh csh shn SShowR) = return (original shn, Just $ CourseR tid ssh csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten" , Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen" , Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben" , Just $ CSheetR tid ssh csh shn SShowR) @@ -1493,7 +1483,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh MaterialListR) = return ("Material" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh MaterialNewR ) = return ("Neu" , Just $ CourseR tid ssh csh MaterialListR) - breadcrumb (CMaterialR tid ssh csh mnm MShowR) = return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) + breadcrumb (CMaterialR tid ssh csh mnm MShowR) = return (original mnm, Just $ CourseR tid ssh csh MaterialListR) breadcrumb (CMaterialR tid ssh csh mnm MEditR) = return ("Bearbeiten" , Just $ CMaterialR tid ssh csh mnm MShowR) breadcrumb (CMaterialR tid ssh csh mnm MDelR) = return ("Löschen" , Just $ CMaterialR tid ssh csh mnm MShowR) -- (CMaterialR tid ssh csh mnm MFileR) -- just for Downloads @@ -2005,8 +1995,8 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemLabel = MsgMenuCorrectionsOwn , menuItemIcon = Nothing , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) - , ("corrections-school", CI.original $ unSchoolKey ssh) - , ("corrections-course", CI.original csh) + , ("corrections-school", original $ unSchoolKey ssh) + , ("corrections-course", original csh) ]) , menuItemModal = False , menuItemAccessCallback' = do @@ -2146,9 +2136,9 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemLabel = MsgMenuCorrectionsOwn , menuItemIcon = Nothing , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) - , ("corrections-school", CI.original $ unSchoolKey ssh) - , ("corrections-course", CI.original csh) - , ("corrections-sheet" , CI.original shn) + , ("corrections-school", original $ unSchoolKey ssh) + , ("corrections-course", original csh) + , ("corrections-sheet" , original shn) ]) , menuItemModal = False , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh @@ -2499,7 +2489,7 @@ routeNormalizers = tell $ Any True maybeOrig f route = maybeT (return route) $ f route hasChanged a b - | ((/=) `on` CI.original) a b = do + | ((/=) `on` original) a b = do $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] tell $ Any True | otherwise = return () @@ -2565,7 +2555,7 @@ instance YesodAuth UniWorX where now <- liftIO getCurrentTime let - userIdent = CI.mk credsIdent + userIdent = mk credsIdent uAuth = UniqueAuthentication userIdent isDummy = credsPlugin == "dummy" @@ -2603,7 +2593,7 @@ instance YesodAuth UniWorX where flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do - ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (CI.original userIdent) credsExtra + ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData let @@ -2620,7 +2610,7 @@ instance YesodAuth UniWorX where userEmail <- if | Just [bs] <- userEmail' , Right userEmail <- Text.decodeUtf8' bs - -> return $ CI.mk userEmail + -> return $ mk userEmail | otherwise -> throwError $ ServerError "Could not retrieve user email" userDisplayName <- if @@ -2675,7 +2665,7 @@ instance YesodAuth UniWorX where Right str <- return $ Text.decodeUtf8' v' return str - termNames = nubBy ((==) `on` CI.mk) $ do + termNames = nubBy ((==) `on` mk) $ do (k, v) <- ldapData guard $ k == Attr "dfnEduPersonFieldOfStudyString" v' <- v diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 9f68b6fbb..7dc79ae4f 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -149,7 +149,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) mkRoute = do cid <- mkCid return $ CSubmissionR tid ssh csh shn cid SubShowR - in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) + in anchorCellM 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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 9717a04df..94b00334d 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -236,7 +236,7 @@ getSheetListR tid ssh csh = do mkRoute = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' SubShowR - in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|]) -- TODO: replace display + in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{cid2}|]) , sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} -> let stats = sheetTypeSum sheetType in -- for statistics over all shown rows diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 43c2598f7..a00fa8ae9 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -237,7 +237,7 @@ submissionCell crse shn sid = csh = crse ^. _3 mkCid = encrypt sid mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR - mkText = display2widget -- TODO: replace with toWgt once there is a ToMarkup instance for CryptoIDs + mkText = toWgt -- display2widget -- TODO: replace with toWgt once there is a ToMarkup instance for CryptoIDs in anchorCellM' mkCid mkRoute mkText correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index 848557260..78a4533b2 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -2,7 +2,7 @@
_{MsgSubmission} - #{display cid} + #{cid} $maybe Entity _ User{userDisplayName} <- corrector
_{MsgRatingBy} diff --git a/templates/mail/submissionRated.hamlet b/templates/mail/submissionRated.hamlet index e632a5bef..51f675e70 100644 --- a/templates/mail/submissionRated.hamlet +++ b/templates/mail/submissionRated.hamlet @@ -22,7 +22,7 @@ $newline never _{MsgSubmission}
- #{display csid} + #{csid} $maybe User{userDisplayName} <- corrector
_{MsgRatingBy}