refactor: improve cryptoid caching

src/CryptoID.hs

@@ -3,6 +3,7 @@
 
 module CryptoID
   ( module CryptoID
+  , module CryptoID.Cached
   , module Data.CryptoID.Poly.ImplicitNamespace
   , module Data.UUID.Cryptographic.ImplicitNamespace
   , module System.FilePath.Cryptographic.ImplicitNamespace
@@ -18,6 +19,7 @@ import qualified Data.CryptoID as E
 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 CryptoID.Cached
 
 import qualified Data.Text as Text
 
@@ -28,28 +30,6 @@ 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

src/CryptoID/Cached.hs

@@ -0,0 +1,51 @@
+module CryptoID.Cached
+  ( encrypt, decrypt
+  ) where
+
+import Import.NoModel
+
+import qualified Data.Binary as Binary
+
+import qualified Data.CryptoID.Class.ImplicitNamespace as I
+
+
+newtype CryptoIDDecryption ciphertext plaintext = CryptoIDDecryption plaintext
+  deriving (Typeable)
+newtype CryptoIDEncryption ciphertext plaintext = CryptoIDEncryption ciphertext
+  deriving (Typeable)
+
+encrypt :: forall plaintext ciphertext m.
+           ( I.HasCryptoID ciphertext plaintext (HandlerFor (HandlerSite m))
+           , Typeable plaintext, Typeable ciphertext
+           , Binary plaintext, Binary ciphertext
+           , MonadHandler m
+           )
+        => plaintext -> m (I.CryptoID ciphertext plaintext)
+encrypt plain = liftHandler $ do
+  (cachedEnc :: Maybe (CryptoIDEncryption ciphertext plaintext)) <- cacheByGet cacheKey
+  case cachedEnc of
+    Nothing -> do
+      cID@(I.CryptoID crypt) <- I.encrypt plain
+      cacheBySet cacheKey (CryptoIDEncryption crypt :: CryptoIDEncryption ciphertext plaintext)
+      cacheBySet (toStrict $ Binary.encode crypt) (CryptoIDDecryption plain :: CryptoIDDecryption ciphertext plaintext)
+      return cID
+    Just (CryptoIDEncryption crypt) -> return $ I.CryptoID crypt
+  where cacheKey = toStrict $ Binary.encode plain
+
+decrypt :: forall plaintext ciphertext m.
+           ( I.HasCryptoID ciphertext plaintext (HandlerFor (HandlerSite m))
+           , Typeable plaintext, Typeable ciphertext
+           , Binary plaintext, Binary ciphertext
+           , MonadHandler m
+           )
+        => I.CryptoID ciphertext plaintext -> m plaintext
+decrypt cID@(I.CryptoID crypt) = liftHandler $ do
+  (cachedDec :: Maybe (CryptoIDDecryption ciphertext plaintext)) <- cacheByGet cacheKey
+  case cachedDec of
+    Nothing -> do
+      plain <- I.decrypt cID
+      cacheBySet (toStrict $ Binary.encode plain) (CryptoIDEncryption crypt :: CryptoIDEncryption ciphertext plaintext)
+      cacheBySet cacheKey (CryptoIDDecryption plain :: CryptoIDDecryption ciphertext plaintext)
+      return plain
+    Just (CryptoIDDecryption plain) -> return plain
+  where cacheKey = toStrict $ Binary.encode crypt

src/Foundation/Yesod/Middleware.hs

@@ -321,7 +321,7 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
         & typesUsing @RouteChildren @WorkflowPayloadLabel . filtered (== wpl) .~ wpl'
     verifySubmission = maybeOrig $ \route -> do
       CSubmissionR _tid _ssh _csh _shn cID sr <- return route
-      sId <- $cachedHereBinary cID $ decrypt cID
+      sId <- decrypt cID
       Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
       Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
       Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse

src/Handler/Course/Application/Files.hs

@@ -57,7 +57,7 @@ getCAppsFilesR tid ssh csh = do
              E.&&. course E.^. CourseShorthand E.==. E.val csh
         return (allocation, user, courseApplication)
       apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do
-        cID <- cachedByBinary appId $ encrypt appId
+        cID <- encrypt appId
         lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
       let
         applicationAllocs = setOf (folded . _1) apps'
@@ -87,7 +87,7 @@ getCAppsFilesR tid ssh csh = do
           = id
 
       forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do
-        cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication
+        cID <- encrypt appId :: _ CryptoFileNameCourseApplication
         let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . (</>) (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|])
             fileEntitySource = E.selectSource . E.from $ \courseApplicationFile -> do
               E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId

