Commit 55a44b17 authored by Sophie Herold's avatar Sophie Herold 🌼

Starts full schema inquire from database

parent 9c8d0a22
Pipeline #789 passed with stage
in 4 minutes and 16 seconds
......@@ -32,7 +32,8 @@ library
DeriveGeneric,
FlexibleContexts,
FlexibleInstances,
OverloadedStrings
OverloadedStrings,
QuasiQuotes
other-extensions:
GADTs,
......@@ -124,10 +125,15 @@ test-suite hamsql-tests
type: exitcode-stdio-1.0
main-is: test/hamsql-tests.hs
hs-source-dirs: . test
default-extensions:
OverloadedStrings
build-depends:
base >=4.8 && <5.0,
hamsql,
directory,
safe-exceptions,
postgresql-simple,
transformers,
-- test
tasty,
tasty-hunit,
......
......@@ -8,6 +8,8 @@
module Database.HamSql.Internal.DbUtils where
import Control.Exception
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader
import qualified Data.ByteString.Char8 as B
import Data.String
import qualified Data.Text as T
......@@ -21,6 +23,22 @@ import Database.HamSql.Internal.Stmt
import Database.HamSql.Internal.Utils
import Database.YamSql
type SqlT = ReaderT Connection IO
psqlQry
:: (ToRow q, FromRow r)
=> Query -> q -> SqlT [r]
psqlQry template qs = do
conn <- ask
lift $ query conn template qs
psqlQry_
:: (FromRow r)
=> Query -> SqlT [r]
psqlQry_ que = do
conn <- ask
lift $ query_ conn que
sqlErrObjectInUse :: B.ByteString
sqlErrObjectInUse = "55006"
......@@ -34,10 +52,12 @@ logStmt opt x =
Just filename -> TIO.appendFile filename (x <> "\n")
getConUrl :: OptCommonDb -> URI
getConUrl optDb = appendQuery "application_name=hamsql" uri
getConUrl = getConUrlApp "hamsql" . optConnection
getConUrlApp :: String -> String -> URI
getConUrlApp app str = appendQuery ("application_name=" <> app) uri
where
uri =
fromJustReason "Not a valid URI" (parseAbsoluteURI $ optConnection optDb)
uri = fromJustReason "Not a valid URI" (parseAbsoluteURI $ str)
appendQuery v u =
u
{ uriQuery =
......
......@@ -6,6 +6,7 @@ module Database.HamSql.Internal.InquireDeployed where
import Data.Text (stripPrefix)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Database.PostgreSQL.Simple.Types (PGArray(..), fromPGArray)
import Database.HamSql.Internal.DbUtils
......@@ -13,6 +14,62 @@ import Database.HamSql.Internal.Utils
import Database.HamSql.Setup
import Database.YamSql
deployedTables :: SqlName -> SqlT [Table]
deployedTables schema = do
tbls <- psqlQry qry (Only $ toSqlCode schema)
sequence $ map toTable tbls
where
toTable (table, pname) = do
columns <- deployedColumns (schema, table)
return $
Table
{ tableName = table
, tableDescription = "x"
, tableColumns = columns
, tablePrimaryKey = [pname]
, tableUnique = Nothing
, tableForeignKeys = Nothing
, tableChecks = Nothing
, tableInherits = Nothing
, tablePrivSelect = Nothing
, tablePrivInsert = Nothing
, tablePrivUpdate = Nothing
, tablePrivDelete = Nothing
, tableTemplates = Nothing
}
qry =
[sql|
SELECT table_name, table_name
FROM information_schema.tables
WHERE table_schema::regnamespace = ?::regnamespace
|]
deployedColumns :: (SqlName, SqlName) -> SqlT [Column]
deployedColumns tbl = map toColumn <$> psqlQry qry (Only $ toSqlCode tbl)
where
toColumn (sname, dataType, columnDefault') =
Column
{ columnName = sname
, columnType = dataType
, columnDescription = "x"
, columnDefault = columnDefault'
, columnNull = Nothing
, columnReferences = Nothing
, columnOnRefDelete = Nothing
, columnOnRefUpdate = Nothing
, columnUnique = Nothing
, columnChecks = Nothing
}
qry =
[sql|
SELECT
column_name,
COALESCE(domain_schema || '.' || domain_name, data_type),
column_default
FROM information_schema.columns
WHERE (table_schema || '.' || table_name)::regclass = ?::regclass
|]
sqlManageSchemaJoin :: Text -> Text
sqlManageSchemaJoin schemaid =
" JOIN pg_namespace AS n " <\> " ON" <-> schemaid <-> "= n.oid AND " <\>
......
......@@ -17,7 +17,6 @@ data Table = Table
, tablePrivUpdate :: Maybe [SqlName]
, tablePrivDelete :: Maybe [SqlName]
, tableTemplates :: Maybe [SqlName]
, tableTemplateData :: Maybe [TableTpl]
} deriving (Data, Generic, Show)
instance FromJSON Table where
......
......@@ -117,10 +117,10 @@ instance Eq SqlName where
(==) x y = toSqlCode x == toSqlCode y
instance ToSqlCode SqlName where
toSqlCode (SqlName n) =
toSqlCode n'@(SqlName n) =
if '"' `isIn` n
then n
else toSqlCode' $ expSqlName $ SqlName n
else toSqlCode' $ expSqlName n'
instance SqlIdentifierConcat SqlName where
(//) (SqlName s) (SqlName t) = SqlName (s <> t)
......@@ -188,6 +188,9 @@ newtype SqlName =
SqlName Text
deriving (Generic, Ord, Show, Data)
unsafeInternalName :: SqlName -> Text
unsafeInternalName (SqlName x) = x
instance FromJSON SqlName where
parseJSON = genericParseJSON myOpt
......
module Main where
import System.Directory
import Control.Exception.Safe
import Control.Monad.Trans.Reader (runReaderT)
import Database.PostgreSQL.Simple
import System.Exit
--import System.Directory
import Test.Tasty
import Test.Tasty.HUnit
import Database.HamSql.Cli
import Database.HamSql.Internal.DbUtils
import Database.HamSql.Internal.InquireDeployed
import Database.YamSql.Internal.SqlId (SqlName(..))
main :: IO ()
main = defaultMain tests
conn :: IO Connection
conn =
pgsqlConnectUrl $
getConUrlApp "hamsql-test" "postgresql://postgres@/carnivora"
tests :: TestTree
tests =
tests = testGroup "Integration Tests" [integrationTests, integrationTests2, abc]
abc :: TestTree
abc =
testGroup
"Integration Tests"
[testCase "1" (exec ["--help"]), integrationTests]
"grp3"
[ testCase "setups/domain.yml" $
exec'
[ "install"
, "--permit-data-deletion"
, "-ds"
, "test/setups/domain.yml"
, "-c"
, "postgresql://postgres@/test1"
]
, xx
]
xx :: TestTree
xx =
testCase "tables" $ do
tables <- conn >>= runReaderT (deployedTables $ SqlName "web")
print $ show tables
integrationTests2 :: TestTree
integrationTests2 = testCase "x" $ exec' ["--help"]
integrationTests :: TestTree
integrationTests =
testCase "x" $
--exec ["--help"]
do
exec
[ "install"
, "-s"
, "test/setups/invalid.yml"
, "-c"
, "postgresql://postgres@/test1"
]
getCurrentDirectory >>= putStrLn
exec xs = parseThisArgv xs >>= run
testCase "y" $ do
r <-
exec
(ExitFailure 1)
[ "install"
, "-s"
, "test/setups/invalid.yml"
, "-c"
, "postgresql://postgres@/test1"
]
r @? "Should fail"
exec
:: (Eq e, Exception e)
=> e -> [String] -> IO Bool
exec y xs =
handle (\x -> return $ x == y) (parseThisArgv xs >>= run >> return True)
exec' :: [String] -> Assertion
exec' xs = do
r <- exec ExitSuccess xs
r @? "Exec should not fail"
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment