fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed DisplayAble instance for CryptoIDs

Browse Source
This commit is contained in:
Sarah Vaupel 2019-06-26 19:03:13 +02:00
parent 09e072c6e3
commit a40456f2cd
7 changed files with 27 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/Data/CryptoID/Instances.hs
View File

@ -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
instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
toMarkup = toMarkup . CID.ciphertext

44
src/Foundation.hs
View File

@ -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

2
src/Handler/Corrections.hs
View File

@ -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

2
src/Handler/Sheet.hs
View File

@ -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

2
src/Handler/Utils/Table/Cells.hs
View File

@ -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

2
templates/correction-user.hamlet
View File

@ -2,7 +2,7 @@
<table .table .table--striped .table--hover .table--vertical>
<tr .table__row>
<th .table__th>_{MsgSubmission}
<td .table__td>#{display cid}
<td .table__td>#{cid}
$maybe Entity _ User{userDisplayName} <- corrector
<tr .table__row>
<th .table__th>_{MsgRatingBy}

2
templates/mail/submissionRated.hamlet
View File

@ -22,7 +22,7 @@ $newline never
_{MsgSubmission}
<dd>
<a href=@{CSubmissionR tid ssh csh shn csid SubShowR}>
#{display csid}
#{csid}
$maybe User{userDisplayName} <- corrector
<dt>
_{MsgRatingBy}