lpr: add postal address field to user table

messages/uniworx/categories/user/de-de-formal.msg

@@ -12,6 +12,8 @@ AdminUserTelephone: Telefonnummer
 AdminUserMobile: Mobiltelefonmummer
 AdminUserFPersonalNumber: Personalnummer (nur Fraport AG)
 AdminUserFDepartment: Abteilung
+AdminUserPostAddress: Postalische Anschrift
+AdminUserPrefersPostal: Briefe anstatt Email bevorzugt
 AdminUserAssimilate: Benutzer assimilieren
 UserAdded: Benutzer erfolgreich angelegt
 UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden

messages/uniworx/categories/user/en-eu.msg

@@ -12,6 +12,8 @@ AdminUserTelephone: Phone
 AdminUserMobile: Mobile
 AdminUserFPersonalNumber: Personalnumber (Fraport AG only)
 AdminUserFDepartment: Department
+AdminUserPostAddress: Postal Address
+AdminUserPrefersPostal: Prefers postal letters over email
 AdminUserAssimilate: Assimilate user
 UserAdded: Successfully added user
 UserCollision: Could not create user due to uniqueness constraint

models/users.model

@@ -11,7 +11,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
-    email          UserEmail                -- Case-insensitive eMail address
+    email          UserEmail                -- Case-insensitive eMail address -- TODO: make this nullable
     ident          UserIdent                -- Case-insensitive user-identifier
     authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
     lastAuthentication UTCTime Maybe        -- last login date
@@ -39,8 +39,10 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     mobile         Text Maybe                   
     companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP 
     companyDepartment     Text Maybe -- thus we store such information for ease of reference directly, if available 
-    examOfficeGetSynced Bool default=true   -- whether synced status should be displayed for exam results by default
+    postAddress           StoredMarkup Maybe 
-    examOfficeGetLabels Bool default=true   -- whether labels should be displayed for exam results by default
+    prefersPostal         Bool default=false    -- user prefers letters by post instead of email
+    examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
+    examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
     UniqueAuthentication ident                  -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory

src/Foundation/Yesod/Auth.hs

@@ -268,6 +268,8 @@ upsertCampusUser upsertMode ldapData = do
       , userDisplayEmail         = userEmail
       , userMatrikelnummer       = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
       , userTitle                = Nothing
+      , userPostAddress          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+      , userPrefersPostal        = False
       , ..
       }
     userUpdate =  [ 

src/Handler/PrintCenter.hs

@@ -11,8 +11,8 @@ import Import
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-import qualified Data.Text      as T
+-- import qualified Data.Text      as T
-import qualified Data.Text.Lazy as LT
+-- import qualified Data.Text.Lazy as LT
 -- import qualified Data.ByteString.Lazy as LBS
 import qualified Text.Pandoc          as P
 import qualified Text.Pandoc.Builder  as P
@@ -98,13 +98,7 @@ mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
   where
     deOrEn     = if isDe mppLang then "de" else "en"
     keyOpening = deOrEn <> "-opening"
-    keyClosing = deOrEn <> "-closing"
+    keyClosing = deOrEn <> "-closing"  
-    mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
-    mbMeta   = foldMap . toMeta
-    toMeta :: P.ToMetaValue a => Text ->       a -> Map Text P.MetaValue
-    toMeta k = singletonMap k . P.toMetaValue
-    html2textlines :: StoredMarkup -> [Text]
-    html2textlines sm = T.lines . LT.toStrict $ markupInput sm
 
 mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
 mprToMetaUser entUser@Entity{entityVal = u} mpr = do 

src/Handler/Users/Add.hs

@@ -23,6 +23,8 @@ data AdminUserForm = AdminUserForm
   , aufTelephone :: Maybe Text   
   , aufFPersonalNumber :: Maybe Text 
   , aufFDepartment     :: Maybe Text 
+  , aufPostAddress     :: Maybe StoredMarkup
+  , aufPrefersPostal   :: Bool
   , aufEmail :: UserEmail
   , aufIdent :: UserIdent
   , aufAuth :: AuthenticationKind  
@@ -56,7 +58,9 @@ adminUserForm template = renderAForm FormStandard
   <*> aopt (textField & cfStrip)        (fslI MsgAdminUserMobile) (aufMobile <$> template)
   <*> aopt (textField & cfStrip)        (fslI MsgAdminUserTelephone) (aufTelephone <$> template)  
   <*> aopt (textField & cfStrip)        (fslI MsgAdminUserFPersonalNumber) (aufFPersonalNumber <$> template)
-  <*> aopt (textField & cfStrip)        (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template)
+  <*> aopt (textField & cfStrip)        (fslI MsgAdminUserFDepartment)     (aufFDepartment <$> template)
+  <*> aopt htmlField                    (fslI MsgAdminUserPostAddress)     (aufPostAddress   <$> template) 
+  <*> areq checkBoxField                (fslI MsgAdminUserPrefersPostal)   (aufPrefersPostal <$> template)
   <*> areq (emailField & cfCI)          (fslI MsgAdminUserEmail) (aufEmail <$> template)
   <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template)
   <*> areq (selectField optionsFinite)  (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP)
