diff --git a/models/company.model b/models/company.model index 94688d1be..883aba0ff 100644 --- a/models/company.model +++ b/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 diff --git a/package.yaml b/package.yaml index 8f8291151..eeb46233e 100644 --- a/package.yaml +++ b/package.yaml @@ -147,6 +147,8 @@ dependencies: - extended-reals - rfc5051 - unidecode + - doctemplates + - doclayout - pandoc - pandoc-types - typed-process diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index ebefebe94..1b2107632 100644 --- a/src/Handler/LMS.hs +++ b/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 - getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _entityVal . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps + 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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index b312a83d5..e245950e5 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost -- -- 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 - getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _entityVal . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps + 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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 0bc4e434a..6c830642d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- 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]) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 8d8108ee5..2375e3f3c 100644 --- a/src/Utils/Lens.hs +++ b/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) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 7bd9e2c5d..22b98c773 100644 --- a/src/Utils/Print.hs +++ b/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) - tmpl <- ExceptT $ $cachedHereBinary ("template: \n" <> template) (pure . P.runPure $ compileTemplate template) + -- doc <- ExceptT $ memcachedBy (Just . Right $ 6 * diffHour) ("pandoc-md: \n" <> template) (pure . P.runPure $ P.readMarkdown readerOpts 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 diff --git a/src/Utils/Print/Letters.hs b/src/Utils/Print/Letters.hs index 2b4b94ac0..e57d2b5ab 100644 --- a/src/Utils/Print/Letters.hs +++ b/src/Utils/Print/Letters.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later