src/Handler/Exam/Form.hs

@@ -421,7 +421,6 @@ examTemplate cid = runMaybeT $ do
 validateExam :: forall m.
                 ( MonadHandler m
                 , HandlerSite m ~ UniWorX
-                , MonadThrow m
                 )
              => CourseId -> Maybe (Entity Exam) -> FormValidator ExamForm (SqlPersistT m) ()
 validateExam cId oldExam = do

src/Handler/Utils/Form.hs

@@ -1502,11 +1502,10 @@ fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
 
 optionsPersistCryptoId :: forall backend a msg.
                           ( HasCryptoUUID (Key a) (HandlerFor UniWorX)
-                          , KnownSymbol (CryptoIDNamespace UUID (Key a))
                           , RenderMessage UniWorX msg
                           , YesodPersistBackend UniWorX ~ backend
                           , PersistRecordBackend a backend
-                          , PathPiece (Key a)
+                          , Binary (Key a), Typeable a
                           )
                        => [Filter a]
                        -> [SelectOpt a]
@@ -1518,11 +1517,10 @@ optionsPersistCryptoId filts ords toDisplay = do
 
 optionsCryptoIdE :: forall backend a msg.
                     ( HasCryptoUUID (Key a) (HandlerFor UniWorX)
-                    , KnownSymbol (CryptoIDNamespace UUID (Key a))
                     , RenderMessage UniWorX msg
                     , YesodPersistBackend UniWorX ~ backend
                     , PersistRecordBackend a backend
-                    , PathPiece (Key a)
+                    , Binary (Key a), Typeable a
                     )
                  => E.SqlQuery (E.SqlExpr (Entity a))
                  -> (a -> msg)
@@ -1532,12 +1530,11 @@ optionsCryptoIdE query toDisplay = do
   optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)
 
 optionsCryptoIdF :: forall m mono k msg.
-                    ( HasCryptoUUID k m
-                    , KnownSymbol (CryptoIDNamespace UUID k)
+                    ( HasCryptoUUID k (HandlerFor (HandlerSite m))
                     , RenderMessage (HandlerSite m) msg
                     , MonoFoldable mono
-                    , MonadHandler m
-                    , PathPiece k
+                    , MonadHandler m, HandlerSite m ~ UniWorX
+                    , Binary k, Typeable k
                     )
                  => mono
                  -> (Element mono -> m k)

src/Handler/Utils/Workflow/EdgeForm.hs

@@ -72,7 +72,6 @@ workflowEdgeForm :: ( MonadHandler m
                     , HandlerSite m ~ UniWorX
                     , MonadHandler m'
                     , HandlerSite m' ~ UniWorX
-                    , MonadCatch m'
                     , MonadUnliftIO m'
                     )
                  => Either WorkflowInstanceId WorkflowWorkflowId

src/Utils.hs

@@ -966,6 +966,12 @@ foreverBreak :: Monad m
 foreverBreak cont = evalContT . callCC $ forever . cont
 
 
+sortOnM :: (Ord b, Monad m)
+        => (a -> m b)
+        -> [a]
+        -> m [a]
+sortOnM f = fmap (map snd . sortBy (comparing fst)) . mapM (\x -> (\y -> y `seq` (y, x)) <$> f x)
+
 --------------
 -- Foldable --
 --------------

src/Utils/Exam/Correct.hs

@@ -22,7 +22,7 @@ deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
   } ''CorrectInterfaceUser
 
-userToResponse :: (MonadHandler m, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => Entity User -> m CorrectInterfaceUser
+userToResponse :: (MonadHandler m, MonadCrypto (HandlerFor (HandlerSite m)), MonadCryptoKey (HandlerFor (HandlerSite m)) ~ CryptoIDKey) => Entity User -> m CorrectInterfaceUser
 userToResponse (Entity uid User{..}) = do
   uuid <- encrypt uid
   return CorrectInterfaceUser