diff --git a/Database/Persist/HsSqlPpp.hs b/Database/Persist/HsSqlPpp.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/HsSqlPpp.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} +module Database.Persist.HsSqlPpp + (Query, + persistSql, + persistSqlFile, + parseEntityFromFile, + parseEntity, + selectFromQuery, + selectFromQuery', + checkSQL + ) where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.Trans +import Control.Monad.Error +import Control.Monad.Instances +import Control.Monad.IO.Control +import Data.Char +import Data.List (intercalate) +import qualified Data.ByteString as B +import qualified Data.Text as Text +import Language.Haskell.TH +import qualified Language.Haskell.TH.Lift as THL +import qualified Language.Haskell.TH.Syntax as TH +import Language.Haskell.TH.Quote + +import Database.Persist +import Database.Persist.Base +import Database.Persist.GenericSql.Raw +import qualified Database.Persist.GenericSql.Internal as I +import Database.Persist.TH + +import Database.HsSqlPpp.Types as Types +import Database.HsSqlPpp.Ast as AST +import Database.HsSqlPpp.Annotation +import Database.HsSqlPpp.Catalog +import Database.HsSqlPpp.Parser +import Database.HsSqlPpp.Pretty + +-- | Pairs (column name, column type) +type Types = [(String, String)] + +-- | (SQL query text, entity definition) +type Query = (QueryExpr, EntityDef) + +class IsName x where + name2string :: x -> String + +instance IsName String where + name2string = id + +instance IsName AST.Name where + name2string (AST.Name _ list) = name2string list + +instance IsName NameComponent where + name2string n = ncStr n + +instance IsName [NameComponent] where + name2string list = ncStr (last list) + +toString :: B.ByteString -> String +toString bs = map (chr . fromIntegral) (B.unpack bs) + +THL.deriveLift ''SelectItem +THL.deriveLift ''SelectList +THL.deriveLift ''Distinct +THL.deriveLift ''FrameClause +THL.deriveLift ''TypeName +THL.deriveLift ''LiftFlavour +THL.deriveLift ''IntervalField +THL.deriveLift ''InList +THL.deriveLift ''ExtractField +THL.deriveLift ''ScalarExpr +THL.deriveLift ''Direction +THL.deriveLift ''TableAlias +THL.deriveLift ''NameComponent +THL.deriveLift ''AST.Name +THL.deriveLift ''JoinExpr +THL.deriveLift ''JoinType +THL.deriveLift ''Natural +THL.deriveLift ''TableRef +THL.deriveLift ''CombineType +THL.deriveLift ''WithQuery +THL.deriveLift ''TypeError +THL.deriveLift ''FunFlav +THL.deriveLift ''CastContext +THL.deriveLift ''PseudoType +THL.deriveLift ''Types.Type +THL.deriveLift ''CatalogUpdate +THL.deriveLift ''Annotation +THL.deriveLift ''QueryExpr + +allE :: (a -> Either e b) -> b -> [a] -> Either e b +allE _ b [] = Right b +allE fn b (x:xs) = + case fn x of + Left e -> Left e + Right _ -> allE fn b xs + +(<&>) :: Either String a -> Either String a -> (a -> Either String a) +(Right _) <&> (Right _) = Right +(Right _) <&> (Left e) = \_ -> Left e +(Left e) <&> (Right _) = \_ -> Left e +(Left e) <&> (Left e') = \_ -> Left (e ++ "; " ++ e') + +emptyAnn :: Annotation +emptyAnn = Annotation Nothing Nothing [] Nothing [] Nothing Nothing + +makeQuery :: (PersistEntity t) => I.Connection -> QueryExpr -> [Filter t] -> Either String QueryExpr +makeQuery conn query filts = foldM (addWhere conn) query filts + +addWhere :: (PersistEntity t) => I.Connection -> QueryExpr -> Filter t -> Either String QueryExpr +addWhere conn (Select ann dist fields trefs old a b c d e) filt = Right $ Select ann dist fields trefs (Just $ convertCond conn filt old) a b c d e +addWhere _ x _ = Left $ "Unsupported query expr in addWhere: " ++ show x + +name :: String -> AST.Name +name s = Name emptyAnn [Nmc s] + +convertCond :: (PersistEntity t) => I.Connection -> Filter t -> Maybe ScalarExpr -> ScalarExpr +convertCond conn f Nothing = convertFilter conn f +convertCond conn f (Just old) = FunCall emptyAnn (name "!and") [convertFilter conn f, old] + +convertFilter conn (Filter field value op) = + FunCall emptyAnn (name $ showSqlFilter op) (Identifier emptyAnn (Nmc fname): allVals) + where + allVals = map persist2expr $ filterValueToPersistValues value + + persist2expr (PersistText t) = StringLit emptyAnn (Text.unpack t) + persist2expr (PersistByteString bstr) = StringLit emptyAnn (toString bstr) + persist2expr (PersistInt64 i) = NumberLit emptyAnn (show i) + persist2expr (PersistDouble x) = NumberLit emptyAnn (show x) + persist2expr (PersistBool b) = BooleanLit emptyAnn b + persist2expr (PersistDay d) = StringLit emptyAnn (show d) + persist2expr (PersistTimeOfDay tod) = StringLit emptyAnn (show tod) + persist2expr (PersistUTCTime t) = StringLit emptyAnn (show t) + persist2expr (PersistNull) = NullLit emptyAnn + persist2expr x = error $ "persist2expr: unsupported Persistent value in filter: " ++ show x + + filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue] + filterValueToPersistValues v = map toPersistValue $ either return id v + + fname = I.escapeName conn $ getFieldName t $ columnName $ persistColumnDef field + t = entityDef $ dummyFromFilts [Filter field value op] + + getFieldName :: EntityDef -> String -> I.RawName + getFieldName t s = I.rawFieldName $ tableColumn t s + +-- This is copy-paste from Database.Persist.GenericSql.Internal +showSqlFilter Eq = "=" +showSqlFilter Ne = "<>" +showSqlFilter Gt = ">" +showSqlFilter Lt = "<" +showSqlFilter Ge = ">=" +showSqlFilter Le = "<=" +showSqlFilter In = " IN " +showSqlFilter NotIn = " NOT IN " +showSqlFilter (BackendSpecificFilter s) = s + +dummyFromFilts :: [Filter v] -> v +dummyFromFilts _ = error "dummyFromFilts" + +tableColumn :: EntityDef -> String -> ColumnDef +tableColumn t s | s == id_ = ColumnDef id_ "Int64" [] + where id_ = I.unRawName $ I.rawTableIdName t +tableColumn t s = go $ entityColumns t + where + go [] = error $ "Unknown table column: " ++ s + go (ColumnDef x y z:rest) + | x == s = ColumnDef x y z + | otherwise = go rest +-- End of copy-paste + +-- | Convert SELECT query +convertSelect :: Types -> QueryExpr -> Either String EntityDef +convertSelect types (Select _ _ (SelectList _ items) _ _ _ _ _ _ _) = + EntityDef <$> return "Undefined" + <*> return [] + <*> mapM (convertColumn types) items + <*> return [] + <*> return ["Eq", "Show"] +convertSelect _ expr = Left $ "Unsupported SQL query syntax in " ++ printQueryExpr expr + +getColumnNames :: QueryExpr -> Either String [ColumnName] +getColumnNames (Select _ _ (SelectList _ items) _ _ _ _ _ _ _) = + mapM getColumnName items +getColumnNames expr = Left $ "Unsupported SQL query syntax in " ++ printQueryExpr expr + +checkSelect :: [String] -> QueryExpr -> Either String QueryExpr +checkSelect tables s@(Select _ _ (SelectList _ items) trefs _ _ _ _ _ _) = + (allE goodTref s trefs <&> allE goodCol s items) s + where + goodTref (FunTref _ _ a) = Left $ "Function call as table reference is not allowed: " ++ show a + goodTref (JoinTref _ t1 _ _ t2 _ _) = (goodTref t1 <&> goodTref t2) s + goodTref (SubTref _ q _) = checkSelect tables q + goodTref (Tref _ n@(Name _ list) _) = + let tname = lowerName n + in if tname `elem` tables + then Right s + else Left $ "Table reference is not allowed: " ++ tname + + goodCol (SelExp _ expr) = goodExpr expr + goodCol (SelectItem _ expr _) = goodExpr expr + + goodExpr (FunCall _ fn args) = + let name = map toLower (name2string fn) + in if name `elem` ["count", "max", "min", "avg", "sum"] + then allE goodExpr s args + else Left $ "Function call not allowed: " ++ name2string fn + goodExpr (ScalarSubQuery _ q) = checkSelect tables q + goodExpr (Case {}) = Left "CASE expressions are not allowed" + goodExpr (CaseSimple {}) = Left "CASE expressions are not allowed" + goodExpr (Cast {}) = Left "CAST expressions are not allowed" + goodExpr (Exists _ q) = checkSelect tables q + goodExpr (Extract {}) = Left "EXTRACT expressions are not allowed" + goodExpr (InPredicate _ e _ (InList _ es)) = (goodExpr e <&> allE goodExpr s es) s + goodExpr (InPredicate _ e _ (InQueryExpr _ q)) = (goodExpr e <&> checkSelect tables q) s + goodExpr (LiftOperator _ _ _ es) = allE goodExpr s es + goodExpr (QIdentifier _ _) = Right s --- !? + goodExpr (WindowFn {}) = Left "WINDOW functions are not allowed" + goodExpr _ = Right s +checkSelect _ q = Left $ "Non-SELECT query forbidden: " ++ printQueryExpr q + +getConnection :: (MonadControlIO m) => SqlPersist m I.Connection +getConnection = SqlPersist ask + +-- | Select list of records from DB using given SQL query +selectFromQuery :: forall m a. (MonadControlIO m, PersistEntity a) + => QueryExpr -- ^ SQL query + -> [Filter a] -- ^ Filters + -> SqlPersist m (Either String [a]) +selectFromQuery query filts = do + conn <- getConnection + case makeQuery conn query filts of + Left err -> fail err + Right expr -> withStmt (Text.pack $ printQueryExpr expr) [] worker + where + worker :: I.RowPopper (SqlPersist m) -> SqlPersist m (Either String [a]) + worker popper = runErrorT (go popper) + + go popper = do + row <- lift popper + case row of + Nothing -> return [] + Just list -> case fromPersistValues list of + Left err -> fail err + Right rec -> do + next <- go popper + return (rec: next) + +-- | Check if given SQL query is safe SELECT query +checkSQL :: [String] -- ^ Allowed table names + -> String -- ^ SQL query + -> Either String QueryExpr +checkSQL tables query = do + (expr,_) <- parseSelect "" query + checkSelect tables expr + +-- | Select list of records from DB using given SQL SELECT query. +-- Query is checked for safety (arbitrary function calls, +-- complex expressions, etc are not permitted). +-- Each row will be represented as [PersistValue]. +selectFromQuery' :: (MonadControlIO m) + => [String] -- ^ Names of allowed tables + -> String -- ^ SQL query + -> SqlPersist m (Either String ([ColumnName], [[PersistValue]])) +selectFromQuery' tables query = do + case parseSelect "" query of + Left err -> return (Left err) + Right (expr, names) -> + case checkSelect tables expr of + Right _ -> do + rows <- withStmt (Text.pack query) [] worker + return $ Right (names, rows) + Left err -> return $ Left $ "Forbidden query: " ++ err + where + worker popper = do + row <- popper + case row of + Nothing -> return [] + Just rec -> do + next <- worker popper + return (rec: next) + +-- | Quasi-quoter which parses SQL SELECT queries. +-- Example input: +-- +-- @ +-- SELECT family, salary FROM employee; +-- -------------------- +-- family String +-- salary Int +-- @ +-- +-- NB: entity name will be \"Undefined\", so +-- you'll need to use record update syntax to +-- set name your want, e.g. entity {entityName = \"Query\"}. +persistSql :: QuasiQuoter +persistSql = QuasiQuoter { + quoteExp = \str -> case parseEntity "" str of + Right expr -> TH.lift expr + Left err -> fail err, + quotePat = undefined, + quoteType = undefined, + quoteDec = undefined } + +-- | Load entity declaration from file containing SQL query. +-- TH version. +persistSqlFile :: FilePath -> Q [Exp] +persistSqlFile path = do + entity <- runIO $ parseEntityFromFile path + x <- TH.lift entity + return [x] + +-- | Load entity declaration from file containing SQL query +parseEntityFromFile :: FilePath -> IO (Either String Query) +parseEntityFromFile path = do + text <- readFile path + return (parseEntity path text) + +-- | Parse SQL entity declaration +parseEntity :: FilePath -- ^ File name to use in error messages + -> String -- ^ Declaration text + -> Either String Query +parseEntity path text = + let delimiter str = not (null str) && all (`elem` "-= \t") str && any (`elem` "-=") str + (queryLines, _:typeLines) = break delimiter (lines text) + types = parseTypes typeLines + bad line = all (`elem` " \t") line + query = unlines $ filter (not . bad) queryLines + in parseSelectT path types $ query + +parseSelectT :: String -> Types -> String -> Either String Query +parseSelectT path types query = + case parseQueryExpr path query of + Left err -> Left $ "Cannot parse query expression: " ++ show err + Right expr -> do + res <- convertSelect types expr + return (expr, res) + +parseSelect :: String -> String -> Either String (QueryExpr, [ColumnName]) +parseSelect path query = do + case parseQueryExpr path query of + Left err -> Left (show err) + Right expr -> do + cols <- getColumnNames expr + return (expr, cols) + +parseTypes :: [String] -> Types +parseTypes = concatMap parseLine + where + parseLine line = + case words line of + [] -> [] + (name:other) -> [(name, unwords other)] + +lowerName :: IsName name => name -> String +lowerName n = map toLower (name2string n) + +lookupType :: (IsName name) => name -> Types -> Either String ColumnType +lookupType name ts = + case lookup (name2string name) ts of + Nothing -> Left $ "Do not know type of " ++ name2string name + Just typ -> return typ + +getColumnType :: Types -> SelectItem -> Either String ColumnType +getColumnType t (SelExp _ (Identifier _ name)) = lookupType name t +getColumnType t (SelExp _ (QIdentifier _ name)) = lookupType name t +getColumnType t (SelExp _ (FunCall _ fn args)) = getFuncType t (lowerName fn) args +getColumnType _ (SelExp _ expr) = Left $ "Cannot guess type of " ++ printScalarExpr expr +getColumnType t (SelectItem _ expr name) = + case lookup (name2string name) t of + Just typ -> return typ + Nothing -> getType t expr + +getColumnName :: SelectItem -> Either String ColumnName +getColumnName (SelExp _ (Identifier _ name)) = return (name2string name) +getColumnName (SelExp _ (QIdentifier _ name)) = return (name2string name) +getColumnName (SelExp _ (FunCall _ fn _)) = return (lowerName fn) +getColumnName (SelExp _ (QStar _ name)) = return (name2string name ++ ".*") +getColumnName (SelExp _ (Star _)) = return "*" +getColumnName (SelExp _ expr) = Left $ "Do not want invent the name for " ++ printScalarExpr expr +getColumnName (SelectItem _ _ name) = return (name2string name) + +convertColumn :: Types -> SelectItem -> Either String ColumnDef +convertColumn t s = + ColumnDef <$> getColumnName s <*> getColumnType t s <*> return [] + +getType :: Types -> ScalarExpr -> Either String ColumnType +getType _ (BooleanLit _ _) = return "Bool" +getType _ (Exists _ _) = return "Bool" +getType t (FunCall _ fn args) = getFuncType t (lowerName fn) args +getType _ (InPredicate _ _ _ _) = return "Bool" +getType _ (NumberLit _ _) = return "Int" +getType t (Identifier _ name) = lookupType name t +getType t (QIdentifier _ name) = lookupType name t +getType _ (StringLit _ _) = return "String" +getType _ x = Left $ "Unsupported scalar expression type: " ++ show x + +getFuncType :: Types -> String -> [ScalarExpr] -> Either String ColumnType +getFuncType t "max" [e] = getType t e +getFuncType t "min" [e] = getType t e +getFuncType t "sum" [e] = getType t e +getFuncType t "avg" [e] = getType t e +getFuncType _ "count" _ = return "Int" +getFuncType t fn args = + case lookup fn t of + Just typ -> return typ + Nothing -> Left $ "Cannot invent type for " ++ fn ++ show args + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, IlyaPortnov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of IlyaPortnov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, TypeFamilies, GADTs #-} + +import Control.Monad +import Database.Persist +import Database.Persist.Base +import Database.Persist.TH +import Database.Persist.Postgresql +import Database.Persist.HsSqlPpp +import Database.HsSqlPpp.Pretty + +-- We need to import EntityDef declaraion +-- to pass it to 'share' function because of +-- GHC stage restriction. +import TestSQL + +-- Generate instance PersistEntity Stats. +share [mkPersist sqlSettings] [entity {entityName = "Stats"}] +-- Note that usual persistent query functions, +-- such as 'selectList' or 'insert', would not +-- work with Stats type, because there is no "Stats" +-- table in the DB. Only way to get data from +-- this query is using 'selectFromQuery' function. + +-- A shortcut function to run DB actions +runPG :: SqlPersist IO (Either String a) -> IO a +runPG db = withPostgresqlConn "" $ runSqlConn $ do + res <- db + case res of + Right x -> return x + Left msg -> fail msg + +test :: IO () +test = do + putStrLn "Executing a query:" + putStrLn $ printQueryExpr queryText + list <- runPG $ selectFromQuery queryText [] + putStrLn "Query results:" + putStrLn "Department\tEmployee count\tAverage salary" + forM_ list $ \stat -> + putStrLn $ statsDept stat ++ "\t" ++ show (statsCount stat) ++ "\t" ++ show (statsAvg stat) + +printRow :: (a -> String) -> [a] -> IO () +printRow f list = do + forM_ list $ \str -> putStr (f str ++ "\t") + putStrLn "" + +allowedTables = ["employee", "department"] + +-- Now consider we want to execute a SELECT +-- query (maybe even query is received from user). +-- Almost arbitrary queries are allowed but only "safe" +-- (i.e., no saved functions calls, no complex constructs etc). +test2 :: IO () +test2 = do + let sql = "SELECT d.name AS dept, e.family FROM Employee e, Department d WHERE e.dept = d.id" + putStrLn "Executing a query:" + putStrLn sql + (columns, rows) <- runPG $ selectFromQuery' allowedTables sql + printRow id columns + forM_ rows (printRow show) + +testDialog :: IO () +testDialog = do + putStr "SQL> " + sql <- getLine + if sql == "quit" + then return () + else do + (columns, rows) <- runPG $ selectFromQuery' allowedTables sql + printRow id columns + forM_ rows (printRow show) + testDialog + diff --git a/persistent-hssqlppp.cabal b/persistent-hssqlppp.cabal new file mode 100644 --- /dev/null +++ b/persistent-hssqlppp.cabal @@ -0,0 +1,72 @@ +-- persistent-hssqlppp.cabal auto-generated by cabal init. For +-- additional options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: persistent-hssqlppp + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1 + +-- A short (one-line) description of the package. +Synopsis: Declare Persistent entities using SQL SELECT query syntax + +-- A longer description of the package. +Description: This package exports functions which could help to + declare Persistent entities using SQL SELECT query syntax. + See Test.hs, TestSQL.hs for example usage. + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: IlyaPortnov + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: portnov84@rambler.ru + +-- A copyright notice. +-- Copyright: + +Category: Database + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +Extra-source-files: Test.hs + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.6 + + +Library + -- Modules exported by the library. + Exposed-modules: Database.Persist.HsSqlPpp + + -- Packages needed in order to build this package. + Build-depends: base >= 4 && < 5, mtl >= 2, + persistent >= 0.6.3, + persistent-template >= 0.6.3, + hssqlppp >= 0.4.0, + template-haskell >= 2.6.0.0, + text >= 0.11.1.5, + bytestring, + th-lift >= 0.5.4, + monad-control >= 0.2.0.3 + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +Source-repository head + type: git + location: git://gitorious.org/persistent-hssqlppp/persistent-hssqlppp.git +