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

@@ -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)                                                                          
+                                                                          in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
-      , sortable (Just "pj-name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName         -> n) -> textCell n      
+      , 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

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

src/Utils/Form.hs

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

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