packages feed

scp-streams (empty) → 0.1.0

raw patch · 8 files changed

+513/−0 lines, 8 filesdep +SHAdep +attoparsecdep +basesetup-changed

Dependencies added: SHA, attoparsec, base, bytestring, cmdargs, io-streams, process, scp-streams, sha-streams, unix

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright: (c) Vo Minh Thu, 2013.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS 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 AUTHORS 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.
+ Network/SCP/Protocol.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.SCP.Protocol where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L+import Data.Word (Word8)+import System.Exit (ExitCode(..))+import System.IO (hClose, hFlush, hPutStrLn, stderr)+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as S+import qualified System.IO.Streams.Attoparsec as S+import System.Process (ProcessHandle)+import System.Process (CreateProcess(..), StdStream(..))+import qualified System.Process as P++import Network.SCP.Types++data SCP = SCP+  { scpIn :: OutputStream ByteString+  , scpOut :: InputStream ByteString+  , scpProcess :: Maybe ProcessHandle+  }++----------------------------------------------------------------------+-- "Mid-level" interface+----------------------------------------------------------------------++sendSsh :: String -> String -> FilePath -> IO SCP+sendSsh user host target = sendProcess "ssh"+  [ "-q"+  -- TODO actually use known_hosts and key check.+  , "-o", "UserKnownHostsFile=/dev/null"+  , "-o", "StrictHostKeyChecking=no"+  , "-i", "/home/scp/.ssh/insecure_id_rsa"+  , user ++ "@" ++ host+  , "scp"+  , "-r" -- TODO Only when pushing directories.+         -- TODO Error out when receiving directories without -r.+  , "-t"+  , target+  ]++sendStd :: IO SCP+sendStd = do+  let scp = SCP S.stdout S.stdin Nothing+  _ <- startSending scp+  return scp++sendSelf :: FilePath -> IO SCP+sendSelf target = sendProcess "dist/build/scp-streams/scp-streams" ["-t", target]++sendDirect :: FilePath -> IO SCP+sendDirect target = sendProcess "scp" ["-t", target]++stop :: SCP -> IO ExitCode+stop scp@SCP{..} = do+  stopSending scp+  maybe (return ExitSuccess) P.waitForProcess scpProcess++copy :: SCP -> Word8 -> Word8 -> Word8 -> Word8 -> Int -> ByteString+  -> InputStream ByteString -> IO Bool+copy scp a b c d len filename content = do+  _ <- sendCommand scp $ Copy a b c d len filename+  sendContent scp content++push :: SCP -> Word8 -> Word8 -> Word8 -> Word8 -> ByteString -> IO Bool+push scp a b c d directory = sendCommand scp $ Push a b c d directory++pop :: SCP -> IO Bool+pop scp = sendCommand scp Pop++receiveSsh :: String -> String -> String -> IO SCP+receiveSsh user host path = receiveProcess "ssh"+  [ "-q"+  -- TODO actually use known_hosts and key check.+  , "-o", "UserKnownHostsFile=/dev/null"+  , "-o", "StrictHostKeyChecking=no"+  , "-i", "/home/scp/.ssh/insecure_id_rsa"+  , user ++ "@" ++ host+  , "scp"+  , "-f"+  , path+  ]++receiveStd :: IO SCP+receiveStd = do+  let scp = SCP S.stdout S.stdin Nothing+  startReceiving scp+  return scp++receiveDirect :: String -> IO SCP+receiveDirect path = receiveProcess "scp" ["-f", path]++readCommand :: SCP -> IO Command+readCommand SCP{..} = do+  command <- S.parseFromStream commandParser scpOut+  confirm scpIn+  return command++contentAsInputStream :: SCP -> Int -> IO (InputStream ByteString)+contentAsInputStream SCP{..} len = do+  is <- S.takeBytes (fromIntegral len) scpOut+  is' <- S.atEndOfInput (do+    _ <- getFeedback scpOut+    confirm scpIn) is+  return is'++doneReceiving :: SCP -> IO Bool+doneReceiving SCP{..} = S.atEOF scpOut++----------------------------------------------------------------------+-- "Low-level" interface+----------------------------------------------------------------------++sendProcess :: FilePath -> [String] -> IO SCP+sendProcess cmd args = do+  (inp, out, h) <- runInteractiveProcess cmd args+  let scp = SCP inp out $ Just h+  _ <- startSending scp+  return scp++startSending :: SCP -> IO Bool+startSending SCP{..} = do+  getFeedback scpOut++sendCommand :: SCP -> Command -> IO Bool+sendCommand SCP{..} command = do+  let c = unparse command+  hPutStrLn stderr ("Sending command " ++ C.unpack c) >> hFlush stderr+  S.writeLazyByteString (L.fromChunks [c, "\n"]) scpIn+  S.write (Just "") scpIn -- flush+  getFeedback scpOut++sendContent :: SCP -> InputStream ByteString -> IO Bool+sendContent SCP{..} content = do+  hPutStrLn stderr "Sending content..." >> hFlush stderr+  S.supply content scpIn+  confirm scpIn+  b <- getFeedback scpOut+  return b++stopSending :: SCP -> IO ()+stopSending SCP{..} = S.write Nothing scpIn++receiveProcess :: String -> [String] -> IO SCP+receiveProcess cmd args = do+  (inp, out, h) <- runInteractiveProcess cmd args+  let scp = SCP inp out $ Just h+  startReceiving scp+  return scp++startReceiving :: SCP -> IO ()+startReceiving SCP{..} = do+  confirm scpIn++getFeedback :: InputStream ByteString -> IO Bool+getFeedback feedback = do+  i' <- S.readExactly 1 feedback+  case i' of+    "\0" -> return True+    _ -> do+      msg <- sGetLine feedback+      hPutStrLn stderr ("Bad feedback: " ++ C.unpack msg) >> hFlush stderr+      return False++confirm :: OutputStream ByteString -> IO ()+confirm os = do+  S.writeLazyByteString "\0" os+  S.write (Just "") os -- flush++whine :: OutputStream ByteString -> ByteString -> IO ()+whine os msg = do+  S.writeLazyByteString (L.fromChunks ["\x01", msg, "\n"]) os+  S.write (Just "") os -- flush++sGetLine :: InputStream ByteString -> IO ByteString+sGetLine is = do+  mline <- S.takeBytesWhile (/= '\n') is+  return $ maybe "" B.init mline++-- | Similar to S.runInteractiveProcess but without the stderr pipe.+runInteractiveProcess :: String -> [String]+  -> IO (OutputStream ByteString, InputStream ByteString, ProcessHandle)+runInteractiveProcess cmd args = do+  (Just hin, Just hout , _, ph) <- P.createProcess (P.proc cmd args)+    { std_in = CreatePipe, std_out = CreatePipe }+  sIn  <- S.handleToOutputStream hin >>=+          S.atEndOfOutput (hClose hin) >>=+          S.lockingOutputStream+  sOut <- S.handleToInputStream hout >>=+          S.atEndOfInput (hClose hout) >>=+          S.lockingInputStream+  return (sIn, sOut, ph)
+ Network/SCP/Types.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.SCP.Types where++import Control.Applicative ((<$>), (<|>), (<$))+import Data.Attoparsec.ByteString (anyWord8)+import Data.Attoparsec.ByteString.Char8+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C+import Prelude hiding (takeWhile)+import Data.Word (Word8)++data Command =+    Copy Word8 Word8 Word8 Word8 Int ByteString+  -- ^ Copy a file. Permissions (4 bytes), file size in bytes, filename.+  | Push Word8 Word8 Word8 Word8 ByteString+  -- ^ Enter directory. Permissions, directory name.+  | Pop+  -- ^ Exit directory.+  | Abort ByteString+  -- ^ This is not really a command, it is an error message received from the+  -- client. For instance when the client sends a non-existing file and+  -- discovers the fact only after having started the upload process.+  deriving Show++-- e.g. C0755 567 run.sh+commandParser :: Parser Command+commandParser = copyParser <|> pushParser <|> popParser <|> errorParser++copyParser :: Parser Command+copyParser = do+  _ <- char 'C'+  (a, b, c, d) <- permissionsParser+  _ <- char ' '+  size <- decimal+  _ <- char ' '+  filename <- takeWhile (/= '\n') -- TODO enforce correct filename (no slash, no single dot, ...)+  _ <- char '\n'+  return $ Copy a b c d size filename++pushParser :: Parser Command+pushParser = do+  _ <- char 'D'+  (a, b, c, d) <- permissionsParser+  _ <- string " 0 "+  dir <- takeWhile (/= '\n')+  _ <- char '\n'+  return $ Push a b c d dir++popParser :: Parser Command+popParser = Pop <$ string "E\n"++errorParser :: Parser Command+errorParser = do+  _ <- anyWord8+  msg <- takeWhile (/= '\n')+  _ <- char '\n'+  return $ Abort msg++permissionsParser :: Parser (Word8, Word8, Word8, Word8)+permissionsParser = do+  a <- read . (:[]) <$> digit+  b <- read . (:[]) <$> digit+  c <- read . (:[]) <$> digit+  d <- read . (:[]) <$> digit+  return (a, b, c, d)++-- TODO use cereal+unparse :: Command -> ByteString+unparse command = case command of+  (Copy a b c d size filename) ->+    C.pack ['C', head $ show a, head $ show b, head $ show c, head $ show d]+      `B.append` " " `B.append` C.pack (show size) `B.append` " "+      `B.append` filename+  (Push a b c d filename) ->+    C.pack ['D', head $ show a, head $ show b, head $ show c, head $ show d]+      `B.append` " 0 " `B.append` filename+  Pop -> "E"+  Abort msg -> 1 `B.cons` msg `B.append` "\n"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bin/scp-broken-upload.hs view
@@ -0,0 +1,20 @@+-- Simulate a network failure or a Ctrl-C on the client when a file is being+-- uploaded. Run against a regular remote `scp`, the file is created but empty.+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import qualified System.IO.Streams as S+import System.Environment (getArgs)++import Network.SCP.Protocol+import Network.SCP.Types (Command(Copy))++main :: IO ()+main = do+  [user, host, target] <- getArgs+  scp <- sendSsh user host target+  -- A 10-byte size is advertized...+  _ <- sendCommand scp $ Copy 0 7 5 5 10 "a"+  -- ... but 4-byte input stream is given+  content <- S.fromByteString "AAAA"+  S.connect content (scpIn scp)
+ bin/scp-streams.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Main (main) where++import Control.Applicative ((<$>))+import Control.Monad (forM_, when)+import qualified Data.ByteString.Char8 as C+import Data.Version (showVersion)+import Paths_scp_streams (version)+import System.Console.CmdArgs.Implicit+import System.IO (hFlush, hPutStrLn, stderr)+import qualified System.IO.Streams as S+import System.Posix.Files (fileSize, getFileStatus)++import Data.Digest.Pure.SHA+import System.IO.Streams.SHA++import Network.SCP.Protocol+import Network.SCP.Types++main :: IO ()+main = (runCmd =<<) $ cmdArgs $+  modes+    [ cmdScp+    ]+  &= summary versionString+  &= program "scp-streams"++-- | String with the program name, version and copyright.+versionString :: String+versionString =+  "scp-streams " ++ showVersion version ++ " - Copyright (c) 2013 Vo Minh Thu."++-- | Data type representing the different command-line subcommands.+data Cmd =+    CmdScp+  { cmdScpPaths :: [String]+  , cmdScpDirect :: Bool+  , cmdScpSelf :: Bool+  , cmdScpReceive :: Bool+  , cmdScpSend :: Bool+  }+  deriving (Data, Typeable)++-- | Create the (default) 'Scp' command.+cmdScp :: Cmd+cmdScp = CmdScp+  { cmdScpPaths = def+    &= args++  , cmdScpDirect = def+    &= help "Use the local `scp` instead of a remote `scp` through `ssh`."+    &= explicit+    &= name "direct"+  , cmdScpSelf = def+    &= help "Use the local `scp-streams` instead of a remote `scp` through `ssh`."+    &= explicit+    &= name "self"++  , cmdScpReceive = def+    &= help "Invoke as a sink."+    &= explicit+    &= name "t"+  , cmdScpSend = def+    &= help "Invoke as a source."+    &= explicit+    &= name "f"+  }+    &= help "Drop-in `scp` replacement."+    &= explicit+    &= name "scp"++-- | Run a sub-command.+runCmd :: Cmd -> IO ()+runCmd CmdScp{..} = do+  case (cmdScpReceive, cmdScpSend) of+    (True, True) -> error "-t and -f are exclusive."++    (True, False) -> receiveStd >>= receiveLoop++    (False, True) -> whine S.stdout "Source not implemented."++    (False, False) -> do+      when (length cmdScpPaths < 2) $+        error "Two or more filenames must be provided."+        -- If there is more than 2 filenames, the last one must be a directory.++      let s = if cmdScpDirect then sendDirect else sendSsh "TODO" "TODO"+          send = if cmdScpSelf then sendSelf else s++      -- Operate as a client.+      scp <- send $ last cmdScpPaths+      forM_ (init cmdScpPaths) $ \p -> do+        size <- fileSize <$> getFileStatus p+        S.withFileAsInput p $ \is -> do+          (is1, getSha1) <- sha1Input is+          _ <- copy scp 0 7 5 5 (fromIntegral size) (C.pack p) is1+          getSha1 >>= putStrLn . ("SHA1: " ++ ) . showDigest+          return ()+      _ <- stop scp+      return ()++receiveLoop :: SCP -> IO ()+receiveLoop scp = do+  done <- doneReceiving scp+  if done+    then return ()+    else do+      command@(Copy a b c d len filename) <- readCommand scp+      is <- contentAsInputStream scp len+      (is1, getSha1) <- sha1Input is+      S.skipToEof is1+      getSha1 >>= hPutStrLn stderr . ("SHA1: " ++ ) . showDigest+      hFlush stderr+      receiveLoop scp
+ scp-streams.cabal view
@@ -0,0 +1,58 @@+name:                scp-streams+version:             0.1.0+Cabal-Version:       >= 1.8+synopsis:            An SCP protocol implementation.+description:         An SCP protocol implementation.+category:            System+license:             BSD3+license-file:        LICENSE+author:              Vo Minh Thu+maintainer:          thu@hypered.io+build-type:          Simple+homepage:            https://github.com/noteed/scp-streams++source-repository head+  type: git+  location: git://github.com/noteed/scp-streams.git++library+  build-depends:       attoparsec == 0.10.*,+                       base == 4.*,+                       bytestring == 0.9.*,+                       io-streams == 1.1.*,+                       process == 1.1.*+  exposed-modules:     Network.SCP.Protocol,+                       Network.SCP.Types+  ghc-options:         -Wall++executable scp-streams+  hs-source-dirs:      bin+  main-is:             scp-streams.hs+  build-depends:       cmdargs == 0.9.*,+                       base == 4.*,+                       bytestring == 0.9.*,+                       io-streams == 1.1.*,+                       scp-streams,+                       SHA >= 1.6.3,+                       sha-streams >= 0.1,+                       unix == 2.5.*+  ghc-options:         -Wall++executable scp-broken-upload+  hs-source-dirs:      bin+  main-is:             scp-broken-upload.hs+  build-depends:       base == 4.*,+                       bytestring == 0.9.*,+                       io-streams == 1.1.*,+                       scp-streams+  ghc-options:         -Wall++test-suite run-tests+  hs-source-dirs: tests+  main-is: main.hs+  type: exitcode-stdio-1.0+  build-depends:       base == 4.*,+                       bytestring == 0.9.*,+                       io-streams == 1.1.*,+                       scp-streams+  ghc-options:         -Wall
+ tests/main.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import qualified Data.ByteString as B+import qualified System.IO.Streams as S++import Network.SCP.Protocol++main :: IO ()+main = do+  scp <- sendDirect "/tmp/a"+  _ <- S.fromByteString "A" >>= copy scp 0 7 5 5 1 "a"+  _ <- stop scp+  "A" <- B.readFile "/tmp/a"+  return ()