chore: have uniworxdb accept config file as argument

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
 
@@ -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{..}

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