fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(pandoc): add more tests

Browse Source
This commit is contained in:
Steffen Jost 2022-07-14 19:09:30 +02:00
commit e63a3af926
3 changed files with 36 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/Handler/PrintCenter.hs
View File

@ -172,9 +172,8 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient
E.on $ printJob E.^. PrintJobQualification E.==. quali E.?. QualificationId E.on $ printJob E.^. PrintJobQualification E.==. quali E.?. QualificationId
return (printJob, recipient, sender, course, quali) return (printJob, recipient, sender, course, quali)
mkPJTable :: DB (FormResult (PJTableAction, Set PrintJobId), Widget) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
mkPJTable = do mkPJTable = do
now <- liftIO getCurrentTime
currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here
let let
dbtSQLQuery = pjTableQuery dbtSQLQuery = pjTableQuery
@ -183,11 +182,11 @@ mkPJTable = do
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^? resultPrintJob . _entityVal . _printJobAcknowledged) [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^? resultPrintJob . _entityVal . _printJobAcknowledged)
, sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> numCell k , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow k)
, sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
, sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
, sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview $ resultRecipient . _entityVal -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview $ resultSender . _entityVal -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell , sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
, sortable (Just "pj-qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell , sortable (Just "pj-qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
] ]
@ -233,8 +232,8 @@ mkPJTable = do
, dbParamsFormResult = id , dbParamsFormResult = id
, dbParamsFormIdent = def , dbParamsFormIdent = def
} }
postprocess :: FormResult (First PJTableAction, DBFormResult PrintJobId Bool PJTableData) postprocess :: FormResult (First PJTableActionData, DBFormResult PrintJobId Bool PJTableData)
-> FormResult ( PJTableAction, Set PrintJobId) -> FormResult ( PJTableActionData, Set PrintJobId)
postprocess inp = do postprocess inp = do
(First (Just act), jobMap) <- inp (First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
@ -245,13 +244,11 @@ getPrintCenterR, postPrintCenterR :: Handler Html
getPrintCenterR = postPrintCenterR getPrintCenterR = postPrintCenterR
postPrintCenterR = do postPrintCenterR = do
_currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler _currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
(_pjRes, _pjTable) <- runDB $ do (_pjRes, _pjTable) <- runDB mkPJTable
let _acts :: Map PJTableAction (AForm Handler PJTableActionData)
_acts = mconcat
[ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData
]
error "TODO: continue here"
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
-- TODO: continue here
-- formResult pjRes $ \case
-- (PJActAcknowledgeData, pjIds) -> error "continue here"
siteLayoutMsg MsgMenuApc $ do siteLayoutMsg MsgMenuApc $ do
setTitleI MsgMenuApc setTitleI MsgMenuApc
$(widgetFile "print-center") $(widgetFile "print-center")

12
src/Utils/Print.hs
View File

@ -55,18 +55,18 @@ makePDF wopts doc = do
texopts = [] texopts = []
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict) bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict)
-- | Modify the Meta-Block of Pandoc
-- This could be a lens?
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
-- appMeta f = _Meta %~ f
_Meta :: Lens' P.Pandoc P.Meta _Meta :: Lens' P.Pandoc P.Meta
_Meta = lens mg mp _Meta = lens mg mp
where where
mg (P.Pandoc m _) = m mg (P.Pandoc m _) = m
mp (P.Pandoc _ b) m = P.Pandoc m b mp (P.Pandoc _ b) m = P.Pandoc m b
-- | Modify the Meta-Block of Pandoc
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
-- appMeta f = _Meta %~ f -- lens version. Not sure this is better
-- Add tests for applyMetas, if ever needed
-- applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p -- applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p
-- applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas -- applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas

34
test/PandocSpec.hs
View File

@ -7,32 +7,36 @@ import Utils.Print
import qualified Data.Map.Lazy as Map import qualified Data.Map.Lazy as Map
import Text.Pandoc import Text.Pandoc
import Text.Pandoc.Arbitrary import Text.Pandoc.Arbitrary ()
-- For Lens Check _Meta required:
--instance CoArbitrary Inline
--instance CoArbitrary MetaValue
--instance CoArbitrary Meta
--instance Function Inline
--instance Function MetaValue
--instance Function Meta
spec :: Spec spec :: Spec
spec = do spec = -- do
describe "addMeta" $ do describe "addMeta" $ do
it "should overwrite existing settings" $ do it "should overwrite existing settings" $ do
metaOverwrite <- arbitrary (metaOverwrite, pd) <- generate arbitrary
pd <- arbitrary
let (Pandoc newMeta _) = addMeta metaOverwrite pd let (Pandoc newMeta _) = addMeta metaOverwrite pd
Map.toList newMeta `shouldContain` Map.toList metaOverwrite Map.toList (unMeta newMeta) `shouldContain` Map.toList (unMeta metaOverwrite)
it "should preserve untouched settings" $ do it "should preserve untouched settings" $ do
metaOverwrite <- arbitrary (metaOverwrite, pd) <- generate arbitrary
pd <- arbitrary
let let
(Pandoc keptMeta _) = pd (Pandoc keptMeta _) = pd
(Pandoc newMeta _) = addMeta metaOverwrite pd (Pandoc newMeta _) = addMeta metaOverwrite pd
Map.toList newMeta `shouldContain` Map.toList (keptMeta `Map.difference` metaOverwrite) Map.toList (unMeta newMeta) `shouldContain` Map.toList (unMeta keptMeta `Map.difference` unMeta metaOverwrite)
it "should preserve document block" $ do it "should preserve document block" $ do
metaOverwrite <- arbitrary (metaOverwrite, pd) <- generate arbitrary
pd <- arbitrary let
let (Pandoc _ oldBlocks) = pd
(Pandoc _ oldBlocks) = pd (Pandoc _ newBlocks) = addMeta metaOverwrite pd
(Pandoc - newBlocks) = addMeta metaOverwrite pd oldBlocks `shouldBe` newBlocks
oldBlocks `shouldBe` newBlocks
describe "_Meta" . it "is a lens" . property $ isLens _Meta -- describe "_Meta" . it "is a lens" . property $ isLens _Meta