fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(ldap): add ldap test interface

Browse Source
This commit is contained in:
Steffen Jost 2022-09-14 10:52:05 +02:00
parent a9865c4c2d
commit 0c985fef0c
14 changed files with 137 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -135,6 +135,7 @@ MenuLmsDirectDownload: Direkter Download
MenuLmsFake: Testnutzer generieren
MenuAvs: Schnittstelle AVS
MenuLdap: Schnittstelle LDAP
MenuApc: Druckerei
MenuPrintSend: Manueller Briefversand
MenuPrintDownload: Brief herunterladen

1
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -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

1
routes
View File

@ -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

7
src/Auth/LDAP.hs
View File

@ -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

11
src/Database/Esqueleto/Utils.hs
View File

@ -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

9
src/Foundation/Navigation.hs
View File

@ -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

12
src/Foundation/Yesod/Auth.hs
View File

@ -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

1
src/Handler/Admin.hs
View File

@ -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 =

2
src/Handler/Admin/Avs.hs
View File

@ -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

70
src/Handler/Admin/Ldap.hs Normal file
View File

@ -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")

4
src/Handler/PrintCenter.hs
View File

@ -213,6 +213,7 @@ 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))
@ -223,6 +224,9 @@ mkPJTable = do
[ 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)

2
src/Handler/Utils/LMS.hs
View File

@ -137,4 +137,4 @@ randomLMSIdent = LmsIdent <$> randomText [] lengthIdent
randomLMSpw :: MonadIO m => m Text
randomLMSpw = randomText extra lengthPassword
where
extra = "_-+*.:;=!?#"
extra = "-+*.:;=!?#$"

11
templates/ldap.hamlet Normal file
View File

@ -0,0 +1,11 @@
<section>
<p>
LDAP Person Search:
^{personForm}
$maybe answers <- mbLdapData
<dl>
Antwort: #
<dl>
$forall (lk, lv) <- answers
<dt>#{show lk}
<dd>#{show (fmap Text.decodeUtf8' lv)}