chore(avs): remove avs_cards, add generic queries WIP

src/Handler/Profile.hs

@@ -585,8 +585,7 @@ getForProfileDataR cID = do
 makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
   now <- liftIO getCurrentTime
-  avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
+  avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)  
-  -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
   lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
       E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId

src/Handler/Utils/Avs.hs

@@ -49,7 +49,7 @@ import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Utils        as E
 
-
+import Servant.Client (ClientError)
 
 
 
@@ -573,12 +573,48 @@ updateReceivers uid = do
 ------------------
 -- CR3 Functions
 
+
+class SomeAvsQuery q where 
+  type SomeAvsResponse q :: Type
+  pickQuery :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
+  avsQuery :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
+  avsQuery qry = do 
+    qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
+    throwLeftM $ qfun qry
+
+-- avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
+avsQueryCached :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m
+                  -- , MonadReader UniWorX ((->) (HandlerSite m))
+                  , SomeAvsQuery q
+                  , Typeable (SomeAvsResponse q), Binary q, NFData (SomeAvsResponse q)
+                  , Binary (SomeAvsResponse q)
+             ) => q -> m (SomeAvsResponse q)
+avsQueryCached qry = do
+  cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
+  memcachedBy cexpire qry $ avsQuery qry
+
+instance SomeAvsQuery AvsQueryPerson where
+  type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
+  pickQuery = avsQueryPerson
+
+-- avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson
+-- avsPersonQueryCached = avsQueryCached
+
+-- avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson
+-- avsPersonQueryCached apq = do 
+--   cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
+--   memcachedBy cexpire apq $ do
+--     AvsQuery{avsQueryPerson} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+--     throwLeftM $ avsQueryPerson apq
+
+
+
 queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId)
 queryAvsCardNos = foldMapM queryAvsCardNo
 
 queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
 queryAvsCardNo crd = do 
-    AvsResponsePerson adps <- avsPersonQueryCached $ qry crd
+    AvsResponsePerson adps <- avsQueryCached $ qry crd
     return $ Set.map avsPersonPersonID adps
   where 
     qry (Left acno)               = def{ avsPersonQueryCardNo     = Just acno }
@@ -586,13 +622,6 @@ queryAvsCardNo crd = do
                                        , avsPersonQueryVersionNo  = Just avsFullCardVersion
                                        }
 
-avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson
-avsPersonQueryCached apq = do 
-  cexpire <- getsYesod $ preview $ _appAvsConf . _Just . _avsCacheExpiry . to Right
-  memcachedBy cexpire apq $ do
-    AvsQuery{avsQueryPerson} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-    throwLeftM $ avsQueryPerson apq
-
 
 -- A datatype for a specific heterogeneous list
 -- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate (EntityField record typ) ((typ -> f typ) -> iavs -> f iavs) -- An Record Field and fitting Lens

src/Handler/Utils/Users.hs

@@ -275,7 +275,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
         , Just True == matchesMatriculation x || didLdap
           -> return $ Just $ Left $ NonEmpty.fromList xs
         | not didLdap
-        , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
+        , userMatrs <- ((Set.toList . Set.fromList) (mapMaybe getTermMatr criteria))
           -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
         | otherwise
           -> return Nothing
@@ -908,7 +908,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
     (Nothing, _) 
       -> return ()
     (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _) 
-      -> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId)
+      -> deleteBy (UniqueUserAvsId oldAvsId)
     (Just Entity{entityVal=oldUserAvs}, Nothing) 
       -> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?!
          void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId]

src/Model/Types/Avs.hs

@@ -750,6 +750,7 @@ deriveJSON defaultOptions
 -------------
 -- Queries --
 -------------
+
 data AvsQueryPerson = AvsQueryPerson
         { avsPersonQueryCardNo             :: Maybe AvsCardNo
         , avsPersonQueryVersionNo          :: Maybe AvsVersionNo
@@ -786,3 +787,7 @@ deriveJSON defaultOptions ''AvsQueryGetLicences
 newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence)
   deriving (Eq, Ord, Show, Generic)
 deriveJSON defaultOptions ''AvsQuerySetLicences
+
+type family SomeAvsQueryResonse a where
+  SomeAvsQueryResonse AvsQueryPerson  = AvsResponsePerson
+  SomeAvsQueryResonse AvsQueryContact = AvsResponseContact

src/Utils/Lens.hs

@@ -129,7 +129,6 @@ makeClassyFor_ ''LmsUser
 -- makeClassyFor_ ''LmsUserStatus
 makeClassyFor_ ''LmsReport
 makeClassyFor_ ''UserAvs
-makeClassyFor_ ''UserAvsCard
 
 makeLenses_ ''UserCompany
 makeLenses_ ''Company

test/Database/Fill.hs

@@ -729,10 +729,6 @@ fillDb = do
   void . insert' $ UserAvs (AvsPersonId 4)        sbarth      4         now            Nothing Nothing Nothing
   void . insert' $ UserAvs (AvsPersonId 5)        fhamann     5         now            (Just "another message from avs synch") Nothing Nothing
   void . insert' $ UserAvs (AvsPersonId 77)       tinaTester  77        now            Nothing Nothing Nothing
-  insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True  Nothing Nothing AvsCardColorGelb (Set.fromList ['F'])     Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
-  insert_ $ UserAvsCard (AvsPersonId 2)        (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True  Nothing Nothing AvsCardColorRot  (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
-  insert_ $ UserAvsCard (AvsPersonId 3)        (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot  (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now
-  insert_ $ UserAvsCard (AvsPersonId 4)        (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True  Nothing Nothing AvsCardColorGelb (Set.fromList ['F'])     Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now
 
   let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
   let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]