iyql 0.0.5.6 → 0.0.6
raw patch · 5 files changed
+70/−48 lines, 5 filesdep ~hoauth
Dependency ranges changed: hoauth
Files
- iyql.cabal +2/−2
- src/main/haskell/Yql/Core/Backend.hs +57/−39
- src/main/haskell/Yql/Data/Version.hs +1/−1
- src/main/haskell/Yql/UI/CLI/Commands/Login.hs +8/−4
- src/main/haskell/Yql/UI/Cli.hs +2/−2
iyql.cabal view
@@ -1,5 +1,5 @@ name: iyql-version: 0.0.5.6+version: 0.0.6 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.2.5+ , hoauth>=0.3.0 , directory>=1.0.1.0 , filepath>=1.1.0.3 , containers>=0.3.0.0
src/main/haskell/Yql/Core/Backend.hs view
@@ -65,19 +65,19 @@ -- | 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))+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 "<<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+ execDesc t = execute y c database (mkDesc stmt t) >>= parseXml where database = M.fromList [("request", F.function)] mkDesc (USE u a stmt') t = USE u a (mkDesc stmt' t)@@ -145,22 +145,35 @@ getenv :: y -> [String] -- | Returns the credentials that are used to perform the request.- credentials :: (MonadIO m,HttpClient m) => y -> Security -> OAuthMonad m ()+ credentials :: (MonadIO m,HttpClient c) => y -> c -> 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 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))+ 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+ } where myRequest = mkRequest stmt (getenv y)+ + fixRequest r = r { R.host = fst (endpoint y)+ , R.port = snd (endpoint y)+ }+ + handleE err = case (lines err)+ of [] -> return $ Left "error"+ (x:xs) -> return $ Left (unlines $ ("error: " ++ x) : xs) toString :: Response -> String toString resp | statusOk && isXML = xmlPrint . fromJust . xmlParse $ payload@@ -185,29 +198,34 @@ 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)+ 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)+ }+ } where defReqUrl = "https://api.login.yahoo.com/oauth/v2/get_request_token" defAccUrl = "https://api.login.yahoo.com/oauth/v2/get_token"
src/main/haskell/Yql/Data/Version.hs view
@@ -32,4 +32,4 @@ import Data.Version version :: Version-version = Version [0,0,5] ["alpha"]+version = Version [0,0,6] ["alpha"]
src/main/haskell/Yql/UI/CLI/Commands/Login.hs view
@@ -32,12 +32,16 @@ import Yql.Core.Types import Yql.UI.CLI.Command import Network.OAuth.Consumer-import Network.OAuth.Http.HttpClient+import Network.OAuth.Http.CurlHttpClient -- | Removes any saved oauth_token. login :: Yql y => y -> Command ()-login be = Command (const doc,const (const exe))+login be = Command (const doc, exe) where doc = "Execute the oauth authorization flow to perform authenticated requests."- exe = do unCurlM (runOAuth (credentials be User))- return () + exe link _ = do { runOAuth handleE NoToken (credentials be CurlClient User)+ ; return ()+ }+ where handleE err = case (lines err)+ of [] -> putStrLn $ link ++ ": error"+ (x:xs) -> putStrLn $ unlines ((link ++ ": " ++ x) : xs)
src/main/haskell/Yql/UI/Cli.hs view
@@ -29,7 +29,7 @@ import System import System.FilePath import System.Console.Haskeline-import Network.OAuth.Http.HttpClient+import Network.OAuth.Http.CurlHttpClient import Control.Monad.Trans import Yql.Data.Version import Yql.Data.Cfg (basedir)@@ -105,7 +105,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) (unCurlM (unOutputT (execute y funcDB stmt)))+ Right stmt -> fmap (either id id) (unOutputT (execute y CurlClient funcDB stmt)) execCmd :: (SessionMgr s,Yql y) => s -> y -> String -> InputT IO (Maybe y) execCmd s y input = case (parseCmd input)