diff --git a/iyql.cabal b/iyql.cabal --- a/iyql.cabal +++ b/iyql.cabal @@ -1,5 +1,5 @@ name: iyql -version: 0.0.5 +version: 0.0.5.1 category: Network license: BSD3 license-file: LICENSE @@ -19,25 +19,48 @@ are examples of such functions. executable iyql - build-depends: haskell98 - , base<5 - , hoauth>=0.2.5 - , directory>=1.0.1.0 - , filepath>=1.1.0.3 - , containers>=0.3.0.0 - , utf8-string>=0.3.6 - , bytestring>=0.9.1.5 - , time>=1.1.4 - , mtl>=1.1.0.2 - , xml>=1.3.7 - , old-locale>=1.0.0.2 - , binary>=0.5.0.2 - , parsec>=2.1.0.1 - , haskeline>=0.6.2.2 main-is: iyql.hs hs-source-dirs: src/main/haskell + build-depends: haskell98 + , base<5 + , hoauth>=0.2.5 + , directory>=1.0.1.0 + , filepath>=1.1.0.3 + , containers>=0.3.0.0 + , utf8-string>=0.3.6 + , bytestring>=0.9.1.5 + , time>=1.1.4 + , mtl>=1.1.0.2 + , xml>=1.3.7 + , old-locale>=1.0.0.2 + , binary>=0.5.0.2 + , parsec>=2.1.0.1 + , haskeline>=0.6.2.2 + other-modules: Yql.UI.Cli + , Yql.UI.CLI.Command + , Yql.UI.CLI.Options + , Yql.UI.CLI.Commands.Parser + , Yql.UI.CLI.Commands.WhoAmI + , Yql.UI.CLI.Commands.Logout + , Yql.UI.CLI.Commands.ManLf + , Yql.UI.CLI.Commands.Login + , Yql.UI.CLI.Commands.SetEnv + , Yql.UI.CLI.Input + , Yql.Data.Xml + , Yql.Data.Trie + , Yql.Data.Version + , Yql.Data.Cfg + , Yql.Core.Backend + , Yql.Core.Session + , Yql.Core.Lexer + , Yql.Core.Parser + , Yql.Core.LocalFunctions.Request + , Yql.Core.LocalFunctions.Tables + , Yql.Core.Types + , Yql.Core.LocalFunction ghc-options: -W -Wall -fwarn-tabs -fno-warn-unused-do-bind source-repository head type: git location: git@github.com:dsouza/iyql.git + diff --git a/src/main/haskell/Yql/Core/Backend.hs b/src/main/haskell/Yql/Core/Backend.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Core/Backend.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE FlexibleInstances #-} +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Core.Backend + ( -- * Types + Yql(..) + , Backend(..) + , OutputT() + -- * Monads + , unOutputT + ) where + +import Yql.Data.Cfg +import Yql.Core.Types +import qualified Yql.Core.LocalFunctions.Request as F +import Yql.Core.LocalFunction +import Yql.Core.Session +import Yql.Data.Xml +import Data.Char +import Data.Maybe +import qualified Data.List as L +import Data.Time +import Control.Monad +import Control.Monad.Trans +import qualified Data.Map as M +import qualified Data.ByteString.Lazy as B +import qualified Codec.Binary.UTF8.String as U +import Network.OAuth.Consumer hiding (application) +import qualified Network.OAuth.Http.Request as R +import Network.OAuth.Http.Response +import Network.OAuth.Http.HttpClient + +newtype OutputT m a = OutputT { unOutputT :: m (Either String a) } + +-- | The reference implementation backend available +data Backend s = YqlBackend { application :: Application -- ^ The applicat that is used to perform 3-legged oauth requests + , sessionMgr :: s -- ^ Used for saving/loading oauth tokens + , defaultEnv :: [String] -- ^ Default environment to use when performing requests + , myEndpoint :: (String,Int) -- ^ The hostname and port of yql server + } + +-- | Tells the minimum security level required to perform this +-- statament. +descTablesIn :: (MonadIO m,HttpClient m,Yql y) => y -> [String] -> Expression -> OutputT m Description +descTablesIn y envs stmt = case stmt + of _ | desc stmt -> return $ foldr1 joinDesc (map (const $ Table "<>" Any False) (tables stmt)) + | usingMe stmt -> return $ foldr1 joinDesc (map (const $ Table "<>" User False) (tables stmt)) + | showTables stmt -> return (Table "<>" Any False) + | otherwise -> fmap (foldr1 joinDesc) (mapM execDesc (tables stmt)) + where parseXml xml = case (xmlParse xml) + of Just doc -> case (readDescXml doc) + of Just rst -> return rst + Nothing -> fail $ "couldn't desc tables " ++ L.intercalate "," (tables stmt) + Nothing -> fail "error parsing xml" + + execDesc t = execute y database (mkDesc stmt t) >>= parseXml + where database = M.fromList [("request", F.function)] + + mkDesc (USE u a stmt') t = USE u a (mkDesc stmt' t) + mkDesc _ t = DESC t funcs + + joinDesc (Table _ sec0 ssl0) (Table _ sec1 ssl1) = Table "<>" (max sec0 sec1) (ssl0 || ssl1) + + funcs | null envs = [] + | otherwise = [Local "request" [("env",TxtValue env) | env <- envs]] + +emptyRequest :: R.Request +emptyRequest = R.ReqHttp { R.version = R.Http11 + , R.ssl = False + , R.host = "query.yahooapis.com" + , R.port = 80 + , R.method = R.GET + , R.reqHeaders = R.empty + , R.pathComps = ["","v1","public","yql"] + , R.qString = R.empty + , R.reqPayload = B.empty + } + +mkRequest :: Expression -> [String] -> Description -> R.Request +mkRequest stmt env d = emptyRequest { R.ssl = https d + , R.port = portNumber + , R.pathComps = yqlPath + , R.method = httpMethod + , R.qString = R.fromList $ ("q",show $ preparedStmt stmt) : map (\e -> ("env",e)) env + } + where yqlPath + | security d `elem` [User,App] = ["","v1","yql"] + | otherwise = ["","v1","public","yql"] + + portNumber + | https d = 443 + | otherwise = 80 + + httpMethod | update stmt = R.PUT + | insert stmt = R.PUT + | delete stmt = R.DELETE + | otherwise = R.GET + + preparedStmt stmt_ = case stmt_ + of (SELECT c t w rl ll f) -> SELECT c t w rl ll (filter remote f) + (DESC t _) -> DESC t [] + (UPDATE c t w f) -> UPDATE c t w (filter remote f) + (INSERT c t f) -> INSERT c t (filter remote f) + (DELETE t w f) -> DELETE t w (filter remote f) + (SHOWTABLES f) -> SHOWTABLES (filter remote f) + (USE url as stmt') -> USE url as (preparedStmt stmt') + +-- | Minimum complete definition: endpoint, app. +class Yql y where + -- | Returns the endpoint this backend is pointing to + endpoint :: y -> (String,Int) + endpoint _ = ("query.yahooapis.com",80) + + -- | Add a new env that is included in the request + setenv :: y -> String -> y + + -- | Delete an entry from the environment + unsetenv :: y -> String -> y + + -- | Returns the env that are currently loaded + getenv :: y -> [String] + + -- | Returns the credentials that are used to perform the request. + credentials :: (MonadIO m,HttpClient m) => y -> Security -> OAuthMonad m () + + -- | Given an statement executes the query on yql. This function is + -- able to decide whenever that query requires authentication + -- [TODO]. If it does, it uses the oauth token in order to fullfil + -- the request. + execute :: (MonadIO m,HttpClient m) => y -> Database -> Expression -> OutputT m String + execute y db stmt = do mkRequest' <- fmap execBefore_ (ld' db stmt) + mkResponse <- fmap execAfter_ (ld' db stmt) + mkOutput <- fmap execTransform_ (ld' db stmt) + tableDesc <- descTablesIn y (R.find (=="env") . R.qString . mkRequest' $ emptyRequest) stmt + response <- lift (runOAuth $ do credentials y (security tableDesc) + serviceRequest HMACSHA1 (Just "yahooapis.com") (mkRequest' $ (myRequest tableDesc) { R.host = fst (endpoint y), R.port = snd (endpoint y) } )) + return $ mkOutput (toString (mkResponse response)) + + where myRequest = mkRequest stmt (getenv y) + +toString :: Response -> String +toString resp | statusOk && isXML = xmlPrint . fromJust . xmlParse $ payload + | isXML = xmlPrint . fromJust . xmlParse $ payload + | otherwise = payload + where statusOk = status resp `elem` [200..299] + + payload = U.decode . B.unpack . rspPayload $ resp + + contentType = R.find (\s -> map toLower s == "content-type") (rspHeaders resp) + + isXML = case contentType + of (x:_) -> "text/xml" `L.isPrefixOf` dropWhile isSpace x + _ -> False + +instance SessionMgr a => Yql (Backend a) where + endpoint be = myEndpoint be + + setenv be e = be { defaultEnv = e : defaultEnv be } + + unsetenv be e = be { defaultEnv = L.delete e (defaultEnv be) } + + getenv = defaultEnv + + credentials _ Any = putToken (TwoLegg (Application "no_ckey" "no_csec" OOB) R.empty) + credentials be App = ignite (application be) + credentials be User = do token_ <- liftIO (load (sessionMgr be)) + reqUrl <- liftIO $ fmap (fromJust . R.parseURL) (tryUsrCfg "oauth_reqtoken_url" defReqUrl) + accUrl <- liftIO $ fmap (fromJust . R.parseURL) (tryUsrCfg "oauth_acctoken_url" defAccUrl) + case token_ + of Nothing -> do ignite (application be) + oauthRequest PLAINTEXT Nothing reqUrl + cliAskAuthorization authUrl + oauthRequest PLAINTEXT Nothing accUrl + getToken >>= liftIO . save (sessionMgr be) + Just token + | threeLegged token -> do putToken token + now <- liftIO getCurrentTime + offset <- liftIO $ fmap fromJust (mtime (sessionMgr be)) + when (now >= expiration offset token) $ + do oauthRequest PLAINTEXT Nothing accUrl + getToken >>= liftIO . save (sessionMgr be) + | otherwise -> do putToken token + oauthRequest PLAINTEXT Nothing reqUrl + cliAskAuthorization authUrl + oauthRequest PLAINTEXT Nothing accUrl + getToken >>= liftIO . save (sessionMgr be) + where defReqUrl = "https://api.login.yahoo.com/oauth/v2/get_request_token" + defAccUrl = "https://api.login.yahoo.com/oauth/v2/get_token" + + authUrl = head . R.find (=="xoauth_request_auth_url") . oauthParams + + expiration offset token = let timeout = read . R.findWithDefault ("oauth_expires_in","3600") + . oauthParams $ token + in addUTCTime (fromInteger timeout) offset + +instance MonadTrans OutputT where + lift = OutputT . liftM Right + +instance MonadIO m => MonadIO (OutputT m) where + liftIO mv = OutputT (liftIO $ do v <- mv + return (Right v)) + +instance Monad m => Monad (OutputT m) where + fail = OutputT . return . Left + + return = OutputT . return . Right + + (OutputT mv) >>= f = OutputT $ do v <- mv + case v + of Left msg -> return (Left msg) + Right v' -> unOutputT (f v') + +instance Monad m => Functor (OutputT m) where + fmap f (OutputT mv) = OutputT $ do v <- mv + case v + of Left msg -> return (Left msg) + Right v' -> return (Right $ f v') diff --git a/src/main/haskell/Yql/Core/Lexer.hs b/src/main/haskell/Yql/Core/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Core/Lexer.hs @@ -0,0 +1,131 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +-- | Lexical analysis of yql statements +module Yql.Core.Lexer + ( -- * Types + TokenT(..) + , Token(..) + -- * Lexical Analysis + , scan + , accept + -- * Other + , keywords + ) where + +import Text.ParserCombinators.Parsec +import Data.Char + +-- | Tokens emitted by the lexer. +data TokenT = TkKey String -- ^ Keywords (e.g.: SELECT, DESC, OR, *) + | TkStr String -- ^ Quoted String (e.g.: 'foobar', "foobar") + | TkNum String -- ^ Numeric (e.g.: 1, 1.2, .09999) + | TkSym String -- ^ Any Symbol (e.g.: tables, colum names, etc.) + | TkEOF + deriving (Show,Eq) + +-- | Relates a TokenT with the position in the stream, so that it can +-- feed the parser. +newtype Token = Token { unToken :: (SourcePos,TokenT) } + deriving (Show,Eq) + +-- | Performs the lexical analysis of a string and returns the tokens +-- found. +scan :: GenParser Char String [Token] +scan = do skipMany space + t <- readToken + skipMany space + fmap (t:) (scan <|> (eof >> fmap (:[]) (mkToken TkEOF))) + where readToken = quoted <|> symbol + +-- | Parses a token created by the lexer so that you can use to +-- perform syntactic analysis. +accept :: (TokenT -> Maybe a) -> GenParser Token () a +accept p = token (show.snd.unToken) (fst.unToken) (p.snd.unToken) + +mkToken :: TokenT -> GenParser Char String Token +mkToken t = do p <- getPosition + return (Token (p,t)) + +symbol :: GenParser Char String Token +symbol = (fmap TkKey (try $ string ">=") + <|> fmap TkKey (try $ string "<=") + <|> fmap TkKey (try $ string "!=") + <|> fmap (TkKey.(:[])) (oneOf single) + <|> fmap mksym (many1 (satisfy sym))) >>= mkToken + where single = ",;()=><|" + + sym c = (c `notElem` single) && not (isSpace c) + +quoted :: GenParser Char String Token +quoted = do s <- oneOf "'\"" + content <- loop s + mkToken (TkStr content) + where loop s = do c <- anyChar + case c + of '\\' -> (char s >> fmap (s:) (loop s)) + <|> fmap (c:) (loop s) + x | s==x -> return [] + | otherwise -> fmap (x:) (loop s) + +keywords :: [String] +keywords = [ "SELECT" + , "UPDATE" + , "INSERT" + , "DELETE" + , "DESC" + , "USE" + , "AS" + , "SHOW" + , "TABLES" + , "OR" + , "AND" + , "IN" + , "ME" + , "FROM" + , "WHERE" + , "SET" + , "VALUES" + , "INTO" + , "MATCHES" + , "NULL" + , "NOT" + , "LIKE" + , "IS" + , "*" + , "OFFSET" + , "LIMIT" + ] + +mksym :: String -> TokenT +mksym sym | uSym `elem` keywords = TkKey uSym + | tkNum sym = TkNum sym + | otherwise = TkSym sym + where uSym = map toUpper sym + + tkNum (x:xs) | x=='.' = not (null xs) && all isDigit xs + | otherwise = isDigit x && tkNum xs + tkNum [] = True diff --git a/src/main/haskell/Yql/Core/LocalFunction.hs b/src/main/haskell/Yql/Core/LocalFunction.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Core/LocalFunction.hs @@ -0,0 +1,107 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Core.LocalFunction + ( Database + , Pipeline() + , Exec(..) + , man + , pipeline + , ld' + , execBefore + , execAfter + , execTransform + , execBefore_ + , execAfter_ + , execTransform_ + ) where + +import Yql.Core.Types +import Network.OAuth.Http.Request +import Network.OAuth.Http.Response +import qualified Data.Map as M +import Control.Monad + +type Database = M.Map String Exec + +newtype Pipeline = Pipeline { runPipeline :: Exec } + +-- | Local functions that may change a given yql query +data Exec = Before (String -> String) ([(String,Value)] -> Request -> Request) + | After (String -> String) ([(String,Value)] -> Response -> Response) + | Transform (String -> String) ([(String,Value)] -> String -> String) + | Seq Exec Exec + | NOp + +-- | The documentation of a given function +man :: Exec -> String -> String +man (Before doc _) = doc +man (After doc _) = doc +man (Transform doc _) = doc +man _ = error "man: not found" + +-- | Transforms a list of functions into a pipeline using a given linker. +pipeline :: Monad m => Database -> [Function] -> m Pipeline +pipeline db funcs = do exec <- pipeline' funcs + return (Pipeline exec) + where pipeline' [] = return NOp + pipeline' (f:fs) = case (M.lookup (name f) db) + of Nothing -> fail $ "unknown function: " ++ name f + Just ex -> liftM (bind (args f) ex `Seq`) (pipeline' fs) + + bind argv (Before d f) = Before d (const $ f argv) + bind argv (After d f) = After d (const $ f argv) + bind argv (Transform d f) = Transform d (const $ f argv) + bind _ x = x + +-- | Extracts the local functions from the statement and creates a pipeline. +ld' :: (Monad m) => Database -> Expression -> m Pipeline +ld' l stmt = let fs = filter local (functions stmt) + in pipeline l fs + +execTransform :: [(String,Value)] -> Exec -> String -> String +execTransform argv (Transform _ f) s = f argv s +execTransform argv (Seq fa fb) s = execTransform argv fb (execTransform argv fa s) +execTransform _ _ s = s + +execTransform_ :: Pipeline -> String -> String +execTransform_ = execTransform [] . runPipeline + +execBefore :: [(String,Value)] -> Exec -> Request -> Request +execBefore argv (Before _ f) r = f argv r +execBefore argv (Seq fa fb) r = execBefore argv fb (execBefore argv fa r) +execBefore _ _ r = r + +execBefore_ :: Pipeline -> Request -> Request +execBefore_ = execBefore [] . runPipeline + +execAfter :: [(String,Value)] -> Exec -> Response -> Response +execAfter argv (After _ f) r = f argv r +execAfter argv (Seq fa fb) r = execAfter argv fb (execAfter argv fa r) +execAfter _ _ r = r + +execAfter_ :: Pipeline -> Response -> Response +execAfter_ = execAfter [] . runPipeline diff --git a/src/main/haskell/Yql/Core/LocalFunctions/Request.hs b/src/main/haskell/Yql/Core/LocalFunctions/Request.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Core/LocalFunctions/Request.hs @@ -0,0 +1,84 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Core.LocalFunctions.Request + ( function + , jsonFunction + , diagnosticsFunction + , endpointFunction + ) where + +import Yql.Core.Types +import Yql.Core.LocalFunction +import Network.OAuth.Http.Request as R + +function :: Exec +function = Before doc func + where doc link = unlines [ "Modify the request query string" + , "Example:" + , " SELECT * FROM foobar | " ++ link ++ "(format=\"json\")" + , " SELECT * FROM foobar | " ++ link ++ "(diagnostics=\"true\")" + , " SELECT * FROM foobar | " ++ link ++ "(_maxage=3600)" + ] + + func vs r = r { qString = foldr R.insert (qString r) params } + where params = map (\(k,v) -> (k,myShow v)) vs + + myShow (TxtValue v) = v + myShow v = show v + +jsonFunction :: Exec +jsonFunction = Before doc func + where doc _ = unlines [ "Changes the output format to json." + ] + + func _ r = r { qString = R.insert ("format","json") (qString r) } + +diagnosticsFunction :: Exec +diagnosticsFunction = Before doc func + where doc _ = unlines [ "Sends diagnostics=true parameter to yql" + ] + + func _ r = r { qString = R.insert ("diagnostics","true") (qString r) } + +endpointFunction :: Exec +endpointFunction = Before doc func + where doc link = unlines [ "Allow you to change the yql endpoint" + , "Examples:" + , " SELECT * FROM foobar | " ++ link ++ "(host=\"query.yahooapis.com\", port=80);" + ] + + func vs r = r { host = newHost (host r) + , port = newPort (port r) + } + + where newHost d = case (lookup "host" vs) + of (Just (TxtValue h)) -> h + _ -> d + + newPort d = case (lookup "port" vs) + of (Just (NumValue p)) -> read p + _ -> d diff --git a/src/main/haskell/Yql/Core/LocalFunctions/Tables.hs b/src/main/haskell/Yql/Core/LocalFunctions/Tables.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Core/LocalFunctions/Tables.hs @@ -0,0 +1,166 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Core.LocalFunctions.Tables + ( function + ) where + +import Yql.Core.LocalFunction +import Yql.Data.Xml +import Data.List +import qualified Data.Map as M + +newtype Column = Column { unColumn :: (String,[Cell]) } + deriving (Show) + +data Table = Lines { rows :: [Column] } + deriving (Show) + +data Cell = Complex Table + | Scalar String + deriving (Show) + +data Doc = Text String Doc + | Line Int Doc + | Space Int Doc + | Nil + + +-- ctext :: Int -> Char -> Doc +-- ctext k = text . replicate k + +-- stext :: Show a => a -> Doc +-- stext = text . show + +-- lspace :: Int -> Doc -> Doc +-- lspace by = space by + +rspace :: Int -> Doc -> Doc +rspace by = (<> (space by Nil)) + +text :: String -> Doc +text = flip Text Nil + +newline :: Doc -> Doc +newline = Line 0 + +space :: Int -> Doc -> Doc +space m (Space n d) = Space (m+n) d +space m d = Space m d + +nest :: Int -> Doc -> Doc +nest _ Nil = Nil +nest m (Text s d) = Text s (nest m d) +nest m (Line n d) = Line (m+n) (nest m d) +nest m (Space n d) = Space n (nest m d) + +empty :: Doc +empty = Nil + +width :: Doc -> Int +width = maximum . (0:) . map length . lines . show + +cat :: [Doc] -> Doc +cat [] = empty +cat [x] = x +cat (x:xs) = x <> newline (cat xs) + +-- columns :: Doc -> Int +-- columns (Text s d) = length s + (columns d) +-- columns (Space m d) = m + (columns d) +-- columns _ = 0 + +(<>) :: Doc -> Doc -> Doc +(Text s d) <> x = Text s (d <> x) +(Line n d) <> x = Line n (d <> x) +(Space n d) <> x = Space n (d <> x) +Nil <> x = x +infixr 9 <> + +render :: Doc -> String +render Nil = "" +render (Space k d) = (replicate k ' ') ++ render d +render (Line k d) = "\n" ++ (replicate k ' ') ++ render d +render (Text s d) = s ++ render d + +function :: Exec +function = Transform (const doc) (const $ render . xml2doc) + where doc = unlines [ "Reads the xml output and transform it into tabular form." + ] + +norm :: Table -> Table +norm (Lines cols) = Lines (map fixColumn cols) + where maxHeight = maximum (map (length . snd . unColumn) cols) + + fixHeight xs = (map dig xs) ++ replicate (maxHeight - (length xs)) (Scalar "") + where dig (Complex t) = Complex (norm t) + dig scalar = scalar + + fixColumn (Column (h,cs)) = Column (h,fixHeight cs) + +showCell :: Cell -> (Int,Doc) +showCell (Scalar s) = (length s,text . unwords . lines $ s) +showCell (Complex t) = let doc = showTable t + in (width doc,doc) + +maxWidth :: Column -> Int +maxWidth (Column (h,cs)) = maximum (hSize : map fst cellStr) + where cellStr = map showCell cs + hSize = length h + +showColumn :: Column -> [(Int,Doc)] +showColumn (Column (h,cs)) = (myMaxWidth,text header) : map (\(_,b) -> (myMaxWidth,b)) (map showCell cs) + where header = "*" ++ h ++ "*" + myColumn = Column (header,cs) + myMaxWidth = maxWidth myColumn + +showTable :: Table -> Doc +showTable = cat . map (showTable_ 1) . transpose . map showColumn . rows + where showTable_ _ [] = text "|" + showTable_ acc ((w,x):xs) = nest acc (text "|" + <> rspace (w - width x) x) + <> showTable_ (acc+w+1) xs + +xml2doc :: String -> Doc +xml2doc xml = showTable . xml2table $ results + where Just doc = xmlParse xml + + Just results = fmap (childNodes) (findElement "results" doc) + +xml2table :: [XML] -> Table +xml2table = unpack . build . xmlRows + where xmlRows tag = map (map xmlCols . filter element . childNodes) tag + + xmlCols tag | simple = (tagName tag,[Scalar (verbatim tag)]) + | otherwise = (tagName tag,[Complex (xml2table [tag])]) + where simple = all pcdata (childNodes tag) + + build = foldr (M.unionWith (++)) M.empty . map (M.fromListWith (++)) + + unpack = norm . Lines . map Column . M.toList + +instance Show Doc where + showsPrec _ = showString . render diff --git a/src/main/haskell/Yql/Core/Parser.hs b/src/main/haskell/Yql/Core/Parser.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Core/Parser.hs @@ -0,0 +1,299 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +-- | Syntactic analysis of Yql statements +module Yql.Core.Parser + ( -- * Types + ParserEvents(..) + , AssertOperator(..) + , SingleOperator(..) + , ListOperator(..) + , Limit + , ParseError + -- * Parser + , parseYql + ) + where + +import Text.ParserCombinators.Parsec +import Yql.Core.Lexer + +type YqlParser a = GenParser Token () a + +-- | Limit in terms of (offset,amount) +type Limit = (Integer,Integer) + +-- | Tests if column satisfies a given property +data AssertOperator i = IsNullOp i + | IsNotNullOp i + +-- | Operators in where clause that takes a single value +data SingleOperator i v = EqOp i v + | NeOp i v + | GtOp i v + | GeOp i v + | LtOp i v + | LeOp i v + | LikeOp i v + | NotLikeOp i v + | MatchesOp i v + | NotMatchesOp i v + +-- | Operator in where clause that takes a list of values +data ListOperator i v = InOp i [v] + +-- | Events the parser generates. The main purpose of this is to allow +-- you constructing types that represents yql statements. +data ParserEvents i v w f s = ParserEvents { onIdentifier :: String -> i + , onTxtValue :: String -> v + , onNumValue :: String -> v + , onSubSelect :: s -> v + , onMeValue :: v + , onSelect :: [i] -> i -> Maybe w -> Maybe Limit -> Maybe Limit -> [f] -> s + , onUpdate :: [(i,v)] -> i -> Maybe w -> [f] -> s + , onInsert :: [(i,v)] -> i -> [f] -> s + , onDelete :: i -> Maybe w -> [f] -> s + , onUse :: String -> i -> s -> s + , onShowTables :: [f] -> s + , onDesc :: i -> [f] -> s + , onAssertOp :: AssertOperator i -> w + , onSingleOp :: SingleOperator i v -> w + , onListOp :: ListOperator i v -> w + , onAndExpr :: w -> w -> w + , onOrExpr :: w -> w -> w + , onLocalFunc :: i -> [(i,v)] -> f + , onRemoteFunc :: i -> [(i,v)] -> f + } + +-- | Parses an string, which must be a valid yql expression, using +-- ParserEvents to create generic types. +parseYql :: String -> ParserEvents i v w f s -> Either ParseError s +parseYql input e = case tokStream + of Left err -> Left err + Right input_ -> runParser myParser () "stdin" input_ + where tokStream = runParser scan "" "stdin" input + + myParser = do expr <- parseYql_ e + tkEof + return expr + +parseYql_ :: ParserEvents i v w f s -> YqlParser s +parseYql_ e = do (parseDesc e >>= semiColon) + <|> (parseSelect e >>= semiColon ) + <|> (parseUpdate e >>= semiColon ) + <|> (parseInsert e >>= semiColon ) + <|> (parseDelete e >>= semiColon ) + <|> (parseShowTables e >>= semiColon) + <|> parseUse e + where semiColon v = do keyword (==";") + return v + +quoted :: YqlParser String +quoted = accept test + where test (TkStr s) = Just s + test _ = Nothing + +numeric :: YqlParser String +numeric = accept test + where test (TkNum n) = Just n + test _ = Nothing + +keyword :: (String -> Bool) -> YqlParser String +keyword p = accept test + where test (TkKey k) | p k = Just k + | otherwise = Nothing + test _ = Nothing + +symbol :: (String -> Bool) -> YqlParser String +symbol p = accept test + where test (TkSym s) | p s = Just s + | otherwise = Nothing + test _ = Nothing + +symbol_ :: YqlParser String +symbol_ = symbol (const True) + +-- anyTokenT :: YqlParser TokenT +-- anyTokenT = accept Just + +tkEof :: YqlParser () +tkEof = accept $ \t -> case t + of TkEOF -> Just () + _ -> Nothing + +parseDesc :: ParserEvents i v w f s -> YqlParser s +parseDesc e = do keyword (=="DESC") + t <- parseIdentifier e + f <- parseFunctions e + return (onDesc e t f) + +parseShowTables :: ParserEvents i v w f s -> YqlParser s +parseShowTables e = do keyword (=="SHOW") + keyword (=="TABLES") + f <- parseFunctions e + return (onShowTables e f) + +parseUse :: ParserEvents i v w f s -> YqlParser s +parseUse e = do keyword (=="USE") + url <- quoted + keyword (=="AS") + as <- parseIdentifier e + keyword (==";") + stmt <- parseYql_ e + return (onUse e url as stmt) + +parseSelect :: ParserEvents i v w f s -> YqlParser s +parseSelect e = do keyword (=="SELECT") + c <- (fmap (const [onIdentifier e "*"]) (keyword (=="*")) + <|> parseIdentifier e `sepBy` keyword (==",")) + keyword (=="FROM") + t <- parseIdentifier e + rl <- remoteLimit + <|> return Nothing + w <- whereClause + <|> return Nothing + ll <- localLimit + <|> return Nothing + f <- parseFunctions e + return (onSelect e c t w rl ll f) + where whereClause = do keyword (=="WHERE") + fmap Just (parseWhere e) + + remoteLimit = do keyword (=="(") + off <- fmap read numeric + lim <- (do keyword (==",") + sz <- fmap read numeric + return (off,sz) + ) <|> return (0,off) + keyword (==")") + return (Just lim) + + localLimit = do keyword (=="LIMIT") + lim <- fmap read numeric + off <- (do keyword (=="OFFSET") + fmap read numeric + ) <|> return 0 + return (Just (off,lim)) + +parseUpdate :: ParserEvents i v w f s -> YqlParser s +parseUpdate e = do keyword (=="UPDATE") + t <- parseIdentifier e + keyword (=="SET") + c <- parseSet `sepBy` keyword (==",") + w <- whereClause + <|> return Nothing + f <- parseFunctions e + return (onUpdate e c t w f) + where whereClause = do keyword (=="WHERE") + fmap Just (parseWhere e) + + parseSet = do k <- parseIdentifier e + keyword (=="=") + v <- parseValue False e + return (k,v) + +parseDelete :: ParserEvents i v w f s -> YqlParser s +parseDelete e = do keyword (=="DELETE") + keyword (=="FROM") + t <- parseIdentifier e + w <- whereClause + <|> return Nothing + f <- parseFunctions e + return (onDelete e t w f) + where whereClause = do keyword (=="WHERE") + fmap Just (parseWhere e) + +parseInsert :: ParserEvents i v w f s -> YqlParser s +parseInsert e = do keyword (=="INSERT") + keyword (=="INTO") + t <- parseIdentifier e + keyword (=="(") + c <- parseIdentifier e `sepBy` keyword (==",") + keyword (==")") + keyword (=="VALUES") + keyword (=="(") + v <- parseValue False e `sepBy` keyword (==",") + keyword (==")") + f <- parseFunctions e + return (onInsert e (zip c v) t f) + +parseIdentifier :: ParserEvents i v w f s -> YqlParser i +parseIdentifier e = fmap (onIdentifier e) symbol_ + +parseValue :: Bool -> ParserEvents i v w f s -> YqlParser v +parseValue allowss e = fmap (onTxtValue e) quoted + <|> fmap (onNumValue e) numeric + <|> fmap (const $ onMeValue e) (keyword (=="ME")) + <|> if (allowss) + then fmap (onSubSelect e) (parseSelect e) + else fail "expecting Numeric|String|me" + +parseWhere :: ParserEvents i v w f s -> YqlParser w +parseWhere e = do c <- parseIdentifier e + wclause <- parseScalar c + <|> parseList c + <|> parseAssert c + (keyword (=="AND") >> fmap (onAndExpr e wclause) (parseWhere e)) + <|> (keyword (=="OR") >> fmap (onOrExpr e wclause) (parseWhere e)) + <|> return wclause + where parseScalar c = (keyword (=="=") >> fmap (onSingleOp e . EqOp c) (parseValue False e)) + <|> (keyword (=="!=") >> fmap (onSingleOp e . NeOp c) (parseValue False e)) + <|> (keyword (==">=") >> fmap (onSingleOp e . GeOp c) (parseValue False e)) + <|> (keyword (=="<=") >> fmap (onSingleOp e . LeOp c) (parseValue False e)) + <|> (keyword (==">") >> fmap (onSingleOp e . GtOp c) (parseValue False e)) + <|> (keyword (=="<") >> fmap (onSingleOp e . LtOp c) (parseValue False e)) + <|> (keyword (=="LIKE") >> fmap (onSingleOp e . LikeOp c) (parseValue False e)) + <|> (keyword (=="MATCHES") >> fmap (onSingleOp e . MatchesOp c) (parseValue False e)) + <|> (keyword (=="NOT") >> ((keyword (=="LIKE") >> fmap (onSingleOp e . NotLikeOp c) (parseValue False e)) + <|> (keyword (=="MATCHES") >> fmap (onSingleOp e . NotMatchesOp c) (parseValue False e)))) + + parseAssert c = keyword (=="IS") >> ((keyword (=="NOT") >> keyword (=="NULL") >> return (onAssertOp e (IsNotNullOp c))) + <|> (keyword (=="NULL") >> return (onAssertOp e (IsNullOp c)))) + + parseList c = do keyword (=="IN") + keyword (=="(") + list <- fmap (onListOp e . InOp c) (parseValue True e `sepBy` keyword (==",")) + keyword (==")") + return list + +parseFunctions :: ParserEvents i v w f s -> YqlParser [f] +parseFunctions e = (keyword (=="|") >> parseFunction e `sepBy` keyword (=="|")) + <|> return [] + +parseFunction :: ParserEvents i v w f s -> YqlParser f +parseFunction e = do n <- symbol_ + keyword (=="(") + argv <- arguments `sepBy` keyword (==",") + keyword (==")") + mkFunc n argv + where arguments = do k <- parseIdentifier e + keyword (=="=") + v <- parseValue False e + return (k,v) + + mkFunc ('.':n) argv = return (onLocalFunc e (onIdentifier e n) argv) + mkFunc n argv = return (onRemoteFunc e (onIdentifier e n) argv) + diff --git a/src/main/haskell/Yql/Core/Session.hs b/src/main/haskell/Yql/Core/Session.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Core/Session.hs @@ -0,0 +1,94 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Core.Session + ( -- * Types + SessionMgr(..) + , SessionBackend(..) + ) where + +import Network.OAuth.Consumer +import Data.Time +import Data.Binary +import System.Locale +import System.Directory +import Control.Monad (join,when) + +data SessionBackend = FileStorage FilePath + | DevNullStorage + +-- | Extends the token adding time information. +newtype TimedToken = TimedToken { unToken :: (String,Token) } + +augument :: Token -> IO TimedToken +augument tk = do ts <- fmap (formatTime defaultTimeLocale "%s") getCurrentTime + return (TimedToken (ts,tk)) + +fileSessionSave :: FilePath -> TimedToken -> IO () +fileSessionSave = encodeFile + +fileSessionLoad :: FilePath -> IO (Maybe TimedToken) +fileSessionLoad file = do shouldTry <- doesFileExist file + if (shouldTry) + then fmap Just (decodeFile file) + else return Nothing + +-- | Provide support for saving and restoring oauth tokens. +class SessionMgr s where + -- | Saves the token. + save :: s -> Token -> IO () + + -- | Loads the latest saved token. + load :: s -> IO (Maybe Token) + + -- | Delete the latest saved token. + unlink :: s -> IO () + + -- | Returns the time of the latest successfully save operation. + mtime :: s -> IO (Maybe UTCTime) + +instance SessionMgr SessionBackend where + save (FileStorage file) tk = augument tk >>= fileSessionSave file + save DevNullStorage _ = return () + + unlink (FileStorage file) = do shouldRemove <- doesFileExist file + when shouldRemove (removeFile file) + unlink DevNullStorage = return () + + load (FileStorage file) = fmap (fmap (snd . unToken)) (fileSessionLoad file) + load DevNullStorage = return Nothing + + mtime DevNullStorage = return Nothing + mtime (FileStorage file) = fmap (join . fmap (toUTC . fst . unToken)) (fileSessionLoad file) + where toUTC = parseTime defaultTimeLocale "%s" + +instance Binary TimedToken where + put (TimedToken (ts,tk)) = do put ts + put tk + + get = do ts <- get + tk <- get + return (TimedToken (ts,tk)) diff --git a/src/main/haskell/Yql/Core/Types.hs b/src/main/haskell/Yql/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Core/Types.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE FlexibleInstances #-} +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Core.Types + ( -- * Types + Value(..) + , Where(..) + , Description(..) + , Security(..) + , Expression(..) + , Function(..) + -- * Query + , select + , update + , insert + , delete + , use + , desc + , local + , remote + , functions + , usingMe + , tables + , showTables + -- * Parsing + , builder + , readStmt + , readDescXml + , readShowTablesXml + -- * Priting + , showStmt + , showFunc + , showValue + , showWhere + ) where + +import Yql.Core.Parser +import Yql.Data.Xml +import Data.List hiding (insert,delete) +import Data.Char +import Control.Monad + +-- | The different type of values that may appear in a yql statement. +data Value = TxtValue String + | NumValue String + | SubSelect Expression + | MeValue + deriving (Eq) + +-- | Where clause to filter/limit data in yql statements. +data Where = String `OpEq` Value + | String `OpNe` Value + | String `OpGt` Value + | String `OpGe` Value + | String `OpLike` Value + | String `OpNotLike` Value + | String `OpMatches` Value + | String `OpNotMatches` Value + | String `OpLt` Value + | String `OpLe` Value + | String `OpIn` [Value] + | OpIsNull String + | OpIsNotNull String + | Where `OpAnd` Where + | Where `OpOr` Where + deriving (Eq) + +-- | Functions that transform output. +data Function = Local { name :: String + , args :: [(String,Value)] + } + | Remote { name :: String + , args :: [(String,Value)] + } + deriving (Eq) + +-- | The different statements supported. +data Expression = SELECT [String] String (Maybe Where) (Maybe Limit) (Maybe Limit) [Function] + | DESC String [Function] + | UPDATE [(String,Value)] String (Maybe Where) [Function] + | INSERT [(String,Value)] String [Function] + | DELETE String (Maybe Where) [Function] + | SHOWTABLES [Function] + | USE String String Expression + deriving (Eq) + +-- | The different security level tables may request +data Security = User -- ^ Requires 3-legged oauth to perform the request + | App -- ^ Requires 2-legged oauth to perform the request + | Any -- ^ No authentication is required + deriving (Eq) + +-- | The description of a table, usually the result of a desc +-- command. +data Description = Table { table :: String + , security :: Security + , https :: Bool + } + deriving (Eq) + +-- | Listen to parser events to build Expression type. +builder :: ParserEvents String Value Where Function Expression +builder = ParserEvents { onIdentifier = id + , onTxtValue = TxtValue + , onNumValue = NumValue + , onSubSelect = SubSelect + , onMeValue = MeValue + , onUse = USE + , onSelect = SELECT + , onUpdate = UPDATE + , onDelete = DELETE + , onInsert = INSERT + , onDesc = DESC + , onShowTables = SHOWTABLES + , onAssertOp = mkAssertOp + , onSingleOp = mkSingleOp + , onListOp = mkListOp + , onAndExpr = OpAnd + , onOrExpr = OpOr + , onRemoteFunc = Remote + , onLocalFunc = Local + } + where mkSingleOp (EqOp c v) = OpEq c v + mkSingleOp (NeOp c v) = OpNe c v + mkSingleOp (GeOp c v) = OpGe c v + mkSingleOp (GtOp c v) = OpGt c v + mkSingleOp (LeOp c v) = OpLe c v + mkSingleOp (LtOp c v) = OpLt c v + mkSingleOp (LikeOp c v) = OpLike c v + mkSingleOp (NotLikeOp c v) = OpNotLike c v + mkSingleOp (MatchesOp c v) = OpMatches c v + mkSingleOp (NotMatchesOp c v) = OpNotMatches c v + + mkListOp (InOp c vs) = OpIn c vs + + mkAssertOp (IsNullOp c) = OpIsNull c + mkAssertOp (IsNotNullOp c) = OpIsNotNull c + +-- | Test if the statement is a select statement +select :: Expression -> Bool +select (SELECT _ _ _ _ _ _) = True +select (USE _ _ e) = select e +select _ = False + +-- | Test if the statment is a desc statament +desc :: Expression -> Bool +desc (DESC _ _) = True +desc (USE _ _ e) = desc e +desc _ = False + +-- | Test if the statement is a show tables statement +showTables :: Expression -> Bool +showTables (SHOWTABLES _) = True +showTables (USE _ _ e) = showTables e +showTables _ = False + +update :: Expression -> Bool +update (UPDATE _ _ _ _) = True +update (USE _ _ e) = update e +update _ = False + +-- | Test if the statement is a insert statement +insert :: Expression -> Bool +insert (INSERT _ _ _) = True +insert (USE _ _ e) = insert e +insert _ = False + +-- | Test if this is a use statement +use :: Expression -> Bool +use (USE _ _ _) = True +use _ = False + +-- | Test if the statement is a delete statement +delete :: Expression -> Bool +delete (DELETE _ _ _) = True +delete (USE _ _ e) = delete e +delete _ = False + +-- | Test if the function is a local function +local :: Function -> Bool +local (Local _ _) = True +local _ = False + +-- | Test if the function is a remote function +remote :: Function -> Bool +remote (Remote _ _) = True +remote _ = False + +-- | Extracts all tables in use in the statement +tables :: Expression -> [String] +tables stmt = case stmt + of (SELECT _ t (Just w) _ _ _) -> t : walkWhere w + (SELECT _ t Nothing _ _ _) -> [t] + (DESC t _) -> [t] + (INSERT _ t _) -> [t] + (DELETE t _ _) -> [t] + (UPDATE _ t _ _) -> [t] + (SHOWTABLES _) -> [] + (USE _ _ stmt') -> tables stmt' + where walkWhere (_ `OpIn` []) = [] + walkWhere (_ `OpIn` vs) = let subselects = filter (\v -> case v of (SubSelect _) -> True; _ -> False) vs + in concatMap (\(SubSelect v) -> tables v) subselects + walkWhere (l `OpAnd` r) = walkWhere l ++ walkWhere r + walkWhere (l `OpOr` r) = walkWhere l ++ walkWhere r + walkWhere _ = [] + +-- | Test whether or not a query contains the ME keyword in the where +-- clause +usingMe :: Expression -> Bool +usingMe stmt = case stmt + of (SELECT _ _ w _ _ _) -> Just True == fmap findMe w + (DESC _ _) -> False + (UPDATE c _ w _) -> Just True == fmap findMe w + || any (MeValue==) (map snd c) + (INSERT c _ _) -> any (MeValue==) (map snd c) + (DELETE _ w _) -> Just True == fmap findMe w + (SHOWTABLES _) -> False + (USE _ _ stmt') -> usingMe stmt' + where findMe (_ `OpEq` v) = v == MeValue + findMe (_ `OpNe` v) = v == MeValue + findMe (_ `OpGe` v) = v == MeValue + findMe (_ `OpGt` v) = v == MeValue + findMe (_ `OpLe` v) = v == MeValue + findMe (_ `OpLt` v) = v == MeValue + findMe (_ `OpLike` v) = v == MeValue + findMe (_ `OpNotLike` v) = v == MeValue + findMe (_ `OpMatches` v) = v == MeValue + findMe (_ `OpNotMatches` v) = v == MeValue + findMe (_ `OpIn` vs) = any (==MeValue) vs + findMe (OpIsNull _) = False + findMe (OpIsNotNull _) = False + findMe (w0 `OpAnd` w1) = findMe w0 || findMe w1 + findMe (w0 `OpOr` w1) = findMe w0 || findMe w1 + +functions :: Expression -> [Function] +functions (SELECT _ _ _ _ _ f) = f +functions (DESC _ f) = f +functions (UPDATE _ _ _ f) = f +functions (INSERT _ _ f) = f +functions (DELETE _ _ f) = f +functions (SHOWTABLES f) = f +functions (USE _ _ stmt) = functions stmt + +showStmt :: Expression -> String +showStmt stmt = case stmt + of DESC tbl func -> "DESC " + ++ tbl + ++ funcString func + ++ ";" + SELECT cols tbl whre lim0 lim1 func -> "SELECT " + ++ intercalate "," cols + ++ " FROM " + ++ tbl + ++ showRemoteLimit lim0 + ++ whereString whre + ++ showLocalLimit lim1 + ++ funcString func + ++ ";" + UPDATE set tbl whre func -> "UPDATE " + ++ tbl + ++ " SET " + ++ intercalate "," (map (\(k,v) -> k++"="++showValue v) set) + ++ whereString whre + ++ funcString func + ++ ";" + INSERT set tbl func -> "INSERT INTO " + ++ tbl + ++ " (" + ++ intercalate "," (map fst set) + ++ ") VALUES (" + ++ intercalate "," (map (showValue . snd) set) + ++ ")" + ++ funcString func + ++ ";" + DELETE tbl whre func -> "DELETE FROM " + ++ tbl + ++ whereString whre + ++ funcString func + ++ ";" + SHOWTABLES func -> "SHOW TABLES" + ++ funcString func + ++ ";" + USE url as stmt' -> "USE "++ (showValue (TxtValue url)) ++" AS "++ as ++";"++ showStmt stmt' + where funcString func | null func = "" + | otherwise = " | " ++ intercalate " | " (map show func) + + whereString Nothing = "" + whereString (Just w) = " WHERE "++ (show w) + + showRemoteLimit Nothing = "" + showRemoteLimit (Just (o,l)) = " ("++ show o ++","++ show l ++ ")" + + showLocalLimit Nothing = "" + showLocalLimit (Just (o,l)) = " LIMIT "++ show l ++" OFFSET "++ show o + +readStmt :: String -> Either ParseError Expression +readStmt = flip parseYql builder + +readDescXml :: XML -> Maybe Description +readDescXml xml = case (map toLower securityAttr) + of "user" -> fmap (\n -> Table n User httpsAttr) (attr "name") + "app" -> fmap (\n -> Table n App httpsAttr) (attr "name") + _ -> fmap (\n -> Table n Any httpsAttr) (attr "name") + where attr k = join (fmap (attribute k) (findElement "table" xml)) + Just securityAttr = attr "security" `mplus` Just "ANY" + httpsAttr = Just "true" == attr "https" + +readShowTablesXml :: XML -> [String] +readShowTablesXml = map verbatim . findElements "table" + +showFunc :: Function -> String +showFunc f = prefix ++ name f ++ "(" ++ intercalate "," (map showArg (args f)) ++ ")" + where showArg (k,v) = k ++ "=" ++ show v + + prefix | local f = "." + | otherwise = "" + +showWhere :: Where -> String +showWhere (c `OpEq` v) = c ++" = "++ show v +showWhere (c `OpGt` v) = c ++" > "++ show v +showWhere (c `OpLt` v) = c ++" < "++ show v +showWhere (c `OpNe` v) = c ++" != "++ show v +showWhere (c `OpGe` v) = c ++" >= "++ show v +showWhere (c `OpLe` v) = c ++" <= "++ show v +showWhere (c `OpLike` v) = c ++" LIKE "++ show v +showWhere (c `OpNotLike` v) = c ++" NOT LIKE "++ show v +showWhere (c `OpMatches` v) = c ++" MATCHES "++ show v +showWhere (c `OpNotMatches` v) = c ++" NOT MATCHES "++ show v +showWhere (c `OpIn` vs) = c ++" IN ("++ intercalate "," (map show vs) ++")" +showWhere (l `OpAnd` r) = show l ++" AND "++ show r +showWhere (l `OpOr` r) = show l ++" OR "++ show r +showWhere (OpIsNull c) = c ++ " IS NULL" +showWhere (OpIsNotNull c) = c ++ " IS NOT NULL" + +showValue :: Value -> String +showValue (MeValue) = "me" +showValue (SubSelect s) = init (showStmt s) +showValue (NumValue v) = v +showValue (TxtValue v) = ("\""++ escape v ++"\"") + where escape ('"':xs) = '\\' : '"' : escape xs + escape (x:xs) = x : escape xs + escape [] = [] + +instance Read Expression where + readsPrec _ input = case (readStmt input) + of Left _ -> [] + Right stmt -> [(stmt,"")] + +instance Show Expression where + showsPrec _ = showString . showStmt + +instance Show Function where + showsPrec _ = showString . showFunc + +instance Show Where where + showsPrec _ = showString . showWhere + +instance Show Value where + showsPrec _ = showString . showValue + +instance Ord Security where + compare Any Any = EQ + compare App App = EQ + compare User User = EQ + compare Any _ = LT + compare User _ = GT + compare App Any = GT + compare App User = LT diff --git a/src/main/haskell/Yql/Data/Cfg.hs b/src/main/haskell/Yql/Data/Cfg.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Data/Cfg.hs @@ -0,0 +1,119 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Data.Cfg + ( -- * Types + Cfg() + -- * Reading + , cfg + , tryCfg + , tryCfgs + , tryUsrCfg + , tryUsrCfgs + , usrCfg + , parseCfg + , basedir + -- * Building + , empty + , fromList + ) where + +import Prelude hiding (catch) +import Data.Char +import Data.List +import Control.Exception +import System.FilePath +import System.Directory +import System.IO + +newtype Cfg = Cfg [(String,String)] + deriving (Show,Eq,Ord) + +-- | Returns an empty configuration +empty :: Cfg +empty = fromList [] + +-- | Reads configuration from a list +fromList :: [(String,String)] -> Cfg +fromList = Cfg + +-- | Read a config entry or return a default value in case there is an +-- error. +tryCfg :: Cfg -> String -> String -> String +tryCfg (Cfg db) key def = case (lookup key db) + of Nothing -> def + Just rst -> rst + +-- | Read a config entry that is allowed to be defined multiple times. +tryCfgs :: Cfg -> String -> [String] -> [String] +tryCfgs (Cfg ((k,v):es)) key def + | k==key = v : tryCfgs (Cfg es) key [] + | otherwise = tryCfgs (Cfg es) key def +tryCfgs (Cfg []) _ def = def + +-- | Read a config from the user configuration file. +tryUsrCfg :: String -> String -> IO String +tryUsrCfg key def = usrCfg >>= \db -> return $ tryCfg db key def + +-- | Read a config from the user configuration file. +tryUsrCfgs :: String -> [String] -> IO [String] +tryUsrCfgs key def = usrCfg >>= \db -> return $ tryCfgs db key def + +-- | Read a config entry from the configuration file. +cfg :: FilePath -> IO Cfg +cfg file = catch readCfg (\(SomeException _) -> return (Cfg [])) + where readCfg = do available <- doesFileExist file + if (available) + then bracket (openFile file ReadMode) hClose (\h -> fmap parseCfg (hGetContents h >>= evaluate)) + else return (Cfg []) + +-- | The configuration file is as follows: +-- 1. Lines starting with -- are considered comments; +-- 2. Empty lines are also discarded; +-- 3. Entries are simply pairs, separated by colon (:); +parseCfg :: String -> Cfg +parseCfg = Cfg . map (parseEntry . stripComments) . filter properEntries . lines + where properEntries xs0 + | "--" `isPrefixOf` xs = False + | null xs = False + | otherwise = True + where xs = dropWhile isSpace xs0 + + parseEntry xs = let (key,val) = break (==':') (dropWhile isSpace xs) + in (key,dropWhile isSpace (drop 1 val)) + + stripComments [] = [] + stripComments ('-':'-':_) = [] + stripComments (x:xs) = x : stripComments xs + +-- | Base directory where configuration files are read from +basedir :: IO FilePath +basedir = fmap (\home -> joinPath [home,".iyql"]) getHomeDirectory + +-- | File configuration file +usrCfg :: IO Cfg +usrCfg = do home <- basedir + cfg (joinPath [home,"cfg"]) diff --git a/src/main/haskell/Yql/Data/Trie.hs b/src/main/haskell/Yql/Data/Trie.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Data/Trie.hs @@ -0,0 +1,99 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +-- | A [inefficient] implementation of Trie +module Yql.Data.Trie + ( -- * Types + Trie() + -- * Query + , Yql.Data.Trie.null + , member + , size + , subtrie + -- * Conversion + , fromList + , toList + -- * Traversal + , fold + -- * Construction + , empty + , singleton + -- * Combine + , union + ) where + +import qualified Data.Map as M + +data Trie k = Trie (M.Map k (Bool,Trie k)) + deriving (Show,Eq,Ord) + +fold :: ([k] -> a -> a) -> a -> Trie k -> a +fold f0 z0 = fst . fold' f0 (z0,id) + where fold' f z (Trie m) = M.foldrWithKey g z m + where g k (leaf,t) (acc,ks) + | leaf = (f (ks.(k:) $ []) (fold h acc t), ks) + | otherwise = fold' h (acc, ks) t + where h = f . (k:) + +-- | Test if a given Trie is empty +null :: Trie k -> Bool +null (Trie m) = M.null m + +-- | Creates an empty trie +empty :: Trie k +empty = Trie M.empty + +-- | Returns a trie with a single value +singleton :: Ord k => [k] -> Trie k +singleton ks = fromList [ks] + +-- | Maps a trie into list type, such as `toList . fromList = id' +toList :: Show k => Trie k -> [[k]] +toList = fold (:) [] + +-- | Maps a list into trie, such as `fromList . toList = id'. +fromList :: Ord k => [[k]] -> Trie k +fromList = foldr union empty . map fromList' + where fromList' (k:ks) = Trie (M.singleton k (Prelude.null ks,fromList' ks)) + fromList' [] = empty + +-- | The number of entries in the trie. +size :: Show k => Trie k -> Int +size = fold (const (1+)) 0 + +union :: Ord k => Trie k -> Trie k -> Trie k +union (Trie v0) (Trie v1) = Trie (M.unionWith unionValue v0 v1) + where unionValue (a,t0) (b,t1) = (a || b,t0 `union` t1) + +-- | Performs a prefix search. +subtrie :: Ord k => [k] -> Trie k -> Trie k +subtrie = flip (foldl f) + where f (Trie m) k = snd $ M.findWithDefault (False,empty) k m + +-- | Test whether a given prefix is in the trie. +member :: Ord k => [k] -> Trie k -> Bool +member ks t = fst $ foldl f (True,t) ks + where f (_,Trie m) k = M.findWithDefault (False,empty) k m diff --git a/src/main/haskell/Yql/Data/Version.hs b/src/main/haskell/Yql/Data/Version.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Data/Version.hs @@ -0,0 +1,35 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Data.Version + ( version + , showVersion + ) where + +import Data.Version + +version :: Version +version = Version [0,0,5] ["alpha"] diff --git a/src/main/haskell/Yql/Data/Xml.hs b/src/main/haskell/Yql/Data/Xml.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/Data/Xml.hs @@ -0,0 +1,91 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.Data.Xml + ( -- * Types + XML() + -- * Parsing + , xmlParse + -- * Querying + , findElement + , findElements + , childNodes + , attributes + , attribute + , tagName + , verbatim + , element + , pcdata + -- * Printing + , xmlPrint + ) where + +import qualified Text.XML.Light as X + +newtype XML = XML X.Content + +unpackElement :: XML -> X.Element +unpackElement (XML (X.Elem e)) = e +unpackElement _ = error "element expected" + +element :: XML -> Bool +element (XML (X.Elem _)) = True +element _ = False + +pcdata :: XML -> Bool +pcdata (XML (X.Text _)) = True +pcdata _ = False + +xmlParse :: String -> Maybe XML +xmlParse = fmap (XML . X.Elem) . X.parseXMLDoc + +xmlPrint :: XML -> String +xmlPrint = X.ppTopElement . unpackElement + +findElement :: String -> XML -> Maybe XML +findElement tag = fmap (XML . X.Elem) . X.findElement (X.QName tag Nothing Nothing) . unpackElement + +findElements :: String -> XML -> [XML] +findElements tag = map (XML . X.Elem) . X.findElements (X.QName tag Nothing Nothing) . unpackElement + +childNodes :: XML -> [XML] +childNodes (XML (X.Elem (X.Element _ _ cs _))) = map XML cs +childNodes _ = [] + +verbatim :: XML -> String +verbatim (XML (X.Text e)) = X.cdData e +verbatim xml = concatMap verbatim (childNodes xml) + +tagName :: XML -> String +tagName (XML (X.Elem (X.Element q _ _ _))) = X.qName q +tagName _ = error "element was expected" + +attributes :: XML -> [(String,String)] +attributes (XML (X.Elem (X.Element _ attrs _ _))) = map (\attr -> (X.qName (X.attrKey attr), X.attrVal attr)) attrs +attributes _ = [] + +attribute :: String -> XML -> Maybe String +attribute k = lookup k . attributes diff --git a/src/main/haskell/Yql/UI/CLI/Command.hs b/src/main/haskell/Yql/UI/CLI/Command.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Command.hs @@ -0,0 +1,71 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Command + ( Command(..) + , Database + , man + , bin + , help + , bind + , dump + ) where + +import qualified Data.Map as M + +-- | The command is a pair consisting of a) The documentation; and b) +-- the command itself. +newtype Command a = Command { runCommand :: (String -> String,String -> [String] -> IO a) } + +-- | The database of available commands +type Database a = M.Map String (Command a) + +dump :: Command String -> Command () +dump (Command (d,f)) = Command (d,proxy) + where proxy n argv = f n argv >>= putStrLn + +bind :: a -> Command b -> Command a +bind a (Command (d,f)) = Command (d,proxy) + where proxy n argv = f n argv >> return a + +-- | Extracts the help message of the command +man :: Command a -> String -> String +man = fst . runCommand + +-- | Extracts the binary +bin :: Command a -> String -> [String] -> IO a +bin = snd . runCommand + +-- | The help command, whith displays all available commands in the database +help :: Database a -> Command String +help database = Command (const doc,const (const exe)) + where doc = "This message" + exe = return $ unlines $ map (manThis 16) (M.toList database) + where manThis avail (link,cmd) = let diff = max 0 (avail - length link) + in " :" ++ link ++ (replicate diff ' ') ++ (addMargin (avail+2) (lines (man cmd link))) + addMargin by (l:ls) = unlines (l : map ((replicate by ' ')++) ls) + addMargin _ [] = unlines [] + diff --git a/src/main/haskell/Yql/UI/CLI/Commands/Login.hs b/src/main/haskell/Yql/UI/CLI/Commands/Login.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Commands/Login.hs @@ -0,0 +1,43 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Commands.Login + ( login + ) where + +import Yql.Core.Backend +import Yql.Core.Types +import Yql.UI.CLI.Command +import Network.OAuth.Consumer +import Network.OAuth.Http.HttpClient + +-- | Removes any saved oauth_token. +login :: Yql y => y -> Command () +login be = Command (const doc,const (const exe)) + where doc = "Execute the oauth authorization flow to perform authenticated requests." + exe = do unCurlM (runOAuth (credentials be User)) + return () + diff --git a/src/main/haskell/Yql/UI/CLI/Commands/Logout.hs b/src/main/haskell/Yql/UI/CLI/Commands/Logout.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Commands/Logout.hs @@ -0,0 +1,38 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Commands.Logout + ( logout + ) where + +import Yql.Core.Session +import Yql.UI.CLI.Command + +-- | Removes any saved oauth_token. +logout :: SessionMgr s => s -> Command () +logout session = Command (const doc,const (const exe)) + where doc = "Purges any saved oauth token previously" + exe = unlink session diff --git a/src/main/haskell/Yql/UI/CLI/Commands/ManLf.hs b/src/main/haskell/Yql/UI/CLI/Commands/ManLf.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Commands/ManLf.hs @@ -0,0 +1,52 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Commands.ManLf + ( manlf + ) where + +import qualified Yql.Core.LocalFunction as F +import qualified Data.Map as M +import Data.List (sort) +import Yql.UI.CLI.Command + +-- | Invokes the man of a given local function +manlf :: F.Database -> Command String +manlf db = Command (doc, const exe) + where doc link = unlines [ "Prints the help message of the given local function. Without arguments prints all available functions." + , "Examples:" + , " :"++ link ++" .request" + , " :"++ link ++" .tables" + ] + exe args = if (null args) + then return list + else return $ concatMap manpage args + where list = let links = M.keys db + in unlines (map ('.':) (sort links)) + + manpage link = case (M.lookup (drop 1 link) db) + of Nothing -> "man: no manual entry for "++ link + Just f -> link ++": "++ F.man f link diff --git a/src/main/haskell/Yql/UI/CLI/Commands/Parser.hs b/src/main/haskell/Yql/UI/CLI/Commands/Parser.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Commands/Parser.hs @@ -0,0 +1,76 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Commands.Parser + ( parseCmd + ) where + +import Data.Char +import Text.ParserCombinators.Parsec + +type CmdParser a = GenParser Char String a + +parseCmd :: String -> Maybe (String,[String]) +parseCmd input = case (runParser parser "" "stdin" input) + of Left _ -> Nothing + Right output -> Just output + +parser :: CmdParser (String,[String]) +parser = do many space + command <- parseIdentifier + args <- sepEndBy parseArgument (many space) + return (command,filter (not . all isSpace) args) + +parseIdentifier :: CmdParser String +parseIdentifier = do char ':' + many identifier + where identifier = letter <|> digit <|> char '_' + +parseArgument :: CmdParser String +parseArgument = do c <- lookAhead anyChar + case c of + '\'' -> parseQuotedArg + '"' -> parseQuotedArg + _ -> parseSimpleArg + +parseQuotedArg :: CmdParser String +parseQuotedArg = do q <- oneOf ['"','\''] + value <- regular q + return value + where regular q = do c <- anyChar + if (c==q) + then return [] + else accept c q + + exceptional q = do c <- oneOf [q,'\\'] + fmap (c:) (accept c q) + + accept '\\' q = exceptional q + accept c q | c==q = regular q + | otherwise = fmap (c:) (regular q) + +parseSimpleArg :: CmdParser String +parseSimpleArg = many (satisfy (not . isSpace)) diff --git a/src/main/haskell/Yql/UI/CLI/Commands/SetEnv.hs b/src/main/haskell/Yql/UI/CLI/Commands/SetEnv.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Commands/SetEnv.hs @@ -0,0 +1,48 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Commands.SetEnv + ( setenv + ) where + +import qualified Yql.Core.Backend as Y +import Yql.UI.CLI.Command + +-- | Modifies the env parameters that are sent to yql +setenv :: Y.Yql y => y -> Command (Either String y) +setenv be0 = Command (doc, const exe) + where doc n = unlines [ "Modifies the env parameters that are sent to yql" + , "Examples:" + , " :"++n++" +foobar :: Appends the `foobar' string to the env list" + , " :"++n++" -foobar :: Removes the `foobar' string from the env list" + , " :"++n++" foobar :: Resets the env, leaving only `foobar' string defined" + , " :"++n++" :: Dump the current env list" + ] + exe [] = return (Left $ unlines (Y.getenv be0)) + exe es = return (Right $ foldr fold be0 es) + where fold ('+':env) be = Y.setenv be env + fold ('-':env) be = Y.unsetenv be env + fold (env) be = Y.setenv (foldr (flip Y.unsetenv) be (Y.getenv be)) env diff --git a/src/main/haskell/Yql/UI/CLI/Commands/WhoAmI.hs b/src/main/haskell/Yql/UI/CLI/Commands/WhoAmI.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Commands/WhoAmI.hs @@ -0,0 +1,43 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Commands.WhoAmI + ( whoami + ) where + +import Yql.Core.Session +import Yql.UI.CLI.Command +import Network.OAuth.Consumer +import Network.OAuth.Http.Request + +-- | Returns the guid of the current user. +whoami :: SessionMgr s => s -> Command String +whoami session = Command (const doc, const (const exe)) + where doc = "Returns the guid of the current authenticated user (if any)" + exe = do mtoken <- load session + case mtoken + of Nothing -> return "nobody" + Just token -> return (findWithDefault ("xoauth_yahoo_guid","nobody") (oauthParams token)) diff --git a/src/main/haskell/Yql/UI/CLI/Input.hs b/src/main/haskell/Yql/UI/CLI/Input.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Input.hs @@ -0,0 +1,89 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Input + ( -- * Types + EventHandler(..) + , loop + ) where + +import System.Console.Haskeline +import System.Console.Haskeline.History +import Control.Monad.State +import Data.Maybe +import Data.Char +import Data.List +import Yql.Core.Backend + +data EventHandler y = Handler { execCommand :: y -> String -> InputT IO (Maybe y) + , execStatement :: y -> String -> InputT IO () + } + +empty :: String -> Bool +empty = all isSpace + +prompt :: (String,String) +prompt = ("iyql> "," ...> ") + +defPrompt :: String +defPrompt = fst prompt + +contPrompt :: String +contPrompt = snd prompt + +appendHistory :: String -> InputT IO () +appendHistory e = fmap (addHistoryUnlessConsecutiveDupe e) get >>= put + +command :: String -> Bool +command = (":" `isPrefixOf`) . dropWhile isSpace + +next :: InputT IO (Maybe String) +next = next_ defPrompt + where next_ p = do minput <- getInputLine p + case minput + of Nothing -> return Nothing + Just input + | empty input -> next_ defPrompt + | scEnding input -> return (Just input) + | command input -> return (Just input) + | otherwise -> do Just suffix <- fmap (`mplus` Just "") (next_ contPrompt) + return (Just $ input ++" "++ suffix) + + scEnding xs = ";" `isPrefixOf` (dropWhile (isSpace) (reverse xs)) + +loop :: Yql y => y -> EventHandler y -> InputT IO () +loop y ex = do minput <- next + case minput + of Nothing -> return () + Just input + | command input -> do appendHistory input + newY <- execCmd input + when (isJust newY) (loop (fromJust newY) ex) + | otherwise -> do appendHistory input + execStmt input + loop y ex + where execCmd = execCommand ex y + execStmt = execStatement ex y diff --git a/src/main/haskell/Yql/UI/CLI/Options.hs b/src/main/haskell/Yql/UI/CLI/Options.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/CLI/Options.hs @@ -0,0 +1,101 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.CLI.Options + ( Options(..) + , options + , usage + , getoptions + , wantVersion + , wantHelp + , wantExecStmt + , wantVerbose + , version + , verbose + , help + , execStmt + , env + ) where + +import System.Console.GetOpt + +data Options = Verbose + | Version + | Help + | ExecStmt String + | Env String + deriving (Eq,Show) + +options :: [ OptDescr Options ] +options = [ Option "x" ["execute"] (ReqArg ExecStmt "") "Specifies the statement to be sent to yql and print the results to the standard output" + , Option "V" ["version"] (NoArg Version) "Print a version number to the standard output" + , Option "h" ["help"] (NoArg Help) "This message" + , Option "e" ["env"] (ReqArg Env "") "Default env to load. May be used multiple times" + ] + +usage :: [String] -> String +usage argv | null argv = usageInfo "Usage:" options + | otherwise = usageInfo ("iyql usage:") options + +version :: Options -> Bool +version Version = True +version _ = False + +verbose :: Options -> Bool +verbose Verbose = True +verbose _ = False + +help :: Options -> Bool +help Help = True +help _ = False + +env :: Options -> Bool +env (Env _) = True +env _ = False + +execStmt :: Options -> Bool +execStmt (ExecStmt _) = True +execStmt _ = False + +wantVersion :: [Options] -> Bool +wantVersion = any version + +wantHelp :: [Options] -> Bool +wantHelp = any help + +wantVerbose :: [Options] -> Bool +wantVerbose = any version + +wantExecStmt :: [Options] -> Bool +wantExecStmt = any execStmt + +getoptions :: [String] -> Either String [Options] +getoptions argv = case (errors,unknown) + of ([],[]) -> Right actions + _ -> Left (concat errors + ++ concat unknown + ++ usage argv) + where (actions,unknown,errors) = getOpt Permute options argv diff --git a/src/main/haskell/Yql/UI/Cli.hs b/src/main/haskell/Yql/UI/Cli.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Yql/UI/Cli.hs @@ -0,0 +1,167 @@ +-- Copyright (c) 2010, Diego Souza +-- 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 the nor the names of its 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 HOLDER 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. + +module Yql.UI.Cli where + +import System +import System.FilePath +import System.Console.Haskeline +import Network.OAuth.Http.HttpClient +import Control.Monad.Trans +import Yql.Data.Version +import Yql.Data.Cfg (basedir) +import Yql.Data.Xml +import Yql.Data.Trie +import Yql.Core.Backend +import Yql.Core.LocalFunction +import Yql.Core.Lexer (keywords) +import qualified Yql.Core.LocalFunctions.Request as R +import qualified Yql.Core.LocalFunctions.Tables as T +import Yql.Core.Session +import Yql.Core.Parser +import Yql.Core.Types +import Yql.UI.CLI.Input +import Yql.UI.CLI.Command +import Yql.UI.CLI.Commands.Parser +import Yql.UI.CLI.Commands.WhoAmI +import Yql.UI.CLI.Commands.Logout +import Yql.UI.CLI.Commands.Login +import Yql.UI.CLI.Commands.ManLf +import qualified Yql.UI.CLI.Commands.SetEnv as E +import qualified Data.Map as M +import qualified Yql.UI.CLI.Options as O + +funcDB :: Yql.Core.LocalFunction.Database +funcDB = M.fromList [ ("request", R.function) + , ("json", R.jsonFunction) + , ("diagnostics", R.diagnosticsFunction) + , ("tables", T.function) + , ("endpoint", R.endpointFunction) + ] + + +cmdDB :: (SessionMgr s, Yql y) => s -> y -> Yql.UI.CLI.Command.Database y +cmdDB s y = M.insert "help" (bind y $ dump $ help woHelp) woHelp + where woHelp = M.fromList [ ("logout", bind y $ logout s) + , ("login", bind y $ login y) + , ("whoami", bind y $ dump $ whoami s) + , ("help", bind y $ help M.empty) + , ("env", fixSetenv (E.setenv y)) + , ("man", bind y $ dump $ manlf funcDB) + ] + + fixSetenv (Command (d,f)) = Command (d,proxy) + where proxy n argv = do output <- f n argv + case output + of Left out -> do putStrLn out + return y + Right y' -> return y' + +completeCli :: Trie Char -> String -> [Completion] +completeCli t w + | member w t = map (\s -> Completion s s True) (w : list) + | otherwise = map (\s -> Completion s s True) list + where fixPrefix = map (w++) + list = fixPrefix (toList (subtrie w t)) + +outputVersion :: String -> InputT IO () +outputVersion link = outputStrLn $ unlines [ link ++" "++ showVersion version + , "Copyright (C) 2010 dsouza " + , "License GPLv3+: " + , "This is free software, and you are welcome to change and redistribute it." + , "This program comes with ABSOLUTELY NO WARRANTY." + ] + +outputHelp :: InputT IO () +outputHelp = do outputStrLn "Enter :help for instructions" + outputStrLn "Enter YQL statements terminated with a \";\"" + +execYql_ :: Yql y => y -> String -> InputT IO () +execYql_ y input = liftIO (execYql y input) >>= outputStrLn + +execYql :: Yql y => y -> String -> IO String +execYql y input = case (parseYql input builder) + of Left err -> return (show err) + Right stmt -> fmap (either id id) (unCurlM (unOutputT (execute y funcDB stmt))) + +execCmd :: (SessionMgr s,Yql y) => s -> y -> String -> InputT IO (Maybe y) +execCmd s y input = case (parseCmd input) + of Nothing -> do outputStrLn (input ++ " : parse error") + return (Just y) + Just ("quit",_) -> return Nothing + Just (link,argv) -> case (M.lookup link (cmdDB s y)) + of Nothing -> do outputStrLn (input ++ " : unknown command") + return (Just y) + Just cmd -> fmap Just (liftIO $ bin cmd link argv) + +putenv :: Yql y => y -> [String] -> y +putenv = foldr (flip setenv) + +putenvM :: Yql y => y -> IO y +putenvM y = do argv <- getArgs + case (O.getoptions argv) + of Right opts -> return (putenv y (map (\(O.Env e) -> e) (filter O.env opts))) + _ -> return y + +run :: (SessionMgr s,Yql y) => s -> y -> InputT IO () +run s y = do argv <- liftIO getArgs + case (O.getoptions argv) + of Left errors -> outputStrLn errors + Right actions -> runActions argv actions + where runActions argv opts + | O.wantVersion opts = liftIO getProgName >>= outputVersion + | O.wantHelp opts = outputStrLn $ O.usage argv + | O.wantExecStmt opts = let O.ExecStmt stmt = head . filter O.execStmt $ opts + in execYql_ y stmt + | otherwise = do outputHelp + loop y (Handler (execCmd s) execYql_) + return () + + +runShowTables :: Yql y => y -> IO [String] +runShowTables y = do mxml <- fmap xmlParse (execYql y "SHOW TABLES;") + case mxml + of Nothing -> return [] + Just xml -> return (readShowTablesXml xml) + +iyql :: (SessionMgr s,Yql y) => s -> y -> IO () +iyql s y0 = do y <- putenvM y0 + alltables <- runShowTables y + myCfg <- fmap (settings (mkTrie alltables)) basedir + runInputT myCfg (run s y) + where settings trie home = Settings { complete = let func = return . completeCli trie + in completeQuotedWord (Just '\\') "\"'" func (completeWord (Just '\\') " \t;" func) + , historyFile = Just $ joinPath [home,"history"] + , autoAddHistory = False + } + + mkTrie alltables = fromList . concat $ [ allcommands + , allfunctions + , keywords + , alltables + ] + where allcommands = map (':':) (M.keys (cmdDB s y0)) + allfunctions = map ('.':) (M.keys funcDB)