{-# 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."