Merge branch 'master' into workflows

.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

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)
 
 

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

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

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "20.11.0",
+  "version": "20.12.1",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "20.11.0",
+  "version": "20.12.1",
   "description": "",
   "keywords": [],
   "author": "",

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

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
+    , handler, handler'
-    , db
+    , 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{..}

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

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

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

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

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)

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

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
+    , return () -- Unused; used to create and fill `ChangelogItemFirstSeen`
-        [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
-                    ]
     )
   ]
 

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)

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

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

templates/i18n/changelog/ldap-ad-errors.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Bessere Fehlermeldungen bei fehlgeschlagenem Login

templates/i18n/changelog/ldap-ad-errors.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Better error messages on failed login

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

test/Database.hs

@@ -4,8 +4,8 @@ module Database
   , module Database.Fill
   ) where
 
-import "uniworx" Import hiding (Option(..))
+import "uniworx" Import hiding (Option(..), getArgs)
-import "uniworx" Application (db, getAppDevSettings)
+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
+  case getOpt' Permute argsDescr args of
-    (acts@(_:_), [], []) -> forM_ acts $ \case
+    (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 ()
+      DBMigrate -> db' $ return ()
-      DBFill    -> db $ fillDb
+      DBFill    -> db' $ fillDb
-    (_, _, errs) -> do
+    (_, _, _, errs) -> do
       forM_ errs $ hPutStrLn stderr
       hPutStrLn stderr $ usageInfo "uniworxdb" argsDescr
       exitWith $ ExitFailure 2