libssh2-conduit (empty) → 0.1

raw patch · 6 files changed

+292/−0 lines, 6 filesdep +basedep +conduitdep +libssh2setup-changed

Dependencies added: base, conduit, libssh2, monad-control, stm, transformers

Files

LICENSE +30/−0
Makefile +13/−0
Network/SSH/Client/LibSSH2/Conduit.hs +168/−0
Setup.hs +2/−0
libssh2-conduit.cabal +44/−0
ssh-client.hs +35/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c)2012, IlyaPortnov++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 IlyaPortnov nor the names of other+      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+OWNER 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.

+ Makefile view

@@ -0,0 +1,13 @@+LIBS=-lssh2+GHC=ghc $(LIBS) --make+HSFILES=Network/SSH/Client/LibSSH2/Conduit.hs++all: ssh-client++ssh-client: ssh-client.hs $(HSFILES)+	$(GHC) $<++clean:+	find . -name \*.hi -delete+	find . -name \*.o -delete+	rm -f ssh-client

+ Network/SSH/Client/LibSSH2/Conduit.hs view

@@ -0,0 +1,168 @@+{-# LANGUAGE FlexibleContexts #-}+module Network.SSH.Client.LibSSH2.Conduit+  (sourceChannel,+   splitLines,+   CommandsHandle,+   execCommand,+   getReturnCode+  ) where++import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Resource+import Control.Monad.Trans.Control+import System.IO.Unsafe (unsafeInterleaveIO)+import Control.Concurrent.STM+import Data.Monoid+import Data.Conduit+import Data.Conduit.Lazy++import Network.SSH.Client.LibSSH2.Foreign+import Network.SSH.Client.LibSSH2++-- | Read all contents of libssh2's Channel.+sourceChannel :: Channel -> Source IO String+sourceChannel ch = src+  where+    src = Source pull close++    pull = do+        (sz, res) <- liftIO $ readChannel ch 0x400+        if sz > 0+            then return $ Open src res+            else return Closed++    close = return ()++-- | Similar to Data.Conduit.Binary.lines, but for Strings.+splitLines :: Resource m => Conduit String m String+splitLines =+    conduitState id push close+  where+    push front bs' = return $ StateProducing leftover ls+      where+        bs = front bs'+        (leftover, ls) = getLines id bs++    getLines front bs+        | null bs = (id, front [])+        | null y = ((x ++), front [])+        | otherwise = getLines (front . (x:)) (drop 1 y)+      where+        (x, y) = break (== '\n') bs++    close front+        | null bs = return []+        | otherwise = return [bs]+      where+        bs = front ""++-- | Execute one command and read it's output lazily.+-- If first argument is True, then you *must* get return code+-- using getReturnCode on returned CommandsHandle. Moreover,+-- you *must* guarantee that getReturnCode will be called+-- only when all command output will be read.+execCommand :: Bool                          -- ^ Set to True if you want to get return code when command will terminate.+            -> Session+            -> String                        -- ^ Command+            -> IO (Maybe CommandsHandle, Source IO String) +execCommand b s cmd = do+  (ch, channel) <- initCH b s+  let src = execCommandS ch channel cmd $= splitLines+  return (if b then Just ch else Nothing, src)++-- execCommands :: Bool -> Session -> [String] -> IO [String]+-- execCommands b s cmds = do+--   let srcs = [execCommandS (v i) s cmd | (i, cmd) <- zip [1..] cmds ]+--       v i | i == length cmds = var+--           | otherwise        = Nothing+--   res <- runResourceT $ lazyConsume $ mconcat srcs $= splitLines+--   return res++-- | Handles channel opening and closing.+data CommandsHandle = CommandsHandle {+  chReturnCode :: Maybe (TMVar Int),+  chChannel :: TMVar Channel,+  chChannelClosed :: TVar Bool }++initCH :: Bool -> Session -> IO (CommandsHandle, Channel)+initCH False s = do+  c <- newTVarIO False+  ch <- newEmptyTMVarIO+  channel <- openCH ch s+  return (CommandsHandle Nothing ch c, channel)+initCH True s = do+  r <- newEmptyTMVarIO+  c <- newTVarIO False+  ch <- newEmptyTMVarIO+  channel <- openCH ch s+  return (CommandsHandle (Just r) ch c, channel)++openCH :: TMVar Channel -> Session -> IO Channel+openCH var s = do+      ch <- openChannelSession s+      atomically $ putTMVar var ch+      return ch++-- | Get return code for previously run command.+-- It will fail if command was run using execCommand False.+-- Should be called only when all command output is read.+getReturnCode :: CommandsHandle -> IO Int+getReturnCode ch = do+  c <- atomically $ readTVar (chChannelClosed ch)+  if c+    then do+      case chReturnCode ch of+        Nothing -> fail "Channel already closed and no exit code return was set up for command."+        Just v -> atomically $ takeTMVar v+    else do+      channel <- atomically $ takeTMVar (chChannel ch)+      cleanupChannel ch channel+      atomically $ writeTVar (chChannelClosed ch) True+      case chReturnCode ch of+        Nothing -> fail "No exit code return was set up for commnand."+        Just v  -> do+                   rc <- atomically $ takeTMVar v+                   return rc+    +execCommandS :: CommandsHandle -> Channel -> String -> Source IO String+execCommandS var channel command =+  Source {+      sourcePull = pull channel +    , sourceClose = return () }+  where+    +    next ch =+      Source (pullAnswer ch) $ do+          return ()+          --liftIO $ cleanupChannel var ch++    pullAnswer ch = do+      (sz, res) <- liftIO $ readChannel ch 0x400+      if sz > 0+        then return $ Open (next ch) res+        else do+             liftIO $ cleanupChannel var ch+             return Closed++    pull ch = do+      liftIO $ channelExecute ch command+      pullAnswer ch++-- | Close Channel and write return code+cleanupChannel :: CommandsHandle -> Channel -> IO ()+cleanupChannel ch channel = do+  c <- atomically $ readTVar (chChannelClosed ch)+  when (not c) $ do+    closeChannel channel+    case chReturnCode ch of+      Nothing -> return ()+      Just v  -> do+                 exitStatus <- channelExitStatus channel+                 atomically $ putTMVar v exitStatus+    closeChannel channel+    freeChannel channel+    atomically $ writeTVar (chChannelClosed ch) True+    return ()+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ libssh2-conduit.cabal view

@@ -0,0 +1,44 @@+Name:                libssh2-conduit+Version:             0.1++Synopsis:            Conduit wrappers for libssh2 FFI bindings (see libssh2 package).++Description:         This package provides Conduit interface (see conduit package) for+                     libssh2 FFI bindings (see libssh2 package). This allows one to+                     receive data from SSH channels lazily, without need to read+                     all channel output to the memory.++Homepage:            http://redmine.iportnov.ru/projects/libssh2-hs++License:             BSD3++License-file:        LICENSE++Author:              IlyaPortnov++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer:          portnov84@rambler.ru++-- A copyright notice.+-- Copyright:           ++Category:            Network++Build-type:          Simple++Extra-source-files:  Makefile, ssh-client.hs++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.6++Library+  Exposed-modules:     Network.SSH.Client.LibSSH2.Conduit+  +  Build-depends:       base >= 4 && <5, stm, transformers,+                       monad-control >= 0.3.1,+                       conduit >= 0.2.0, libssh2+  +  -- Modules not exported by this package.+  -- Other-modules:       +

+ ssh-client.hs view

@@ -0,0 +1,35 @@++import Control.Monad+import Control.Monad.Trans.Resource+import Control.Concurrent.STM+import Data.Conduit+import Data.Conduit.Lazy+import System.Environment+import System.FilePath+import Codec.Binary.UTF8.String++import Network.SSH.Client.LibSSH2.Foreign+import Network.SSH.Client.LibSSH2.Conduit+import Network.SSH.Client.LibSSH2++main = do+  args <- getArgs+  case args of+    [user, host, port, cmd]  -> ssh user host (read port) cmd+    _ -> putStrLn "Synopsis: ssh-client USERNAME HOSTNAME PORT COMMAND"++ssh login host port command = do+  initialize True+  home <- getEnv "HOME"+  let known_hosts = home </> ".ssh" </> "known_hosts"+      public = home </> ".ssh" </> "id_rsa.pub"+      private = home </> ".ssh" </> "id_rsa"+  withSessionBlocking host port $ \session -> do+    r <- checkHost session host port known_hosts+    publicKeyAuthFile session login public private ""+    (Just ch, src) <- execCommand True session command+    res <- runResourceT $ lazyConsume src+    forM (map decodeString res) putStrLn+    rc <- getReturnCode ch+    putStrLn $ "Exit code: " ++ show rc+  exit