diff --git a/leksah-server.cabal b/leksah-server.cabal --- a/leksah-server.cabal +++ b/leksah-server.cabal @@ -1,5 +1,5 @@ name: leksah-server -version: 0.14.0.1 +version: 0.14.3.0 cabal-version: >= 1.10.2 build-type: Simple license: GPL @@ -18,18 +18,15 @@ tested-with: GHC ==7.4 || ==7.6 || ==7.8 data-files: data/prefscoll.lkshp -flag curl - Default: False - Description: Use runs curl instead of wget (curl is the default on OSX) -flag libcurl - Default: False - Description: Use libcurl instead of running wget - flag threaded default: True description: Build with support for multithreaded execution +flag network-uri + description: Get Network.URI from the network-uri package + default: True + library default-language: Haskell98 build-depends: Cabal >=1.10.2.0 && <1.22, base >= 4.0.0.0 && <4.8, binary >=0.5.0.0 && <0.8, @@ -38,10 +35,11 @@ directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.4, ghc >=7.0.4 && <7.9, ltk >=0.14.0.0 && <0.15, parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4, - hslogger >= 1.0.7 && <1.3, network >=2.2 && <3.0, conduit >= 1.0.8 && <1.3, + hslogger >= 1.0.7 && <1.3, conduit >= 1.0.8 && <1.3, conduit-extra >=1.0.0.1 && <1.2, resourcet, attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.13, - transformers >=0.2.2.0 && <0.5, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.3 + transformers >=0.2.2.0 && <0.5, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.3, + HTTP >=4000.1.2 && <4000.3 if (impl(ghc >= 7.8)) build-depends: haddock >= 2.7.2 && <2.15 else @@ -70,12 +68,10 @@ else build-depends: unix >=2.3.1.0 && <2.8 - if flag(curl) || os(osx) - cpp-options: -DUSE_CURL - - if flag(libcurl) - build-depends: curl >=1.3.5 && <1.4 - cpp-options: -DUSE_LIBCURL + if flag(network-uri) + build-depends: network-uri >=2.6 && <2.7, network >= 2.6 && <2.7 + else + build-depends: network >=2.2 && <2.6 exposed-modules: IDE.Utils.GHCUtils IDE.Utils.Utils IDE.Utils.Tool IDE.Utils.FileUtils IDE.Core.CTypes IDE.Core.Serializable IDE.StrippedPrefs @@ -102,10 +98,11 @@ directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.6, ghc >=7.0.4 && <7.9, ltk >=0.14.0.0 && <0.15, parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4, - hslogger >= 1.0.7 && <1.3, network >=2.2 && <3.0, conduit >= 1.0.8 && <1.3, + hslogger >= 1.0.7 && <1.3, conduit >= 1.0.8 && <1.3, conduit-extra >=1.0.0.1 && <1.2, resourcet, attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.13, - transformers >=0.2.2.0 && <0.5, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.3 + transformers >=0.2.2.0 && <0.5, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.3, + HTTP >=4000.1.2 && <4000.3 if (impl(ghc >= 7.8)) build-depends: haddock >= 2.7.2 && <2.15 else @@ -134,16 +131,14 @@ else build-depends: unix >=2.3.1.0 && <2.8 + if flag(network-uri) + build-depends: network-uri >=2.6 && <2.7, network >= 2.6 && <2.7 + else + build-depends: network >=2.2 && <2.6 + if os(osx) ghc-options: -optl-headerpad_max_install_names - if flag(curl) || os(osx) - cpp-options: -DUSE_CURL - - if flag(libcurl) - build-depends: curl >=1.3.5 && <1.4 - cpp-options: -DUSE_LIBCURL - main-is: IDE/Metainfo/Collector.hs buildable: True default-extensions: CPP @@ -199,7 +194,7 @@ hs-source-dirs: tests main-is: TestTool.hs build-depends: base >= 4.0.0.0 && <4.8, hslogger >= 1.0.7 && <1.3, - leksah-server == 0.14.0.1, + leksah-server == 0.14.3.0, HUnit >=1.2 && <1.3, transformers >=0.2.2.0 && <0.5, conduit >= 1.0.8 && <1.3, conduit-extra >=1.0.0.1 && <1.2, resourcet diff --git a/src/IDE/Core/Serializable.hs b/src/IDE/Core/Serializable.hs --- a/src/IDE/Core/Serializable.hs +++ b/src/IDE/Core/Serializable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -XScopedTypeVariables diff --git a/src/IDE/HeaderParser.hs b/src/IDE/HeaderParser.hs --- a/src/IDE/HeaderParser.hs +++ b/src/IDE/HeaderParser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- -- Module : IDE.HeaderParser diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-} ----------------------------------------------------------------------------- -- diff --git a/src/IDE/Metainfo/PackageCollector.hs b/src/IDE/Metainfo/PackageCollector.hs --- a/src/IDE/Metainfo/PackageCollector.hs +++ b/src/IDE/Metainfo/PackageCollector.hs @@ -24,7 +24,7 @@ import PackageConfig (PackageConfig) import IDE.Metainfo.SourceCollectorH (findSourceForPackage, packageFromSource, PackageCollectStats(..)) -import System.Log.Logger (debugM, infoM) +import System.Log.Logger (errorM, debugM, infoM) import IDE.Metainfo.InterfaceCollector (collectPackageFromHI) import IDE.Core.CTypes (getThisPackage, SimpleDescr(..), TypeDescr(..), @@ -33,7 +33,7 @@ PackageDescr(..), metadataVersion, leksahVersion, packageIdentifierToString) import IDE.Utils.FileUtils (getCollectorPath) -import System.Directory (doesFileExist, setCurrentDirectory) +import System.Directory (setCurrentDirectory) import IDE.Utils.Utils (leksahMetadataPathFileExtension, leksahMetadataSystemFileExtension) @@ -43,25 +43,25 @@ (fromListWith, fromList, keys, lookup) import Data.List (delete, nub) import Distribution.Text (display) -import Control.Exception (SomeException) -#if defined(USE_LIBCURL) -import Network.Curl (curlGetString_, CurlCode(..)) -import Control.Monad (when) -import System.IO (withBinaryFile, IOMode(..)) -import Data.ByteString (hPutStr) -#else -#ifdef MIN_VERSION_process_leksah -import IDE.System.Process (system) -#else -import System.Process (system) -#endif -#endif import Control.Monad.IO.Class (MonadIO, MonadIO(..)) import qualified Control.Exception as E (SomeException, catch) import IDE.Utils.Tool (runTool') import Data.Monoid ((<>)) import qualified Data.Text as T (unpack) import Data.Text (Text) +import Control.Applicative ((<$>)) +import Network.HTTP.Proxy (Proxy(..), fetchProxy) +import Network.Browser + (request, setAuthorityGen, setOutHandler, setErrHandler, setProxy, + browse) +import Data.Char (isSpace) +import Network.URI (parseURI) +import Network.HTTP (rspBody, rspCode, Header(..), Request(..)) +import Network.HTTP.Base (RequestMethod(..)) +import Network.HTTP.Headers (HeaderName(..)) +import qualified Data.ByteString as BS (writeFile, empty) +import qualified Paths_leksah_server (version) +import Distribution.System (buildArch, buildOS) collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats collectPackage writeAscii prefs numPackages (packageConfig, packageIndex) = do @@ -133,23 +133,37 @@ setCurrentDirectory collectorPath let fullUrl = T.unpack (retrieveURL prefs) <> "/metadata-" <> leksahVersion <> "/" <> T.unpack packString <> leksahMetadataSystemFileExtension filePath = collectorPath T.unpack packString <.> leksahMetadataSystemFileExtension - debugM "leksah-server" $ "collectPackage: before retreiving = " <> fullUrl -#if defined(USE_LIBCURL) - E.catch (do - (code, string) <- curlGetString_ fullUrl [] - when (code == CurlOK) $ - withBinaryFile filePath WriteMode $ \ file -> do - hPutStr file string) -#elif defined(USE_CURL) - E.catch ((system $ "curl -OL --fail " ++ fullUrl) >> return ()) -#else - E.catch ((system $ "wget " ++ fullUrl) >> return ()) -#endif - (\(e :: SomeException) -> - debugM "leksah-server" $ "collectPackage: Error when calling wget " ++ show e) - debugM "leksah-server" . T.unpack $ "collectPackage: after retreiving = " <> packString -- ++ " result = " ++ res - exist <- doesFileExist filePath - return exist + + case parseURI fullUrl of + Nothing -> do + errorM "leksah-server" $ "collectPackage: invalid URI = " <> fullUrl + return False + Just uri -> do + debugM "leksah-server" $ "collectPackage: before retreiving = " <> fullUrl + proxy <- filterEmptyProxy . trimProxyUri <$> fetchProxy True + (_, rsp) <- browse $ do + setProxy proxy + setErrHandler (errorM "leksah-server") + setOutHandler (debugM "leksah-server") + setAuthorityGen (\_ _ -> return Nothing) + request Request{ rqURI = uri + , rqMethod = GET + , rqHeaders = [Header HdrUserAgent userAgent] + , rqBody = BS.empty } + if rspCode rsp == (2,0,0) + then do + BS.writeFile filePath $ rspBody rsp + return True + else return False + + trimProxyUri (Proxy uri auth) = Proxy (trim uri) auth + trimProxyUri p = p + filterEmptyProxy (Proxy "" _) = NoProxy + filterEmptyProxy p = p + trim = f . f where f = reverse . dropWhile isSpace + userAgent = concat [ "leksah-server/", display Paths_leksah_server.version + , " (", display buildOS, "; ", display buildArch, ")" + ] writeMerged packageDescrS packageDescrHi fpSource packageName = do let mergedPackageDescr = mergePackageDescrs packageDescrHi packageDescrS liftIO $ writeExtractedPackage writeAscii mergedPackageDescr @@ -157,10 +171,12 @@ runCabalConfigure fpSource = do let dirPath = dropFileName fpSource setCurrentDirectory dirPath - E.catch (runTool' "cabal" (["configure","--user"]) Nothing >> return ()) - (\ (_e :: E.SomeException) -> do - debugM "leksah-server" "Can't configure" - return ()) + E.catch (do runTool' "cabal" ["clean"] Nothing + runTool' "cabal" ["configure","--user"] Nothing + return ()) + (\ (_e :: E.SomeException) -> do + debugM "leksah-server" "Can't configure" + return ()) writeExtractedPackage :: MonadIO m => Bool -> PackageDescr -> m () writeExtractedPackage writeAscii pd = do @@ -240,7 +256,7 @@ mergeDescr (Just (Real rdhi)) (Just (Real rdsrc)) = Real RealDescr { dscName' = dscName' rdhi - , dscMbTypeStr' = dscMbTypeStr' rdhi + , dscMbTypeStr' = dscMbTypeStr' rdsrc , dscMbModu' = dscMbModu' rdsrc , dscMbLocation' = dscMbLocation' rdsrc , dscMbComment' = dscMbComment' rdsrc diff --git a/src/IDE/Metainfo/SourceCollectorH.hs b/src/IDE/Metainfo/SourceCollectorH.hs --- a/src/IDE/Metainfo/SourceCollectorH.hs +++ b/src/IDE/Metainfo/SourceCollectorH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- @@ -145,9 +146,9 @@ debugM "leksah-server" "would block" return ([]) handler (e :: NewException.SomeException) = do - warningM "leksah-server" ("Ghc failed to process: " ++ show e) + warningM "leksah-server" ("Ghc failed to process: " ++ show e ++ " (" ++ cabalPath ++ ")") return (Nothing, PackageCollectStats packageName Nothing False False - (Just ("Ghc failed to process: " <> T.pack (show e)))) + (Just ("Ghc failed to process: " <> T.pack (show e) <> " (" <> T.pack cabalPath <> ")"))) inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ dflags -> do #if MIN_VERSION_haddock(2,8,0) (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] [] diff --git a/src/IDE/Metainfo/SourceDB.hs b/src/IDE/Metainfo/SourceDB.hs --- a/src/IDE/Metainfo/SourceDB.hs +++ b/src/IDE/Metainfo/SourceDB.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- diff --git a/src/IDE/Metainfo/WorkspaceCollector.hs b/src/IDE/Metainfo/WorkspaceCollector.hs --- a/src/IDE/Metainfo/WorkspaceCollector.hs +++ b/src/IDE/Metainfo/WorkspaceCollector.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables, PatternGuards, OverloadedStrings #-} ----------------------------------------------------------------------------- -- diff --git a/src/IDE/StrippedPrefs.hs b/src/IDE/StrippedPrefs.hs --- a/src/IDE/StrippedPrefs.hs +++ b/src/IDE/StrippedPrefs.hs @@ -121,7 +121,7 @@ _ -> return p getSourceDirectories :: Prefs -> IO [FilePath] -getSourceDirectories = (mapM expandHomePath) . sourceDirectories +getSourceDirectories = mapM expandHomePath . sourceDirectories getUnpackDirectory :: Prefs -> IO (Maybe FilePath) getUnpackDirectory = maybe (return Nothing) (liftM Just . expandHomePath) . unpackDirectory diff --git a/src/IDE/Utils/FileUtils.hs b/src/IDE/Utils/FileUtils.hs --- a/src/IDE/Utils/FileUtils.hs +++ b/src/IDE/Utils/FileUtils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/IDE/Utils/Server.hs b/src/IDE/Utils/Server.hs --- a/src/IDE/Utils/Server.hs +++ b/src/IDE/Utils/Server.hs @@ -33,6 +33,7 @@ import Data.Word import System.Log.Logger (infoM) import Data.Text (Text) +import Control.Monad (void) data UserAndGroup = UserAndGroup Text Text | UserWithDefaultGroup Text @@ -57,7 +58,7 @@ sock <- serverSocket' server setSocketOption sock ReuseAddr 1 bindSocket sock (serverAddr server) - infoM "leksah-server" $ ("Bind " ++ show (serverAddr server)) + infoM "leksah-server" $ "Bind " ++ show (serverAddr server) listen sock maxListenQueue return (sock, server) @@ -89,7 +90,7 @@ waitFor :: a -> IO () instance WaitFor (MVar a) where - waitFor mvar = readMVar mvar >> return () + waitFor mvar = void (readMVar mvar) instance WaitFor a => WaitFor [a] where waitFor = mapM_ waitFor @@ -100,7 +101,7 @@ acceptance :: Socket -> ServerRoutine -> IO () acceptance sock action = E.catch (do dta <- accept sock - forkIO (action dta) >> return ()) + void . forkIO $ action dta) (\(e :: SomeException) -> print e) >> acceptance sock action diff --git a/src/IDE/Utils/Utils.hs b/src/IDE/Utils/Utils.hs --- a/src/IDE/Utils/Utils.hs +++ b/src/IDE/Utils/Utils.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XDeriveDataTypeable -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.Utils diff --git a/src/IDE/Utils/VersionUtils.hs b/src/IDE/Utils/VersionUtils.hs --- a/src/IDE/Utils/VersionUtils.hs +++ b/src/IDE/Utils/VersionUtils.hs @@ -35,13 +35,13 @@ else vers debugM "leksah-server" $ "Got GHC Version " ++ T.unpack vers2 return $ T.unpack vers2 - ) $ \ (_ :: SomeException) -> error ("FileUtils>>getGhcVersion failed") + ) $ \ (_ :: SomeException) -> error "FileUtils>>getGhcVersion failed" getGhcInfo :: IO Text getGhcInfo = E.catch (do (!output,_) <- runTool' "ghc" ["--info"] Nothing return . T.unlines $ map toolline output - ) $ \ (_ :: SomeException) -> error ("FileUtils>>getGhcInfo failed") + ) $ \ (_ :: SomeException) -> error "FileUtils>>getGhcInfo failed" getHaddockVersion :: IO Text getHaddockVersion = E.catch (do @@ -51,7 +51,7 @@ then T.init vers else vers return vers2 - ) $ \ (_ :: SomeException) -> error ("FileUtils>>getHaddockVersion failed") + ) $ \ (_ :: SomeException) -> error "FileUtils>>getHaddockVersion failed"