diff --git a/exherbo-cabal.cabal b/exherbo-cabal.cabal --- a/exherbo-cabal.cabal +++ b/exherbo-cabal.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.3 +version: 0.1.0.4 -- A short (one-line) description of the package. synopsis: Exheres generator for cabal packages @@ -51,6 +51,7 @@ location: https://github.com/ony/exherbo-cabal executable exherbo-cabal + ghc-options: -O3 -Wall -fwarn-tabs -fwarn-monomorphism-restriction -- .hs or .lhs file containing the Main module. main-is: Main.hs @@ -60,10 +61,11 @@ -- LANGUAGE extensions used by modules in this package. other-extensions: FlexibleInstances, + LambdaCase, OverloadedStrings, UnicodeSyntax, ViewPatterns - + -- Other library packages from which modules are imported. build-depends: Cabal >=1.20 && <1.23, @@ -72,6 +74,7 @@ containers, haddock-library >=1.0 && <1.3, http-client >=0.4 && <0.5, + http-types <1, pcre-light <0.5, pretty >=1.1 && <1.2 diff --git a/src/ExRender.hs b/src/ExRender.hs --- a/src/ExRender.hs +++ b/src/ExRender.hs @@ -1,7 +1,7 @@ -- Copyright © 2015 Mykola Orliuk -- Distributed under the terms of the GNU General Public License v2 -{-# LANGUAGE UnicodeSyntax, ViewPatterns #-} +{-# LANGUAGE UnicodeSyntax, ViewPatterns, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} @@ -28,16 +28,22 @@ exWrapWidth ∷ Int exWrapWidth = 80 +-- TODO: make GHC version configurable exGHCVersion ∷ Version -exGHCVersion = Version [7, 10, 1] [] -- TODO: solve this hard-coded GHC version assumption +exGHCVersion = case buildCompilerId of + (CompilerId GHC ver) → ver + x → error $ "Unsupported compiler " ++ show x exKnownLicenses ∷ [String] exKnownLicenses = ["CC0"] +-- | Double-quoted string for bash dquoted ∷ String → String dquoted [] = [] dquoted ('\\':xs) = "\\\\" ++ dquoted xs dquoted ('"':xs) = "\\\"" ++ dquoted xs +dquoted ('`':xs) = "\\`" ++ dquoted xs +dquoted ('$':xs) = "\\$" ++ dquoted xs dquoted (x:xs) = x : dquoted xs softWidth ∷ Int → [String] → [[String]] @@ -95,6 +101,7 @@ DocAName s → exDispQ s DocProperty s → exDispQ s DocExamples _ → empty -- XXX: examples are filtered out + _ -> error $ "Unsupported haddock node" instance ExRender LowerBound where exDisp (LowerBound v InclusiveBound) = ">=" <> disp v @@ -105,17 +112,45 @@ exDisp (UpperBound v ExclusiveBound) = "<" <> disp v exDisp x = error $ "Unsupported UpperBound: " ++ show x +-- | Render some of VersionInterval's that can be represented with a single +-- condition and thus suitable for using in disjunction list +maybeExVersion ∷ VersionInterval → Maybe Doc +maybeExVersion = \case + -- >=x && <=x + (LowerBound a InclusiveBound, UpperBound b InclusiveBound) + | a == b → Just $ char '=' <> disp a + + -- =x, >x + (lb, NoUpperBound) → Just $ exDisp lb + + (LowerBound (Version [] _) _, _) → Nothing + (_, UpperBound (Version [] _) _) → Nothing + -- >=x.y && =x.y.z && disp v + where a' = init a + + _ → Nothing + instance ExRender VersionInterval where - exDisp (LowerBound v InclusiveBound, - UpperBound v' InclusiveBound) | v == v' = brackets ("=" <> disp v) exDisp (LowerBound (Version [0] []) InclusiveBound, NoUpperBound) = empty - exDisp (LowerBound (Version [0] []) InclusiveBound, ub) = brackets (exDisp ub) - exDisp (lb, NoUpperBound) = brackets (exDisp lb) - exDisp (lb, ub) = brackets (exDisp lb <> char '&' <> exDisp ub) + exDisp (maybeExVersion → Just exVi) = exVi + exDisp (lb, ub) = exDisp lb <> char '&' <> exDisp ub instance ExRender VersionRange where exDisp vr = case asVersionIntervals vr of - [vi] → exDisp vi + [vi] → nbrackets $ exDisp vi + (mapM maybeExVersion → Just exVis) → nbrackets . hcat $ punctuate (char '|') exVis _ → error $ "Unsupported version range: " ++ display vr instance ExRender Dependency where @@ -129,9 +164,13 @@ exDisp (LGPL (Just v)) = "LGPL-" <> disp v exDisp (Apache Nothing) = "Unspecified-Apache" exDisp (Apache (Just v)) = "Apache-" <> disp v + exDisp (MPL v) = "MPL-" <> disp v + exDisp BSD2 = "BSD-2" exDisp BSD3 = "BSD-3" exDisp BSD4 = "BSD-4" + exDisp ISC = "ISC" exDisp MIT = "MIT" + exDisp PublicDomain = "public-domain" exDisp (UnknownLicense "BSD2") = "BSD-2" exDisp (UnknownLicense "MPL-2") = "MPL-2.0" exDisp (UnknownLicense x) | x `elem` exKnownLicenses = text x @@ -237,8 +276,8 @@ build t = condTreeConstraints t ++ concatMap buildOptional (condTreeComponents t) buildOptional (eval → True, t, _) = build t - buildOptional (eval → False, _, Just t) = build t - buildOptional (eval → False, _, Nothing) = [] + buildOptional (_, _, Just t) = build t + buildOptional (_, _, Nothing) = [] collectLibDeps, collectBinDeps, collectTestDeps ∷ GenericPackageDescription → [Dependency] collectLibDeps = collectDeps (maybeToList . condLibrary) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -5,8 +5,8 @@ module Main where -import Control.Applicative import Control.Monad +import Control.Concurrent (threadDelay) import Control.Exception import Data.Maybe import Data.ByteString.Lazy.Char8 (unpack) @@ -22,6 +22,7 @@ import Distribution.PackageDescription.Parse import Distribution.Verbosity import Network.HTTP.Client +import Network.HTTP.Types import qualified Text.Regex.PCRE.Light.Char8 as R @@ -30,7 +31,12 @@ -- |Fetch content by provided URI simpleFetch ∷ String → IO String simpleFetch url = do - let settings = defaultManagerSettings + let settings = defaultManagerSettings { managerRetryableException = isTemporary + , managerResponseTimeout = Just 120000000 + , managerWrapIOException = (threadDelay 1 >>) + } + isTemporary (fromException → Just (StatusCodeException e _ _)) = statusCode e `elem` [503] + isTemporary _ = False req ← parseUrl url withManager settings $ liftM (unpack . responseBody) . httpLbs req @@ -53,13 +59,24 @@ hackageBaseUri = "http://hackage.haskell.org/package/" fixLicense ∷ GenericPackageDescription → IO GenericPackageDescription -fixLicense descr | license pkgDescr == OtherLicense = adjustLicense +fixLicense descr | isNothing maybeLicensePath = return descr + | license pkgDescr == OtherLicense = catch adjustLicense handler | otherwise = return descr where pkgDescr = packageDescription descr packageUri = hackageBaseUri ++ display (package pkgDescr) + + handler ∷ SomeException → IO GenericPackageDescription + handler e = do + hPutStrLn stderr $ "# No license fix for " ++ display (package pkgDescr) ++ ": " ++ show e + return descr + + -- TODO: proper handling of multiple licenses + maybeLicensePath = case licenseFiles pkgDescr of + [x] → Just x + _ → Nothing adjustLicense = do - let licensePath = head $ licenseFiles pkgDescr -- TODO: proper handling of multiple licenses + let licensePath = fromJust $ maybeLicensePath licenseContent ← simpleFetch (packageUri ++ "/src/" ++ licensePath) license' ← guessLicense licenseContent case license' of @@ -84,17 +101,43 @@ main ∷ IO () main = do args ← getArgs - sources ← case args of - [] → liftM lines getContents - _ → return args - forM_ sources $ \source → do - descr ← case source of - ('.':_) → readPackageDescription verbose source >>= fixLicense - ('/':_) → readPackageDescription verbose source >>= fixLicense - (simpleParse → Just pkgId) -> fetchPackageDescription pkgId - _ -> error $ "Specified source " ++ show source - ++ " neither starts with '.' or '/' (local file)" - ++ " nor a valid packageIdentifier (to fetch from hackage)" - let handler ∷ SomeException → IO () - handler e = hPutStrLn stderr $ "# Failed fetch/generate for " ++ show source ++ ": " ++ show e - catch (evaluate (exRender descr) >>= putStrLn) handler + case args of + "-h":_ → putStr helpString + "--help":_ → putStr helpString + _ → do + sources ← case args of + [] → liftM lines getContents + _ → return args + forM_ sources $ \source → do + hPutStrLn stderr $ "# Processing " ++ show source + descr ← case source of + ('.':_) → readPackageDescription verbose source >>= fixLicense + ('/':_) → readPackageDescription verbose source >>= fixLicense + (simpleParse → Just pkgId) -> fetchPackageDescription pkgId + _ -> error $ "Specified source " ++ show source + ++ " neither starts with '.' or '/' (local file)" + ++ " nor a valid packageIdentifier (to fetch from hackage)" + let handler ∷ SomeException → IO () + handler e = hPutStrLn stderr $ "# Failed fetch/generate for " ++ show source ++ ": " ++ show e + catch (evaluate (exRender descr) >>= putStrLn) handler + + +helpString :: String +helpString = + "Generate package description from .cabal files in format of exheres-0 for\n" ++ + "Exherbo Linux.\n" ++ + "\n" ++ + "See https://github.com/ony/exherbo-cabal\n" ++ + "\n" ++ + "Usage: exherbo-cabal [ -h | --help | ... ]\n"++ + " -h | --help Print this help and exit\n" ++ + " either a package name (mtl) at Hackage with optional\n" ++ + " version (mtl-2.2.1) or path to local cabal file (./exherbo-cabal.cabal)\n" ++ + " If no provided in args read them from standart input\n" ++ + "\n" ++ + "Examples:\n" ++ + " > exherbo-cabal mtl-2.2.1\n" ++ + " > exherbo-cabal mtl transformers\n" ++ + " > echo yesod-core | exherbo-cabal\n" ++ + " > exherbo-cabal ./exherbo-cabal.cabal\n" ++ + " > find /tmp/index -name \\*.cabal | exherbo-cabal\n"