chore(avs): creating new users by cardno or internpersno completed

src/Handler/Utils/Avs.hs

@@ -116,14 +116,21 @@ checkLicences = do
   error "CONTINUE HERE" -- TODO STUB
 
 
-
 upsertAvsUser :: Text -> Handler (Maybe UserId)
-upsertAvsUser _someid = error "TODO" -- TODO STUB
+-- upsertAvsUser (readAvsFullCardNo -> Just afcn) = upsertAvsUserByCard afcn
-{-
+-- upsertAvsUser someid 
-  | isAvsId   someid = error "TODO"
+-- | Just avsid <- discernAvsIds someid 
-  | isEmail   someid = error "TODO"
+-- = upsertAvsUserByCard $ over _Right (const someid) avsid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot discern, but the latter is much more likely and useful!
-  | isNumber  someid = error "TODO"
+upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid
--}
+upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary now
+  {- maybe this code helps?
+  upsRes :: Either CampusUserConversionException (Entity User)
+    <- try $ upsertCampusUserByOther persNo
+  case upsRes of
+    Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
+    _other -> return mbuid -- ==Nothing -- user could not be created somehow
+  -}
+
 
 -- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created.
 --   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
@@ -167,22 +174,27 @@ upsertAvsUserById api = do
             , aufFDepartment = Nothing
             , aufPostAddress = plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
             , aufPrefersPostal = isJust firmAddress
-            , aufPinPassword = getFullCardNo <$> bestCard
+            , aufPinPassword = tshowAvsFullCardNo . getFullCardNo <$> bestCard
             , aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
             , 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
             }
-      mbUid <- addNewUser newUsr -- trigger JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
+      mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe      
-      case (mbCompany, mbUid) of
+      case mbUid of 
-        (Just cpy, Just uid) -> runDB $ do
+        Just uid -> runDB $ do
-            cid <- upsertCompany cpy
+          now <- liftIO getCurrentTime
-            insert_ $ UserCompany cid uid False
+          insert_ $ UserAvs avsPersonPersonID uid
-        _ -> return ()
+          -- forM_ avsPersonPersonCards $ -- save all cards for later           
+          forM_ bestCard $  -- only save the card used to the postal address
+             \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now 
+          case mbCompany of
+            Just cpy -> do
+              cid <- upsertCompany cpy
+              insert_ $ UserCompany cid uid False
+            _ -> return ()
+        _ -> return ()      
+      return mbUid
 
-
-          -- _newAvs = UserAvs avsPersonPersonID uid
-          -- _newAvsCards = UserAvsCard
-      error "TODO" -- CONTINUE HERE
     (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates
       error "TODO" -- CONTINUE HERE
 
@@ -192,11 +204,11 @@ upsertAvsUserById api = do
 --upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
 -- upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m )
 upsertAvsUserByCard ::
-  Either (AvsCardNo,AvsVersionNo) AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
+  Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
 upsertAvsUserByCard persNo = do
   let qry = case persNo of
-              Left (acn,avn) -> def{ avsPersonQueryCardNo = Just acn, avsPersonQueryVersionNo = Just avn }
+              Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
-              Right fpn      -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
+              Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
   AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
   case Set.elems adps of

src/Model/Types/Avs.hs

@@ -18,6 +18,7 @@ import qualified Data.Csv as Csv
 import Utils.Lens.TH
 
 import Text.Read (Read(..))
+import qualified Data.Char          as Char
 import qualified Data.Text          as Text
 import qualified Data.Set           as Set
 
@@ -80,7 +81,7 @@ instance FromJSON SloppyBool where
 -- AVS Datatypes --
 -------------------
 
-type AvsInternalPersonalNo = Text -- type synonym for clarity/documentation within types
+type AvsInternalPersonalNo = Text -- ought to be all digits, type synonym for clarity/documentation within types
 
 -- CompleteCardNo = xxxxxxxx.y 
 -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo
