FTPLine 1.0.2 → 1.1.0
raw patch · 2 files changed
+136/−98 lines, 2 filesdep +bytestringdep +strictdep −MissingHdep −deepseq
Dependencies added: bytestring, strict
Dependencies removed: MissingH, deepseq
Files
- FTPLine.cabal +11/−8
- Main.hs +125/−90
FTPLine.cabal view
@@ -1,5 +1,5 @@ Name: FTPLine -Version: 1.0.2 +Version: 1.1.0 Cabal-Version: >= 1.6 License: BSD3 License-file: license @@ -12,26 +12,29 @@ . Changes from last version: . - * Now, FTPLine shows a correct version number. + * State becomes a record (was a tuple). . - * Changed @handres@ error handling. + * File content changes from @String@ to @ByteString@. . - * Added error handling to @curdir@ operation. + * Added modes (local and remote). . - * Removed @underline@ function (It didn't has any effect). + * Changed lazy state to strict state, + and it has been instantiated at haskeline's @MonadException@ class. . - * A little change on the welcome message. + * The way FTP results are shown has varied. + . + * Memory usage has been reduced considerably. Build-Type: Simple Executable FTPLine Build-depends: base == 4.* , mtl - , MissingH , ftphs , directory , network , haskeline >=0.6.2.4 && < 0.7 , ansi-terminal - , deepseq + , strict + , bytestring Extensions: FlexibleInstances Main-is: Main.hs
Main.hs view
@@ -2,7 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} import Data.Maybe -import Control.Monad.State +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) @@ -11,36 +12,53 @@ import Network.FTP.Client.Parser import System.Directory import Control.Applicative ((<$>)) -import Data.List (genericLength,intercalate) +import Data.List (intercalate) import Prelude hiding (catch) -import System.IO.Binary (writeBinaryFile,readBinaryFile) import System.Console.ANSI import System.IO (hFlush,stdout) 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 "Displaying help..." - return "help" + 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 String - -type FTPState = StateT (Maybe FTPConnection,Maybe File,Maybe String) IO +data File = File FilePath !B.ByteString -type FTPLine a = InputT FTPState a +type SMaybe = Strict.Maybe -fst3 (x,_,_) = x +data FTPState = FTPState { conn :: Maybe FTPConnection + , file :: !(SMaybe File) + , host :: Maybe String + , mode :: Bool } -snd3 (_,x,_) = x +initialFTPState :: FTPState +initialFTPState = FTPState Nothing Strict.Nothing Nothing False -thr3 (_,_,x) = x +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 @@ -49,26 +67,32 @@ modif = lift . modify getConnection :: FTPLine (Maybe FTPConnection) -getConnection = getting fst3 +getConnection = getting conn newConnection :: String -> FTPConnection -> FTPLine () -newConnection hn c = modif $ \(mc,mf,md) -> (Just c,mf,Just hn) +newConnection hn c = modif $ \(FTPState _ mf _ b) -> FTPState (Just c) mf (Just hn) b removeConnection :: FTPLine () -removeConnection = modif $ \(mc,mf,md) -> (Nothing,mf,Nothing) +removeConnection = modif $ \(FTPState _ mf _ b) -> FTPState Nothing mf Nothing b -getFile :: FTPLine (Maybe File) -getFile = getting snd3 +getFile :: FTPLine (SMaybe File) +getFile = getting file newFile :: File -> FTPLine () -newFile f = modif $ \(mc,_,md) -> (mc,Just f,md) +newFile f = modif $! \(FTPState mc _ md b) -> FTPState mc (Strict.Just f) md b cleanFile :: FTPLine () -cleanFile = modif $ \(mc,_,md) -> (mc,Nothing,md) +cleanFile = modif $! \(FTPState mc _ md b) -> FTPState mc Strict.Nothing md b getHost :: FTPLine String -getHost = getting (maybe "Local" id . thr3) +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 } + -- connect :: HostName -> PortNumber -> FTPLine FTPResult @@ -81,7 +105,7 @@ withConnection :: (FTPConnection -> FTPLine a) -> FTPLine a withConnection f = do mc <- getConnection - if isNothing mc then fail "Connection not established." + if isNothing mc then ftperror "Connection not established." else f $ fromJust mc ftplogin :: Maybe (String,String) -> FTPLine FTPResult @@ -107,10 +131,23 @@ 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 mc <- getConnection - if isNothing mc then la - else ra $ fromJust mc +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 @@ -122,30 +159,31 @@ \c -> liftIO (dir c fp) >>= mapM_ outputStrLn getfile :: String -> FTPLine FTPResult -getfile fp = (do x <- liftIO $ readBinaryFile fp - newFile $ File fp x +getfile fp = (do x <- liftIO $ B.readFile fp + newFile $ File fp x -- $ B.pack x return success ) <-> \c -> do (x,r) <- liftIO $ getbinary c fp - newFile $ File fp x + 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 isNothing x then fail "File memory empty." - else let (File _ cnt) = fromJust x - in do liftIO $ writeBinaryFile fp cnt + 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 isNothing x then fail "File memory empty." - else let (File _ cnt) = fromJust x - in liftIO $ putbinary c fp cnt + 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 $ @@ -164,10 +202,12 @@ ) <-> \c -> liftIO $ delete c fp -sizefile :: (Read a,Num a) => String -> FTPLine a -sizefile fp = ( liftIO $ genericLength <$> readBinaryFile fp - ) <-> - \c -> liftIO $ size 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 @@ -211,8 +251,8 @@ where xs = args str -handres :: Show a => FTPLine a -> FTPLine () -handres c = hand ((>> (liftIO $ fail "No command result.")) . withColor Red . output) c >>= output +handres :: FTPLine FTPResult -> FTPLine () +handres c = hand ((>> return failure) . withColor Red . output) c >>= outputFTPResult hand_ :: FTPLine () -> FTPLine () hand_ = hand (withColor Red . output) @@ -222,31 +262,32 @@ 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 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" _ = 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 +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 "switch" _ = turnMode +runCom x _ = withColor Cyan $ outputStrLn $ "Command doesn't exist: " ++ x commands :: [String] commands = [ "connect" , "disconnect" @@ -256,7 +297,8 @@ , "download" , "upload" , "rename" , "delete" , "size" - , "pause" + , "switch" + , "pause" , "exit" ] @@ -298,10 +340,13 @@ 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 _ = ["Invalid command."] mkCom :: Arg a => [String] -> (a -> FTPLine b) -> FTPLine b -mkCom [] f = fail "Need more arguments." +mkCom [] f = ftperror "Need more arguments." mkCom args f = if length args > 1 then parse (concat [ "(" , intercalate "," args , ")" ]) >>= f else parse (head args) >>= f @@ -361,16 +406,16 @@ -- Main +main :: IO () main = do setSGR [ SetColor Foreground Vivid White ] -- args <- getArgs - putStrLn "*** Welcome to FTPLine 1.0.2 ***" + putStrLn "*** Welcome to FTPLine 1.1.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) + runStateT (runInputT defaultSettings runCicle) initialFTPState setSGR [ Reset ] else do let arg = head args exst <- doesFileExist arg @@ -382,11 +427,19 @@ let cd = if isNothing mcd then "? " else fromJust mcd getInputLine_ (unwords [cd , "@" , hn ++ ">>\n"]) str hand_ $ command str) $ lines txt ++ ["disconnect"] ) - (Nothing,Nothing,Nothing) + initialFTPState putStrLn "Closing FTPLine." else withColor Red $ putStrLn $ "File " ++ arg ++ " doesn't exist." setSGR [ Reset ] +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 @@ -395,27 +448,9 @@ 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 + mainCicle +exit :: FTPLine () exit = do hand (\_ -> return failure) $ withColor Green disconnect outputStrLn "Closing FTPLine." - - - - - - - - - - - - - - -