diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 48adc6a88..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,9 +173,10 @@ frontend:test: interruptible: true deploy:uniworx3: + cache: {} stage: deploy script: - - ssh -i ~/.ssh/id root@uniworx3.ifi.lmu.de =0.2 - parsec + - parsec-numbers - attoparsec - uuid - exceptions diff --git a/src/Application.hs b/src/Application.hs index 50feb8b4d..970337dc8 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 @@ -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{..} diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 007178793..471e59dd7 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 + 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 -> 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 c70fe827f..02a5d6394 100644 --- 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" <>) 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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index c8512223b..f409abc86 100644 --- 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) 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/Model/Migration.hs b/src/Model/Migration.hs index a1fe221e1..f38c00af5 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,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` ) ] 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/stack.yaml b/stack.yaml index a34917221..87b3b255d 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 6bfec429d..278298787 100644 --- 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 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 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