chore(ldap): add ldap test interface

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

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

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

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

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

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

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
 

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 =

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

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

src/Handler/PrintCenter.hs

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

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

templates/ldap.hamlet

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