{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-----------------------------------------------------------------------------
--
-- Module      :  Main
-- Copyright   :  2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GPL
--
-- Maintainer  :  maintainer@leksah.org
-- Stability   :  provisional
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module Main (
    main
,   collectPackage
) where

import Control.Applicative
import Prelude
import System.Console.GetOpt
    (ArgDescr(..), usageInfo, ArgOrder(..), getOpt, OptDescr(..))
import System.Environment (getArgs)
import Control.Monad (when, forM)
import Data.Version (showVersion)
import IDE.Utils.FileUtils
import IDE.Utils.Utils
import IDE.Utils.GHCUtils
import IDE.StrippedPrefs
import IDE.Metainfo.WorkspaceCollector
import Data.Maybe(catMaybes, fromJust, mapMaybe, isJust)
#if MIN_VERSION_ghc(7,8,0)
#else
import Prelude hiding(catch)
#endif
import Control.Monad (liftM)
import qualified Data.Set as Set (member)
import qualified Data.Map as Map (toList, fromListWith)
import IDE.Core.CTypes hiding (Extension)
import IDE.Metainfo.SourceDB (buildSourceForPackageDB, getDataDir, version)
import Data.Time
import Control.Exception
       (catch, SomeException)
import System.Log
import System.Log.Logger(updateGlobalLogger,rootLoggerName,addHandler,debugM,infoM,errorM,
    setLevel)
import System.Log.Handler.Simple(fileHandler)
import Network(withSocketsDo)
import Network.Socket
       (inet_addr, SocketType(..), SockAddr(..))
import IDE.Utils.Server
import System.IO (Handle, hPutStrLn, hGetLine, hFlush, hClose)
import IDE.HeaderParser(parseTheHeader)
import Data.IORef
import Control.Concurrent (MVar,putMVar)
import IDE.Metainfo.PackageCollector(collectPackage)
import Data.List (delete)
import System.Directory
       (removeFile, doesFileExist, removeDirectoryRecursive,
        doesDirectoryExist)
import IDE.Metainfo.SourceCollectorH (PackageCollectStats(..))
import Control.Monad.IO.Class (MonadIO(..))
import qualified Data.Text as T (strip, pack, unpack)
import Data.Text (Text)
import Data.Monoid ((<>))
import Distribution.Package (PackageIdentifier)

-- --------------------------------------------------------------------
-- Command line options
--


data Flag =    CollectSystem

             | ServerCommand (Maybe Text)
             --modifiers
             | Rebuild
             | Sources
             -- | Directory FilePath
             --others
             | VersionF
             | Help
             | Debug
             | Verbosity Text
             | LogFile Text
             | Forever
             | EndWithLast
       deriving (Show,Eq)

options :: [OptDescr Flag]

options =   [
-- main functions
             Option ['s'] ["system"] (NoArg CollectSystem)
                "Collects new information for installed packages"
         ,   Option ['r'] ["server"] (OptArg (ServerCommand . (T.pack <$>)) "Maybe Port")
                "Start as server."
         ,   Option ['b'] ["rebuild"] (NoArg Rebuild)
                "Modifier for -s and -p: Rebuild metadata"
         ,   Option ['o'] ["sources"] (NoArg Sources)
                "Modifier for -s: Gather info about pathes to sources"
         ,   Option ['v'] ["version"] (NoArg VersionF)
                "Show the version number of ide"
         ,   Option ['h'] ["help"] (NoArg Help)
                "Display command line options"
         ,   Option ['d'] ["debug"] (NoArg Debug)
                "Write ascii pack files"
         ,   Option ['e'] ["verbosity"] (ReqArg (Verbosity . T.pack) "Verbosity")
                "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"
         ,   Option ['l'] ["logfile"] (ReqArg (LogFile . T.pack) "LogFile")
                "File path for logging messages"
         ,   Option ['f'] ["forever"] (NoArg Forever)
                "Don't end the server when last connection ends"
         ,   Option ['c'] ["endWithLast"] (NoArg EndWithLast)
                "End the server when last connection ends"

    ]

header :: String
header = "Usage: leksah-server [OPTION...] files..."

ideOpts :: [String] -> IO ([Flag], [String])
ideOpts argv =
    case getOpt Permute options argv of
          (o,n,[]  ) -> return (o,n)
          (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options

-- ---------------------------------------------------------------------
-- | Main function
--

main :: IO ()
main =  withSocketsDo $ catch inner handler
    where
        handler (e :: SomeException) = do
            putStrLn $ "leksah-server: " ++ (show e)
            errorM "leksah-server" (show e)
            return ()
        inner = do
            args            <- getArgs
            (o,_)           <- ideOpts args
            let verbosity'   =  catMaybes $
                                    map (\x -> case x of
                                        Verbosity s -> Just s
                                        _           -> Nothing) o
            let verbosity    =  case verbosity' of
                                    [] -> INFO
                                    h:_ -> read $ T.unpack h
            let logFile'     =  catMaybes $
                                    map (\x -> case x of
                                        LogFile s   -> Just s
                                        _           -> Nothing) o
            let logFile     =  case logFile' of
                                    [] -> Nothing
                                    h:_ -> Just h
            updateGlobalLogger rootLoggerName (\ l -> setLevel verbosity l)
            when (isJust logFile) $  do
                handler' <- fileHandler (T.unpack $ fromJust logFile) verbosity
                updateGlobalLogger rootLoggerName (\ l -> addHandler handler' l)
            infoM "leksah-server" $ "***server start"
            debugM "leksah-server" $ "args: " ++ show args
            dataDir         <- getDataDir
            prefsPath       <- getConfigFilePathForLoad strippedPreferencesFilename Nothing dataDir
            prefs           <- readStrippedPrefs prefsPath
            debugM "leksah-server" $ "prefs " ++ show prefs
            connRef  <- newIORef []
            localServerAddr <- inet_addr "127.0.0.1"

            if elem VersionF o
                then putStrLn $ "Leksah Haskell IDE (server), version " ++ showVersion version
                else if elem Help o
                    then putStrLn $ "Leksah Haskell IDE (server) " ++ usageInfo header options
                    else do
                        let servers     =   catMaybes $
                                                map (\x -> case x of
                                                                ServerCommand s -> Just s
                                                                _        -> Nothing) o
                        let sources     =   elem Sources o
                        let rebuild     =   elem Rebuild o
                        let debug       =   elem Debug o
                        let forever     =   elem Forever o
                        let endWithLast =   elem EndWithLast o
                        let newPrefs    =   if forever && not endWithLast
                                                then prefs{endWithLastConn = False}
                                                else if  not forever && endWithLast
                                                        then prefs{endWithLastConn = True}
                                                        else prefs
                        if elem CollectSystem o
                            then do
                                debugM "leksah-server" "collectSystem"
                                collectSystem prefs debug rebuild sources []
                            else
                                case servers of
                                    (Nothing:_)  -> do
                                        running <- serveOne Nothing (server (fromIntegral
                                            (serverPort prefs)) newPrefs connRef localServerAddr)
                                        waitFor running
                                        return ()
                                    (Just ps:_)  -> do
                                        let port = read $ T.unpack ps
                                        running <- serveOne Nothing (server
                                            (fromIntegral port) newPrefs connRef localServerAddr)
                                        waitFor running
                                        return ()
                                    _ -> return ()

        server port prefs connRef hostAddr = Server (SockAddrInet port hostAddr) Stream
                                        (doCommands prefs connRef)

doCommands :: Prefs -> IORef [Handle] -> (Handle, t1, t2) -> MVar ()-> IO ()
doCommands prefs connRef (h,n,p) mvar = do
    atomicModifyIORef connRef (\ list -> (h : list, ()))
    doCommands' prefs connRef (h,n,p) mvar


doCommands' :: Prefs -> IORef [Handle] -> (Handle, t1, t2) -> MVar () -> IO ()
doCommands' prefs connRef (h,n,p) mvar = do
    debugM "leksah-server" $ "***wait"
    mbLine <- catch (liftM Just (hGetLine h))
                (\ (_e :: SomeException) -> do
                    infoM "leksah-server" $ "***lost connection"
                    hClose h
                    atomicModifyIORef connRef (\ list -> (delete h list,()))
                    handles <- readIORef connRef
                    case handles of
                        [] -> do
                                if (endWithLastConn prefs)
                                    then do
                                       infoM "leksah-server" $ "***lost last connection - exiting"
                                       -- we're waiting on that mvar before exiting
                                       putMVar mvar ()
                                    else do
                                        infoM "leksah-server" $ "***lost last connection - waiting"
                                return Nothing
                        _  -> return Nothing)
    case mbLine of
        Nothing -> return ()
        Just line -> do
            case read line of
                    SystemCommand rebuild sources _extract dbs -> --the extract arg is not used
                        catch (do
                            collectSystem prefs False rebuild sources dbs
                            hPutStrLn h (show ServerOK)
                            hFlush h)
                        (\ (e :: SomeException) -> do
                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))
                            hFlush h)
                    WorkspaceCommand rebuild package path modList ->
                        catch (do
                            collectWorkspace package modList rebuild False path
                            hPutStrLn h (show ServerOK)
                            hFlush h)
                        (\ (e :: SomeException) -> do
                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))
                            hFlush h)
                    ParseHeaderCommand filePath ->
                        catch (do
                            res <- parseTheHeader filePath
                            hPutStrLn h (show res)
                            hFlush h)
                        (\ (e :: SomeException) -> do
                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))
                            hFlush h)
            doCommands' prefs connRef (h,n,p) mvar

