fraport/fradrive
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")

26
src/Handler/PrintCenter.hs
View File

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

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 = "-+*.:;=!?#$"

2
src/Utils/Form.hs
View File

@ -297,7 +297,7 @@ data FormIdentifier
| FIDAllocationRegister
| FIDAllocationNotification
| FIDAvsQueryPerson
| FIDAvsQueryStatus
| FIDAvsQueryStatus
| FIDLmsLetter
deriving (Eq, Ord, Read, Show)

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)}