FTPLine-1.3.0: Main.hs
{-# 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."