From 39474d169c10be1fc499723d95ead7d75480a326 Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Wed, 16 Nov 2022 17:43:46 +0100
Subject: [PATCH] chore(company): company added by upsertAvsUser

---
 models/company.model         | 11 +++++++--
 src/Handler/Utils.hs         |  1 +
 src/Handler/Utils/Avs.hs     | 14 +++++++-----
 src/Handler/Utils/Company.hs | 43 ++++++++++++++++++++++++++++++++++++
 4 files changed, 62 insertions(+), 7 deletions(-)
 create mode 100644 src/Handler/Utils/Company.hs

diff --git a/models/company.model b/models/company.model
index 53ceecc43..da7b295e8 100644
--- a/models/company.model
+++ b/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
\ No newline at end of file
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 27416a072..b5b1547f2 100644
--- a/src/Handler/Utils.hs
+++ b/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
 
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index c57d5cd05..36375783b 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/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 
diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs
new file mode 100644
index 000000000..12fc28ec5
--- /dev/null
+++ b/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