yjftp-0.3: Network/CommandList.hs

module Network.CommandList (
  CommandList
, defaultCommandList

, const2
, helpFTP
, quitFTP
, systemFTP
, pwdFTP
, listFTP
, directoryFTP
, changeDirectoryLocal
, changeDirectoryFTP
, getFileFTP
, putFileFTP
, showFileFTP
, removeFileFTP
, makeDirectoryFTP
, removeDirectoryFTP
, moveFileFTP
, copyFileFTP
, editBy
, readBy

) where

import Network.FTP.Client   (FTPConnection, getbinary, putbinary, uploadbinary, downloadbinary,
                             nlst, dir, pwd, cwd, rename, delete, mkdir, rmdir)
import System.IO            (Handle, hClose, hPutStr)
import System.Directory     (setCurrentDirectory, removeFile, getTemporaryDirectory)
import System.Cmd           (system)
import System.Posix.Temp    (mkstemp)
import Data.Maybe           (fromJust)
import Control.Exception    (catchJust, ioErrors, ioError, bracketOnError)
import System.IO.Error      (isUserError)

type Action      = FTPConnection -> [String] -> IO Bool
type CommandList = [(String, Action)]

defaultCommandList :: CommandList
defaultCommandList = [
   ("?",     helpFTP)
 , ("q",     quitFTP)
 , ("quit",  quitFTP)
 , ("exit",  quitFTP)
 , ("bye",   quitFTP)
 , ("!",     systemFTP)
 , ("pwd",   pwdFTP)
 , ("ls",    \h args   -> case args of
                            ("-l":args_) -> directoryFTP h args_
                            _            -> listFTP h args)
 , ("cd",    changeDirectoryFTP)
 , ("lcd",   changeDirectoryLocal)
 , ("put",   putFileFTP)
 , ("get",   getFileFTP)
 , ("cat",   showFileFTP)
 , ("rm",    removeFileFTP)
 , ("mkdir", makeDirectoryFTP)
 , ("rmdir", removeDirectoryFTP)
 , ("mv",    moveFileFTP)
 , ("cp",    copyFileFTP)
 , ("vi",    editBy ("vi "++))
 , ("view",  readBy ("view "++))
 ]

const2 :: a -> b -> c -> a
const2 = const . const

helpFTP :: Action
helpFTP = const2 $ putStr helpStr >> return True
  where helpStr = unlines [ "ls: list directory contents" , "q : quit" ]

quitFTP :: Action
quitFTP = const2 $ return False

systemFTP :: Action
systemFTP = const $ (>> return True) . system . unwords

pwdFTP :: Action
pwdFTP h [] = pwd h >>= putStrLn . fromJust . fst >> return True
pwdFTP _ _  = error "pwdFTP: args incorrect"

listFTP :: Action
listFTP h []          = nlst h Nothing     >>= putStrLn . unwords >> return True
listFTP h [path]      = nlst h (Just path) >>= putStrLn . unwords >> return True
listFTP _ _           = error "listFTP: args incorrect"

directoryFTP :: Action
directoryFTP h []     = dir h Nothing      >>= putStrLn . unlines >> return True
directoryFTP h [path] = dir h (Just path)  >>= putStrLn . unlines >> return True
directoryFTP _ _      = error "directoryFTP: args incorrect"

changeDirectoryFTP :: Action
changeDirectoryFTP h [dirPath] = cwd h dirPath >> return True
changeDirectoryFTP _ _         = error "changeDirectoryFTP: args incorrect"

changeDirectoryLocal :: Action
changeDirectoryLocal _ [dirPath] = setCurrentDirectory dirPath >> return True
changeDirectoryLocal _ _         = error "changeDirectoryLocal: args incorrect"

putFileFTP :: Action
putFileFTP h [file] = uploadbinary h file >> return True
putFileFTP _ _      = error "putFileFTP: args incorrect"

getFileFTP :: Action
getFileFTP h [file] = downloadbinary h file >> return True
getFileFTP _ _      = error "getFileFTP: args incorrect"

showFileFTP :: Action
showFileFTP h [file] = getbinary h file >>= putStr . fst >> return True
showFileFTP _ _      = error "showFileFTP: args incorrect"

removeFileFTP :: Action
removeFileFTP h [file] = delete h file >> return True
removeFileFTP _ _      = error "removeFileFTP: args incorrect"

makeDirectoryFTP :: Action
makeDirectoryFTP h [dr] = mkdir h dr >> return True
makeDirectoryFTP _ _    = error "makeDirectoryFTP: args incorrect"

removeDirectoryFTP :: Action
removeDirectoryFTP h [dr] = rmdir h dr >> return True
removeDirectoryFTP _ _    = error "removeDirectoryFTP: args incorrect"

moveFileFTP :: Action
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 _ _ = error "Usage: cp src dist"

editBy :: (String -> String) -> Action
editBy mkEdtr h [fp] =
  bracketOnError (mkTempFile $ "ftpvi_" ++ basename fp)
                 (\(fn, fd) -> hClose fd >> tmpFileSave fn) $ \(fn, fd) -> do
    catchJust ioErrors (getbinary h fp >>= hPutStr fd . fst)
                       (\err -> if isUserError err then return () else ioError err)
    hClose fd
    system $ mkEdtr fn
    readFile fn >>= putbinary h fp
    removeFile fn
    return True
  where tmpFileSave n = putStrLn $ "temp file save as " ++ "'" ++ n ++ "'"
editBy _ _ _ = error "editBy: bad args"

readBy :: (String -> String) -> Action
readBy vwr h [fp] =
  bracketOnError (mkTempFile $ "ftpview_" ++ basename fp)
                 (\(fn, fd) -> hClose fd >> removeFile fn) $ \(fn, fd) -> do
    getbinary h fp >>= hPutStr fd . fst
    hClose fd
    system $ vwr fn
    removeFile fn
    return True
readBy _ _ _ = error "readBy: bad arguments"

basename :: FilePath -> FilePath
basename = reverse . takeWhile (/='/') . reverse

mkTempFile :: String -> IO (String, Handle)
mkTempFile fn = do
  tmpDir <- getTemporaryDirectory
  mkstemp $ tmpDir ++ "/" ++ fn ++ "-XXXXXX"