diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2fd91c505..720bed254 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,6 +1,6 @@ module Handler.Utils.Avs - ( - checkLicences + ( checkLicences + , setLicence ) where import Import @@ -12,13 +12,19 @@ import Utils.Avs -- | Retrieve all currently valid driving licences and check against our database -- Only react to changes as compared to last seen status in avs.model +-- TODO: turn into a job, once the interface is actually available checkLicences :: Handler () checkLicences = do - getsYesod (view _appAvsQuery) >>= \case - Nothing -> error "Avs Fail" -- TODO - Just AvsQuery{..} -> do - avsQueryGetLicences >>= \case - Left err -> error $ show err -- TODO - Right (AvsGetLicences _licences) -> do - error "CONTINUE HERE" -- TODO STUB + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + AvsGetLicences _licences <- throwLeftM avsQueryGetLicences + --TODO this must be chunked into separate jobs/tasks + --forM licences $ \AvsDataLicence{..} -> do + error "CONTINUE HERE" -- TODO STUB +-- Do we need this? +-- getLicence :: UserId -> Handler AvsLicence + +-- +setLicence :: UserId -> AvsLicence -> Handler () +setLicence _uid _al = do + error "CONTINUE HERE" -- TODO STUB \ No newline at end of file diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index aca992367..46abe8659 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -61,6 +61,7 @@ data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Typeable) instance ToJSON AvsLicence where + -- toJSON al = Number $ fromEnum AvsLicence -- would do, but... toJSON AvsNoLicence = Number 0 toJSON AvsLicenceVorfeld = Number 1 toJSON AvsLicenceRollfeld = Number 2 diff --git a/src/Utils.hs b/src/Utils.hs index 7c565484b..14e70d231 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -791,6 +791,10 @@ catchMPlus _ = handle (const mzero :: e -> m a) catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> Bool) -> m a -> m a catchIfMPlus p act = catchIf p act (const mzero) +-- | Monadic version of 'fromMaybe' +fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a +fromMaybeM act = maybeM act pure + fromMaybeT :: MaybeT Identity a -> Maybe a fromMaybeT = runIdentity . runMaybeT @@ -816,8 +820,10 @@ formResultToMaybe _ = empty maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a maybeThrow exc = maybe (throwM exc) return -maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a -maybeThrowM excM = maybe (throwM =<< excM) return +-- | Monadic version of 'fromMaybe' +maybeThrowM :: (Exception e, MonadThrow m) => e -> m (Maybe a) -> m a +maybeThrowM = fromMaybeM . throwM + mapMaybeM :: ( Monad m , MonoFoldable (f a) @@ -880,15 +886,17 @@ whenIsRight :: Applicative f => Either a b -> (b -> f ()) -> f () whenIsRight (Right x) f = f x whenIsRight (Left _) _ = pure () -throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a -throwLeft = either throwM return - - {- Just a reminder for Steffen: mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft = over _Left -} +throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a +throwLeft = either throwM return + +throwLeftM :: (MonadThrow m, Exception exc) => m (Either exc a) -> m a +throwLeftM = (throwLeft =<<) + actLeft :: Applicative f => Either a b -> (a -> f (Either c b)) -> f (Either c b) actLeft (Left x) f = f x actLeft (Right y) _ = pure $ Right y diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 0f82e470f..8926c25d5 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -54,6 +54,19 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other + + +-------------------- +-- AVS Exceptions -- +-------------------- + +data AvsException + = AvsInterfaceUnavailable + deriving (Show, Generic, Typeable) +instance Exception AvsException + + + {- TODOs Connect AVS query to LDAP queries for automatic synchronisation: