leksah-server-0.12.0.3: src/IDE/Metainfo/Collector.hs
{-# OPTIONS_GHC -XScopedTypeVariables -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 System.Console.GetOpt
(ArgDescr(..), usageInfo, ArgOrder(..), getOpt, OptDescr(..))
import System.Environment (getArgs)
import Control.Monad (when)
import Data.Version (showVersion)
import Paths_leksah_server (getDataDir, version)
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)
import Prelude hiding(catch)
import Control.Monad (liftM)
import qualified Data.Set as Set (member)
import IDE.Core.CTypes hiding (Extension)
import IDE.Metainfo.SourceDB (buildSourceForPackageDB)
import Data.Time
import Control.Exception
(catch, SomeException)
import MyMissing(trim)
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(..), PortNumber(..))
import IDE.Utils.Server
import System.IO (Handle, hPutStrLn, hGetLine, hFlush, hClose)
import IDE.HeaderParser(parseTheHeader)
import System.Exit (ExitCode(..))
import Data.IORef
import Control.Concurrent (throwTo, ThreadId, myThreadId)
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(..))
-- --------------------------------------------------------------------
-- Command line options
--
data Flag = CollectSystem
| ServerCommand (Maybe String)
--modifiers
| Rebuild
| Sources
-- | Directory FilePath
--others
| VersionF
| Help
| Debug
| Verbosity String
| LogFile String
| 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 "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 "Verbosity")
"One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"
, Option ['l'] ["logfile"] (ReqArg LogFile "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 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 (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 []
threadId <- myThreadId
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 (PortNum (fromIntegral
(serverPort prefs))) newPrefs connRef threadId localServerAddr)
waitFor running
return ()
(Just ps:_) -> do
let port = read ps
running <- serveOne Nothing (server (PortNum
(fromIntegral port)) newPrefs connRef threadId localServerAddr)
waitFor running
return ()
_ -> return ()
server port prefs connRef threadId hostAddr = Server (SockAddrInet port hostAddr) Stream
(doCommands prefs connRef threadId)
doCommands :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO ()
doCommands prefs connRef threadId (h,n,p) = do
atomicModifyIORef connRef (\ list -> (h : list, ()))
doCommands' prefs connRef threadId (h,n,p)
doCommands' :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO ()
doCommands' prefs connRef threadId (h,n,p) = 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
when (endWithLastConn prefs) $ do
infoM "leksah-server" $ "***lost last connection - exiting"
throwTo threadId ExitSuccess
--exitSuccess
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 -> --the extract arg is not used
catch (do
collectSystem prefs False rebuild sources
hPutStrLn h (show ServerOK)
hFlush h)
(\ (e :: SomeException) -> do
hPutStrLn h (show (ServerFailed (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 (show e)))
hFlush h)
ParseHeaderCommand filePath ->
catch (do
res <- parseTheHeader filePath
hPutStrLn h (show res)
hFlush h)
(\ (e :: SomeException) -> do
hPutStrLn h (show (ServerFailed (show e)))
hFlush h)
doCommands' prefs connRef threadId (h,n,p)
collectSystem :: Prefs -> Bool -> Bool -> Bool -> IO()
collectSystem prefs writeAscii forceRebuild findSources = 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
debugM "leksah-server" $ "collectSystem knownPackages= " ++ show knownPackages
packageInfos <- inGhcIO [] [] $ \ _ -> getInstalledPackageInfos
debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map getThisPackage packageInfos)
let newPackages = filter (\pid -> not $Set.member (packageIdentifierToString $ getThisPackage pid)
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 ++ details
header' _time = "\nLeksah system metadata collection "
summary = "\nSuccess with = " ++ packs ++
"\nPackages total = " ++ show packagesTotal ++
"\nPackages with source = " ++ show packagesWithSource ++
"\nPackages retreived = " ++ 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 ++ " " ++ trim (fromJust (mbError stat))
packs = foldr (\stat string -> string ++ packageString stat ++ " ")
"" (take 10 (filter withSource stats))
++ if packagesWithSource > 10 then "..." else ""