collectSystem :: Prefs -> Bool -> Bool -> Bool -> [[FilePath]] -> IO()
collectSystem prefs writeAscii forceRebuild findSources dbLists = do
    collectorPath       <- getCollectorPath
    when forceRebuild $ do
        exists           <- doesDirectoryExist collectorPath
        when exists $ removeDirectoryRecursive collectorPath
        reportPath       <-  getConfigFilePathForSave "collectSystem.report"
        exists'          <- doesFileExist reportPath
        when exists' (removeFile reportPath)
        return ()
    knownPackages       <-  findKnownPackages collectorPath
    libDir <- getSysLibDir
    debugM "leksah-server" $ "collectSystem knownPackages= " ++ show knownPackages
    packageInfos        <-  concat <$> forM dbLists (\dbs -> inGhcIO libDir [] [] dbs $  \ _ -> map (,dbs) <$> getInstalledPackageInfos)
    debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map (packId . getThisPackage . fst) packageInfos)
    let newPackages = filter (\pi -> not $ Set.member (packageIdentifierToString . packId . getThisPackage $ fst pi) knownPackages)
                            packageInfos
    if null newPackages
        then do
            infoM "leksah-server" "Metadata collector has nothing to do"
        else do
            when findSources $ liftIO $ buildSourceForPackageDB prefs
            infoM "leksah-server" "update_toolbar 0.0"
            stats <- mapM (collectPackage writeAscii prefs (length newPackages))
                            (zip newPackages [1 .. length newPackages])
            writeStats stats
    infoM "leksah-server" "Metadata collection has finished"

