FTPLine 1.3.0 → 1.4.0.0
raw patch · 3 files changed
+591/−589 lines, 3 filesdep ~haskelinedep ~mtl
Dependency ranges changed: haskeline, mtl
Files
- FTPLine.cabal +13/−18
- Main.hs +577/−570
- license +1/−1
FTPLine.cabal view
@@ -1,35 +1,30 @@ Name: FTPLine -Version: 1.3.0 +Version: 1.4.0.0 Cabal-Version: >= 1.6 License: BSD3 License-file: license -Author: Daniel Diaz -Maintainer: Daniel Diaz <danieldiaz@asofilak.es> -Homepage: http://ddiaz.asofilak.es/packages/FTPLine +Author: Daniel Díaz +Maintainer: Daniel Diaz (dhelta `dot` diaz `at` gmail `dot` com) Category: Network Synopsis: A command-line FTP client. -Description: A command-line FTP client. Type @help@ for a list of commands. Online documentation at the homepage. - . - Changes from the last version: - . - * Now, mtl dependency is == 2.0.*. - . - * Due to the update to mtl-2, now haskeline dependency is >= 0.6.3.2 && < 0.7. - . - * New feature: Reestablishing of last connection and login. - . - * Current mode (local or remote) is displayed when switching between them. +Description: A command-line FTP client. Type @help@ for a list of commands. Build-Type: Simple +Source-repository head + type: git + location: git://github.com/Daniel-Diaz/FTPLine.git + Executable FTPLine Build-depends: base == 4.* - , mtl == 2.0.* + , mtl , ftphs , directory , network - , haskeline >= 0.6.3.2 && < 0.7 + , haskeline , ansi-terminal , strict , bytestring Extensions: FlexibleInstances - Main-is: Main.hs+ Main-is: Main.hs + Other-modules: Paths_FTPLine + ghc-options: -O2 -Wall
Main.hs view
@@ -1,570 +1,577 @@- -{-# LANGUAGE FlexibleInstances #-} - --- --- Below is the code of the FTPLine application. --- Sorry for the lack of code notes. --- If you have any question about the code, I have your answer (I hope). --- --- Daniel Diaz < danieldiaz@asofilak.es > --- 2011 --- - -import Data.Maybe -import qualified Data.Strict.Maybe as Strict -import Control.Monad.State.Strict -import Control.Monad.Error.Class -import System.Console.Haskeline hiding (getInputLine) -import qualified System.Console.Haskeline as Haskeline (getInputLine) -import Network.Socket hiding (connect) -import Network.FTP.Client -import Network.FTP.Client.Parser -import System.Directory -import Control.Applicative ((<$>)) -import Data.List (intercalate) -import Prelude hiding (catch) -import System.Console.ANSI -import System.IO -import System.Environment (getArgs) -import qualified Data.ByteString.Char8 as B - --- Instance of StateT monad in MonadException class - -instance MonadException m => MonadException (StateT s m) where - catch f h = StateT $ \s -> catch (runStateT f s) - (\e -> runStateT (h e) s) - block = mapStateT block - unblock = mapStateT unblock - --- - -ftperror :: String -> FTPLine a -ftperror = liftIO . fail - --- - -getInputLine :: String -> FTPLine String -getInputLine str = do withColor Yellow $ outputStr str - ms <- Haskeline.getInputLine "\n" - if ms == Nothing then do -- CTRL + D command - withColor Green $ outputStrLn "Switching local/remote..." - return "switch" - else return $ fromJust ms - -getInputLine_ :: String -> String -> FTPLine () -getInputLine_ str com = do withColor Yellow $ outputStr str - outputStrLn com - -data File = File FilePath !B.ByteString - -type SMaybe = Strict.Maybe - -data FTPState = FTPState { conn :: Maybe FTPConnection - , file :: !(SMaybe File) - , host :: Maybe String - , mode :: Bool - , interactive :: Bool } - --- Added for the 1.3.0 version. -boolToMode :: Bool -> String -boolToMode b = if b then "Remote" else "Local" - -initialFTPState :: FTPState -initialFTPState = FTPState { conn = Nothing - , file = Strict.Nothing - , host = Nothing - , mode = False - , interactive = False - } - -type FTPLine a = InputT (StateT FTPState IO) a - -getting :: (MonadState st m, MonadTrans t,Functor (t m)) => (st -> x) -> t m x -getting f = f <$> lift get - -modif :: (MonadTrans t, MonadState s m) => (s -> s) -> t m () -modif = lift . modify - -getConnection :: FTPLine (Maybe FTPConnection) -getConnection = getting conn - -newConnection :: String -> FTPConnection -> FTPLine () -newConnection hn c = modif $ \(FTPState _ mf _ b i) -> FTPState (Just c) mf (Just hn) b i - -removeConnection :: FTPLine () -removeConnection = modif $ \(FTPState _ mf _ b i) -> FTPState Nothing mf Nothing b i - -getFile :: FTPLine (SMaybe File) -getFile = getting file - -newFile :: File -> FTPLine () -newFile f = modif $! \(FTPState mc _ md b i) -> FTPState mc (Strict.Just f) md b i - -cleanFile :: FTPLine () -cleanFile = modif $! \(FTPState mc _ md b i) -> FTPState mc Strict.Nothing md b i - -getHost :: FTPLine String -getHost = return "Local" <-> const (getting $ maybe "Local" id . host) - -getMode :: FTPLine Bool -getMode = getting mode - -turnMode :: FTPLine () -turnMode = modif $ \s -> s { mode = not $ mode s } - -isInteractive :: FTPLine Bool -isInteractive = getting interactive - -setInteractive :: Bool -> FTPLine () -setInteractive b = modif $ \s -> s { interactive = b } - --- - -connect :: HostName -> PortNumber -> FTPLine FTPResult -connect hn pn = do mc <- getConnection - if isNothing mc then return () - else (liftIO $ quit $ fromJust mc) >> return () - (c,r) <- liftIO $ connectFTP hn pn - newConnection hn c - saveConnection hn pn - return r - --- Added for the 1.3.0 version. -saveConnection :: HostName -> PortNumber -> FTPLine () -saveConnection hn pn = do - appDir <- liftIO ftpLineDir - liftIO $ writeFile (appDir ++ "/LastConnection") $ - show (hn,pn) - -withConnection :: (FTPConnection -> FTPLine a) -> FTPLine a -withConnection f = do mc <- getConnection - if isNothing mc then ftperror "Connection not established." - else f $ fromJust mc - --- Added for the 1.3.0 version. -saveLogin :: String -> String -> FTPLine () -saveLogin name pass = do - appDir <- liftIO ftpLineDir - liftIO $ writeFile (appDir ++ "/LastLogin") $ - show (name,pass) - -ftplogin :: Maybe (String,String) -> FTPLine FTPResult -ftplogin Nothing = withConnection $ liftIO . loginAnon -ftplogin (Just (name,pass)) = do - r <- withConnection $ - \c -> liftIO $ login c name (Just pass) Nothing - saveLogin name pass - return r - --- Added for the 1.3.0 version. -lastConn :: FTPLine () -lastConn = hand (const $ withColor Red $ outputStrLn "Last connection doesn't exist.") $ do - appDir <- liftIO ftpLineDir - lc <- liftIO $ readFile $ appDir ++ "/LastConnection" - (liftIO $ readIO lc) >>= uncurry connect - outputStrLn "Last connection reestablished." - hand (const $ withColor Red $ outputStrLn "Last login doesn't exist.") $ do - ll <- liftIO $ readFile $ appDir ++ "/LastLogin" - (liftIO $ readIO ll) >>= ftplogin . Just - outputStrLn "Last login reestablished." - -disconnect :: FTPLine FTPResult -disconnect = withConnection $ - \c -> do removeConnection - liftIO $ quit c - --- - -ftpdebug :: FTPLine () -ftpdebug = liftIO enableFTPDebugging - --- - -success :: FTPResult -success = (1,["Success"]) - -failure :: FTPResult -failure = (0,["Failure"]) - -showFTPResult :: FTPResult -> String -showFTPResult (n,xs) = unwords $ [ show n , ":" ] ++ xs - -outputFTPResult :: FTPResult -> FTPLine () -outputFTPResult = withColor Magenta . outputStrLn . showFTPResult - -discardConnection :: FTPLine Bool -discardConnection = - do mc <- getConnection - b <- getMode - return $ not b || isNothing mc - -(<->) :: FTPLine a -> (FTPConnection -> FTPLine a) -> FTPLine a -la <-> ra = do b <- discardConnection - if b then la - else do mc <- getConnection - ra $ fromJust mc - -localdir :: Maybe String -> FTPLine () -localdir fp = if isNothing fp then liftIO (getDirectoryContents ".") >>= mapM_ outputStrLn - else liftIO (getDirectoryContents $ fromJust fp) >>= mapM_ outputStrLn - -pdir :: Maybe String -> FTPLine () -pdir fp = localdir fp <-> - \c -> liftIO (dir c fp) >>= mapM_ outputStrLn - -getfile :: String -> FTPLine FTPResult -getfile fp = (do x <- liftIO $ B.readFile fp - newFile $ File fp x - return success - ) <-> - \c -> do (x,r) <- liftIO $ getbinary c fp - newFile $ File fp $ B.pack x - return r - -download :: String -> FTPLine FTPResult -download fp = withConnection $ - \c -> liftIO $ downloadbinary c fp - -putfile :: String -> FTPLine FTPResult -putfile fp = (do x <- getFile - if Strict.isNothing x - then ftperror "File memory empty." - else let (File _ cnt) = Strict.fromJust x - in do liftIO $ B.writeFile fp cnt - return success - ) <-> - \c -> do x <- getFile - if Strict.isNothing x - then ftperror "File memory empty." - else let (File _ cnt) = Strict.fromJust x - in liftIO $ putbinary c fp $ B.unpack cnt - -upload :: String -> FTPLine FTPResult -upload fp = withConnection $ - \c -> liftIO $ uploadbinary c fp - -renamefile :: String -> String -> FTPLine FTPResult -renamefile fp1 fp2 = - ( do liftIO $ renameFile fp1 fp2 - return success - ) <-> - \c -> liftIO $ rename c fp1 fp2 - -deletefile :: String -> FTPLine FTPResult -deletefile fp = ( do liftIO $ removeFile fp - return success - ) <-> - \c -> liftIO $ delete c fp - -sizefile :: String -> FTPLine FTPResult -sizefile fp = do n <- ( liftIO $ B.length <$> B.readFile fp - ) <-> - \c -> liftIO $ size c fp - outputStrLn $ show n - return success - -ccd :: String -> FTPLine FTPResult -ccd fp = ( do liftIO $ setCurrentDirectory fp - return success - ) <-> - \c -> liftIO $ cwd c fp - -newdir :: String -> FTPLine FTPResult -newdir fp = ( do liftIO $ createDirectory fp - return success - ) <-> - \c -> liftIO $ snd <$> mkdir c fp - -remdir :: String -> FTPLine FTPResult -remdir fp = ( do liftIO $ removeDirectory fp - return success - ) <-> - \c -> liftIO $ rmdir c fp - -curdir :: FTPLine (Maybe String,FTPResult) -curdir = ( do x <- liftIO getCurrentDirectory - return (Just x,success) - ) <-> ( liftIO . pwd ) - ----------------- - -class Read a => Arg a where - parse :: String -> FTPLine a - -- - parse = liftIO . readIO - -output :: Show a => a -> FTPLine () -output = outputStrLn . show - -command :: String -> FTPLine () -command str = if null xs then outputStrLn "No command introduced." - else withColor Green $ runCom (head xs) (tail xs) - where - xs = args str - -printHelp :: String -> FTPLine () -printHelp str = withColor Cyan $ mapM_ (\ln -> if head ln == '*' then outputStrLn ln - else italized $ outputStrLn ln ) $ commandDesc str - --- Handling exceptions - -hand :: MonadException m => (IOException -> m a) -> m a -> m a -hand = handle - -handres :: FTPLine FTPResult -> FTPLine () -handres c = hand ((>> return failure) . withColor Red . output) c >>= outputFTPResult - -hand_ :: FTPLine () -> FTPLine () -hand_ = hand (withColor Red . output) - --- Echo setting - -inEchoOff, inEchoOn :: FTPLine () -inEchoOff = liftIO $ hSetEcho stdin False -inEchoOn = liftIO $ hSetEcho stdin True - --- - -runCom :: String -> [String] -> FTPLine () -runCom str ["help"] = printHelp str -runCom "help" _ = do withColor Cyan $ outputStrLn helpHead - mapM_ printHelp commands -runCom "connect" args = handres $ mkCom args $ uncurry connect -runCom "login" args = - do isInt <- isInteractive - if isInt then do let isAnon = do withColor Yellow $ outputStr "Login as anonymous? (y/n) " - c <- getInputChar "" - case c of - Just 'y' -> return True - Just 'n' -> return False - _ -> do liftIO $ do cursorUpLine 1 - clearFromCursorToScreenEnd - isAnon - b <- isAnon - if b then handres $ withColor Green $ ftplogin Nothing - else do withColor Yellow $ outputStr "User name: " - name <- Haskeline.getInputLine "" - withColor Yellow $ outputStr "Password : " - pass <- getPassword (Just '*') "" - if isNothing name || isNothing pass then outputStrLn "Incorrect login." - else handres $ withColor Green $ - ftplogin $ Just (fromJust name,fromJust pass) - else if null args then handres $ ftplogin Nothing - else handres $ mkCom args $ ftplogin . Just -runCom "disconnect" _ = handres disconnect -runCom "ftpdebug" _ = ftpdebug -runCom "dir" args = if null args then hand_ $ pdir Nothing - else hand_ $ mkCom args $ pdir . Just -runCom "getfile" args = handres $ mkCom args $ getfile -runCom "download" args = handres $ mkCom args $ download -runCom "putfile" args = handres $ mkCom args $ putfile -runCom "upload" args = handres $ mkCom args $ upload -runCom "rename" args = handres $ mkCom args $ uncurry renamefile -runCom "delete" args = handres $ mkCom args $ deletefile -runCom "size" args = handres $ mkCom args $ sizefile -runCom "cd" args = handres $ mkCom args $ ccd -runCom "md" args = handres $ mkCom args $ newdir -runCom "rd" args = handres $ mkCom args $ remdir -runCom "clear" _ = do hand_ cleanFile - outputStrLn "Memory Cleared." -runCom "pause" _ = do outputStr "PAUSE. Press ENTER to continue..." - inEchoOff - liftIO $ getLine - inEchoOn - outputStrLn "" -runCom "switch" _ = do turnMode - b <- getMode - outputStrLn $ "Current mode: " ++ boolToMode b -runCom "last" _ = lastConn -runCom x _ = withColor Cyan $ outputStrLn $ "Command doesn't exist: " ++ x - --- List of commands - -commands :: [String] -commands = [ "connect" , "disconnect" - , "login" , "ftpdebug" - , "last" - , "dir" , "cd" , "md" , "rd" - , "getfile" , "putfile" , "clear" - , "download" , "upload" - , "rename" , "delete" - , "size" - , "switch" - , "pause" - , "exit" - ] - -helpHead :: String -helpHead = unlines [ "" - , "Below is a list of available commands." - , "Arguments in brackets are optional." - , "Arguments in braces are only used in batch mode." - ] - --- Description of the commands. - -commandDesc :: String -> [String] -commandDesc "connect" = [ "connect HostName Port" - , "* Connect to remote FTP server." ] -commandDesc "login" = [ "login {[UserName Password]}" - , "* Login to the FTP server." ] -commandDesc "disconnect" = [ "disconnect" - , "* Close the current conection." ] -commandDesc "ftpdebug" = [ "ftpdebug" - , "* Enable logging of FTP messages." ] -commandDesc "dir" = [ "dir [FilePath]" - , "* Show a directory content." ] -commandDesc "getfile" = [ "getfile FilePath" - , "* Load specified file and save its content in a temporal memory." ] -commandDesc "download" = [ "download FilePath" - , "* Download a remote file to your system." ] -commandDesc "putfile" = [ "putfile FilePath" - , "* Write a file with the temporal memory's content." ] -commandDesc "upload" = [ "upload FilePath" - , "* Upload a file from disk." ] -commandDesc "rename" = [ "rename FilePath1 FilePath2" - , "* Rename a file." ] -commandDesc "delete" = [ "delete FilePath" - , "* Delete a file." ] -commandDesc "size" = [ "size FilePath" - , "* Return the size of a file." ] -commandDesc "cd" = [ "cd FilePath" - , "* Change the current directory." ] -commandDesc "md" = [ "md FilePath" - , "* Create a new directory." ] -commandDesc "rd" = [ "rd FilePath" - , "* Remove a directory" ] -commandDesc "exit" = [ "exit" - , "* Close the client." ] -commandDesc "clear" = [ "clear" - , "* Clear the temporal memory." ] -commandDesc "pause" = [ "pause" - , "* Stop the program until pressing ENTER." - , "* Useful for FTP batch programs." ] -commandDesc "switch" = [ "switch" - , "* Switch between local and remote mode." - , "* CTRL+D invokes this action." ] -commandDesc "last" = [ "last" - , "* Try to connect and login as it was done the last time." ] -commandDesc _ = ["* Invalid command."] - -mkCom :: Arg a => [String] -> (a -> FTPLine b) -> FTPLine b -mkCom [] f = ftperror "Need more arguments." -mkCom args f = if length args > 1 then parse (concat [ "(" , intercalate "," args , ")" ]) >>= f - else parse (head args) >>= f - ----- - -instance Arg [Char] where - parse = return - -instance Read PortNumber where - readsPrec n str = (\(x,str) -> (fromIntegral x , str)) <$> readsPrec n str - -instance (Arg a, Arg b) => Arg (a,b) where - parse str = let str' = init . tail $ str - xs = takeWhile (/=',') str' - tail' [] = [] - tail' xs = tail xs - ys = tail' $ dropWhile (/=',') str' - in do x <- parse xs - y <- parse ys - return (x,y) - -instance Arg PortNumber where - parse str = liftIO $ do x <- readIO str - return $ fromIntegral x - ------------------------ --- Arguments - -addChar :: Char -> [String] -> [String] -addChar c [] = [[c]] -addChar c (x:xs) = (c : x) : xs - -args' :: String -> [String] -> Bool -> [String] -args' [] xs _ = xs -args' (x:xs) ys b - | x == ' ' = if b then args' xs (addChar x ys) b - else args' xs ([] : ys) b - | x == '\"' = args' xs ys $ not b - | otherwise = args' xs (addChar x ys) b - -args :: String -> [String] -args str = reverse $ reverse <$> args' str [] False - ------------------------ - -withSGR :: MonadIO m => [SGR] -> [SGR] -> m a -> m a -withSGR xs ys comp = do liftIO $ setSGR xs - x <- comp - liftIO $ setSGR ys - return x - -withColor :: MonadIO m => Color -> m a -> m a -withColor col = withSGR [ SetColor Foreground Vivid col ] [ SetColor Foreground Vivid White ] - -italized :: MonadIO m => m a -> m a -italized = withSGR [ SetSwapForegroundBackground True ] [ SetSwapForegroundBackground False ] - --- Main - -ftpLineDir :: IO FilePath -ftpLineDir = getAppUserDataDirectory "FTPLine" - -main :: IO () -main = do setSGR [ SetColor Foreground Vivid White ] - -- - args <- getArgs - appDir <- ftpLineDir - createDirectoryIfMissing True appDir - -- - putStrLn "*** Welcome to FTPLine 1.3.0 ***" - if null args then do withColor Cyan $ do putStr "Type " - italized $ putStr "help" - putStrLn " for a list of commands." - -- - let sets = defaultSettings { historyFile = Just $ appDir ++ "/History" } - runStateT (runInputT sets mainInteractive) initialFTPState - return () - else do let arg = head args - exst <- doesFileExist arg - if exst then do txt <- readFile arg - runStateT (runInputT defaultSettings $ mapM_ (\str -> do (mcd,hn) <- withColor Green $ do mcd <- hand (( >> (return $ Just "?")) . withColor Red . output) - $ fst <$> curdir - hn <- getHost - return (mcd,hn) - let cd = if isNothing mcd then "? " else fromJust mcd - getInputLine_ (unwords [cd , "@" , hn ++ ">>\n"]) str - hand_ $ command str) $ lines txt ++ ["disconnect"] ) - initialFTPState - putStrLn "Closing FTPLine." - else withColor Red $ putStrLn $ "File " ++ arg ++ " doesn't exist." - setSGR [ Reset ] - -mainInteractive :: FTPLine () -mainInteractive = do setInteractive True - runCicle - -runCicle :: FTPLine () -runCicle = hand (\e -> do withColor Red $ output e - ln <- getInputLine "? >>" - if ln == "exit" then exit - else do hand_ $ command ln - runCicle ) mainCicle - -mainCicle :: FTPLine () -mainCicle = do (mcd,hn) <- withColor Green $ do mcd <- hand (\e -> do withColor Red $ output e - return Nothing ) $ fst <$> curdir - hn <- getHost - return (mcd,hn) - let cd = if isNothing mcd then "? " else fromJust mcd - ln <- getInputLine $ unwords [ cd , "@" , hn ++ ">>" ] - if ln == "exit" then exit - else do hand_ $ command ln - mainCicle - -exit :: FTPLine () -exit = do hand (\_ -> return failure) $ withColor Green disconnect - outputStrLn "Closing FTPLine." - ++{-# LANGUAGE FlexibleInstances #-}++module Main (main) where+import Data.Maybe+import qualified Data.Strict.Maybe as Strict+import Control.Monad.State.Strict+import System.Console.Haskeline hiding (getInputLine)+import qualified System.Console.Haskeline as Haskeline+ (getInputLine)+import Network.Socket hiding (connect)+import Network.FTP.Client+import Network.FTP.Client.Parser+import System.Directory+import Control.Applicative ((<$>))+import Data.List (intercalate)+import System.Console.ANSI+import System.IO+import System.Environment (getArgs)+import qualified Data.ByteString.Char8 as B+import Paths_FTPLine (version)+import Data.Version (showVersion)+ +ftperror :: String -> FTPLine a+ftperror = liftIO . fail+ +getInputLine :: String -> FTPLine String+getInputLine str+ = do withColor Yellow $ outputStr str+ ms <- Haskeline.getInputLine "\n"+ if ms == Nothing then+ do withColor Green $ outputStrLn "Switching local/remote..."+ return "switch"+ else return $ fromJust ms+ +getInputLine_ :: String -> String -> FTPLine ()+getInputLine_ str com+ = do withColor Yellow $ outputStr str+ outputStrLn com+ +data File = File FilePath !B.ByteString+ +type SMaybe = Strict.Maybe+ +data FTPState = FTPState{conn :: Maybe FTPConnection,+ file :: !(SMaybe File), host :: Maybe String, mode :: Bool,+ interactive :: Bool}+ +boolToMode :: Bool -> String+boolToMode b = if b then "Remote" else "Local"+ +initialFTPState :: FTPState+initialFTPState+ = FTPState{conn = Nothing, file = Strict.Nothing, host = Nothing,+ mode = False, interactive = False}+ +type FTPLine a = InputT (StateT FTPState IO) a+ +getting ::+ (MonadState st m, MonadTrans t, Functor (t m)) =>+ (st -> x) -> t m x+getting f = f <$> lift get+ +modif :: (MonadTrans t, MonadState s m) => (s -> s) -> t m ()+modif = lift . modify+ +getConnection :: FTPLine (Maybe FTPConnection)+getConnection = getting conn+ +newConnection :: String -> FTPConnection -> FTPLine ()+newConnection hn c+ = modif $+ \ (FTPState _ mf _ b i) -> FTPState (Just c) mf (Just hn) b i+ +removeConnection :: FTPLine ()+removeConnection+ = modif $+ \ (FTPState _ mf _ b i) -> FTPState Nothing mf Nothing b i+ +getFile :: FTPLine (SMaybe File)+getFile = getting file+ +newFile :: File -> FTPLine ()+newFile f+ = modif $!+ \ (FTPState mc _ md b i) -> FTPState mc (Strict.Just f) md b i+ +cleanFile :: FTPLine ()+cleanFile+ = modif $!+ \ (FTPState mc _ md b i) -> FTPState mc Strict.Nothing md b i+ +getHost :: FTPLine String+getHost+ = return "Local" <-> const (getting $ maybe "Local" id . host)+ +getMode :: FTPLine Bool+getMode = getting mode+ +turnMode :: FTPLine ()+turnMode = modif $ \ s -> s{mode = not $ mode s}+ +isInteractive :: FTPLine Bool+isInteractive = getting interactive+ +setInteractive :: Bool -> FTPLine ()+setInteractive b = modif $ \ s -> s{interactive = b}+ +connect :: HostName -> PortNumber -> FTPLine FTPResult+connect hn pn+ = do mc <- getConnection+ if isNothing mc then return () else+ (liftIO $ quit $ fromJust mc) >> return ()+ (c, r) <- liftIO $ connectFTP hn pn+ newConnection hn c+ saveConnection hn pn+ return r+ +saveConnection :: HostName -> PortNumber -> FTPLine ()+saveConnection hn pn+ = do appDir <- liftIO ftpLineDir+ liftIO $ writeFile (appDir ++ "/LastConnection") $ show (hn, pn)+ +withConnection :: (FTPConnection -> FTPLine a) -> FTPLine a+withConnection f+ = do mc <- getConnection+ if isNothing mc then ftperror "Connection not established." else+ f $ fromJust mc+ +saveLogin :: String -> String -> FTPLine ()+saveLogin name pass+ = do appDir <- liftIO ftpLineDir+ liftIO $ writeFile (appDir ++ "/LastLogin") $ show (name, pass)+ +ftplogin :: Maybe (String, String) -> FTPLine FTPResult+ftplogin Nothing = withConnection $ liftIO . loginAnon+ftplogin (Just (name, pass))+ = do r <- withConnection $+ \ c -> liftIO $ login c name (Just pass) Nothing+ saveLogin name pass+ return r+ +lastConn :: FTPLine ()+lastConn+ = hand+ (const $+ withColor Red $ outputStrLn "Last connection doesn't exist.")+ $+ do appDir <- liftIO ftpLineDir+ lc <- liftIO $ readFile $ appDir ++ "/LastConnection"+ _ <- (liftIO $ readIO lc) >>= uncurry connect+ outputStrLn "Last connection reestablished."+ hand+ (const $ withColor Red $ outputStrLn "Last login doesn't exist.")+ $+ do ll <- liftIO $ readFile $ appDir ++ "/LastLogin"+ _ <- (liftIO $ readIO ll) >>= ftplogin . Just+ outputStrLn "Last login reestablished."+ +disconnect :: FTPLine FTPResult+disconnect+ = withConnection $+ \ c ->+ do removeConnection+ liftIO $ quit c+ +ftpdebug :: FTPLine ()+ftpdebug = liftIO enableFTPDebugging+ +success :: FTPResult+success = (1, ["Success"])+ +failure :: FTPResult+failure = (0, ["Failure"])+ +showFTPResult :: FTPResult -> String+showFTPResult (n, xs) = unwords $ [show n, ":"] ++ xs+ +outputFTPResult :: FTPResult -> FTPLine ()+outputFTPResult = withColor Magenta . outputStrLn . showFTPResult+ +discardConnection :: FTPLine Bool+discardConnection+ = do mc <- getConnection+ b <- getMode+ return $ not b || isNothing mc+ +(<->) :: FTPLine a -> (FTPConnection -> FTPLine a) -> FTPLine a+la <-> ra+ = do b <- discardConnection+ if b then la else+ do mc <- getConnection+ ra $ fromJust mc+ +localdir :: Maybe String -> FTPLine ()+localdir fp+ = if isNothing fp then+ liftIO (getDirectoryContents ".") >>= mapM_ outputStrLn . reverse+ else+ liftIO (getDirectoryContents $ fromJust fp) >>= mapM_ outputStrLn+ +pdir :: Maybe String -> FTPLine ()+pdir fp+ = localdir fp <-> \ c -> liftIO (dir c fp) >>= mapM_ outputStrLn+ +getfile :: String -> FTPLine FTPResult+getfile fp+ = (do x <- liftIO $ B.readFile fp+ newFile $ File fp x+ return success)+ <->+ \ c ->+ do (x, r) <- liftIO $ getbinary c fp+ newFile $ File fp $ B.pack x+ return r+ +download :: String -> FTPLine FTPResult+download fp = withConnection $ \ c -> liftIO $ downloadbinary c fp+ +putfile :: String -> FTPLine FTPResult+putfile fp+ = (do x <- getFile+ if Strict.isNothing x then ftperror "File memory empty." else+ let (File _ cnt) = Strict.fromJust x in+ do liftIO $ B.writeFile fp cnt+ return success)+ <->+ \ c ->+ do x <- getFile+ if Strict.isNothing x then ftperror "File memory empty." else+ let (File _ cnt) = Strict.fromJust x in+ liftIO $ putbinary c fp $ B.unpack cnt+ +upload :: String -> FTPLine FTPResult+upload fp = withConnection $ \ c -> liftIO $ uploadbinary c fp+ +renamefile :: String -> String -> FTPLine FTPResult+renamefile fp1 fp2+ = (do liftIO $ renameFile fp1 fp2+ return success)+ <-> \ c -> liftIO $ rename c fp1 fp2+ +deletefile :: String -> FTPLine FTPResult+deletefile fp+ = (do liftIO $ removeFile fp+ return success)+ <-> \ c -> liftIO $ delete c fp+ +sizefile :: String -> FTPLine FTPResult+sizefile fp+ = do n <- (liftIO $ B.length <$> B.readFile fp) <->+ \ c -> liftIO $ size c fp+ outputStrLn $ show n+ return success+ +ccd :: String -> FTPLine FTPResult+ccd fp+ = (do liftIO $ setCurrentDirectory fp+ return success)+ <-> \ c -> liftIO $ cwd c fp+ +newdir :: String -> FTPLine FTPResult+newdir fp+ = (do liftIO $ createDirectory fp+ return success)+ <-> \ c -> liftIO $ snd <$> mkdir c fp+ +remdir :: String -> FTPLine FTPResult+remdir fp+ = (do liftIO $ removeDirectory fp+ return success)+ <-> \ c -> liftIO $ rmdir c fp+ +curdir :: FTPLine (Maybe String, FTPResult)+curdir+ = (do x <- liftIO getCurrentDirectory+ return (Just x, success))+ <-> (liftIO . pwd)+ +class (Read a) => Arg a where+ parse :: String -> FTPLine a+ parse = liftIO . readIO+ +output :: (Show a) => a -> FTPLine ()+output = outputStrLn . show+ +command :: String -> FTPLine ()+command str+ = if null xs then outputStrLn "No command introduced." else+ withColor Green $ runCom (head xs) (tail xs)+ where xs = separgs str+ +printHelp :: String -> FTPLine ()+printHelp str+ = withColor Cyan $+ mapM_+ (\ ln ->+ if head ln == '*' then outputStrLn ln else+ italized $ outputStrLn ln)+ $ commandDesc str+ +hand :: (MonadException m) => (IOException -> m a) -> m a -> m a+hand = handle+ +handres :: FTPLine FTPResult -> FTPLine ()+handres c+ = hand ((>> return failure) . withColor Red . output) c >>=+ outputFTPResult+ +hand_ :: FTPLine () -> FTPLine ()+hand_ = hand (withColor Red . output)+ +inEchoOff, inEchoOn :: FTPLine ()+inEchoOff = liftIO $ hSetEcho stdin False+inEchoOn = liftIO $ hSetEcho stdin True+ +runCom :: String -> [String] -> FTPLine ()+runCom str ["help"] = printHelp str+runCom "help" _+ = do withColor Cyan $ outputStrLn helpHead+ mapM_ printHelp commands+runCom "connect" args = handres $ mkCom args $ uncurry connect+runCom "login" args+ = do isInt <- isInteractive+ if isInt then+ do let isAnon+ = do withColor Yellow $ outputStr "Login as anonymous? (y/n) "+ c <- getInputChar ""+ case c of+ Just 'y' -> return True+ Just 'n' -> return False+ _ -> do liftIO $+ do cursorUpLine 1+ clearFromCursorToScreenEnd+ isAnon+ b <- isAnon+ if b then handres $ withColor Green $ ftplogin Nothing else+ do withColor Yellow $ outputStr "User name: "+ name <- Haskeline.getInputLine ""+ withColor Yellow $ outputStr "Password : "+ pass <- getPassword (Just '*') ""+ if isNothing name || isNothing pass then+ outputStrLn "Incorrect login." else+ handres $+ withColor Green $ ftplogin $ Just (fromJust name, fromJust pass)+ else+ if null args then handres $ ftplogin Nothing else+ handres $ mkCom args $ ftplogin . Just+runCom "disconnect" _ = handres disconnect+runCom "ftpdebug" _ = ftpdebug+runCom "dir" args+ = if null args then hand_ $ pdir Nothing else+ hand_ $ mkCom args $ pdir . Just+runCom "getfile" args = handres $ mkCom args $ getfile+runCom "download" args = handres $ mkCom args $ download+runCom "putfile" args = handres $ mkCom args $ putfile+runCom "upload" args = handres $ mkCom args $ upload+runCom "rename" args = handres $ mkCom args $ uncurry renamefile+runCom "delete" args = handres $ mkCom args $ deletefile+runCom "size" args = handres $ mkCom args $ sizefile+runCom "cd" args = handres $ mkCom args $ ccd+runCom "md" args = handres $ mkCom args $ newdir+runCom "rd" args = handres $ mkCom args $ remdir+runCom "clear" _+ = do hand_ cleanFile+ outputStrLn "Memory Cleared."+runCom "pause" _+ = do outputStr "PAUSE. Press ENTER to continue..."+ inEchoOff+ _ <- liftIO $ getLine+ inEchoOn+ outputStrLn ""+runCom "switch" _+ = do turnMode+ b <- getMode+ outputStrLn $ "Current mode: " ++ boolToMode b+runCom "last" _ = lastConn+runCom x _+ = withColor Cyan $ outputStrLn $ "Command doesn't exist: " ++ x+ +commands :: [String]+commands+ = ["connect", "disconnect", "login", "ftpdebug", "last", "dir",+ "cd", "md", "rd", "getfile", "putfile", "clear", "download",+ "upload", "rename", "delete", "size", "switch", "pause", "exit"]+ +helpHead :: String+helpHead+ = unlines+ ["", "Below is a list of available commands.",+ "Arguments in brackets are optional.",+ "Arguments in braces are only used in batch mode."]+ +commandDesc :: String -> [String]+commandDesc "connect"+ = ["connect HostName Port", "* Connect to remote FTP server."]+commandDesc "login"+ = ["login {[UserName Password]}", "* Login to the FTP server."]+commandDesc "disconnect"+ = ["disconnect", "* Close the current conection."]+commandDesc "ftpdebug"+ = ["ftpdebug", "* Enable logging of FTP messages."]+commandDesc "dir"+ = ["dir [FilePath]", "* Show a directory content."]+commandDesc "getfile"+ = ["getfile FilePath",+ "* Load specified file and save its content in a temporal memory."]+commandDesc "download"+ = ["download FilePath", "* Download a remote file to your system."]+commandDesc "putfile"+ = ["putfile FilePath",+ "* Write a file with the temporal memory's content."]+commandDesc "upload"+ = ["upload FilePath", "* Upload a file from disk."]+commandDesc "rename"+ = ["rename FilePath1 FilePath2", "* Rename a file."]+commandDesc "delete" = ["delete FilePath", "* Delete a file."]+commandDesc "size"+ = ["size FilePath", "* Return the size of a file."]+commandDesc "cd"+ = ["cd FilePath", "* Change the current directory."]+commandDesc "md" = ["md FilePath", "* Create a new directory."]+commandDesc "rd" = ["rd FilePath", "* Remove a directory"]+commandDesc "exit" = ["exit", "* Close the client."]+commandDesc "clear" = ["clear", "* Clear the temporal memory."]+commandDesc "pause"+ = ["pause", "* Stop the program until pressing ENTER.",+ "* Useful for FTP batch programs."]+commandDesc "switch"+ = ["switch", "* Switch between local and remote mode.",+ "* CTRL+D invokes this action."]+commandDesc "last"+ = ["last",+ "* Try to connect and login as it was done the last time."]+commandDesc _ = ["* Invalid command."]+ +mkCom :: (Arg a) => [String] -> (a -> FTPLine b) -> FTPLine b+mkCom [] _ = ftperror "Need more arguments."+mkCom args f+ = if length args > 1 then+ parse (concat ["(", intercalate "," args, ")"]) >>= f else+ parse (head args) >>= f+ +instance Arg [Char] where+ parse = return+ +instance Read PortNumber where+ readsPrec n str = (\(x,r) -> ((fromIntegral :: Int -> PortNumber) x , r)) <$> readsPrec n str+ +safeTail :: [a] -> [a]+safeTail [] = []+safeTail (_:xs) = xs++instance (Arg a, Arg b) => Arg (a, b) where+ parse str+ = let str' = init . tail $ str+ xs = takeWhile (/= ',') str'+ ys = safeTail $ dropWhile (/= ',') str'+ in+ do x <- parse xs+ y <- parse ys+ return (x, y)+ +instance Arg PortNumber where+ parse str = liftIO $ readIO str+ +addChar :: Char -> [String] -> [String]+addChar c [] = [[c]]+addChar c (x : xs) = (c : x) : xs+ +args' :: String -> [String] -> Bool -> [String]+args' [] xs _ = xs+args' (x : xs) ys b+ | x == ' ' =+ if b then args' xs (addChar x ys) b else args' xs ([] : ys) b+ | x == '"' = args' xs ys $ not b+ | otherwise = args' xs (addChar x ys) b+ +separgs :: String -> [String]+separgs str = reverse $ reverse <$> args' str [] False+ +withSGR :: (MonadIO m) => [SGR] -> [SGR] -> m a -> m a+withSGR xs ys comp+ = do liftIO $ setSGR xs+ x <- comp+ liftIO $ setSGR ys+ return x+ +withColor :: (MonadIO m) => Color -> m a -> m a+withColor col+ = withSGR [SetColor Foreground Vivid col]+ [SetColor Foreground Vivid White]+ +italized :: (MonadIO m) => m a -> m a+italized+ = withSGR [SetSwapForegroundBackground True]+ [SetSwapForegroundBackground False]+ +ftpLineDir :: IO FilePath+ftpLineDir = getAppUserDataDirectory "FTPLine"+ +main :: IO ()+main+ = do setSGR [SetColor Foreground Vivid White]+ args <- getArgs+ appDir <- ftpLineDir+ createDirectoryIfMissing True appDir+ putStrLn $ "*** Welcome to FTPLine " ++ showVersion version ++ " ***"+ if null args then+ withColor Cyan $+ do putStr "Type "+ italized $ putStr "help"+ putStrLn " for a list of commands."+ let sets+ = defaultSettings{historyFile = Just $ appDir ++ "/History"}+ evalStateT (runInputT sets mainInteractive) initialFTPState+ else+ do let arg = head args+ exst <- doesFileExist arg+ if exst then+ do txt <- readFile arg+ evalStateT+ (runInputT defaultSettings $+ mapM_+ (\ str ->+ do (mcd, hn) <- withColor Green $+ do mcd <- hand+ ((>> (return $ Just "?")) .+ withColor Red . output)+ $ fst <$> curdir+ hn <- getHost+ return (mcd, hn)+ let cd = if isNothing mcd then "? " else fromJust mcd+ getInputLine_ (unwords [cd, "@", hn ++ ">>\n"]) str+ hand_ $ command str)+ $ lines txt ++ ["disconnect"])+ initialFTPState+ putStrLn "Closing FTPLine."+ else withColor Red $ putStrLn $ "File " ++ arg ++ " doesn't exist."+ setSGR [Reset]+ +mainInteractive :: FTPLine ()+mainInteractive+ = do setInteractive True+ runCicle+ +runCicle :: FTPLine ()+runCicle+ = hand+ (\ e ->+ do withColor Red $ output e+ ln <- getInputLine "? >>"+ if ln == "exit" then exit else+ do hand_ $ command ln+ runCicle)+ mainCicle+ +mainCicle :: FTPLine ()+mainCicle+ = do (mcd, hn) <- withColor Green $+ do mcd <- hand+ (\ e ->+ do withColor Red $ output e+ return Nothing)+ $ fst <$> curdir+ hn <- getHost+ return (mcd, hn)+ let cd = if isNothing mcd then "? " else fromJust mcd+ ln <- getInputLine $ unwords [cd, "@", hn ++ ">>"]+ if ln == "exit" then exit else+ do hand_ $ command ln+ mainCicle+ +exit :: FTPLine ()+exit+ = do _ <- hand (\ _ -> return failure) $ withColor Green disconnect+ outputStrLn "Closing FTPLine."
license view
@@ -1,4 +1,4 @@-Copyright (c)2010, Daniel Díaz +Copyright (c)2011, Daniel Díaz All rights reserved.