packages feed

iyql 0.0.5 → 0.0.5.1

raw patch · 23 files changed

+2625/−16 lines, 23 files

Files

iyql.cabal view
@@ -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+
+ src/main/haskell/Yql/Core/Backend.hs view
@@ -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 <ORGANIZATION> 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 "<<many>>" Any False) (tables stmt))+                                | usingMe stmt    -> return $ foldr1 joinDesc (map (const $ Table "<<many>>" User False) (tables stmt))+                                | showTables stmt -> return (Table "<<dummy>>" 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 "<<many>>" (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')
+ src/main/haskell/Yql/Core/Lexer.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/Core/LocalFunction.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/Core/LocalFunctions/Request.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/Core/LocalFunctions/Tables.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/Core/Parser.hs view
@@ -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 <ORGANIZATION> 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)+
+ src/main/haskell/Yql/Core/Session.hs view
@@ -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 <ORGANIZATION> 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))
+ src/main/haskell/Yql/Core/Types.hs view
@@ -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 <ORGANIZATION> 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 <table>+-- 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
+ src/main/haskell/Yql/Data/Cfg.hs view
@@ -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 <ORGANIZATION> 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"])
+ src/main/haskell/Yql/Data/Trie.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/Data/Version.hs view
@@ -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 <ORGANIZATION> 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"]
+ src/main/haskell/Yql/Data/Xml.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/UI/CLI/Command.hs view
@@ -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 <ORGANIZATION> 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 []+
+ src/main/haskell/Yql/UI/CLI/Commands/Login.hs view
@@ -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 <ORGANIZATION> 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 ()+
+ src/main/haskell/Yql/UI/CLI/Commands/Logout.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/UI/CLI/Commands/ManLf.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/UI/CLI/Commands/Parser.hs view
@@ -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 <ORGANIZATION> 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))
+ src/main/haskell/Yql/UI/CLI/Commands/SetEnv.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/UI/CLI/Commands/WhoAmI.hs view
@@ -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 <ORGANIZATION> 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))
+ src/main/haskell/Yql/UI/CLI/Input.hs view
@@ -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 <ORGANIZATION> 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
+ src/main/haskell/Yql/UI/CLI/Options.hs view
@@ -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 <ORGANIZATION> 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 "<stmt>") "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 "<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
+ src/main/haskell/Yql/UI/Cli.hs view
@@ -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 <ORGANIZATION> 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 <dsouza+iyql at bitforest.org>"+                                           , "License GPLv3+: <http://github.com/dsouza/iyql/raw/master/LICENSE>"+                                           , "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)