writeStats :: [PackageCollectStats] -> IO ()
writeStats stats = do
    reportPath       <-  getConfigFilePathForSave "collectSystem.report"
    time             <-  getCurrentTime
    appendFile reportPath (report time)
    where
        report time = "\n++++++++++++++++++++++++++++++\n" ++ show time ++ "\n++++++++++++++++++++++++++++++\n"
                        ++ header' time ++ summary ++ T.unpack details
        header' _time = "\nLeksah system metadata collection "
        summary = "\nSuccess with         = " ++ T.unpack packs ++
                  "\nPackages total       = " ++ show packagesTotal ++
                  "\nPackages with source = " ++ show packagesWithSource ++
                  "\nPackages retrieved   = " ++ show packagesRetreived ++
                  "\nModules total        = " ++ show modulesTotal' ++
                  "\nModules with source  = " ++ show modulesWithSource ++
                  "\nPercentage source    = " ++ show percentageWithSource
        packagesTotal        = length stats
        packagesWithSource   = length (filter withSource stats)
        packagesRetreived    = length (filter retrieved stats)
        modulesTotal'        = sum (mapMaybe modulesTotal stats)
        modulesWithSource    = sum (mapMaybe modulesTotal (filter withSource stats))
        percentageWithSource = (fromIntegral modulesWithSource) * 100.0 /
                                    (fromIntegral modulesTotal')
        details              = foldr detail "" (filter (isJust . mbError) stats)
        detail stat string   = string <> "\n" <> packageString stat <> " " <> (T.strip . fromJust $ mbError stat)
        packs                = foldr (\stat string -> string <> packageString stat <> " ")
                                        "" (take 10 (filter withSource stats))
                                        <> if packagesWithSource > 10 then "..." else ""


