{-# LANGUAGE FlexibleInstances #-} 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 (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 "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 } initialFTPState :: FTPState initialFTPState = FTPState Nothing Strict.Nothing Nothing 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) -> FTPState (Just c) mf (Just hn) b removeConnection :: FTPLine () removeConnection = modif $ \(FTPState _ mf _ b) -> FTPState Nothing mf Nothing b getFile :: FTPLine (SMaybe File) getFile = getting file newFile :: File -> FTPLine () newFile f = modif $! \(FTPState mc _ md b) -> FTPState mc (Strict.Just f) md b cleanFile :: FTPLine () cleanFile = modif $! \(FTPState mc _ md b) -> FTPState mc Strict.Nothing md b 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 } -- 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 ftperror "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"]) 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 -- $ B.pack 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 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 :: FTPLine FTPResult -> FTPLine () handres c = hand ((>> return failure) . withColor Red . output) c >>= outputFTPResult 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" _ = 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 "switch" _ = turnMode 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" , "switch" , "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 "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 = 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 main :: IO () main = do setSGR [ SetColor Foreground Vivid White ] -- args <- getArgs 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 runCicle) initialFTPState 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"] ) 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 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."