hesql 0.4 → 0.5
raw patch · 7 files changed
+168/−69 lines, 7 filesdep +hssqlppp
Dependencies added: hssqlppp
Files
- HESQL/Parser.hs +40/−25
- HESQL/Syntax.hs +13/−8
- HESQL/Translator.hs +80/−11
- HESQL/Verifier.hs +3/−1
- README +14/−10
- example/Account.hesql +16/−12
- hesql.cabal +2/−2
HESQL/Parser.hs view
@@ -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
HESQL/Syntax.hs view
@@ -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
HESQL/Translator.hs view
@@ -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
HESQL/Verifier.hs view
@@ -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.
README view
@@ -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:
example/Account.hesql view
@@ -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;
hesql.cabal view
@@ -1,5 +1,5 @@ Name: hesql-Version: 0.4+Version: 0.5 Author: Christoph Bauer <ich@christoph-bauer.net> Maintainer: Christoph Bauer <ich@christoph-bauer.net> 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,