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