From ba5e8bca3b8dabbf276e18bd26d8434631fb76c0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 13 Oct 2020 15:01:53 +0200 Subject: [PATCH 01/14] chore: add cabal files to dependencies to quiet warnings --- stack.yaml | 4 ++-- stack.yaml.lock | 48 ++++++++++++++++++++++++------------------------ 2 files changed, 26 insertions(+), 26 deletions(-) diff --git a/stack.yaml b/stack.yaml index 9ea2e6ee1..d31829f49 100644 --- a/stack.yaml +++ b/stack.yaml @@ -30,7 +30,7 @@ extra-deps: - serversession - serversession-backend-acid-state - git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git - commit: 074ed7c8810aca81f60f2c535f9e7bad67e9d95a + commit: dc928c3a456074b8777603bea20e81937321777f - git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git commit: f8170266ab25b533576e96715bedffc5aa4f19fa subdirs: @@ -39,7 +39,7 @@ extra-deps: commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 subdirs: - cryptoids-class - cryptoids-types diff --git a/stack.yaml.lock b/stack.yaml.lock index d36679f52..81a666051 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -101,12 +101,12 @@ packages: version: 0.3.6 git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git pantry-tree: - size: 691 - sha256: 7cada516aa3cad4adc214f5eb90dd07c3a8ecabdc5551f761366fc270ae2e086 - commit: 074ed7c8810aca81f60f2c535f9e7bad67e9d95a + size: 750 + sha256: f567a1c834448daaa164f2029fad164e6c8df2d4c92b51f811bae19cc0c95975 + commit: dc928c3a456074b8777603bea20e81937321777f original: git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git - commit: 074ed7c8810aca81f60f2c535f9e7bad67e9d95a + commit: dc928c3a456074b8777603bea20e81937321777f - completed: subdir: colonnade name: colonnade @@ -137,65 +137,65 @@ packages: version: 0.0.0 git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git pantry-tree: - size: 350 - sha256: f014c9ff9666a4d4bab82dd2b3092fd2004b40ebf2bcd32cf7d90035e08ce75b - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + size: 412 + sha256: 30466648d273ffb1d580b7961188d67a0bedb3703d6d5f8cca3c15a45295f203 + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 original: subdir: cryptoids-class git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - completed: subdir: cryptoids-types name: cryptoids-types version: 1.0.0 git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git pantry-tree: - size: 258 - sha256: d1465d25a1a1807d5a88d9a09085fd4a2f49f2e57b8398496691ffad30e8f88c - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + size: 320 + sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 original: subdir: cryptoids-types git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - completed: subdir: cryptoids name: cryptoids version: 0.5.1.0 git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git pantry-tree: - size: 510 - sha256: 7c16ce6b5de6988ba628027a055fe7faa8b3a2e2bc77d7088e8dad23e9bac7a1 - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + size: 566 + sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 original: subdir: cryptoids git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - completed: subdir: filepath-crypto name: filepath-crypto version: 0.1.0.0 git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git pantry-tree: - size: 614 - sha256: 2f5d7053ba61d8727b2a0b4443017e9af013196d2d53064c98f21bbd196ccd52 - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + size: 676 + sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9 + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 original: subdir: filepath-crypto git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - completed: subdir: uuid-crypto name: uuid-crypto version: 1.4.0.0 git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git pantry-tree: - size: 359 - sha256: 1861593e0b304b8a09db3e7b435ae6763f57d2051a1c8770a051adc5aa0f0edd - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + size: 417 + sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4 + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 original: subdir: uuid-crypto git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - completed: subdir: gearhash name: gearhash From 4a731eca4e69b5ee080f229a602e76f5ae165c64 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 08:28:19 +0200 Subject: [PATCH 02/14] fix(allocations): work around yesod weirdness wrt "none" --- messages/uniworx/de-de-formal.msg | 2 +- messages/uniworx/en-eu.msg | 2 +- src/Handler/Allocation/Compute.hs | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index aba2c9510..3d52ca2b6 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2761,7 +2761,7 @@ AllocationUsersMissingPrioritiesTip: Es muss sichergestellt sein, dass keine Tei AllocationUsersMissingPrioritiesOk: Es wurde sichergestellt, dass es für jeden der genannten Benutzer einen zulässigen Grund gibt, warum dieser nicht an der Zentralanmeldung teilnehmen sollte. AllocationRestrictCourses: Kurse einschränken AllocationRestrictCoursesTip: Sollen nur Plätze für eine Teilmenge von Kursen zugewiesen werden? So können u.A. Nachrücker verteilt werden. Diese Funktionalität sollte nur verwendet werden, wenn manche Kurse aus zulässigen Gründen ausgeschlossen werden müssen; z.B. weil ein Seminar bereits ein Treffen zur Organisation hatte und nun keine weiteren Teilnehmer mehr akzeptieren kann. -AllocationCourseRestrictionNone: Nicht einschränken +AllocationCourseRestrictionDontRestrict: Nicht einschränken AllocationCourseRestrictionSubstitutes: Kurse, die aktuell Nachrücker azkeptieren AllocationCourseRestrictionCustom: Benutzerdefiniert AllocationRestrictCoursesSelection: Kurse diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 6b9f93c16..41d77282b 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2762,7 +2762,7 @@ AllocationUsersMissingPrioritiesTip: Care must be taken, that no participant is AllocationUsersMissingPrioritiesOk: It was ensured, that all participants mentioned above, are excluded from the allocation on valid grounds. AllocationRestrictCourses: Restrict courses AllocationRestrictCoursesTip: Should places be assigned only in a subset of courses? This functionality can be used to make alternate placements in the case that some participants withdraw from their assigned courses. This functionality should only be used to exclude courses on valid grounds. E.g. if a seminar already had a planning meeting and is thus unable to accept new participants. -AllocationCourseRestrictionNone: Don't restrict +AllocationCourseRestrictionDontRestrict: Don't restrict AllocationCourseRestrictionSubstitutes: Courses which currently allow substitute registrations AllocationCourseRestrictionCustom: Custom AllocationRestrictCoursesSelection: Courses diff --git a/src/Handler/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs index d1d5a18ef..bf13fa05a 100644 --- a/src/Handler/Allocation/Compute.hs +++ b/src/Handler/Allocation/Compute.hs @@ -72,7 +72,7 @@ missingPriorities aId = wFormToAForm $ do data AllocationCourseRestrictionMode - = AllocationCourseRestrictionNone + = AllocationCourseRestrictionDontRestrict | AllocationCourseRestrictionSubstitutes | AllocationCourseRestrictionCustom deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -81,10 +81,10 @@ nullaryPathPiece ''AllocationCourseRestrictionMode $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''AllocationCourseRestrictionMode id restrictCourses :: (MonadHandler m, HandlerSite m ~ UniWorX) => AllocationId -> AForm m (Maybe (Set CourseId)) -restrictCourses aId = hoistAForm liftHandler $ multiActionA restrictOpts (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just AllocationCourseRestrictionNone) +restrictCourses aId = hoistAForm liftHandler $ multiActionA restrictOpts (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just AllocationCourseRestrictionDontRestrict) where restrictOpts = mapF $ \case - AllocationCourseRestrictionNone -> pure Nothing + AllocationCourseRestrictionDontRestrict -> pure Nothing AllocationCourseRestrictionSubstitutes -> wFormToAForm $ do now <- liftIO getCurrentTime allocCourses <- fmap (setOf $ folded . _Value) . liftHandler . runDB . E.select . E.from $ \allocationCourse -> do From 8eedfdd4c1406f745a0f6ba3907b6890af0d3b72 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 08:29:01 +0200 Subject: [PATCH 03/14] chore(release): 20.11.1 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 46d0c0932..390b4a24f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +### [20.11.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.11.0...v20.11.1) (2020-10-14) + + +### Bug Fixes + +* **allocations:** work around yesod weirdness wrt "none" ([4a731ec](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4a731eca4e69b5ee080f229a602e76f5ae165c64)) + ## [20.11.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.10.0...v20.11.0) (2020-10-13) diff --git a/package-lock.json b/package-lock.json index 5813877ac..863e8b427 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.11.0", + "version": "20.11.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index ed1815145..3d3fd829c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.11.0", + "version": "20.11.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 209a459aa..f74e06638 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.11.0 +version: 20.11.1 dependencies: - base From 51ed7e0a26a94d2178a4ca10ad7ea36b99076b54 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 12:40:08 +0200 Subject: [PATCH 04/14] feat(ldap): expose active directory errors --- messages/uniworx/de-de-formal.msg | 14 +++- messages/uniworx/en-eu.msg | 12 +++ package.yaml | 1 + src/Auth/LDAP.hs | 19 +++++ src/Auth/LDAP/AD.hs | 76 +++++++++++++++++++ src/Foundation/I18n.hs | 2 + src/Import/NoModel.hs | 1 + src/Ldap/Client/Instances.hs | 11 +++ src/Utils/Metrics.hs | 1 + .../ldap-ad-errors.de-de-formal.hamlet | 2 + .../changelog/ldap-ad-errors.en-eu.hamlet | 2 + test/Auth/LDAP/ADSpec.hs | 18 +++++ 12 files changed, 158 insertions(+), 1 deletion(-) create mode 100644 src/Auth/LDAP/AD.hs create mode 100644 src/Ldap/Client/Instances.hs create mode 100644 templates/i18n/changelog/ldap-ad-errors.de-de-formal.hamlet create mode 100644 templates/i18n/changelog/ldap-ad-errors.en-eu.hamlet create mode 100644 test/Auth/LDAP/ADSpec.hs diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 3d52ca2b6..fff9e6611 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2880,4 +2880,16 @@ SystemExamOffice: Prüfungsverwaltung SystemFaculty: Fakultätsmitglied ChangelogItemFeature: Feature -ChangelogItemBugfix: Bugfix \ No newline at end of file +ChangelogItemBugfix: Bugfix + +InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht +InvalidCredentialsADLogonFailure: Ungültiges Passwort +InvalidCredentialsADAccountRestriction: Kontobeschränkungen verhindern Login +InvalidCredentialsADInvalidLogonHours: Benutzer darf sich zur aktuellen Tageszeit nicht anmelden +InvalidCredentialsADInvalidWorkstation: Benutzer darf sich von diesem System aus nicht anmelden +InvalidCredentialsADPasswordExpired: Passwort abgelaufen +InvalidCredentialsADAccountDisabled: Benutzereintrag gesperrt +InvalidCredentialsADTooManyContextIds: Benutzereintrag trägt zu viele Sicherheitskennzeichen +InvalidCredentialsADAccountExpired: Benutzereintrag abgelaufen +InvalidCredentialsADPasswordMustChange: Passwort muss geändert werden +InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingserkennung gesperrt \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 41d77282b..74fb98ab2 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2883,3 +2883,15 @@ SystemFaculty: Faculty member ChangelogItemFeature: Feature ChangelogItemBugfix: Bugfix + +InvalidCredentialsADNoSuchObject: User entry does not exist +InvalidCredentialsADLogonFailure: Invalid passwod +InvalidCredentialsADAccountRestriction: Account restrictions are preventing login +InvalidCredentialsADInvalidLogonHours: User may not login at the current time of day +InvalidCredentialsADInvalidWorkstation: User may not login from this system +InvalidCredentialsADPasswordExpired: Password expired +InvalidCredentialsADAccountDisabled: Account disabled +InvalidCredentialsADTooManyContextIds: Account carries to many security identifiers +InvalidCredentialsADAccountExpired: Account expired +InvalidCredentialsADPasswordMustChange: Password needs to be changed +InvalidCredentialsADAccountLockedOut: Account disabled by intruder detection diff --git a/package.yaml b/package.yaml index f74e06638..5d3e8bc73 100644 --- a/package.yaml +++ b/package.yaml @@ -70,6 +70,7 @@ dependencies: - blaze-html - conduit-resumablesink >=0.2 - parsec + - parsec-numbers - attoparsec - uuid - exceptions diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 007178793..c8e49ab16 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,5 +1,6 @@ module Auth.LDAP ( apLdap + , ADError(..), ADInvalidCredentials(..) , campusLogin , CampusUserException(..) , campusUser, campusUser' @@ -26,6 +27,8 @@ import qualified Data.Text.Encoding as Text import qualified Yesod.Auth.Message as Msg +import Auth.LDAP.AD + data CampusLogin = CampusLogin { campusIdent :: CI Text @@ -155,6 +158,13 @@ campusUserMatr' pool mode +newtype ADInvalidCredentials = ADInvalidCredentials ADError + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +isUnusualADError :: ADError -> Bool +isUnusualADError = flip notElem [ADNoSuchObject, ADLogonFailure] + + campusForm :: ( RenderMessage (HandlerSite m) FormMessage , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m)) , RenderMessage (HandlerSite m) CampusMessage @@ -174,6 +184,7 @@ campusLogin :: forall site. , RenderMessage site CampusMessage , RenderMessage site AFormMessage , RenderMessage site (ValueRequired site) + , RenderMessage site ADInvalidCredentials , Button site ButtonSubmit ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site campusLogin pool mode = AuthPlugin{..} @@ -203,6 +214,14 @@ campusLogin pool mode = AuthPlugin{..} $logErrorS apName $ "Error during login: " <> tshow err observeLoginOutcome apName LoginError loginErrorMessageI LoginR Msg.AuthError + Right (Left (Ldap.ResponseErrorCode _ errCode _ errTxt)) + | Right adError <- parseADError errCode errTxt + , isUnusualADError adError -> do + $logInfoS apName [st|#{campusIdent}: #{toPathPiece adError}|] + observeLoginOutcome apName LoginADInvalidCredentials + setSessionJson SessionError . InternalError $ toPathPiece adError + MsgRenderer mr <- liftHandler getMsgRenderer + loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError Right (Left bindErr) -> do case bindErr of Ldap.ResponseErrorCode _ _ _ errTxt -> diff --git a/src/Auth/LDAP/AD.hs b/src/Auth/LDAP/AD.hs new file mode 100644 index 000000000..58d0ca4f8 --- /dev/null +++ b/src/Auth/LDAP/AD.hs @@ -0,0 +1,76 @@ +module Auth.LDAP.AD + ( ADError(..) + , parseADError + ) where + +import Import.NoFoundation hiding (try) + +import Model.Types.TH.PathPiece + +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map + +import Text.Parsec hiding ((<|>)) +import Text.Parsec.String +import Text.ParserCombinators.Parsec.Number (hexnum) + +import Ldap.Client (ResultCode(..)) + + +-- | Copied from +data ADError + = ADNoSuchObject + | ADLogonFailure + | ADAccountRestriction + | ADInvalidLogonHours + | ADInvalidWorkstation + | ADPasswordExpired + | ADAccountDisabled + | ADTooManyContextIds + | ADAccountExpired + | ADPasswordMustChange + | ADAccountLockedOut + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''ADError $ camelToPathPiece' 1 +pathPieceJSON ''ADError +pathPieceJSONKey ''ADError +derivePersistFieldPathPiece ''ADError + + +fromADErrorCode :: ResultCode -> Word32 -> Maybe ADError +fromADErrorCode resCode subResCode = IntMap.lookup (fromIntegral subResCode) =<< Map.lookup resCode errorCodes + where + errorCodes = Map.fromList + [ ( InvalidCredentials + , IntMap.fromList + [ ( 0x525, ADNoSuchObject ) + , ( 0x52e, ADLogonFailure ) + , ( 0x52f, ADAccountRestriction ) + , ( 0x530, ADInvalidLogonHours ) + , ( 0x531, ADInvalidWorkstation ) + , ( 0x532, ADPasswordExpired ) + , ( 0x533, ADAccountDisabled ) + , ( 0x568, ADTooManyContextIds ) + , ( 0x701, ADAccountExpired ) + , ( 0x773, ADPasswordMustChange ) + , ( 0x775, ADAccountLockedOut ) + , ( 0x80090346, ADAccountLockedOut ) + ] + ) + ] + +parseADError :: ResultCode -> Text -> Either ParseError ADError +parseADError resCode = parse (pADError resCode <* eof) "LDAP" . unpack + +pADError :: ResultCode -> Parser ADError +pADError resCode = do + void . manyTill anyChar . try $ string ": " + let pItem = asum + [ do + void $ string "data " + fmap Just $ hexnum >>= hoistMaybe . fromADErrorCode resCode + , Nothing <$ manyTill anyChar (lookAhead . try $ void (string ", ") <|> eof) + ] + (hoistMaybe =<<) $ ala First foldMap <$> pItem `sepBy1` try (string ", ") diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 1d5ac1248..ac5e31cb0 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -231,6 +231,8 @@ embedRenderMessage ''UniWorX ''AuthenticationMode id embedRenderMessage ''UniWorX ''RatingValidityException id +embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" <>) + newtype ShortSex = ShortSex Sex embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 23e4f09b3..97cd8d3d7 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -175,6 +175,7 @@ import Data.Word.Word24.Instances as Import () import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache) import Database.Persist.Sql.Types.Instances as Import () import Control.Monad.Catch.Instances as Import () +import Ldap.Client.Instances as Import () import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512) import Crypto.Random as Import (ChaChaDRG, Seed) diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs new file mode 100644 index 000000000..ca45d6cc1 --- /dev/null +++ b/src/Ldap/Client/Instances.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ldap.Client.Instances + ( + ) where + +import ClassyPrelude +import Ldap.Client + + +deriving instance Ord ResultCode diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index c1f6a7abf..f8b21dad5 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -305,6 +305,7 @@ observeFavouritesQuickActionsDuration act = do data LoginOutcome = LoginSuccessful | LoginInvalidCredentials + | LoginADInvalidCredentials | LoginError deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) diff --git a/templates/i18n/changelog/ldap-ad-errors.de-de-formal.hamlet b/templates/i18n/changelog/ldap-ad-errors.de-de-formal.hamlet new file mode 100644 index 000000000..0a8eeebdf --- /dev/null +++ b/templates/i18n/changelog/ldap-ad-errors.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Bessere Fehlermeldungen bei fehlgeschlagenem Login diff --git a/templates/i18n/changelog/ldap-ad-errors.en-eu.hamlet b/templates/i18n/changelog/ldap-ad-errors.en-eu.hamlet new file mode 100644 index 000000000..401d12e67 --- /dev/null +++ b/templates/i18n/changelog/ldap-ad-errors.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Better error messages on failed login diff --git a/test/Auth/LDAP/ADSpec.hs b/test/Auth/LDAP/ADSpec.hs new file mode 100644 index 000000000..790dc32f4 --- /dev/null +++ b/test/Auth/LDAP/ADSpec.hs @@ -0,0 +1,18 @@ +module Auth.LDAP.ADSpec where + +import TestImport + +import Auth.LDAP.AD +import Ldap.Client + + +spec :: Spec +spec = do + describe "parseADError" $ do + it "parses some examples" . mapM_ exampleEntry $ + [ ( InvalidCredentials, ADAccountDisabled, "80090308: LdapErr: DSID-0C090446, comment: AcceptSecurityContext error, data 533, v2580") + , ( InvalidCredentials, ADLogonFailure , "80090308: LdapErr: DSID-0C090446, comment: AcceptSecurityContext error, data 52e, v2580") + ] + +exampleEntry :: ( ResultCode, ADError, Text ) -> Expectation +exampleEntry ( resCode, adError, errMsg ) = example $ parseADError resCode errMsg `shouldBe` Right adError From 7529933ebea382ed50372e7d47031940d1f96644 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 12:40:31 +0200 Subject: [PATCH 05/14] chore: have uniworxdb accept config file as argument --- src/Application.hs | 14 ++++++++------ test/Database.hs | 19 ++++++++++--------- 2 files changed, 18 insertions(+), 15 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index d4dd082fb..cd87498a4 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Application - ( getAppDevSettings + ( getAppSettings, getAppDevSettings , appMain , develMain , makeFoundation @@ -11,8 +11,8 @@ module Application , getApplicationRepl , shutdownApp -- * for GHCI - , handler - , db + , handler, handler' + , db, db' , addPWEntry ) where @@ -619,17 +619,19 @@ shutdownApp app = do --------------------------------------------- -- | Run a handler -handler :: Handler a -> IO a +handler, handler' :: Handler a -> IO a handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h +handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries -db :: DB a -> IO a +db, db' :: DB a -> IO a db = handler . runDB +db' = handler' . runDB addPWEntry :: User -> Text {-^ Password -} -> IO () -addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do +addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do PWHashConf{..} <- getsYesod $ view _appAuthPWHash (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength void $ insert User{..} diff --git a/test/Database.hs b/test/Database.hs index 8644d0df7..1317574a8 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -4,8 +4,8 @@ module Database , module Database.Fill ) where -import "uniworx" Import hiding (Option(..)) -import "uniworx" Application (db, getAppDevSettings) +import "uniworx" Import hiding (Option(..), getArgs) +import "uniworx" Application (db', getAppSettings) import UnliftIO.Pool (destroyAllResources) @@ -15,6 +15,7 @@ import Control.Monad.Logger import System.Console.GetOpt import System.Exit (exitWith, ExitCode(..)) import System.IO (hPutStrLn) +import System.Environment (getArgs, withArgs) import Database.Persist.Sql.Raw.QQ @@ -39,19 +40,19 @@ argsDescr = main :: IO () main = do args <- map unpack <$> getArgs - case getOpt Permute argsDescr args of - (acts@(_:_), [], []) -> forM_ acts $ \case + case getOpt' Permute argsDescr args of + (acts@(_:_), nonOpts, unrecOpts, []) -> withArgs (unrecOpts ++ nonOpts) . forM_ acts $ \case DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet - settings <- liftIO getAppDevSettings + settings <- liftIO getAppSettings withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do [executeQQ|drop owned by current_user|] :: ReaderT SqlBackend _ () - DBTruncate -> db $ do + DBTruncate -> db' $ do foundation <- getYesod liftIO . destroyAllResources $ appConnPool foundation truncateDb - DBMigrate -> db $ return () - DBFill -> db $ fillDb - (_, _, errs) -> do + DBMigrate -> db' $ return () + DBFill -> db' $ fillDb + (_, _, _, errs) -> do forM_ errs $ hPutStrLn stderr hPutStrLn stderr $ usageInfo "uniworxdb" argsDescr exitWith $ ExitFailure 2 From 286407252afdeeb6c6d0f054eb3f4a68faa098cf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 13:04:47 +0200 Subject: [PATCH 06/14] chore: use better exit code for "migration needed" --- src/Application.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Application.hs b/src/Application.hs index cd87498a4..9566dee7a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -234,7 +234,7 @@ makeFoundation appSettings'@AppSettings{..} = do migrateAll `runSqlPool` sqlPool | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do $logErrorS "setup" "Migration required" - liftIO . exitWith $ ExitFailure 2 + liftIO . exitWith $ ExitFailure 130 $logDebugS "setup" "Cluster-Config" appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool From 02056207360405fb3a4a99d1e623b993192828f4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 13:06:56 +0200 Subject: [PATCH 07/14] chore: improve deployment script --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 48adc6a88..456bbaba6 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -169,7 +169,7 @@ frontend:test: deploy:uniworx3: stage: deploy script: - - ssh -i ~/.ssh/id root@uniworx3.ifi.lmu.de Date: Wed, 14 Oct 2020 13:13:41 +0200 Subject: [PATCH 08/14] chore(release): 20.12.0 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 390b4a24f..0b207c084 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [20.12.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.11.1...v20.12.0) (2020-10-14) + + +### Features + +* **ldap:** expose active directory errors ([51ed7e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/51ed7e0a26a94d2178a4ca10ad7ea36b99076b54)) + ### [20.11.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.11.0...v20.11.1) (2020-10-14) diff --git a/package-lock.json b/package-lock.json index 863e8b427..85a204976 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.11.1", + "version": "20.12.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 3d3fd829c..f467a3705 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.11.1", + "version": "20.12.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 5d3e8bc73..0e3576f99 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.11.1 +version: 20.12.0 dependencies: - base From c8d83aeb933f740dd8a0aa8866b5902e3654f4fc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 15:50:01 +0200 Subject: [PATCH 09/14] chore(deployment): quiet zip production --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 456bbaba6..d962f3367 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -169,7 +169,7 @@ frontend:test: deploy:uniworx3: stage: deploy script: - - zip -j - bin/uniworx bin/uniworxdb | ssh root@uniworx3.ifi.lmu.de /root/bin/accept_uni2work + - zip -qj - bin/uniworx bin/uniworxdb | ssh root@uniworx3.ifi.lmu.de /root/bin/accept_uni2work needs: - yesod:build - frontend:test # For sanity From ea95d74cb5572688531ba0fdeed3983fb70ab236 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 16:24:21 +0200 Subject: [PATCH 10/14] fix(migration): don't consider changelog in requiresMigration --- src/Model/Migration.hs | 43 ++++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index a1fe221e1..4c0b6ea0b 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -110,6 +110,9 @@ migrateAll = do $logDebugS "Migration" "Persistent automatic migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' + $logDebugS "Migration" "Migrations marked as ‘always safe’" + mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAlwaysSafe + requiresMigration :: forall m. ( MonadLogger m , MonadResource m @@ -131,6 +134,8 @@ requiresMigration = mapReaderT (exceptT return return) $ do $logInfoS "Migration" $ intercalate "; " automatic throwError True + -- Does not consider `migrateAlwaysSafe` + return False initialMigration :: Migration @@ -172,19 +177,6 @@ migrateManual = do , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" ) , ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" ) ] - - recordedChangelogItems <- lift . lift $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] [] - let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems' - where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ] - unless (null missingChangelogItems) $ do - now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - addMigration False $ - let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|] - vals = Text.intercalate ", " $ do - item <- missingChangelogItems - return [st|('#{toPathPiece item}', '#{now}')|] - in sql - where addIndex :: Text -> Sql -> Migration addIndex ixName ixDef = do @@ -194,6 +186,23 @@ migrateManual = do _other -> return True unless alreadyDefined $ addMigration False ixDef +migrateAlwaysSafe :: Migration +-- | Part of `migrateAll` but not checked in `requiresMigration` +migrateAlwaysSafe = do + recordedChangelogItems <- lift . lift $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] [] + let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems' + where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ] + unless (null missingChangelogItems) $ do + now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + addMigration False $ do + let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|] + vals = Text.intercalate ", " $ do + item <- missingChangelogItems + let itemDay = case Map.lookup item changelogItemDays of + Just d -> iso8601Show d + Nothing -> now + return [st|('#{toPathPiece item}', '#{itemDay}')|] + in sql {- Confusion about quotes, from the PostgreSQL Manual: @@ -979,13 +988,7 @@ customMigrations = Map.fromListWith (>>) |] ) , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|] - , unlessM (tableExists "changelog_item_first_seen") $ do - [executeQQ| - CREATE TABLE "changelog_item_first_seen" (PRIMARY KEY ("item"), "item" VARCHAR NOT NULL, "first_seen" DATE NOT NULL); - |] - insertMany_ [ ChangelogItemFirstSeen{..} - | (changelogItemFirstSeenItem, changelogItemFirstSeenFirstSeen) <- Map.toList changelogItemDays - ] + , return () -- Unused; used to create and fill `ChangelogItemFirstSeen` ) ] From b631ed7d0620748fd833c4cda4b421dc147d0906 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 16:24:54 +0200 Subject: [PATCH 11/14] fix(auth): prettier active directory errors in help messages --- src/Auth/LDAP.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index c8e49ab16..471e59dd7 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -219,8 +219,8 @@ campusLogin pool mode = AuthPlugin{..} , isUnusualADError adError -> do $logInfoS apName [st|#{campusIdent}: #{toPathPiece adError}|] observeLoginOutcome apName LoginADInvalidCredentials - setSessionJson SessionError . InternalError $ toPathPiece adError MsgRenderer mr <- liftHandler getMsgRenderer + setSessionJson SessionError . PermissionDenied . mr $ ADInvalidCredentials adError loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError Right (Left bindErr) -> do case bindErr of From f1ba4659acf557f57bfcf349a72598f7de525693 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 16:30:39 +0200 Subject: [PATCH 12/14] chore(gitlab-ci): better caching --- .gitlab-ci.yml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d962f3367..db4ef096a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,7 +1,7 @@ default: image: name: fpco/stack-build:lts-16.11 - cache: + cache: &global_cache paths: - node_modules - .stack @@ -57,6 +57,9 @@ npm install: interruptible: true frontend:build: + cache: + <<: *global_cache + policy: pull stage: frontend:build script: - npm run frontend:build @@ -146,6 +149,9 @@ yesod:build: resource_group: ram frontend:test: + cache: + <<: *global_cache + policy: pull stage: test script: - npm run frontend:test @@ -167,6 +173,7 @@ frontend:test: interruptible: true deploy:uniworx3: + cache: {} stage: deploy script: - zip -qj - bin/uniworx bin/uniworxdb | ssh root@uniworx3.ifi.lmu.de /root/bin/accept_uni2work From 3f5b5727e3ff21491dfcfae325bde4db81d13c0d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 16:43:55 +0200 Subject: [PATCH 13/14] refactor: hlint --- src/Model/Migration.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 4c0b6ea0b..f38c00af5 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -193,15 +193,13 @@ migrateAlwaysSafe = do let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems' where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ] unless (null missingChangelogItems) $ do - now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime addMigration False $ do let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|] vals = Text.intercalate ", " $ do item <- missingChangelogItems - let itemDay = case Map.lookup item changelogItemDays of - Just d -> iso8601Show d - Nothing -> now - return [st|('#{toPathPiece item}', '#{itemDay}')|] + let itemDay = Map.findWithDefault today item changelogItemDays + return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] in sql {- From 46fda627098c155473a2f00acd1e93ee7f54eb9e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 14 Oct 2020 16:44:32 +0200 Subject: [PATCH 14/14] chore(release): 20.12.1 --- CHANGELOG.md | 8 ++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 11 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0b207c084..87274836d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +### [20.12.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.12.0...v20.12.1) (2020-10-14) + + +### Bug Fixes + +* **auth:** prettier active directory errors in help messages ([b631ed7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b631ed7d0620748fd833c4cda4b421dc147d0906)) +* **migration:** don't consider changelog in requiresMigration ([ea95d74](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ea95d74cb5572688531ba0fdeed3983fb70ab236)) + ## [20.12.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.11.1...v20.12.0) (2020-10-14) diff --git a/package-lock.json b/package-lock.json index 85a204976..aada929cb 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.12.0", + "version": "20.12.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index f467a3705..7270318df 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.12.0", + "version": "20.12.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 0e3576f99..e89d9721b 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.12.0 +version: 20.12.1 dependencies: - base