Removed DisplayAble instance for CryptoIDs

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 Text.Blaze (ToMarkup(..))
--- import qualified Data.CaseInsensitive as CI
 
--- import Text.Blaze (ToMarkup(..))
+import ClassyPrelude
 
--- import ClassyPrelude
+instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
-
+  toMarkup = toMarkup . CID.ciphertext
--- TODO: markup instance for UUIDs
--- instance ToMarkup c => ToMarkup (CID.CryptoID c s) where
---   toMarkup = toMarkup . CID.ciphertext

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 Data.CaseInsensitive (original, mk)
-import qualified Data.CaseInsensitive as CI
-
-import qualified Data.CryptoID as E
 
 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-school", original $ unSchoolKey ssh)
-                                                 , ("corrections-course", CI.original csh)
+                                                 , ("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-school", original $ unSchoolKey ssh)
-                                                 , ("corrections-course", CI.original csh)
+                                                 , ("corrections-course", original csh)
-                                                 , ("corrections-sheet" , CI.original shn)
+                                                 , ("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

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

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

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

templates/correction-user.hamlet

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

templates/mail/submissionRated.hamlet

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