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