diff --git a/iyql.cabal b/iyql.cabal --- a/iyql.cabal +++ b/iyql.cabal @@ -1,5 +1,5 @@ name: iyql -version: 0.0.6 +version: 0.0.7 category: Network license: GPL-3 license-file: LICENSE @@ -23,7 +23,7 @@ hs-source-dirs: src/main/haskell build-depends: haskell98 , base<5 - , hoauth>=0.3.0 + , hoauth>=0.3.1 , directory>=1.0.1.0 , filepath>=1.1.0.3 , containers>=0.3.0.0 diff --git a/src/main/haskell/Yql/Core/Backend.hs b/src/main/haskell/Yql/Core/Backend.hs --- a/src/main/haskell/Yql/Core/Backend.hs +++ b/src/main/haskell/Yql/Core/Backend.hs @@ -52,7 +52,7 @@ import Network.OAuth.Consumer hiding (application) import qualified Network.OAuth.Http.Request as R import Network.OAuth.Http.Response -import Network.OAuth.Http.HttpClient +import Network.OAuth.Http.CurlHttpClient newtype OutputT m a = OutputT { unOutputT :: m (Either String a) } @@ -65,19 +65,19 @@ -- | Tells the minimum security level required to perform this -- statament. -descTablesIn :: (MonadIO m,HttpClient c,Yql y) => y -> c -> [String] -> Expression -> OutputT m Description -descTablesIn y c envs stmt = case stmt - of _ | desc stmt -> return $ foldr1 joinDesc (map (const $ Table "<>" Any False) (tables stmt)) - | usingMe stmt -> return $ foldr1 joinDesc (map (const $ Table "<>" User False) (tables stmt)) - | showTables stmt -> return (Table "<>" Any False) - | otherwise -> fmap (foldr1 joinDesc) (mapM execDesc (tables stmt)) +descTablesIn :: (MonadIO m,Yql y) => y -> [String] -> Expression -> OutputT m Description +descTablesIn y envs stmt = case stmt + of _ | desc stmt -> return $ foldr1 joinDesc (map (const $ Table "<>" Any False) (tables stmt)) + | usingMe stmt -> return $ foldr1 joinDesc (map (const $ Table "<>" User False) (tables stmt)) + | showTables stmt -> return (Table "<>" Any False) + | otherwise -> fmap (foldr1 joinDesc) (mapM execDesc (tables stmt)) where parseXml xml = case (xmlParse xml) of Just doc -> case (readDescXml doc) of Just rst -> return rst Nothing -> fail $ "couldn't desc tables " ++ L.intercalate "," (tables stmt) Nothing -> fail "error parsing xml" - execDesc t = execute y c database (mkDesc stmt t) >>= parseXml + 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) @@ -134,7 +134,10 @@ -- | Returns the endpoint this backend is pointing to endpoint :: y -> (String,Int) endpoint _ = ("query.yahooapis.com",80) - + + -- | The OAuth application that is being used + app :: y -> Application + -- | Add a new env that is included in the request setenv :: y -> String -> y @@ -145,28 +148,30 @@ getenv :: y -> [String] -- | Returns the credentials that are used to perform the request. - credentials :: (MonadIO m,HttpClient c) => y -> c -> Security -> OAuthMonadT m () + credentials :: (MonadIO m) => y -> Security -> OAuthMonadT 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 c) => y -> c -> Database -> Expression -> OutputT m String - execute y c db stmt = do { mkRequest' <- fmap (execBefore_) (ld' db stmt) - ; mkResponse <- fmap execAfter_ (ld' db stmt) - ; mkOutput <- fmap execTransform_ (ld' db stmt) - ; tableDesc <- descTablesIn y c (R.find (=="env") . R.qString . mkRequest' $ emptyRequest) stmt - ; result <- lift $ runOAuth handleE NoToken $ do { credentials y c (security tableDesc) - ; url <- signRq2 HMACSHA1 (Just $ Realm "yahooapis.com") (fixRequest $ mkRequest' $ (myRequest tableDesc)) - ; serviceRequest c url >>= return . Right . mkOutput . toString . mkResponse - } - ; case result - of Right v -> return v - Left err -> fail err - } + execute :: (MonadIO 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 + ; result <- lift $ runOAuth handleE token $ do { credentials y (security tableDesc) >> getToken + ; url <- signRq2 HMACSHA1 (Just $ Realm "yahooapis.com") (fixRequest $ mkRequest' $ (myRequest tableDesc)) + ; serviceRequest CurlClient url >>= return . Right . mkOutput . toString . mkResponse + } + ; case result + of Right v -> return v + Left err -> fail err + } where myRequest = mkRequest stmt (getenv y) + token = fromApplication (app y) + fixRequest r = r { R.host = fst (endpoint y) , R.port = snd (endpoint y) } @@ -192,40 +197,42 @@ instance SessionMgr a => Yql (Backend a) where endpoint be = myEndpoint be + app = application + 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 c 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) - ; signRq2 PLAINTEXT Nothing reqUrl >>= oauthRequest c - ; cliAskAuthorization authUrl - ; signRq2 PLAINTEXT Nothing accUrl >>= oauthRequest c - ; 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 { signRq2 PLAINTEXT Nothing accUrl >>= oauthRequest c - ; getToken >>= liftIO . save (sessionMgr be) - } - } - | otherwise -> do { putToken token - ; signRq2 PLAINTEXT Nothing reqUrl >>= oauthRequest c - ; cliAskAuthorization authUrl - ; signRq2 PLAINTEXT Nothing accUrl >>= oauthRequest c - ; getToken >>= liftIO . save (sessionMgr be) - } - } + credentials _ Any = return () + 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) + ; signRq2 PLAINTEXT Nothing reqUrl >>= oauthRequest CurlClient + ; cliAskAuthorization authUrl + ; signRq2 PLAINTEXT Nothing accUrl >>= oauthRequest CurlClient + ; 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 { signRq2 PLAINTEXT Nothing accUrl >>= oauthRequest CurlClient + ; getToken >>= liftIO . save (sessionMgr be) + } + } + | otherwise -> do { putToken token + ; signRq2 PLAINTEXT Nothing reqUrl >>= oauthRequest CurlClient + ; cliAskAuthorization authUrl + ; signRq2 PLAINTEXT Nothing accUrl >>= oauthRequest CurlClient + ; 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" diff --git a/src/main/haskell/Yql/Data/Version.hs b/src/main/haskell/Yql/Data/Version.hs --- a/src/main/haskell/Yql/Data/Version.hs +++ b/src/main/haskell/Yql/Data/Version.hs @@ -32,4 +32,4 @@ import Data.Version version :: Version -version = Version [0,0,6] ["alpha"] +version = Version [0,0,7] ["alpha"] diff --git a/src/main/haskell/Yql/UI/CLI/Commands/Login.hs b/src/main/haskell/Yql/UI/CLI/Commands/Login.hs --- a/src/main/haskell/Yql/UI/CLI/Commands/Login.hs +++ b/src/main/haskell/Yql/UI/CLI/Commands/Login.hs @@ -32,16 +32,17 @@ import Yql.Core.Types import Yql.UI.CLI.Command import Network.OAuth.Consumer -import Network.OAuth.Http.CurlHttpClient -- | Removes any saved oauth_token. login :: Yql y => y -> Command () login be = Command (const doc, exe) where doc = "Execute the oauth authorization flow to perform authenticated requests." - exe link _ = do { runOAuth handleE NoToken (credentials be CurlClient User) + exe link _ = do { runOAuth handleE token (credentials be User) ; return () } where handleE err = case (lines err) of [] -> putStrLn $ link ++ ": error" (x:xs) -> putStrLn $ unlines ((link ++ ": " ++ x) : xs) + + token = fromApplication (app be) diff --git a/src/main/haskell/Yql/UI/Cli.hs b/src/main/haskell/Yql/UI/Cli.hs --- a/src/main/haskell/Yql/UI/Cli.hs +++ b/src/main/haskell/Yql/UI/Cli.hs @@ -29,7 +29,6 @@ import System import System.FilePath import System.Console.Haskeline -import Network.OAuth.Http.CurlHttpClient import Control.Monad.Trans import Yql.Data.Version import Yql.Data.Cfg (basedir) @@ -105,7 +104,7 @@ 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) (unOutputT (execute y CurlClient funcDB stmt)) + Right stmt -> fmap (either id id) (unOutputT (execute y funcDB stmt)) execCmd :: (SessionMgr s,Yql y) => s -> y -> String -> InputT IO (Maybe y) execCmd s y input = case (parseCmd input) diff --git a/src/main/haskell/iyql.hs b/src/main/haskell/iyql.hs --- a/src/main/haskell/iyql.hs +++ b/src/main/haskell/iyql.hs @@ -38,8 +38,8 @@ config <- usrCfg iyql session (backend session config) where backend session config = YqlBackend (Application cfgCKey cfgCSec OOB) session (tryCfgs config "env" []) yqlEndpoint - where cfgCKey = tryCfg config "oauth_consumer_key" "<>" - cfgCSec = tryCfg config "oauth_consumer_sec" "<>" + where cfgCKey = tryCfg config "oauth_consumer_key" "iyql" + cfgCSec = tryCfg config "oauth_consumer_sec" "" yqlEndpoint = let (host,port) = break (==':') (tryCfg config "endpoint" "query.yahooapis.com:80") in case port of [] -> (host,80)