FTPLine (empty) → 1.0.0
raw patch · 4 files changed
+450/−0 lines, 4 filesdep +MissingHdep +ansi-terminaldep +basesetup-changed
Dependencies added: MissingH, ansi-terminal, base, directory, ftphs, haskeline, mtl, network
Files
- FTPLine.cabal +23/−0
- Main.hs +424/−0
- Setup.hs +3/−0
- license +0/−0
+ FTPLine.cabal view
@@ -0,0 +1,23 @@+Name: FTPLine +Version: 1.0.0 +Cabal-Version: >= 1.6 +License: BSD3 +License-file: license +Author: Daniel Diaz +Maintainer: danieldiaz@asofilak.es +Homepage: http://ddiaz.asofilak.es/packages/FTPLine +Category: Network +Synopsis: A command-line FTP client. +Description: A command-line FTP client. Type @help@ for a list of commands. +Build-Type: Simple + +Executable FTPLine + Build-depends: base == 4.* + , mtl + , MissingH + , ftphs + , directory + , network + , haskeline + , ansi-terminal + Main-is: Main.hs
+ Main.hs view
@@ -0,0 +1,424 @@+ +{-# LANGUAGE FlexibleInstances #-} + +import Data.Maybe +import Control.Monad.State +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 (genericLength,intercalate) +import Prelude hiding (catch) +import System.IO.Binary (writeBinaryFile,readBinaryFile) +import System.Console.ANSI +import System.IO (hFlush,stdout) +import System.Environment (getArgs) + +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 "Displaying help..." + return "help" + else return $ fromJust ms + +getInputLine_ :: String -> String -> FTPLine () +getInputLine_ str com = do withColor Yellow $ outputStr str + outputStrLn com + +data File = File FilePath String + +type FTPLine a = InputT (StateT (Maybe FTPConnection,Maybe File,Maybe String) IO) a + +fst3 (x,_,_) = x + +snd3 (_,x,_) = x + +thr3 (_,_,x) = x + +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 f = lift $ modify f + +getConnection :: FTPLine (Maybe FTPConnection) +getConnection = getting fst3 + +newConnection :: String -> FTPConnection -> FTPLine () +newConnection hn c = modif $ \(mc,mf,md) -> (Just c,mf,Just hn) + +removeConnection :: FTPLine () +removeConnection = modif $ \(mc,mf,md) -> (Nothing,mf,Nothing) + +getFile :: FTPLine (Maybe File) +getFile = getting snd3 + +newFile :: File -> FTPLine () +newFile f = modif $ \(mc,mf,md) -> (mc,Just f,md) + +cleanFile :: FTPLine () +cleanFile = modif $ \(mc,mf,md) -> (mc,Nothing,md) + +getHost :: FTPLine String +getHost = getting (maybe "Local" id . thr3) + +-- + +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 + return r + +withConnection :: (FTPConnection -> FTPLine a) -> FTPLine a +withConnection f = do mc <- getConnection + if isNothing mc then fail "Connection not established." + else f $ fromJust mc + +ftplogin :: Maybe (String,String) -> FTPLine FTPResult +ftplogin Nothing = withConnection $ liftIO . loginAnon +ftplogin (Just (name,pass)) = withConnection $ + \c -> liftIO $ login c name (Just pass) Nothing + +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"]) + +(<->) :: FTPLine a -> (FTPConnection -> FTPLine a) -> FTPLine a +la <-> ra = do mc <- getConnection + if isNothing mc then la + else 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 $ readBinaryFile fp + newFile $ File fp x + return success + ) <-> + \c -> do (x,r) <- liftIO $ getbinary c fp + newFile $ File fp 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 isNothing x then fail "File memory empty." + else let (File _ cnt) = fromJust x + in do liftIO $ writeBinaryFile fp cnt + return success + ) <-> + \c -> do x <- getFile + if isNothing x then fail "File memory empty." + else let (File _ cnt) = fromJust x + in liftIO $ putbinary c fp 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 :: (Read a,Num a) => String -> FTPLine a +sizefile fp = ( liftIO $ genericLength <$> readBinaryFile fp + ) <-> + \c -> liftIO $ size c fp + +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 + +hand :: MonadException m => (IOException -> m a) -> m a -> m a +hand = handle + +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 + +handres :: Show a => FTPLine a -> FTPLine () +handres c = hand ((>> fail "No command result.") . withColor Red . output) c >>= output + +hand_ :: FTPLine () -> FTPLine () +hand_ = hand (withColor Red . output) + +printHelp :: String -> FTPLine () +printHelp str = withColor Cyan $ mapM_ (\ln -> if head ln == '*' then outputStrLn ln + else italized $ outputStrLn ln ) $ commandDesc str +runCom :: String -> [String] -> FTPLine () +runCom str ["help"] = printHelp str +runCom "help" _ = mapM_ printHelp commands +runCom "connect" args = handres $ mkCom args $ uncurry connect +runCom "login" args = if null args then handres $ ftplogin Nothing + else handres $ mkCom args $ ftplogin . Just +runCom "disconnect" _ = handres disconnect +runCom "ftpdebug" _ = hand_ 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..." + withColor White $ liftIO getLine + return () +runCom x _ = withColor Cyan $ outputStrLn $ "Command doesn't exist: " ++ x + +commands :: [String] +commands = [ "connect" , "disconnect" + , "login" , "ftpdebug" + , "dir" , "cd" , "md" , "rd" + , "getfile" , "putfile" , "clear" + , "download" , "upload" + , "rename" , "delete" + , "size" + , "pause" + , "exit" + ] + +commandDesc :: String -> [String] +commandDesc "connect" = [ "connect HostName Port" + , "* Connect to remote FTP server." ] +commandDesc "login" = [ "login [UserName Password]" + , "* Log in 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 _ = ["Invalid command."] + +mkCom :: Arg a => [String] -> (a -> FTPLine b) -> FTPLine b +mkCom [] f = fail "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 + +addNChar :: Char -> [String] -> [String] +addNChar c [] = [[c]] +addNChar c (x:xs) = [c] : 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 ] + +underline :: MonadIO m => m a -> m a +underline = withSGR [ SetUnderlining SingleUnderline ] [ SetUnderlining NoUnderline ] + +-- Main + +main = do setSGR [ SetColor Foreground Vivid White ] + -- + args <- getArgs + underline $ putStrLn "Welcome to FTPLine 1.0.0." + if null args then do withColor Cyan $ do putStr "Type " + italized $ putStr "help" + putStrLn " for a list of commands." + -- + runStateT (runInputT defaultSettings mainCicle) + (Nothing,Nothing,Nothing) + setSGR [ Reset ] + 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"] ) + (Nothing,Nothing,Nothing) + putStrLn "Closing FTPLine." + else withColor Red $ putStrLn $ "File " ++ arg ++ " doesn't exist." + setSGR [ Reset ] + +mainCicle = do (mcd,hn) <- withColor Green $ do mcd <- 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 + hand (\e -> do withColor Red $ output e + ln <- getInputLine "? >>" + if ln == "exit" then exit + else do hand_ $ command ln + mainCicle) mainCicle + +exit = do hand (\_ -> return failure) $ withColor Green disconnect + outputStrLn "Closing FTPLine." + + + + + + + + + + + + + + + + +
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple + +main = defaultMain
+ license view