chore(letter): show list of printjobs (wip)
This commit is contained in:
Steffen Jost
parent
51339ac289
commit
5e671f1f76
9
messages/uniworx/categories/print/de-de-formal.msg
Normal file
9
messages/uniworx/categories/print/de-de-formal.msg
Normal file
@ -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
|
||||
9
messages/uniworx/categories/print/en-eu.msg
Normal file
9
messages/uniworx/categories/print/en-eu.msg
Normal file
@ -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
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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')
|
||||
|
||||
2
testdata/avs_json.hs
vendored
2
testdata/avs_json.hs
vendored
@ -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\"}]}]"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user