chore(caching): for company table working

models/company.model

@@ -14,7 +14,7 @@ Company
   UniqueCompanyShorthand shorthand
   -- UniqueCompanyAvsId avsId             -- should be the case, unclear if enforcing works here, since we cannot query avs by company id
   Primary shorthand             -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand }
-  deriving Ord Eq Show Generic
+  deriving Ord Eq Show Generic Binary
 
 -- TODO: a way to populate this table (manually)
 CompanySynonym

package.yaml

@@ -147,6 +147,8 @@ dependencies:
   - extended-reals
   - rfc5051
   - unidecode
+  - doctemplates
+  - doclayout
   - pandoc
   - pandoc-types
   - typed-process

src/Handler/LMS.hs

@@ -367,19 +367,17 @@ mkLmsTable :: ( Functor h, ToSortable h
            => Bool
            -> Entity Qualification
            -> Map LmsTableAction (AForm Handler LmsTableActionData)           
-           -> (Map CompanyId (Entity Company) -> cols)
+           -> (Map CompanyId Company -> cols)
            -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
            -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
 mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
   now <- liftIO getCurrentTime
-  let
-    nowaday = utctDay now
-    companyStamp = "CompanyMap" <> tshow (roundDownToMinutes 5 now)
   -- lookup all companies 
-  cmpMap <- $cachedHereBinary companyStamp $ do 
+  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do 
     cmps <- selectList [] [Asc CompanyId]
-    return $ Map.fromAscList $ fmap (\c -> (entityKey c, c)) cmps
+    return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps
   let        
+    nowaday = utctDay now
     -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
     csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
     dbtIdent :: Text
@@ -496,8 +494,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
           <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserEnded))
         getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of 
           []        -> pure   Nothing
-          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_entityVal . _companyName . _CI)) somecmps
+          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _entityVal . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
+        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
         
     dbtCsvDecode = Nothing
     dbtExtraReps = []
@@ -555,7 +553,7 @@ postLmsR sid qsh = do
                   cs =  [ (cmpName, cmpSpr) 
                         | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                         , let cmpEnt = Map.lookup cmpId cmpMap
-                        , Just (Entity _ Company{companyName = cmpName}) <- [cmpEnt]
+                        , Just Company{companyName = cmpName} <- [cmpEnt]
                         ]
                   companies = intercalate (text2markup ", ") $
                     (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs

src/Handler/Qualification.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <S.Jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -304,20 +304,18 @@ mkQualificationTable ::
            => Bool
            -> Entity Qualification
            -> Map QualificationTableAction (AForm Handler QualificationTableActionData)           
-           -> (Map CompanyId (Entity Company) -> cols)
+           -> (Map CompanyId Company -> cols)
            -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
            -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
 mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
   svs <- getSupervisees
   now <- liftIO getCurrentTime  
+  -- lookup all companies   
+  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do 
+    cmps <- selectList [] [Asc CompanyId]
+    return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps
   let
     nowaday = utctDay now
-    companyStamp = "CompanyMap" <> tshow (roundDownToMinutes 5 now)
-  -- lookup all companies 
-  cmpMap <- $cachedHereBinary companyStamp $ do 
-    cmps <- selectList [] [Asc CompanyId]
-    return $ Map.fromAscList $ fmap (\c -> (entityKey c, c)) cmps
-  let
     mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
     csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
     dbtIdent :: Text
@@ -412,10 +410,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
           <*>  view    (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
           <*>  getStatusPlusTxt
           <*>  getStatusPlusDay
-        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of 
+        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal .  _userCompanyCompany)) cmps of 
           []        -> pure   Nothing
-          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_entityVal . _companyName . _CI)) somecmps
+          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _entityVal . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
+        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
 
         getStatusPlusTxt = 
           (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus)) >>= \case 
@@ -486,7 +484,7 @@ postQualificationR sid qsh = do
                   cs =  [ (cmpName, cmpSpr) 
                         | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                         , let cmpEnt = Map.lookup cmpId cmpMap
-                        , Just (Entity _ Company{companyName = cmpName}) <- [cmpEnt]
+                        , Just Company{companyName = cmpName} <- [cmpEnt]
                         ]
                   companies = intercalate (text2markup ", ") $
                     (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs

src/Handler/Users.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,7 +45,7 @@ import Auth.Dummy (apDummy)
 
 
 hijackUserForm :: Form ()
-hijackUserForm = identifyForm FIDHijackUser $ \csrf -> do
+hijackUserForm = \csrf -> do
   (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
   return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView])
 

src/Utils/Lens.hs

@@ -128,7 +128,7 @@ makeClassyFor_ ''LmsResult
 makeClassyFor_ ''UserAvs
 makeClassyFor_ ''UserAvsCard
 
-makeClassyFor_ ''UserCompany
+makeLenses_ ''UserCompany
 makeLenses_ ''Company
 
 _entityKey :: Getter (Entity record) (Key record)

src/Utils/Print.hs

@@ -42,6 +42,7 @@ import Text.Hamlet
 import System.Exit
 import System.Process.Typed -- for calling pdftk for pdf encryption
 
+-- import Handler.Utils.Memcached
 import Handler.Utils.Users
 import Handler.Utils.DateTime
 import Handler.Utils.Mail
@@ -49,6 +50,7 @@ import Handler.Utils.Widgets (nameHtml')
 import Handler.Utils.Avs (updateReceivers)
 import Jobs.Handler.SendNotification.Utils
 
+-- import Utils.Print.Instances
 import Utils.Print.Letters
 import Utils.Print.RenewQualification
 import Utils.Print.CourseCertificate
@@ -113,8 +115,10 @@ mdTemplating template meta = runExceptT $ do
   let readerOpts = def  { P.readerExtensions    = P.pandocExtensions
                         , P.readerStripComments = True
                         }
-  doc  <- ExceptT $ $cachedHereBinary ("pandoc: \n"   <> template) (pure . P.runPure $ P.readMarkdown readerOpts template)
+  -- doc  <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("pandoc-md: \n"   <> template) (pure . P.runPure $ P.readMarkdown readerOpts template)
-  tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template)
+  -- tmpl <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("template-md: \n" <> template) (pure . P.runPure $ compileTemplate template)
+  doc  <- ExceptT (pure . P.runPure $ P.readMarkdown readerOpts template)
+  tmpl <- ExceptT (pure . P.runPure $ compileTemplate template)
   let writerOpts = def { P.writerExtensions = P.pandocExtensions
                        , P.writerTemplate = Just tmpl
                        }
@@ -126,7 +130,8 @@ mdTemplating template meta = runExceptT $ do
 -- | creates a PDF using a LaTeX template
 pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString)
 pdfLaTeX lk doc = do
-  e_tmpl <- $cachedHereBinary ("LetterKind:" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk)
+  e_tmpl <- liftIO . P.runIO $ compileTemplate $ templateLatex lk
+  -- e_tmpl <- memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-latex: \n" <> tshow lk) (liftIO . P.runIO $ compileTemplate $ templateLatex lk)
   actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
       let writerOpts  = def { P.writerExtensions = P.pandocExtensions
                             , P.writerTemplate   = Just tmpl }      
@@ -377,7 +382,7 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read
 -- | Internal only, use `printLetter` instead
 lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text)
 lprPDF (sanitizeCmdArg' -> jb) bs = do
-    mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
+    mbLprServerArg <- getLprServerArg
     case mbLprServerArg of
       Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set."
       Just lprServerArg -> do

src/Utils/Print/Letters.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later