fix(avs): avs update on company shorthands working now

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

@@ -51,7 +51,7 @@ AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwo
 AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user}
 AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr)
 AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig
-AvsSatusSearchEmpty: AVS lieferte keine Ausweisinformationen
+AvsStatusSearchEmpty: AVS lieferte keine Ausweisinformationen
 AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
 AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
 AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}

models/avs.model

@@ -31,4 +31,4 @@ AvsSync
   creationTime      UTCTime
   pause             Day Maybe   -- Don't synch if last synch after this day, otherwise synch
   UniqueAvsSyncUser user
-  deriving Generic
+  deriving Generic Show

models/company.model

@@ -17,9 +17,9 @@ Company
   Primary shorthand                       -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
   deriving Ord Eq Show Generic Binary
 
--- TODO: a way to populate this table (manually)
+-- -- TODO: a way to populate this table (manually)
-CompanySynonym
+-- CompanySynonym
-  synonym     CompanyName
+--   synonym     CompanyName
-  canonical   CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId
+--   canonical   CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId
-  UniqueCompanySynonym synonym
+--   UniqueCompanySynonym synonym
-  deriving Ord Eq Show Generic
+--   deriving Ord Eq Show Generic

models/jobs.model

@@ -20,11 +20,11 @@ CronLastExec
     time                UTCTime -- When was the job executed
     instance            InstanceId -- Which uni2work-instance did the work
     UniqueCronLastExec job
-    deriving Generic
+    deriving Generic Show
 
 TokenBucket
     ident               TokenBucketIdent
     lastValue           Int64
     lastAccess          UTCTime
     Primary             ident
-    deriving Generic
+    deriving Generic Show

models/lms.model

@@ -22,7 +22,7 @@ Qualification
   -- across all schools, only one qualification may be a driving licence:
   UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique
     -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
-  deriving Eq Generic
+  deriving Show Eq Generic
 
 -- TODOs:
 --  - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?
@@ -44,7 +44,7 @@ QualificationPrecondition                       -- NOTE: this can only be enforc
   qualification     QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
   required          [QualificationId]           -- OR : alternatives, any one will suffice
   continuous        Bool                        -- expiring precondition blocks qualification
-  deriving Generic
+  deriving Generic Show
 
 -- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version)
 -- QualificationRequirement
@@ -60,7 +60,7 @@ QualificationEdit
   user            UserId
   time            UTCTime
   qualification   QualificationId OnDeleteCascade OnUpdateCascade
-  deriving Generic
+  deriving Generic Show
 
 QualificationUser
   user              UserId OnDeleteCascade OnUpdateCascade
@@ -73,7 +73,7 @@ QualificationUser
   -- Reasons and temporary revocations are implemented through QualificationUserBlock
   -- TODO: adjust SAP interface to transmit end dates
   UniqueQualificationUser qualification user
-  deriving Generic
+  deriving Generic Show
 
 QualificationUserBlock
   qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade
@@ -130,7 +130,7 @@ LmsUser
   -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? No.
   UniqueLmsIdent ident                            -- idents must be unique accross all qualifications, since idents are global within LMS!
   UniqueLmsQualificationUser qualification user   -- each user may be enrolled at most once per course
-  deriving Generic
+  deriving Generic Show
 
 -- LmsUserStatus
 --   lmsUser LmsUserId OnDeleteCascade OnUpdateCascade
@@ -148,7 +148,7 @@ LmsReport
   lock              Bool            -- (0|1)
   timestamp         UTCTime         default=now()
   UniqueLmsReport qualification ident -- required by DBTable
-  deriving Generic
+  deriving Generic Show
 
 -- LmsAudit removed by commit 71cde92a
 -- due to frequent transmit errors, a separate lms tranmission log is necessary again
@@ -160,4 +160,4 @@ LmsReportLog
   lock              Bool            -- (0|1)
   timestamp         UTCTime         default=now()  
   missing           Bool            default=false
-  deriving Generic
+  deriving Generic Show

models/print.model

@@ -16,16 +16,16 @@ PrintJob
   lmsUser         LmsIdent        Maybe OnDeleteSetNull OnUpdateCascade   -- allows tracking if recipient has been notified; must be unique  
   -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
   -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used
-  deriving Generic
+  deriving Generic Show
 
 PrintAcknowledge -- just to store acknowledging requests to be evaluated by a background job later on
   apcIdent        Text
   timestamp       UTCTime         default=now()
   processed       Bool
-  deriving Generic
+  deriving Generic Show
 
 PrintAckIdAlias
   needle          Text
   replacement     Text  
   priority        Int
-  deriving Generic
+  deriving Generic Show

models/users.model

@@ -61,31 +61,31 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation
     function SchoolFunction
     UniqueUserFunction user school function
     deriving Generic
-UserSystemFunction
+UserSystemFunction Show
     user     UserId
     function SystemFunction   -- Defined in Model.Types.User
     manual   Bool             -- Inserted manually by Admin or automatic from LDAP
     isOptOut Bool             -- User has currently deactivate the role for themselves
     UniqueUserSystemFunction user function
-    deriving Generic
+    deriving Generic Show
 UserExamOffice
     user      UserId
     field     StudyTermsId
     UniqueUserExamOffice user field
-    deriving Generic
+    deriving Generic Show
 UserSchool -- Managed by users themselves, encodes "schools of interest"
     user     UserId
     school   SchoolId
     isOptOut Bool     -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically 
     UniqueUserSchool user school
-    deriving Generic
+    deriving Generic Show
 UserGroupMember
     group         UserGroupName
     user          UserId
     primary       Checkmark nullable
     UniquePrimaryUserGroupMember group primary !force
     UniqueUserGroupMember group user
-    deriving Generic
+    deriving Generic Show
 UserCompany 
     user                  UserId  
     company               CompanyId  OnDeleteCascade OnUpdateCascade
@@ -94,7 +94,7 @@ UserCompany
     priority              Int        default=0     -- higher number, higher priority
     useCompanyAddress     Bool       default=true  -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
     UniqueUserCompany user company   -- a user may belong to multiple companies, but to each one only once
-    deriving Generic
+    deriving Generic Show
 UserSupervisor
     supervisor            UserId          -- multiple supervisor per trainee possible
     user                  UserId
@@ -102,5 +102,5 @@ UserSupervisor
     company               CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry
     reason                Text      Maybe -- miscellaneous reason, e.g. Winterservice supervisision
     UniqueUserSupervisor supervisor user  -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
-    deriving Generic
+    deriving Generic Show
     

src/Application.hs

@@ -746,8 +746,8 @@ shutdownApp app = do
 
 -- | Run a handler
 handler, handler' :: Handler a -> IO a
-handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
+handler  h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
-handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
+handler' h = runResourceT $ getAppSettings    >>= makeFoundation >>= liftIO . flip unsafeHandler h
 
 -- | Run DB queries
 db, db' :: DB a -> IO a

src/Handler/Admin/Avs.hs

@@ -759,7 +759,7 @@ postAdminAvsUserR uuid = do
             Left err -> exceptionWgt err
             Right (AvsResponseStatus asts) ->
               if null asts
-                then [whamlet|_{MsgAvsPersonSearchEmpty}|]
+                then [whamlet|_{MsgAvsStatusSearchEmpty}|]
                 else
                   let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
                   in mconcat cs

src/Handler/Utils/Avs.hs

@@ -584,19 +584,28 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
                   , companyPostAddress    = newAvsFirmInfo ^. _avsFirmPostAddress
                   , companyEmail          = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
                   }
-        newCmp <- insertEntity $ foldl' upd dmy firmInfo2company
+        newCmp <- insertEntity $ foldl' upd dmy $ firmInfo2key : firmInfo2company
         reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
         return newCmp
 
       (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do                               -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
         let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
-        Entity firmid <$> updateGet firmid cmp_ups
+            key_ups =           mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2key
-        
+        res_cmp <- updateGetEntity firmid cmp_ups
+        case key_ups of 
+          Nothing -> return res_cmp
+          Just key_up -> do
+            let uniq_cmp = UniqueCompanyAvsId $ res_cmp ^. _entityVal . _companyAvsId
+            updateBy uniq_cmp [key_up]                                                                    -- this is ok, since we have OnUpdateCascade on all CompanyId entries
+            maybeM (return res_cmp) return $ getBy uniq_cmp
+
+
   where
+    firmInfo2key  = 
+        CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI  -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
     firmInfo2company = 
-      [ CheckUpdate CompanyName        $ _avsFirmFirm          . from _CI
+      [ CheckUpdate CompanyName        $ _avsFirmFirm          . from _CI      
-      , CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI
+      , CheckUpdate CompanyAvsId         _avsFirmFirmNo                    -- Updating unique might be problematic
-      , CheckUpdate CompanyAvsId         _avsFirmFirmNo                    -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade
       -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
       , CheckUpdate CompanyPostAddress   _avsFirmPostAddress
       , CheckUpdate CompanyEmail       $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just

src/Utils/DB.hs

@@ -129,6 +129,7 @@ updateBy uniq updates = do
   key <- getKeyBy uniq
   for_ key $ flip update updates
 
+-- | update and retrieve an entity. Will throw an error if the key is updaded
 updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record)
 updateGetEntity k = fmap (Entity k) . updateGet k