Merge remote-tracking branch 'origin/fradrive/localmaster'

src/Handler/Admin/Avs.hs

@@ -95,7 +95,7 @@ makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateA
     parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
       where
         nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
-        ids = catMaybes $ readMay <$> nonemptys
+        ids = mapMaybe readMay nonemptys
     unparseAvsIds :: AvsQueryStatus -> Text
     unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
 
@@ -113,7 +113,7 @@ makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validat
     parseAvsIds txt = AvsQueryContact $ Set.fromList ids
       where        
         nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
-        ids = catMaybes $ fmap AvsObjPersonId . readMay <$> nonemptys
+        ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys
     unparseAvsIds :: AvsQueryContact -> Text
     unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
 

src/Handler/Tutorial/Users.hs

@@ -135,7 +135,7 @@ postTUsersR tid ssh csh tutn = do
             let fName = letterFileName aletter
             renderLetters rcvr letters apcIdent >>= \case
               Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err                      
-              Right pdf -> Just <$> sendByteStringAsFile fName (LBS.toStrict pdf) now
+              Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
                 -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
                 -- let typePDF :: ContentType 
                 --     typePDF = "application/pdf"
@@ -165,7 +165,7 @@ postTUsersR tid ssh csh tutn = do
     _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
   
   case tcontent of 
-    Just content -> return content -- abort and return produced content
+    Just act -> act -- abort and return produced content
     Nothing -> do
       tutors <- runDB $ E.select $ do
         (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User

src/Handler/Utils/Avs.hs

@@ -531,9 +531,13 @@ lookupAvsUsers apis = do
 -- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
 updateReceivers :: UserId -> Handler  (Entity User, [Entity User], Bool)
 updateReceivers uid = do
-  (underling :: Entity User, avsUnderling :: Maybe (Entity UserAvs), avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,,)
+  -- First perform AVS update for receiver
-    <$> getJustEntity uid
+  runDB (getBy (UniqueUserAvsUser uid)) >>= \case 
-    <*> getBy (UniqueUserAvsUser uid)
+      Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ upsertAvsUserById apid
+      Nothing -> return ()    
+  -- Retrieve updated user and supervisors now
+  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
+    <$> getJustEntity uid    
     <*> (E.select $ do
           (usrSuper :& usrAvs) <-
             E.from $     E.table @UserSupervisor            
@@ -544,10 +548,9 @@ updateReceivers uid = do
           pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId)
         )
   let (superVs, avsIds) = unzip avsSupers
-      receiverIDs :: [UserId] = E.unValue <$> superVs
+      receiverIDs :: [UserId] = E.unValue <$> superVs      
-      underlingAvsId = userAvsPersonId . entityVal <$> avsUnderling
+      toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
-      toUpdate = Set.fromList $ catMaybes (underlingAvsId : (E.unValue <$> avsIds))      
+      directResult = return (underling, pure underling, True)     -- already contains updated address
-      directResult = return (underling, pure underling, True)
   forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById)       -- attempt to update postaddress from AVS  
   if null receiverIDs 
     then directResult

src/Handler/Utils/Profile.hs

@@ -83,7 +83,7 @@ validEmail :: Email -> Bool      -- Email = Text
 validEmail email = validRFC5322 && not invalidFraport
   where 
     validRFC5322 = Email.isValid $ encodeUtf8 email
-    invalidFraport = case Text.stripSuffix "@fraport.de" email of  
+    invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of  
       Just fralogin -> all isDigit $ drop 1 fralogin
       Nothing       -> False
 

src/Model/Types/Avs.hs

@@ -587,6 +587,7 @@ deriveJSON defaultOptions
 -- Responses --
 ---------------
 
+type AvsResponseStatus :: Type
 newtype AvsResponseStatus = AvsResponseStatus (Set AvsStatusPerson)
   deriving (Eq, Ord, Show, Generic)
 deriveJSON defaultOptions
@@ -595,6 +596,8 @@ deriveJSON defaultOptions
   , tagSingleConstructors = False
   , rejectUnknownFields = False
   } ''AvsResponseStatus
+instance Semigroup AvsResponseStatus where 
+  (AvsResponseStatus a) <> (AvsResponseStatus b) = AvsResponseStatus (a <> b)
 
 newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson)
   deriving (Eq, Ord, Show, Generic)

src/Utils/Avs.hs

@@ -34,6 +34,10 @@ type AVSSetRampLicences = "RampDrivingLicence"      :> ReqBody '[JSON] AvsQueryS
 avsMaxSetLicenceAtOnce :: Int
 avsMaxSetLicenceAtOnce = 99   -- maximum input set size for avsQuerySetLicences as enforced by AVS
 
+avsMaxGetStatusAtOnce :: Int
+avsMaxGetStatusAtOnce = 990   -- maximum input set size for avsQueryStatus as enforced by AVS
+
+
 avsApi :: Proxy AVS
 avsApi = Proxy
 
@@ -75,7 +79,7 @@ mkAvsQuery _ _ _ = AvsQuery
 #else
 mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
     { avsQueryPerson      = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson      q)  cliEnv
-    , avsQueryStatus      = \q -> liftIO $                     runClientM (rawQueryStatus      q)  cliEnv
+    , avsQueryStatus      = \q -> liftIO $                     runClientM (splitQueryStatus    q)  cliEnv
     , avsQueryContact     = \q -> liftIO $                     runClientM (rawQueryContact     q)  cliEnv
     , avsQuerySetLicences = \q -> liftIO $                     runClientM (rawQuerySetLicences q)  cliEnv
     -- , avsQueryGetLicences = \q -> liftIO $                     runClientM (rawQueryGetLicences q)  cliEnv
@@ -91,6 +95,16 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
     catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404)))
       | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
     catch404toEmpty other = other
+
+    -- TODO: make a generic implementation for this
+    splitQueryStatus :: AvsQueryStatus -> ClientM AvsResponseStatus
+    splitQueryStatus q@(AvsQueryStatus avids)
+      | Set.size avids <= avsMaxGetStatusAtOnce = rawQueryStatus q
+      | otherwise = do 
+          let (avid_1,avid_2) = Set.splitAt avsMaxGetStatusAtOnce avids
+          res1 <- rawQueryStatus   (AvsQueryStatus avid_1)
+          res2 <- splitQueryStatus (AvsQueryStatus avid_2)
+          return $ res1 <> res2
 #endif
 
 -----------------------

test/Database/Fill.hs

@@ -164,7 +164,7 @@ fillDb = do
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "94094094094"
-    , userEmail  = "e12345@fraport.de"
+    , userEmail  = "S.Jost@Fraport.de"
     , userDisplayEmail = "jost@tcs.ifi.lmu.de"
     , userDisplayName = "Steffen Jost"
     , userSurname = "Jost"