Merge branch 'master' into workflows

2020-10-14 17:01:31 +02:00 · 2020-10-14 17:01:31 +02:00 · ddd1dd5df4
commit ddd1dd5df4
parent 6cd9f9bbfd 46fda62709
22 changed files with 315 additions and 49 deletions
--- 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,9 +173,10 @@ frontend:test:
  interruptible: true

 deploy:uniworx3:
+  cache: {}
  stage: deploy
  script:
-    - ssh -i ~/.ssh/id root@uniworx3.ifi.lmu.de <bin/uniworx
+    - zip -qj - bin/uniworx bin/uniworxdb | ssh root@uniworx3.ifi.lmu.de /root/bin/accept_uni2work
  needs:
    - yesod:build
    - frontend:test # For sanity
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -2,6 +2,28 @@

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


--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@ -2796,7 +2796,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
@ -2968,4 +2968,16 @@ WorkflowDescriptionTitle: Titel
 WorkflowDescription: Beschreibung

 ChangelogItemFeature: Feature
-ChangelogItemBugfix: Bugfix
+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
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@ -2770,7 +2770,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
@ -2922,3 +2922,15 @@ WorkflowDefinitionDeleted: Successfully deleted workflow definition

 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
--- a/package-lock.json
+++ b/package-lock.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "20.11.0",
+  "version": "20.12.1",
  "lockfileVersion": 1,
  "requires": true,
  "dependencies": {
--- a/package.json
+++ b/package.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "20.11.0",
+  "version": "20.12.1",
  "description": "",
  "keywords": [],
  "author": "",
--- a/package.yaml
+++ b/package.yaml
@ -1,5 +1,5 @@
 name:    uniworx
-version: 20.11.0
+version: 20.12.1

 dependencies:
  - base
@ -70,6 +70,7 @@ dependencies:
  - blaze-html
  - conduit-resumablesink >=0.2
  - parsec
+  - parsec-numbers
  - attoparsec
  - uuid
  - exceptions
--- 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

@ -235,7 +235,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
@ -620,17 +620,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{..}
--- 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
+                MsgRenderer mr <- liftHandler getMsgRenderer
+                setSessionJson SessionError . PermissionDenied . mr $ ADInvalidCredentials adError
+                loginErrorMessage (tp LoginR) . mr $ ADInvalidCredentials adError
          Right (Left bindErr) -> do
            case bindErr of
              Ldap.ResponseErrorCode _ _ _ errTxt -> 
--- a/src/Auth/LDAP/AD.hs
+++ 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 <https://ldapwiki.com/wiki/Common%20Active%20Directory%20Bind%20Errors>
+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 ", ")
--- a/src/Foundation/I18n.hs
+++ b/src/Foundation/I18n.hs
@ -232,6 +232,8 @@ embedRenderMessage ''UniWorX ''AuthenticationMode id

 embedRenderMessage ''UniWorX ''RatingValidityException id

+embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" <>)
+
 newtype ShortSex = ShortSex Sex
 embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)

--- 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
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@ -177,6 +177,7 @@ 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 Text.Shakespeare.Text.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)
--- a/src/Ldap/Client/Instances.hs
+++ 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
--- 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,21 @@ 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
+    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 = Map.findWithDefault today item changelogItemDays
+            return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|]
+       in sql

 {-
  Confusion about quotes, from the PostgreSQL Manual:
@ -979,13 +986,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`
    )
  ]

--- 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)
--- 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
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@ -96,6 +96,17 @@ packages:
    subdir: serversession-backend-acid-state
    git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
    commit: 1c95b0100471279413485411032d639881012a5e
+- completed:
+    name: xss-sanitize
+    version: 0.3.6
+    git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git
+    pantry-tree:
+      size: 750
+      sha256: f567a1c834448daaa164f2029fad164e6c8df2d4c92b51f811bae19cc0c95975
+    commit: dc928c3a456074b8777603bea20e81937321777f
+  original:
+    git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git
+    commit: dc928c3a456074b8777603bea20e81937321777f
 - completed:
    subdir: colonnade
    name: colonnade
@ -120,6 +131,71 @@ packages:
  original:
    git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
    commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
+- completed:
+    subdir: cryptoids-class
+    name: cryptoids-class
+    version: 0.0.0
+    git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
+    pantry-tree:
+      size: 412
+      sha256: 30466648d273ffb1d580b7961188d67a0bedb3703d6d5f8cca3c15a45295f203
+    commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
+  original:
+    subdir: cryptoids-class
+    git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
+    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: 320
+      sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e
+    commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
+  original:
+    subdir: cryptoids-types
+    git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
+    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: 566
+      sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb
+    commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
+  original:
+    subdir: cryptoids
+    git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
+    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: 676
+      sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9
+    commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
+  original:
+    subdir: filepath-crypto
+    git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
+    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: 417
+      sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4
+    commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
+  original:
+    subdir: uuid-crypto
+    git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
+    commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3
 - completed:
    subdir: gearhash
    name: gearhash
--- a/templates/i18n/changelog/ldap-ad-errors.de-de-formal.hamlet
+++ b/templates/i18n/changelog/ldap-ad-errors.de-de-formal.hamlet
@ -0,0 +1,2 @@
+$newline never
+Bessere Fehlermeldungen bei fehlgeschlagenem Login
--- a/templates/i18n/changelog/ldap-ad-errors.en-eu.hamlet
+++ b/templates/i18n/changelog/ldap-ad-errors.en-eu.hamlet
@ -0,0 +1,2 @@
+$newline never
+Better error messages on failed login
--- a/test/Auth/LDAP/ADSpec.hs
+++ 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
--- 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