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