FTPLine-1.0.2: Main.hs
{-# LANGUAGE FlexibleInstances #-}
import Data.Maybe
import Control.Monad.State
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 (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 FTPState = StateT (Maybe FTPConnection,Maybe File,Maybe String) IO
type FTPLine a = InputT FTPState 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 = lift . modify
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,_,md) -> (mc,Just f,md)
cleanFile :: FTPLine ()
cleanFile = modif $ \(mc,_,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 ((>> (liftIO $ 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
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
main = do setSGR [ SetColor Foreground Vivid White ]
--
args <- getArgs
putStrLn "*** Welcome to FTPLine 1.0.2 ***"
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 <- 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
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."