diff --git a/HESQL/Parser.hs b/HESQL/Parser.hs --- a/HESQL/Parser.hs +++ b/HESQL/Parser.hs @@ -10,7 +10,9 @@ import Database.HDBC import Control.Monad (forM_) +import Database.HsSqlPpp.Parsing.Parser + hesqlModule :: Parser HesqlModule hesqlModule = do whiteSpace @@ -28,34 +30,52 @@ whiteSpace char '=' whiteSpace - stmt <- sqlStatement + maybeOpt <- maybeOpt + stmtStr <- sqlStatement whiteSpace - symbol ";" - return $ HesqlDecls fn p stmt + stmt <- + case parseSql stmtStr of + Right [stmt] -> return stmt + Left e -> error $ show e -- TODO proper error message, handle other Right cases + return $ HesqlDecls fn p maybeOpt stmt +maybeOpt = + (reserved "maybe" >> return True) <|> return False +sqlStatement :: Parser String +sqlStatement = do + s <- many (noneOf "\"';") + r <- sqlStatement' + return $ s ++ r -funName = identifier -parameter = identifier +sqlStatement' = do + r <- sqlQuoted "\"" <|> sqlQuoted "'" <|> sqlTerminator + if (r == ";") + then return r + else do + s <- sqlStatement + return $ r++s + -sqlStatement = - selectStatement <|> - insertStatement <|> - updateStatement <|> - deleteStatement - -selectStatement = do - opts <- selectVariant - cols <- sepBy1 sqlExp (symbol ",") - tab <- optionMaybe (reserved "from" >> table) - wh <- optionMaybe whereCondition - ord <- optionMaybe order - return $ SELECT opts - (ExplicitColumns $ map (flip (,) Nothing) cols) tab - wh ord Nothing + +sqlQuoted s = do + l <- between (string s) (string s) $ many qchars + return $ s ++ concat l ++ s + where qchars = many1 (noneOf ('\\':s)) <|> do + c <- char '\\' + q <- anyChar + return ['\\', q] +sqlTerminator = string ";" + + + +funName = identifier +parameter = identifier + + order = do reserved "order" reserved "by" @@ -67,11 +87,6 @@ orderDir = (reserved "asc" >> return ASC)<|> (reserved "desc" >> return DESC) -selectVariant = - select "1'" [Strict, ReturnMaybe] <|> - select "1" [ReturnMaybe] <|> - select "'" [Strict] <|> - select "" [] select suffix opts = reserved ("select"++suffix) >> return opts diff --git a/HESQL/Syntax.hs b/HESQL/Syntax.hs --- a/HESQL/Syntax.hs +++ b/HESQL/Syntax.hs @@ -3,6 +3,8 @@ import Database.HDBC (SqlValue(..)) import Data.List (intercalate) +import Database.HsSqlPpp.Ast.Ast + type ModuleName = String type DeclName = String type Vars = [String] @@ -15,10 +17,11 @@ data HesqlDecls = HesqlDecls { declName :: DeclName , declVars :: Vars - , declSQL :: SQL + , declMaybe :: Bool + , declSQL :: Statement } deriving Show -data SQL = SELECT [SelectOption] SelectColumns (Maybe From) +data SQL = SELECT SelectColumns (Maybe From) (Maybe SqlExp) (Maybe SqlOrder) (Maybe Group) | INSERT TableName InsertColumns [SqlExp] | UPDATE TableName [(ColName, SqlExp)] (Maybe SqlExp) @@ -66,7 +69,7 @@ sqlToString :: SQL -> String sqlToString DummySQL = "" -sqlToString (SELECT _ cols from wh order group) = +sqlToString (SELECT cols from wh order group) = "select " ++ showColumns cols ++ showFrom from ++ showWhere wh ++ showOrder order -- TODO where order group @@ -126,7 +129,7 @@ todo s = error ("TODO " ++ s) -data SelectOption = Strict | ReturnMaybe deriving (Show, Eq) +-- data SelectOption = Strict | ReturnMaybe deriving (Show, Eq) data SelectColumns = AllColumns | ExplicitColumns [(SqlExp, Maybe ColAlias)] deriving Show -- data From = FromSubQuery SQL | FromTables [(TableName, TableAlias)] deriving Show type From = TableName @@ -153,11 +156,13 @@ infixOpToString SqlMult = "*" -isSelect (SELECT _ _ _ _ _ _) = True +isSelect (SelectStatement _ _) = True isSelect _ = False -selectOpts :: SQL -> [SelectOption] +{-selectOpts :: SQL -> [SelectOption] selectOpts (SELECT opts _ _ _ _ _) = opts -selectOpts _ = [] +selectOpts _ = [] -} -selectColumns (SELECT _ cols _ _ _ _) = cols +--selectColumns (SELECT _ cols _ _ _ _) = cols + +selectColumnLength (SelectStatement _ (Select _ _ (SelectList _ l _) _ _ _ _ _ _ _ _)) = length l diff --git a/HESQL/Translator.hs b/HESQL/Translator.hs --- a/HESQL/Translator.hs +++ b/HESQL/Translator.hs @@ -8,7 +8,10 @@ import System.FilePath +import Database.HsSqlPpp.PrettyPrinter.PrettyPrinter +import Database.HsSqlPpp.Ast.Ast +import Data.List (elemIndex) stmtRec = HsIdent "Stmts" funarg = HsPVar . HsIdent @@ -49,7 +52,7 @@ mkStmts = map mkStmt decls mkStmt decl = HsGenerator srcloc (HsPVar $ HsIdent $ declName decl) (hsapps "prepare" [hsvar "conn", HsLit $ HsString sqlText]) - where sqlText = show $ declSQL decl + where sqlText = printSql [declSQL decl] returnRec = HsQualifier $ hsapp "return" $ HsRecConstr (UnQual $ stmtRec) fields fields = map mkField decls mkField decl = HsFieldUpdate @@ -63,27 +66,24 @@ bindAndExecute = HsQualifier $ hsapps "execute" [stmt, valList] selectFlag = isSelect $ declSQL decl result - | selectFlag = [resultStmt (selectOpts $ declSQL decl) stmt] + | selectFlag = [resultStmt decl stmt] | otherwise = [] maybeTupleFun - | selectFlag = [tupleFun $ selectColumnLength $ selectColumns $ declSQL decl] + | selectFlag = [tupleFun $ selectColumnLength $ declSQL decl] | otherwise = [] stmt = HsVar $ UnQual $ HsSymbol "stmt" - valList = HsList $ map mkSqlVal $ placeHoldersSql $ declSQL decl + valList = HsList $ map mkSqlVal $ declVars decl mkSqlVal v = hsapp "toSql" (hsvar v) stmtDef = HsPatBind srcloc (HsPVar $ HsIdent "stmt") (HsUnGuardedRhs $ HsApp (HsVar $ UnQual $ HsIdent $ stmtRecName decl) (hsvar "h")) [] -resultStmt opts stmt = HsQualifier $ hsapps "fmap" [HsParen (hsapp "fmap" (hsvar "toTuple")), HsParen (hsapp (prefix++suffix) stmt)] +resultStmt decl stmt = HsQualifier $ hsapps "fmap" [HsParen (hsapp "fmap" (hsvar "toTuple")), HsParen (hsapp (prefix++suffix) stmt)] where suffix - | opts == [Strict] = "'" | otherwise = "" prefix - | ReturnMaybe `elem` opts = "fetchRow" - | otherwise = "fetchAllRows" - - + | declMaybe decl = "fetchRow" + | otherwise = "fetchAllRows'" tupleFun n = HsFunBind [ @@ -98,6 +98,7 @@ lvar i = HsIdent $ "v" ++ show i convVar v = hsapp "fromSql" (HsVar (UnQual v)) +{- placeHolderCols AllColumns = [] placeHolderCols (ExplicitColumns cols) = concatMap placeHoldersExp $ map fst cols @@ -119,7 +120,8 @@ placeHoldersExp (SqlLiteral _) = [] placeHoldersExp (SqlNot e) = placeHoldersExp e - + + substituteVarsExp vars (SqlInfixApp e1 op e2) = SqlInfixApp e1' op e2' where e1' = substituteVarsExp vars e1 @@ -157,3 +159,70 @@ selectColumnLength (ExplicitColumns cols) = length cols +-} + + +substituteVarsSql :: [String] -> Statement -> Statement +substituteVarsSql vars sql = + case sql of + SelectStatement ann se -> SelectStatement ann $ substituteSelectExpression vars se + Update ann table sets wh sl -> + Update ann table + (substituteSetClauselList vars sets) + (fmap (substituteExpression vars) wh ) + (fmap (substituteSelectList vars) sl) + Insert ann tab cols e sl -> + Insert ann tab cols (substituteSelectExpression vars e) + sl + _ -> todo "substituteVarsSql" + + +substituteSetClauselList vars = map (substituteSetClausel vars) +substituteSetClausel vars (SetClause ann a e) = SetClause ann a (substituteExpression vars e) +substituteSetClausel vars (RowSetClause ann as es) = RowSetClause ann as $ map (substituteExpression vars) es + + + +substituteSelectExpression vars sql = + case sql of + Select ann dist sl tabref wh groupby having order dir a b -> + -- TODO names for a? and b? + Select ann dist + (substituteSelectList vars sl) + tabref -- TODO + (se' wh) + (map se groupby) + (se' having) + (map se order) + dir + (se' a) + (se' b) + Values ann el -> + Values ann (map (map (substituteExpression vars)) el) + where se = substituteExpression vars + se' = fmap se + + +substituteExpression :: [String] -> Expression -> Expression +substituteExpression _ l@(BooleanLit _ _) = l +substituteExpression _ l@(FloatLit _ _) = l +substituteExpression vars l@(FunCall ann s el) = + FunCall ann s (fmap (substituteExpression vars) el) +substituteExpression _ l@(StringLit _ _ _) = l +substituteExpression _ l@(IntegerLit _ _) = l +substituteExpression vars id@(Identifier ann v) = + case v `elemIndex` vars of + Nothing -> id + Just i -> PositionalArg ann (fromIntegral i+1) +substituteExpression _ l = error $ "substituteExpression: " ++ show l + +substituteSelectList vars (SelectList ann sis sl) = SelectList ann sis' sl + where sis' = map (substituteSelectItem vars) sis + +substituteSelectItem vars item = + case item of + SelExp ann e -> SelExp ann (substituteExpression vars e) + SelectItem ann e s -> SelectItem ann (substituteExpression vars e) s + + +--substituteExpression _ _ = todo "substituteExpression" -- TODO print Exp diff --git a/HESQL/Verifier.hs b/HESQL/Verifier.hs --- a/HESQL/Verifier.hs +++ b/HESQL/Verifier.hs @@ -3,11 +3,13 @@ import HESQL.Syntax import Database.HDBC +import Database.HsSqlPpp.PrettyPrinter.PrettyPrinter + verifySql conn sql = handleSqlError $ do putStrLn $ "check " ++ sqlStr prepare conn sqlStr >>= finish - where sqlStr = show sql + where sqlStr = printSql [sql] -- TODO check column names in table. diff --git a/README b/README --- a/README +++ b/README @@ -24,24 +24,28 @@ LoggedIn BOOL DEFAULT FALSE NOT NULL, Locked BOOL DEFAULT FALSE NOT NULL, LastLogout TIMESTAMP, - LastRequest TimeStamp DEFAULT 'now' NOT NULL + LastRequest TimeStamp DEFAULT 'now' NOT NULL, + Validated BOOL DEFAULT FALSE NOT NULL ); CREATE UNIQUE INDEX AccountIdx ON Account(Lower(Login)); -There are four select variants to use HDBC's strict/lazy fetch functions -and return a list or a maybe type. - select: lazy, list of rows - select': strict, list of rows - select1: lazy, maybe row - select1': strict, maybe row +A select query may return a list or just a maybe type. If you +just want the maybe type, use + + maybe select a from t where e; + +It is planned, that a prefix "lazy" should work in the same way. Then with +"lazy", the lazy HBDC-fetchAllRows are used. + + For example: -verifyLogin login' password' = - select1' Accountid, Login, RealName, Email from Account - where (password is null or password = md5(password')) and Lower(Login) = login' +verifyLogin login password = + maybe select Accountid, Login, RealName, Email from Account + where (Password is null or Password = md5(password)) and Lower(Login) = login and not Locked; will generate code for a Haskell-function with the type: diff --git a/example/Account.hesql b/example/Account.hesql --- a/example/Account.hesql +++ b/example/Account.hesql @@ -2,26 +2,30 @@ -- see README for the table definitions -verifyLogin login' password' = - select1' Accountid, Login, RealName, Email from Account - where (password is null or password = md5(password')) and Lower(Login) = Lower(login') +verifyLogin login password = + maybe select Accountid, Login, RealName, Email from Account + where (Password is null or Password = md5(password)) and Lower(Login) = Lower(login) and not Locked; -login accountid' = - update Account set LoggedIn = true where AccountID = accountid'; -logout accountid' = +login accountid = + update Account set LoggedIn = true, + LastRequest = Now(), + Validated = true where AccountID = accountid; + +logout accountid = update Account set LoggedIn = false, LastLogout = Now() - where AccountID = accountid'; + where AccountID = accountid; - createAccount login password email realname = - insert into Account (Login, Password, Email, RealName) values (login,md5(password),email,realname); + insert into Account (Login, Password, Email, RealName, LastRequest) + values (login,md5(password),email,realname, now()); activeUsers = - select Login from Account - where LoggedIn and - now() - LastRequest < '00:05:00'; + select Login from Account where LoggedIn and now() - LastRequest < '00:05:00'; + +listAccounts = + select AccountId, Login, Notes, LastRequest from Account order by LastRequest desc; diff --git a/hesql.cabal b/hesql.cabal --- a/hesql.cabal +++ b/hesql.cabal @@ -1,5 +1,5 @@ Name: hesql -Version: 0.4 +Version: 0.5 Author: Christoph Bauer Maintainer: Christoph Bauer Cabal-Version: >= 1.2 @@ -14,7 +14,7 @@ Executable hesql Main-is: HESQL.hs Build-depends: base >= 2 && < 4, HDBC, HDBC-postgresql, haskell-src, - filepath, parsec + filepath, parsec, hssqlppp >= 0.0.9 Extensions: FlexibleContexts Ghc-Options: -funbox-strict-fields Other-Modules: HESQL.Parser, HESQL.Translator, HESQL.Syntax,