chore(caching): for company table working
This commit is contained in:
parent
cdcd56ea19
commit
d46ff7ed7f
@ -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
|
||||
|
||||
@ -147,6 +147,8 @@ dependencies:
|
||||
- extended-reals
|
||||
- rfc5051
|
||||
- unidecode
|
||||
- doctemplates
|
||||
- doclayout
|
||||
- pandoc
|
||||
- pandoc-types
|
||||
- typed-process
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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
|
||||
|
||||
@ -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])
|
||||
|
||||
|
||||
@ -128,7 +128,7 @@ makeClassyFor_ ''LmsResult
|
||||
makeClassyFor_ ''UserAvs
|
||||
makeClassyFor_ ''UserAvsCard
|
||||
|
||||
makeClassyFor_ ''UserCompany
|
||||
makeLenses_ ''UserCompany
|
||||
makeLenses_ ''Company
|
||||
|
||||
_entityKey :: Getter (Entity record) (Key record)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user