yjftp 0.3.4 → 0.3.6
raw patch · 6 files changed
+154/−50 lines, 6 filesdep +haskelinedep +mtldep −readline
Dependencies added: haskeline, mtl
Dependencies removed: readline
Files
- Network/CommandList.hs +18/−19
- Network/Console.hs +80/−0
- Network/Types.hs +21/−0
- Network/Yjftp.hs +30/−25
- yjftp.cabal +3/−4
- yjftp.hs +2/−2
Network/CommandList.hs view
@@ -27,7 +27,7 @@ , const2 , compRemoteFile , compLs-, filenameCompletionFunction+, compFilename ) where import Network.FTP.Client (FTPConnection, getbinary, putbinary, uploadbinary, downloadbinary,@@ -40,20 +40,11 @@ import System.Posix.Temp (mkstemp) import Data.Maybe (fromJust) import Data.List (isPrefixOf)+import Data.Char (isSpace) import Control.OldException (catchJust, ioErrors, ioError, bracketOnError) -import System.Console.Readline--type Action = FTPConnection -> [String] -> IO Bool-type Command = (Action, String, FTPConnection -> String -> IO [String])-type CommandList = [(String, Command)]--getAction :: Command -> Action-getAction (act, _, _) = act-getHelp :: Command -> String-getHelp (_, help, _) = help-getComp :: Command -> FTPConnection -> String -> IO [String]-getComp (_, _, comp) = comp+import Network.Console(compFilename)+import Network.Types defaultCommandList :: CommandList defaultCommandList = [@@ -69,8 +60,8 @@ "list directory contents\n\toption -l list detail of contents", compLs)) , ("cd", (changeDirectoryFTP, "change directory in remote", compRemoteFile))- , ("lcd", (changeDirectoryLocal, "change directory in local", const filenameCompletionFunction))- , ("put", (putFileFTP, "upload file", const filenameCompletionFunction))+ , ("lcd", (changeDirectoryLocal, "change directory in local", const compFilename))+ , ("put", (putFileFTP, "upload file", const compFilename)) , ("get", (getFileFTP, "download file", compRemoteFile)) , ("cat", (showFileFTP, "show remote file", compRemoteFile)) , ("rm", (removeFileFTP, "delete remote file", compRemoteFile))@@ -144,7 +135,8 @@ moveFileFTP _ _ = error "moveFileFTP: args incorrect" copyFileFTP :: Action-copyFileFTP h [src, dst] = getbinary h src >>= putbinary h dst . fst >> return True+copyFileFTP h [src, dst] = getbinary h src >>= flush >>= putbinary h dst . fst >> return True+ where flush s@(c,_) = putStr (take (length c - length c) "dummy") >> return s copyFileFTP _ _ = error "Usage: cp src dist" editBy :: (String -> IO String) -> Action@@ -183,7 +175,7 @@ mkstemp $ tmpDir ++ "/" ++ fn ++ "-XXXXXX" compLs :: FTPConnection -> String -> IO [String]-compLs h str+compLs h strGen | elem '/' str = do let d = reverse $ dropWhile (/='/') $ reverse str fns <- myNlst h $ Just d@@ -191,16 +183,23 @@ | otherwise = do fns <- myNlst h Nothing return $ addExcess $ filter (isPrefixOf str) $ "-l" : fns+ where str = strGen -- lastWord strGen compRemoteFile :: FTPConnection -> String -> IO [String]-compRemoteFile h str+compRemoteFile h strGen | elem '/' str = do let d = reverse $ dropWhile (/='/') $ reverse str fns <- myNlst h $ Just d return $ addExcess $ filter (isPrefixOf str) $ map (d++) fns | otherwise = do fns <- myNlst h Nothing- return $ addExcess $ filter (isPrefixOf str) fns+ let ret = addExcess $ filter (isPrefixOf str) fns+-- putStr "\nDEBUG2_: "; print strGen+-- putStr "DEBUG3: "; print ret+ return ret -- $ addExcess $ filter (isPrefixOf str) fns+ where str = strGen {- if isSpace $ last strGen+ then ""+ else lastWord strGen -} addExcess :: [String] -> [String] addExcess [""] = [""]
+ Network/Console.hs view
@@ -0,0 +1,80 @@+module Network.Console (+ CompIO+, Comp+, mkComp+, runConsole+, readConsole+, compFilename+, addHist++, compCatch+, compCatch2+, compHFlush+, compPrint+, compPutStr+, compPutStrLn+, compHPutStrLn++, lastWord+) where++import System.Console.Haskeline+import Prelude hiding (catch)+import Control.Monad.Trans+import System.IO+import Data.List (isPrefixOf)+import Control.Exception hiding (catch)+import Data.Char (isSpace)++data Comp = Comp (CompletionFunc IO)++type CompIO = InputT IO++runConsole :: Comp -> CompIO a -> IO a+runConsole (Comp cmp) act = runInputT (setComplete cmp defaultSettings) act++--compCatch :: Exception e => CompIO a -> (e -> CompIO a) -> CompIO a+compCatch :: CompIO a -> (IOException -> CompIO a) -> CompIO a+compCatch = catch++compCatch2 :: CompIO a -> (ErrorCall -> CompIO a) -> CompIO a+compCatch2 = catch++compHFlush :: Handle -> CompIO ()+compHFlush = lift . hFlush++mkComp :: (String -> IO [ String ]) -> Comp+mkComp f = Comp $ \(rts,_) -> do+ ss <-f $ reverse rts+ return (dropWhile (not.isSpace) rts, map (\s -> Completion s s True) ss)+{-+mkComp f = Comp $ completeWord Nothing " " $+ \str -> fmap (map (\s -> Completion s s True)) $ f str+ -}++compPutStrLn :: String -> CompIO ()+compPutStrLn = outputStrLn++compHPutStrLn :: Handle -> String -> CompIO ()+compHPutStrLn = (.) lift . hPutStrLn++compPutStr :: String -> CompIO ()+compPutStr = outputStr++readConsole :: String -> CompIO (Maybe String)+readConsole = getInputLine++compFilename :: String -> IO [ String ]+compFilename inp = do+ fs <- fmap (map replacement) $ listFiles "./"+ return $ filter (isPrefixOf inp) fs++compPrint :: Show a => a -> CompIO ()+compPrint = lift . print++lastWord :: String -> String+lastWord "" = ""+lastWord ln = if isSpace $ last ln then "" else last $ words ln++addHist :: String -> CompIO ()+addHist _ = return ()
+ Network/Types.hs view
@@ -0,0 +1,21 @@+module Network.Types (+ CommandList+, Command+, Action+, getAction+, getHelp+, getComp+) where++import Network.FTP.Client++type Action = FTPConnection -> [ String ] -> IO Bool+type Command = (Action, String, FTPConnection -> String -> IO [String])+type CommandList = [(String, Command)]++getAction :: Command -> Action+getAction (act, _, _) = act+getHelp :: Command -> String+getHelp (_, help, _) = help+getComp :: Command -> FTPConnection -> String -> IO [ String ]+getComp (_, _, comp) = comp
Network/Yjftp.hs view
@@ -6,7 +6,7 @@ import Network.CommandList import Network.FTP.Client (FTPConnection, enableFTPDebugging, easyConnectFTP, login, loginAnon, quit, cwd, uploadbinary, downloadbinary)-import System.IO (hFlush, stdin, stdout, stderr, hPutStrLn,+import System.IO (hFlush, stdin, stdout, stderr, hGetBuffering, hSetBuffering, BufferMode(NoBuffering)) import System.Directory (setCurrentDirectory) import System.Exit (exitFailure)@@ -20,7 +20,8 @@ import Prelude hiding (catch) import Data.Char (isSpace, isAscii) import Data.List (isPrefixOf)-import System.Console.Readline+import Network.Console(addHist, readConsole, runConsole, CompIO, compPutStr, compHFlush, compPrint, compHPutStrLn, Comp, mkComp, lastWord, compCatch, compCatch2)+import Control.Monad.Trans runYjftp :: CommandList -> IO () runYjftp cl = do@@ -31,17 +32,16 @@ (Just Put, Just s) -> do unless (dirname s == "") $ setCurrentDirectory $ dirname s uploadbinary h (basename s) >> return () (Just Get, Just s) -> downloadbinary h s >> return ()- (Nothing, _) -> do- setCompletionEntryFunction $ Just $ myCompFunc h cl+ (Nothing, _) -> runConsole (myComp h cl) $ do doWhile_ $ do- hFlush stdout- cmdln <- readline "> "- maybe (return ()) (addHistory) cmdln+ compHFlush stdout+ cmdln <- readConsole "> "+ maybe (return ()) addHist cmdln case myWords <$> cmdln of Nothing -> return False Just [] -> return True- Just ["?"] -> mapM (\cmd -> putStr $ fst cmd ++ ":\t" ++ getHelp (snd cmd) ++ "\n") cl >> return True- Just (cmd:args) -> catch (executeCommand cl h cmd args) ((>> return True) . print)+ Just ["?"] -> mapM (\cmd -> compPutStr $ fst cmd ++ ":\t" ++ getHelp (snd cmd) ++ "\n") cl >> return True+ Just (cmd:args) -> flip compCatch2 ((>> return True) . compPrint) $ compCatch (executeCommand cl h cmd args) ((>> return True) . compPrint) _ -> error "bad argument (put/get)" quit h return ()@@ -77,10 +77,10 @@ = if (n < 0) then error "tryNTimes: bad! minus times trial?" else catch act (\err -> errM err >> tryNTimes (n-1) errM act) -executeCommand :: CommandList -> FTPConnection -> String -> [String] -> IO Bool+executeCommand :: CommandList -> FTPConnection -> String -> [String] -> CompIO Bool executeCommand cl h cmd args- = maybe (hPutStrLn stderr ("No such command: " ++ cmd) >> return True)- (\c -> (getAction c) h args) (lookup cmd cl)+ = maybe (compHPutStrLn stderr ("No such command: " ++ cmd) >> return True)+ (\c -> liftIO $ (getAction c) h args) (lookup cmd cl) processArgs :: IO (Maybe CLAction, Maybe String, Maybe String, Maybe String, Maybe String, Maybe String)@@ -113,19 +113,7 @@ psswd <- getLineP return psswd -myCompFunc :: FTPConnection -> CommandList -> String -> IO [String]-myCompFunc h cl str = do- bf <- getLineBuffer- case bf of- "" -> return $ filter (isPrefixOf str) $ map fst cl- _ | and (map (not . isSpace) bf) && head bf /= '!'- -> return $ filter (isPrefixOf str) $ map fst cl- | otherwise- -> case getComp <$> lookup (head $ words bf) cl of- Nothing -> return []- Just f -> f h str--doWhile_ :: IO Bool -> IO ()+doWhile_ :: Monad m => m Bool -> m () doWhile_ act = do b <- act if b then doWhile_ act else return ()@@ -197,3 +185,20 @@ | otherwise = error "myWords: maybe your input is not askii" where isNotSpaceAscii c_ = isAscii c_ && not (isSpace c_) isWordHead c_ = isNotSpaceAscii c_ && (c_ /= '!')++myComp :: FTPConnection -> CommandList -> Comp+myComp h cl = mkComp $ myCompFunc h cl++myCompFunc :: FTPConnection -> CommandList -> String -> IO [String]+myCompFunc h cl strGen = do+ let bf = strGen+ str = lastWord strGen+-- putStr "\nDEBUG1: "; print bf+ case bf of+ "" -> return $ filter (isPrefixOf str) $ map fst cl+ _ | and (map (not . isSpace) bf) && head bf /= '!'+ -> return $ filter (isPrefixOf str) $ map fst cl+ | otherwise+ -> case getComp <$> lookup (head $ words bf) cl of+ Nothing -> return []+ Just f -> f h str
yjftp.cabal view
@@ -1,5 +1,5 @@ Name: yjftp-Version: 0.3.4+Version: 0.3.6 License: GPL License-file: LICENSE Author: Yoshikuni Jujo@@ -22,7 +22,6 @@ And you can put or get immediately by doing following. . > yjftp put filepath srvr.address/directorypath [user_name] [-p password]- . > yjftp get srvr.address/filepath [user_name] [-p password] Stability: experimental Homepage: http://homepage3.nifty.com/salamander/second/projects/yjftp/index.xhtml@@ -36,9 +35,9 @@ Library GHC-Options: -Wall- Build-Depends: base >= 4 && <= 4.1.0.0, unix, directory, process, ftphs, readline+ Build-Depends: base >= 4 && <= 4.1.0.0, unix, directory, process, ftphs, haskeline, mtl Exposed-Modules: Network.Yjftp- Other-Modules: Network.CommandList+ Other-Modules: Network.CommandList, Network.Console, Network.Types Executable yjftp GHC-Options: -Wall
yjftp.hs view
@@ -16,8 +16,8 @@ "list directory contents\n\toption -l list detail of contents", compLs)) , ("cd", (changeDirectoryFTP, "change directory in remote", compRemoteFile))- , ("lcd", (changeDirectoryLocal, "change directory in local", const filenameCompletionFunction))- , ("put", (putFileFTP, "upload file", const filenameCompletionFunction))+ , ("lcd", (changeDirectoryLocal, "change directory in local", const compFilename))+ , ("put", (putFileFTP, "upload file", const compFilename)) , ("get", (getFileFTP, "download file", compRemoteFile)) , ("cat", (showFileFTP, "show remote file", compRemoteFile)) , ("rm", (removeFileFTP, "delete remote file", compRemoteFile))