@@ -103,7 +107,9 @@ postAdminUserAddR = do
         , userMobile                  = aufMobile
         , userTelephone               = aufTelephone
         , userCompanyPersonalNumber   = aufFPersonalNumber
-        , userCompanyDepartment       = aufFDepartment        
+        , userCompanyDepartment       = aufFDepartment    
+        , userPostAddress             = aufPostAddress
+        , userPrefersPostal           = aufPrefersPostal
         , userMatrikelnummer          = aufMatriculation
         , userAuthentication          = mkAuthMode aufAuth
         }

src/Handler/Utils/Users.hs

@@ -8,6 +8,7 @@ module Handler.Utils.Users
   , guessUser
   , UserAssimilateException(..), UserAssimilateExceptionReason(..)
   , assimilateUser
+  , userPrefersEmail, userPrefersLetter
   ) where
 
 import Import
@@ -40,6 +41,13 @@ import qualified Data.Text as Text
 import Jobs.Types(Job, JobChildren)
 
 
+userPrefersLetter :: User -> Bool
+userPrefersLetter User{..} = (userPrefersPostal || Text.null (CI.original userEmail)) && isJust userPostAddress
+
+userPrefersEmail :: User -> Bool
+userPrefersEmail = not . userPrefersLetter
+
+
 computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
 computeUserAuthenticationDigest = hashlazy . JSON.encode
 

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -9,6 +9,7 @@ import Import
 
 import Utils.Print
 import Handler.Utils
+import Handler.Utils.Users
 import Jobs.Handler.SendNotification.Utils
 
 import qualified Data.ByteString.Lazy as LBS
@@ -38,16 +39,14 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
   addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
 
 
-checkEmailOk :: User -> Bool
+-- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
-checkEmailOk = const True -- TODO
-
-
 dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
 dispatchNotificationQualificationRenewal nQualification jRecipient = do
-  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}) <- runDB $ (,,)
+  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,)
     <$> getJust jRecipient
     <*> getJust nQualification
-    <*> getJustBy (UniqueQualificationUser nQualification jRecipient)
+    <*> getJustBy (UniqueQualificationUser    nQualification jRecipient)
+    <*> getJustBy (UniqueLmsQualificationUser nQualification jRecipient)
   let entRecipient = Entity jRecipient recipient
       qname = CI.original qualificationName
       -- content = $(i18nWidgetFile "qualification/renewal")
@@ -55,18 +54,22 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
 
   now <- liftIO getCurrentTime
   letterDate <- formatTimeUser SelFormatDate now $ Just entRecipient
-  let pdfMeta = applyMetas 
+
-                  [ ("recipient", userDisplayName)
+  let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address    
-                  , ("date"     , letterDate)              
+      pdfMeta = mkMeta
-                  , ("lang"     , selectDeEn userLanguages) -- select German or English, see Utils.Lang
+                  [ toMeta "date"      letterDate
-                  -- TODO: add more info to interpolate here!
+                  , toMeta "lang"    $ selectDeEn userLanguages -- select German or English, see Utils.Lang
-                  ] mempty
+                  , toMeta "login"    (lmsUserIdent & getLmsIdent)
+                  , toMeta "pin"       lmsUserPin
+                  , toMeta "recipient" userDisplayName
+                  , mbMeta "address"  (prepAddress <$> userPostAddress)
+                  ]
   pdfRenewal pdfMeta >>= \case
     Left err -> do
       let msg = "Notify " <> tshow jRecipient <> " PDF generation failed with error: " <> err
       $logErrorS "LMS" msg
       error $ unpack msg
