summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYoshikuniJujo <>2009-06-14 05:54:24 (GMT)
committerLuite Stegeman <luite@luite.com>2009-06-14 05:54:24 (GMT)
commit93db1fd753715672d92f5bfe33f30757ef0a0a6a (patch)
tree8d731ad76515a7ac578f99a8f3d7086a5d302c8e
parent66f788ccf4f705393ba893e327c6761890bb5588 (diff)
version 0.3.60.3.6
-rw-r--r--Network/CommandList.hs37
-rw-r--r--Network/Console.hs80
-rw-r--r--Network/Types.hs21
-rw-r--r--Network/Yjftp.hs55
-rw-r--r--yjftp.cabal7
-rw-r--r--yjftp.hs4
6 files changed, 154 insertions, 50 deletions
diff --git a/Network/CommandList.hs b/Network/CommandList.hs
index 9bd6cac..38ae6df 100644
--- a/Network/CommandList.hs
+++ b/Network/CommandList.hs
@@ -27,7 +27,7 @@ module Network.CommandList (
, const2
, compRemoteFile
, compLs
-, filenameCompletionFunction
+, compFilename
) where
import Network.FTP.Client (FTPConnection, getbinary, putbinary, uploadbinary, downloadbinary,
@@ -40,20 +40,11 @@ import System.IO.Error (isUserError)
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 @@ defaultCommandList = [
"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 h [src, dst] = rename h src dst >> return True
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 @@ mkTempFile fn = do
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 @@ compLs h str
| 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 [""] = [""]
diff --git a/Network/Console.hs b/Network/Console.hs
new file mode 100644
index 0000000..7bfaaef
--- /dev/null
+++ b/Network/Console.hs
@@ -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 ()
diff --git a/Network/Types.hs b/Network/Types.hs
new file mode 100644
index 0000000..9a40358
--- /dev/null
+++ b/Network/Types.hs
@@ -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
diff --git a/Network/Yjftp.hs b/Network/Yjftp.hs
index b2035dc..0598586 100644
--- a/Network/Yjftp.hs
+++ b/Network/Yjftp.hs
@@ -6,7 +6,7 @@ module Network.Yjftp (
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 Control.Applicative ((<$>))
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 @@ runYjftp cl = do
(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 @@ tryNTimes n errM act
= 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 @@ getPassword = do
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 @@ myWords str@(c:cs)
| 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
diff --git a/yjftp.cabal b/yjftp.cabal
index 2f88c2d..e7e8194 100644
--- a/yjftp.cabal
+++ b/yjftp.cabal
@@ -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 @@ Description: Just CUI FTP client.
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 @@ Extra-Tmp-Files:
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
diff --git a/yjftp.hs b/yjftp.hs
index 1fae67a..1ca7d23 100644
--- a/yjftp.hs
+++ b/yjftp.hs
@@ -16,8 +16,8 @@ myCommandList = [
"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))