@@ -98,6 +99,31 @@ instance ToJSON AvsCardNo where
 normalizeAvsCardNo :: Text -> Text
 normalizeAvsCardNo = Text.justifyRight 8 '0'
 
+data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo }
+  deriving (Eq, Ord, Generic, Typeable)
+
+tshowAvsFullCardNo :: AvsFullCardNo -> Text
+tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo avsFullCardNo <> Text.cons '.' avsFullCardVersion
+
+instance Show AvsFullCardNo where 
+  show = Text.unpack . tshowAvsFullCardNo
+
+readAvsFullCardNo :: Text -> Maybe AvsFullCardNo
+readAvsFullCardNo (Text.span Char.isDigit -> (c, Text.uncons -> Just ('.',v)))
+  | not $ Text.null c, Just (Char.isDigit -> True, "") <- Text.uncons v
+    = Just $ AvsFullCardNo (AvsCardNo c) v
+readAvsFullCardNo _ = Nothing
+
+discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point
+discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv))
+  | Text.null pv 
+    = Just $ Right c
+  | not $ Text.null c
+  , Just ('.', v) <- Text.uncons pv
+  , Just (Char.isDigit -> True, "") <- Text.uncons v
+    = Just $ Left $ AvsFullCardNo (AvsCardNo c) v
+discernAvsCardPersonalNo _ = Nothing
+
 -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId`
 newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int
   deriving (Eq, Ord, Generic, Typeable)
@@ -127,6 +153,17 @@ deriveJSON defaultOptions
   } ''AvsObjPersonId
 
 
+discernAvsIds :: Text -> Maybe (Either AvsFullCardNo AvsPersonId)
+discernAvsIds someid = aux someid
+  where
+    aux (Text.uncons -> Just (h,t))
+      | Char.isDigit h = aux t
+      | h == '.', Just (h2, t2) <- Text.uncons t, Text.null t2, Char.isDigit h2
+      , let afcn = AvsFullCardNo (AvsCardNo $ Text.dropEnd 2 someid) (Text.singleton h2)
+        = Just $ Left afcn
+      | otherwise = Nothing
+    aux _ = Right . AvsPersonId <$> readMay someid -- must always succeed at that point      
+
 data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
   deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable)
 
@@ -252,8 +289,8 @@ instance ToJSON AvsDataPersonCard where
     ]
 derivePersistFieldJSON ''AvsDataPersonCard
 
-getFullCardNo :: AvsDataPersonCard -> Text
+getFullCardNo :: AvsDataPersonCard -> AvsFullCardNo
-getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = avsCardNo avsDataCardNo <> Text.cons '.' avsDataVersionNo
+getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = AvsFullCardNo avsDataCardNo avsDataVersionNo
 
 data AvsStatusPerson = AvsStatusPerson
       { avsStatusPersonID         :: AvsPersonId

src/Utils/Print.hs

@@ -487,9 +487,9 @@ sendEmailOrLetter recipient letter = do
 -- | Converts Triple consisting of @ExitCode@, Success- and Failure-Value to Either Failue- or Success-Value.
 --   Returns @Right@  if the @ExitCode@ is @ExitsSuccess, entirely ignoring the Failure-Value, which might contain warning messages.
 --   To be used with 'System.Process.Typed.readProcess'
-exit2either :: (ExitCode, a, b) -> Either b a
+exit2either :: Monoid a => (ExitCode, a, a) -> Either a a
-exit2either (ExitSuccess   , ok,   _) = Right ok   -- warnings are ignored here!
+exit2either (ExitSuccess   , stdOut,  errOut) = Right $ stdOut <> errOut
-exit2either (ExitFailure _ ,  _, err) = Left err
+exit2either (ExitFailure _ , stdOut,  errOut) = Left  $ stdOut <> errOut
 
 
 readProcess' :: MonadIO m => ProcessConfig stdin stdoutIgnored stderrIgnored -> m (ExitCode, Text, Text)