chore(letter): show list of printjobs (wip)

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

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

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"

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

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

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
+              <div>
+                ^{modal "Beschreibung" (Right $ toWidget descr)}
+              |]
+
 sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
 sheetCell crse shn =
   let tid = crse ^. _1

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')

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\"}]}]"