-    Right pdf | checkEmailOk recipient -> userMailT jRecipient $ do
+    Right pdf | userPrefersEmail recipient -> userMailT jRecipient $ do
 
         replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
         setSubjectI $ MsgMailSubjectQualificationRenewal qname

src/Model.hs

@@ -55,6 +55,7 @@ deriving newtype instance ToSample ExternalApiId
 -- required Show instances for use of getByJust 
 deriving instance Show (Unique ExamPart)
 deriving instance Show (Unique QualificationUser)
+deriving instance Show (Unique LmsUser)
 
 -- ToMarkup and ToMessage instances for displaying selected database primary keys
 

src/Model/Types/Markup.hs

@@ -5,7 +5,8 @@ module Model.Types.Markup
   , markdownToStoredMarkup
   , esqueletoMarkupOutput
   , I18nStoredMarkup
-  , markupIsSmallish
+  , markupIsSmallish  
+  , html2textlines
   ) where
 
 import Import.NoModel
@@ -148,4 +149,8 @@ type I18nStoredMarkup = I18n StoredMarkup
 
 -- | determine whether the StoredMarkup is small-ish
 markupIsSmallish :: StoredMarkup -> Bool
-markupIsSmallish StoredMarkup{markupInput} = GT /= LT.compareLength markupInput 32
+markupIsSmallish StoredMarkup{markupInput} = GT /= LT.compareLength markupInput 32
+
+
+html2textlines :: StoredMarkup -> [Text]
+html2textlines sm = LT.toStrict <$> LT.lines (markupInput sm)

src/Utils/Print.hs

@@ -38,7 +38,6 @@ templateDIN5008 :: Text
 templateDIN5008 = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/din5008.latex")
 
 
-
 ----------------------
 -- Pandoc Functions --
 ----------------------
@@ -68,6 +67,16 @@ _Meta = lens mget mput
     mget (P.Pandoc m _)   = m
     mput (P.Pandoc _ b) m = P.Pandoc m b
 
+toMeta :: P.ToMetaValue a => Text ->       a -> Map Text P.MetaValue
+toMeta k = singletonMap k . P.toMetaValue
+
+mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
+mbMeta   = foldMap . toMeta
+
+-- | For convenience and to avoid importing Pandoc
+mkMeta :: [Map Text P.MetaValue] -> P.Meta
+mkMeta = P.Meta . mconcat
+
 -- | 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

test/Database/Fill.hs

@@ -111,6 +111,8 @@ fillDb = do
     , userMobile = Nothing 
     , userCompanyPersonalNumber = Nothing 
     , userCompanyDepartment = Nothing
+    , userPostAddress = Nothing
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -146,6 +148,8 @@ fillDb = do
     , userTelephone = Nothing     
     , userCompanyPersonalNumber = Nothing 
     , userCompanyDepartment = Nothing
+    , userPostAddress = Nothing
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -187,6 +191,8 @@ fillDb = do
     , userMobile = Just "0173 69 99 646"
     , userCompanyPersonalNumber = Just "57138"
     , userCompanyDepartment = Just "AVN-AR2"
+    , userPostAddress = Nothing
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -222,6 +228,8 @@ fillDb = do
     , userMobile = Nothing 
     , userCompanyPersonalNumber = Nothing 
     , userCompanyDepartment = Nothing
+    , userPostAddress = Nothing
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -257,6 +265,8 @@ fillDb = do
     , userMobile = Nothing 
     , userCompanyPersonalNumber = Nothing 
     , userCompanyDepartment = Nothing
+    , userPostAddress = Nothing
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -292,6 +302,8 @@ fillDb = do
     , userMobile = Nothing 
     , userCompanyPersonalNumber = Nothing 
     , userCompanyDepartment = Nothing
+    , userPostAddress = Nothing
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
     , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
     }
@@ -327,6 +339,8 @@ fillDb = do
     , userMobile = Nothing 
     , userCompanyPersonalNumber = Nothing 
     , userCompanyDepartment = Nothing
+    , userPostAddress = Nothing
+    , userPrefersPostal = False
     , userExamOfficeGetSynced = False
     , userExamOfficeGetLabels = True
     }
@@ -392,6 +406,8 @@ fillDb = do
       , userMobile = Nothing 
       , userCompanyPersonalNumber = Nothing 
       , userCompanyDepartment = Nothing
+      , userPostAddress = Nothing
+      , userPrefersPostal = False
       , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
       , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
       }