From 0c985fef0c1a7bd36027c9972d848cee27b7b141 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 14 Sep 2022 10:52:05 +0200 Subject: [PATCH] chore(ldap): add ldap test interface --- .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 1 + src/Auth/LDAP.hs | 7 +- src/Database/Esqueleto/Utils.hs | 11 ++- src/Foundation/Navigation.hs | 9 +++ src/Foundation/Yesod/Auth.hs | 12 +++- src/Handler/Admin.hs | 1 + src/Handler/Admin/Avs.hs | 2 +- src/Handler/Admin/Ldap.hs | 70 +++++++++++++++++++ src/Handler/PrintCenter.hs | 26 ++++--- src/Handler/Utils/LMS.hs | 2 +- src/Utils/Form.hs | 2 +- templates/ldap.hamlet | 11 +++ 14 files changed, 137 insertions(+), 19 deletions(-) create mode 100644 src/Handler/Admin/Ldap.hs create mode 100644 templates/ldap.hamlet diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 569028694..a6b97fc6c 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -135,6 +135,7 @@ MenuLmsDirectDownload: Direkter Download MenuLmsFake: Testnutzer generieren MenuAvs: Schnittstelle AVS +MenuLdap: Schnittstelle LDAP MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index ee8b49b0b..391796b5d 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -136,6 +136,7 @@ MenuLmsDirectDownload: Direct Download MenuLmsFake: Generate test users MenuAvs: AVS Interface +MenuLdap: LDAP Interface MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter diff --git a/routes b/routes index 2e68773a5..f1c0adf0e 100644 --- a/routes +++ b/routes @@ -62,6 +62,7 @@ /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST +/admin/ldap AdminLdapR GET POST /print PrintCenterR GET POST !system-printer /print/send PrintSendR GET POST diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index e96b1a90d..6d408e270 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -5,7 +5,7 @@ module Auth.LDAP , ADError(..), ADInvalidCredentials(..) , campusLogin , CampusUserException(..) - , campusUser, campusUser' + , campusUser, campusUser', campusUser'' , campusUserReTest, campusUserReTest' , campusUserMatr, campusUserMatr' , CampusMessage(..) @@ -145,8 +145,11 @@ campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList [])) campusUser' pool mode User{userIdent} - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) []) + = campusUser'' pool mode $ CI.original userIdent +campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList [])) +campusUser'' pool mode ident + = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident []) campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList []) campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f5afda286..c20e865db 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -14,7 +14,7 @@ module Database.Esqueleto.Utils , mkExactFilter, mkExactFilterWith , mkExactFilterLast, mkExactFilterLastWith , mkContainsFilter, mkContainsFilterWith - , mkDayFilter + , mkDayFilter, mkDayBetweenFilter , mkExistsFilter , anyFilter, allFilter , orderByList @@ -269,6 +269,15 @@ mkDayFilter lenslike row criterias | otherwise = true +mkDayBetweenFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Last (Day,Day) -- ^ a day range to filter for + -> E.SqlExpr (E.Value Bool) +mkDayBetweenFilter lenslike row criterias + | Last (Just (from,to)) <- criterias = day (lenslike row) `E.between` (E.val from, E.val to) + | otherwise = true + + mkExistsFilter :: PathPiece a => (t -> a -> E.SqlQuery ()) -> t diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 33fbaf5f8..f4a95c6c3 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -105,6 +105,7 @@ breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR +breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR @@ -819,6 +820,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navQuick' = mempty , navForceActive = False } + , NavLink + { navLabel = MsgMenuLdap + , navRoute = AdminLdapR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } ] } , return NavHeaderContainer diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 785acc5d1..0d74c98e5 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -168,6 +168,14 @@ upsertCampusUser upsertMode ldapData = do = return t | otherwise = throwM err + -- accept multiple successful decodings, ignoring all others + decodeLdapN attr err + | t@(_:_) <- rights vs + = return $ Text.unwords t + | otherwise = throwM err + where + vs = Text.decodeUtf8' <$> (ldapMap !!! attr) + -- accept any successful decoding or empty; only throw an error if all decodings fail -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text decodeLdap' attr err @@ -175,7 +183,7 @@ upsertCampusUser upsertMode ldapData = do | (h:_) <- rights vs = return $ Just h | otherwise = throwM err where - vs = Text.decodeUtf8' <$> ldapMap !!! attr + vs = Text.decodeUtf8' <$> (ldapMap !!! attr) -- just returns Nothing on error, pure decodeLdap :: Ldap.Attr -> Maybe Text @@ -208,7 +216,7 @@ upsertCampusUser upsertMode ldapData = do -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail - userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName + userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 262223ac4..12d71ee45 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -9,6 +9,7 @@ import Handler.Admin.ErrorMessage as Handler.Admin import Handler.Admin.Tokens as Handler.Admin import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs as Handler.Admin +import Handler.Admin.Ldap as Handler.Admin getAdminR :: Handler Html getAdminR = diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 43ef56e44..6ee40f5c3 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -51,7 +51,7 @@ validateAvsQueryStatus = do AvsQueryStatus ids <- State.get guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids) -getAdminAvsR, postAdminAvsR :: Handler Html +getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR = postAdminAvsR postAdminAvsR = do mAvsQuery <- getsYesod $ view _appAvsQuery diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs new file mode 100644 index 000000000..45c1f1bf7 --- /dev/null +++ b/src/Handler/Admin/Ldap.hs @@ -0,0 +1,70 @@ + + +module Handler.Admin.Ldap + ( getAdminLdapR + , postAdminLdapR + ) where + +import Import +-- import qualified Control.Monad.State.Class as State +-- import Data.Aeson (encode) +-- import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +-- import qualified Data.Set as Set + +import Handler.Utils + +import qualified Ldap.Client as Ldap +import Auth.LDAP + +newtype LdapQueryPerson = LdapQueryPerson + { ldapQueryIdent :: Text + -- , ldapQueryName :: Maybe Text + -- , ldapQueryPNum :: Maybe Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson +makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html -> + flip (renderAForm FormStandard) html $ LdapQueryPerson + <$> areq textField (fslI MsgAdminUserIdent) (ldapQueryIdent <$> tmpl) + -- <*> aopt textField (fslI MsgAdminUserSurname) (ldapQueryName <$> tmpl) + -- <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum <$> tmpl) + +validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler () +validateLdapQueryPerson = return () -- currently no tests needed + --LdapQueryPerson{..} <- State.get + --guardValidation MsgAvsQueryEmpty + --is _Just ldapQueryIdent || + --is _Just ldapQueryName || + --is _Just ldapQueryPNum + + + +getAdminLdapR, postAdminLdapR :: Handler Html +getAdminLdapR = postAdminLdapR +postAdminLdapR = do + ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing + + let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList [])) + procFormPerson LdapQueryPerson{..} = do + ldapPool' <- getsYesod $ view _appLdapPool + if isNothing ldapPool' + then addMessage Warning $ text2Html "LDAP Configuration missing." + else addMessage Info $ text2Html "Input for LDAP test received." + fmap join . for ldapPool' $ \ldapPool -> + campusUser'' ldapPool FailoverUnlimited ldapQueryIdent + + mbLdapData <- formResultMaybe presult procFormPerson + + + actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute + siteLayoutMsg MsgMenuLdap $ do + setTitleI MsgMenuLdap + let personForm = wrapForm pwidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = penctype + } + -- TODO: use i18nWidgetFile instead if this is to become permanent + $(widgetFile "ldap") + diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index a05d70ab3..784ce47a1 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -3,7 +3,7 @@ module Handler.PrintCenter ( getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR - , getPrintDownloadR + , getPrintDownloadR ) where import Import @@ -98,10 +98,10 @@ mprToMeta MetaPinRenewal{..} = mkMeta where deOrEn = if isDe mppLang then "de" else "en" keyOpening = deOrEn <> "-opening" - keyClosing = deOrEn <> "-closing" + keyClosing = deOrEn <> "-closing" mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta -mprToMetaUser entUser@Entity{entityVal = u} mpr = do +mprToMetaUser entUser@Entity{entityVal = u} mpr = do let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped` meta = mprToMeta mpr{ mppRecipient = userDisplayName u -- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB @@ -189,11 +189,11 @@ mkPJTable = do dbtColonnade = mconcat [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t - , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t + , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey t = r ^. resultPrintJob . _entityVal . _printJobFilename - in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) - , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n + in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) + , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell @@ -201,7 +201,7 @@ mkPJTable = do ] dbtSorting = mconcat [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) - , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) + , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("pj-recipient" , sortUserNameBareM queryRecipient) @@ -213,16 +213,20 @@ mkPJTable = do [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName)) , single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName)) , single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName)) - , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) + , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) , prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) , prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) + --, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) + -- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) + -- ) , prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient) , prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender) , prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) @@ -301,13 +305,13 @@ postPrintSendR = do -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" uID <- maybeAuthId - runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing) >>= \case -- calls lpr + runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing) >>= \case -- calls lpr Left err -> do let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg addMessage Error $ toHtml msg pure False - Right (ok, fpath) -> do + Right (ok, fpath) -> do let response = if null ok then mempty else " Response: " <> ok addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response pure True @@ -319,7 +323,7 @@ postPrintSendR = do pure False when (or oks) $ redirect PrintCenterR formResult sendResult procFormSend - -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute + -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgPrintManualRenewal $ do setTitleI MsgMenuPrintSend let sendForm = wrapForm sendWidget def diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 79a306756..7556085ca 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -137,4 +137,4 @@ randomLMSIdent = LmsIdent <$> randomText [] lengthIdent randomLMSpw :: MonadIO m => m Text randomLMSpw = randomText extra lengthPassword where - extra = "_-+*.:;=!?#" + extra = "-+*.:;=!?#$" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a26776c30..13e9e703f 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -297,7 +297,7 @@ data FormIdentifier | FIDAllocationRegister | FIDAllocationNotification | FIDAvsQueryPerson - | FIDAvsQueryStatus + | FIDAvsQueryStatus | FIDLmsLetter deriving (Eq, Ord, Read, Show) diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet new file mode 100644 index 000000000..a02df7d65 --- /dev/null +++ b/templates/ldap.hamlet @@ -0,0 +1,11 @@ +
+

+ LDAP Person Search: + ^{personForm} + $maybe answers <- mbLdapData +

+ Antwort: # +
+ $forall (lk, lv) <- answers +
#{show lk} +
#{show (fmap Text.decodeUtf8' lv)}