chore(company): company added by upsertAvsUser

models/company.model

@@ -4,12 +4,19 @@
 
 -- Description of companies associated with users
 
-Company json
+Company
   name        CompanyName             -- == (CI Text)
   shorthand   CompanyShorthand        -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId    FUTURE TODO: a shorthand will become available through the AVS interface in the future
   -- postAddress StoredMarkup Maybe   --
   -- avsId     Int                    -- FUTURE TODO: once this number becomes available through AVS interface; this could be the primary key   
-  UniqueCompany name 
+  UniqueCompanyName name 
   UniqueCompanyShorthand shorthand
   Primary shorthand             -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand }
   deriving Ord Eq Show Generic
+
+-- TODO: a way to populate this table (manually)
+CompanySynonym
+  synonym     CompanyName
+  canonical   CompanyShorthand
+  UniqueCompanySynonym synonym
+  deriving Ord Eq Show Generic

src/Handler/Utils.hs

@@ -30,6 +30,7 @@ import Handler.Utils.Memcached  as Handler.Utils hiding (manageMemcachedLocalInv
 import Handler.Utils.Files      as Handler.Utils
 import Handler.Utils.Download   as Handler.Utils
 import Handler.Utils.AuthorshipStatement as Handler.Utils
+--import Handler.Utils.Company    as Handler.Utils
 
 import Handler.Utils.Term as Handler.Utils
 

src/Handler/Utils/Avs.hs

@@ -24,9 +24,9 @@ import qualified Data.CaseInsensitive as CI
 -- import Auth.LDAP (ldapUserPrincipalName)
 import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException())
 
+import Handler.Utils.Company
 import Handler.Users.Add
 
-
 --------------------
 -- AVS Exceptions --
 --------------------
@@ -145,6 +145,7 @@ upsertAvsUserById api = do
     ( _     , Nothing               ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet
     (Nothing, Just AvsDataPerson{..}) -> do                               -- No LDAP User, but found in AVS; create user
       let firmAddress = guessLicenceAddress avsPersonPersonCards
+          mbCompany   = firmAddress ^? _Just . _1 . _Just
           bestCard    = Set.lookupMax avsPersonPersonCards
           fakeIdent   = CI.mk $ tshow api
           newUsr = AdminUserForm 
@@ -166,10 +167,13 @@ upsertAvsUserById api = do
             , aufIdent = fakeIdent -- use AvsPersonId instead
             , aufAuth  = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
             }
-      _ <- addNewUser newUsr -- trigger JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
-        -- upsertBy (UniqueCompanyName firmName) (Company firmName firmShort) []
-        -- 
-        -- <- insertBy (UserCompany firmShort uid False)
+      mbUid <- addNewUser newUsr -- trigger JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
+      case (mbCompany, mbUid) of 
+        (Just cpy, Just uid) -> runDB $ do 
+            cid <- upsertCompany cpy
+            insert_ $ UserCompany cid uid False
+        _ -> return ()
+                  
 
           -- _newAvs = UserAvs avsPersonPersonID uid
           -- _newAvsCards = UserAvsCard 

src/Handler/Utils/Company.hs

@@ -0,0 +1,43 @@
+-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.Utils.Company where
+
+import Import
+-- import Utils.PathPiece
+
+-- import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Char as Char
+import qualified Data.Text as Text
+
+
+upsertCompany :: Text -> DB CompanyId
+upsertCompany cName = 
+  let cName' = CI.mk cName in
+  getBy (UniqueCompanyName cName') >>= \case 
+    Just ent -> return $ entityKey ent
+    Nothing  -> getBy (UniqueCompanySynonym cName') >>= \case
+      Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent
+      Nothing  -> do
+        let cShort  = companyShorthandFromName cName            
+        cShort' <- findShort cName' $ CI.mk cShort
+        let compy  = Company cName' cShort'
+        either entityKey id <$> insertBy compy
+  where 
+    findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand    
+    findShort fna fsh = aux 0
+      where 
+        aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in
+                checkUnique (Company fna fsh') >>= \case
+                  Nothing -> return fsh'
+                  _other  -> aux (n+1)
+
+-- | Just a cheap heuristic, needs manual intervention anyway
+companyShorthandFromName :: Text -> Text
+companyShorthandFromName cName = 
+  let cpats = splitCamel cName
+      strip = Text.filter Char.isAlphaNum . Text.take 3
+      spats = strip <$> cpats
+  in Text.concat spats