diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg new file mode 100644 index 000000000..e370bbd55 --- /dev/null +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -0,0 +1,9 @@ +PJActAcknowledge: Druck und Versand bestätigen +PrintJobName: Dummy TODO EN +PrintJobId: Dummy TODO EN +PrintJobCreated: Dummy TODO EN +PrintJobAcknowledged: Dummy TODO EN +PrintRecipient: Dummy TODO EN +PrintSender: Dummy TODO EN +PrintCourse: Dummy TODO EN +PrintQualification: Dummy TODO EN \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg new file mode 100644 index 000000000..519bbf7e4 --- /dev/null +++ b/messages/uniworx/categories/print/en-eu.msg @@ -0,0 +1,9 @@ +PJActAcknowledge: Acknowledge printing and mailing +PrintJobName: Dummy TODO DE +PrintJobId: Dummy TODO DE +PrintJobCreated: Dummy TODO DE +PrintJobAcknowledged: Dummy TODO DE +PrintRecipient: Dummy TODO DE +PrintSender: Dummy TODO DE +PrintCourse: Dummy TODO DE +PrintQualification: Dummy TODO DE \ No newline at end of file diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index ad8ca332d..47d2fd6fb 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -15,6 +15,7 @@ module Foundation.I18n , UniWorXTermMessage(..), UniWorXSendMessage(..), UniWorXSiteLayoutMessage(..), UniWorXErrorMessage(..) , UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..) , UniWorXQualificationMessage(..) + , UniWorXPrintMessage(..) , UniWorXAvsMessage(..) , UniWorXAuthorshipStatementMessage(..) , ShortTermIdentifier(..) @@ -208,6 +209,7 @@ mkMessageAddition ''UniWorX "ModelTypes" "messages/uniworx/categories/model_type mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-formal" mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal" mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal" +mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal" mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal" mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal" mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal" diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index a25e4a510..86fc9e4df 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -249,7 +249,7 @@ mkLmsTable :: forall h p cols act act'. -> DB (FormResult (act', Set UserId), Widget) mkLmsTable (Entity qid quali) acts restrict cols psValidator = do now <- liftIO getCurrentTime - -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route precisely heres + -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here let currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) nowaday = utctDay now diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index d16d74f32..bdc54b198 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -14,6 +14,10 @@ import qualified Data.ByteString.Lazy as LBS import qualified Text.Pandoc as P import qualified Text.Pandoc.Builder as P +import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH + import qualified Control.Monad.State.Class as State import Utils.Print -- import Data.Aeson (encode) @@ -22,6 +26,10 @@ import Utils.Print import Handler.Utils +-- avoids repetition of local definitions +single :: (k,a) -> Map k a +single = uncurry Map.singleton + data MetaPinRenewal = MetaPinRenewal { mppRecipient :: Text , mppAddress :: StoredMarkup @@ -92,9 +100,149 @@ mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat html2textlines sm = T.lines . LT.toStrict $ markupInput sm +data PJTableAction = PJActAcknowledge + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + + +instance Universe PJTableAction +instance Finite PJTableAction +nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''PJTableAction id + +-- Not yet needed, since there is no additional data for now: +data PJTableActionData = PJActAcknowledgeData + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +type PJTableExpr = ( E.SqlExpr (Entity PrintJob) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Course)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification)) + ) + +queryPrintJob :: PJTableExpr -> E.SqlExpr (Entity PrintJob) +queryPrintJob = $(sqlLOJproj 5 1) + +queryRecipient :: PJTableExpr -> E.SqlExpr (Maybe (Entity User)) +queryRecipient = $(sqlLOJproj 5 2) + +querySender :: PJTableExpr -> E.SqlExpr (Maybe (Entity User)) +querySender = $(sqlLOJproj 5 3) + +queryCourse :: PJTableExpr -> E.SqlExpr (Maybe (Entity Course)) +queryCourse = $(sqlLOJproj 5 4) + +queryQualification :: PJTableExpr -> E.SqlExpr (Maybe (Entity Qualification)) +queryQualification = $(sqlLOJproj 5 5) + +type PJTableData = DBRow (Entity PrintJob, Maybe (Entity User), Maybe (Entity User), Maybe (Entity Course), Maybe (Entity Qualification)) + +resultPrintJob :: Lens' PJTableData (Entity PrintJob) +resultPrintJob = _dbrOutput . _1 + +resultRecipient :: Traversal' PJTableData (Entity User) +resultRecipient = _dbrOutput . _2 . _Just + +resultSender :: Traversal' PJTableData (Entity User) +resultSender = _dbrOutput . _3 . _Just + +resultCourse :: Traversal' PJTableData (Entity Course) +resultCourse = _dbrOutput . _4 . _Just + +resultQualification :: Traversal' PJTableData (Entity Qualification) +resultQualification = _dbrOutput . _5 . _Just + +pjTableQuery :: PJTableExpr -> E.SqlQuery + ( E.SqlExpr (Entity PrintJob) + , E.SqlExpr (Maybe (Entity User)) + , E.SqlExpr (Maybe (Entity User)) + , E.SqlExpr (Maybe (Entity Course)) + , E.SqlExpr (Maybe (Entity Qualification))) +pjTableQuery (printJob `E.LeftOuterJoin` recipient + `E.LeftOuterJoin` sender + `E.LeftOuterJoin` course + `E.LeftOuterJoin` quali ) = do + E.on $ printJob E.^. PrintJobRecipient E.==. recipient E.?. UserId + E.on $ printJob E.^. PrintJobSender E.==. sender E.?. UserId + E.on $ printJob E.^. PrintJobCourse E.==. course E.?. CourseId + E.on $ printJob E.^. PrintJobQualification E.==. quali E.?. QualificationId + return (printJob, recipient, sender, course, quali) + +mkPJTable :: DB (FormResult (PJTableAction, Set PrintJobId), Widget) +mkPJTable = do + now <- liftIO getCurrentTime + currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here + let + dbtSQLQuery = pjTableQuery + dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) + dbtProj = dbtProjFilteredPostId + dbtColonnade = mconcat + [ dbSelectIf (applying _1) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^? resultPrintJob . _printJobAcknowleged) + , 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-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t + , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \(preview $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t + , sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview $ resultRecipient . _entityVal -> u) -> maybeCell u $ cellHasUserLink AdminUserR + , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview $ resultSender . _entityVal -> u) -> maybeCell u $ cellHasUserLink AdminUserR + , 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 + ] + dbtSorting = mconcat + [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) + , single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId)) + , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) + , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) + , single ("pj-recipient" , sortUserNameBare queryRecipient) + , single ("pj-sender" , sortUserNameBare querySender ) + , single ("pj-course" , SortColumn $ queryCourse >>> (E.^. CourseName)) + , single ("pj-qualification", SortColumn $ queryQualification >>> (E.^. QualificationName)) + ] + dbtFilter = mconcat + [ + single ("pj-name") , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName) + -- TODO: continue here + ] + dbtFilterUI = mconcat + [ + -- TODO: continue here + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} + dbtIdent :: Text + dbtIdent = "print-job" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + postprocess :: FormResult (First act', DBFormResult UserId Bool PJTableData) + -> FormResult ( act', Set UserId) + postprocess inp = do + (First (Just act), usrMap) <- inp + let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap + return (act, usrSet) + over _1 postprocess <$> dbTable psValidator DBTable{..} + getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR postPrintCenterR = do + _currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler + (_pjRes, _pjTable) <- runDB $ do + let _acts :: Map PJTableAction (AForm Handler PJTableActionData) + _acts = mconcat + [ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData + ] + error "TODO: continue here" -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 1c02c7e98..1c0034189 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -263,6 +263,19 @@ courseCell Course{..} = anchorCell link name `mappend` desc ^{modal "Beschreibung" (Right $ toWidget descr)} |] +qualificationCell :: IsDBTable m a => Qualification -> DBCell m a +qualificationCell Qualification{..} = anchorCell link name `mappend` desc + where + link = QualificationR qualificationSchool qualificationShorthand + name = citext2widget qualificationName + desc = case qualificationDescription of + Nothing -> mempty + (Just descr) -> cell [whamlet| + $newline never +
+ ^{modal "Beschreibung" (Right $ toWidget descr)} + |] + sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a sheetCell crse shn = let tid = crse ^. _1 diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 538c20e3a..0bd752ea5 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -490,11 +490,13 @@ colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell co -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') -sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user -> +sortUserName = ("user-name",) . sortUserNameBare + +sortUserNameBare :: (t -> E.SqlExpr (Entity User)) -> SortColumn t r' +sortUserNameBare queryUser = SortColumns $ queryUser >>> \user -> [ SomeExprValue $ user E.^. UserSurname , SomeExprValue $ user E.^. UserDisplayName ] - ) -- | Alias for sortUserName for consistency, since column comes in two variants sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') diff --git a/testdata/avs_json.hs b/testdata/avs_json.hs index fd674ac7a..d5bf541a7 100644 --- a/testdata/avs_json.hs +++ b/testdata/avs_json.hs @@ -7,7 +7,7 @@ import Data.String import qualified Data.ByteString.Lazy as B import Data.Aeson import Utils.Avs - +import Utils.PathPiece status1 :: B.ByteString status1 = fromString "[{\"PersonID\":10233,\"personCardStatus\":[{\"CardNo\":\"01234567\",\"VersionNo\":\"4\",\"CardColor\":\"Rot\",\"CardAreas\":\"LY\",\"Valid\":\"true\"},{\"CardNo\":\"00001111\",\"VersionNo\":\"4\",\"CardColor\":\"Rot\",\"CardAreas\":\"F\",\"Valid\":\"true\"}]},{\"PersonID\":10444,\"personCardStatus\":[{\"CardNo\":\"11111111\",\"VersionNo\":\"4\",\"CardColor\":\"Gelb\",\"CardAreas\":\"LF\",\"Valid\":\"false\"}]}]"