jenga (empty) → 0.1.0.0

raw patch · 9 files changed

+363/−0 lines, 9 filesdep +Cabaldep +aesondep +basesetup-changed

Dependencies added: Cabal, aeson, base, bytestring, containers, http-conduit, http-types, jenga, text

Files

• ChangeLog.md +5/−0
• Jenga/Cabal.hs +63/−0
• Jenga/HTTP.hs +35/−0
• Jenga/PackageList.hs +88/−0
• Jenga/Stack.hs +28/−0
• LICENSE +26/−0
• Setup.hs +2/−0
• jenga.cabal +49/−0
• main/jenga.hs +67/−0

@@ -0,0 +1,5 @@+# Revision history for jenga++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,63 @@+module Jenga.Cabal+  ( dependencyName+  , readPackageDependencies+  ) where++-- You would thing that since the Cabal file exposes its cabal parser you would+-- think it would be a simple matter to extract the list of dependencies.+-- Unfortunately its much more work than it should be. See:+-- https://hackage.haskell.org/package/Cabal-1.24.2.0/docs/Distribution-PackageDescription.html#v:buildDepends++import qualified Data.Map.Strict as DM+import           Data.Text (Text)+import qualified Data.Text as T++import           Distribution.Package (Dependency (..), PackageIdentifier (..), PackageName (..))+import           Distribution.PackageDescription+                    ( Benchmark, CondTree (..), ConfVar, Executable, GenericPackageDescription (..)+                    , PackageDescription (..), Library, TestSuite+                    )+import           Distribution.PackageDescription.Parse (readPackageDescription)+import           Distribution.Verbosity (normal)+++readPackageDependencies :: FilePath -> IO [Dependency]+readPackageDependencies fpath = do+  genpkg <- readPackageDescription normal fpath+  pure+    $ sortNubByName+    $ filterPackageName (package $ packageDescription genpkg)+    $ extractLibraryDeps (condLibrary genpkg)+        ++ extractExecutableDeps (condExecutables genpkg)+        ++ extractTestSuiteDeps (condTestSuites genpkg)+        ++ extractBenchmarkDeps (condBenchmarks genpkg)+++sortNubByName :: [Dependency] -> [Dependency]+sortNubByName = fmap toDep . DM.toList . DM.fromList . fmap fromDep+  where+    fromDep (Dependency n v) = (n, v)+    toDep (n, v) = Dependency n v++filterPackageName :: PackageIdentifier -> [Dependency] -> [Dependency]+filterPackageName (PackageIdentifier pname _) =+  filter (\dep -> pname /= packageName dep )+  where+    packageName (Dependency pn _) = pn++dependencyName :: Dependency -> Text+dependencyName (Dependency (PackageName name) _) = T.pack name+++extractLibraryDeps :: Maybe (CondTree ConfVar [Dependency] Library) -> [Dependency]+extractLibraryDeps Nothing = []+extractLibraryDeps (Just x) = condTreeConstraints x++extractExecutableDeps :: [(String, CondTree ConfVar [Dependency] Executable)] -> [Dependency]+extractExecutableDeps = concatMap (condTreeConstraints . snd)++extractTestSuiteDeps :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> [Dependency]+extractTestSuiteDeps = concatMap (condTreeConstraints . snd)++extractBenchmarkDeps :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> [Dependency]+extractBenchmarkDeps = concatMap (condTreeConstraints . snd)

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+module Jenga.HTTP where++import Control.Monad (when, void)++import Data.Aeson (eitherDecode')++import Network.HTTP.Client.Conduit+import Network.HTTP.Types.Header (hAccept)+import Network.HTTP.Types.Status (status200)++import Jenga.PackageList+++newtype StackResolver+  = StackResolver String+  deriving (Eq, Show)++++stackageUrl :: String+stackageUrl = "https://www.stackage.org/"++-- Should use an ErrorT here.+getStackageResolverPkgList :: StackResolver -> IO (Either String PackageList)+getStackageResolverPkgList (StackResolver sr) = do+  -- TODO: swap out for something that doesn't `fail`.+  request <- parseRequest $ stackageUrl ++ sr+  withManager $ do+    response <- httpLbs $ request { requestHeaders = (hAccept, "application/json") : requestHeaders request }++    when (responseStatus response /= status200) $+      void . error $ "getStackageResolverPkgList: status " ++ show (responseStatus response)++    pure $ eitherDecode' (responseBody response)

@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}++module Jenga.PackageList+  ( PackageInfo (..)+  , PackageList (..)+  , lookupPackages+  ) where++import           Data.Aeson+import           Data.Aeson.Types (typeMismatch)++import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as DM++import           Data.Text (Text)+++data PackageList = PackageList+  { ghcVersion :: Text+  , creatDate :: Text+  , resolverName :: Text+  , packageMap :: Map Text PackageInfo+  }+  deriving Show++data Package = Package+  { _pkgName :: Text+  , _pkgVer :: Text+  , _pkgSyn :: Text+  , _pkgCCore :: Bool+  }++data PackageInfo = PackageInfo+  { packageVersion :: Text+  , packageSynopsis :: Text+  , packageCore :: Bool+  }+  deriving Show++-- Temporary data type. Not exported.+data Snapshot = Snapshot+  { ghc :: Text+  , created :: Text+  , name :: Text+  }+++instance FromJSON Package where+  parseJSON (Object v) =+    Package <$> v .: "name"+            <*> v .: "version"+            <*> v .: "synopsis"+            <*> v .: "isCore"+  parseJSON invalid = typeMismatch "Package" invalid+++instance FromJSON Snapshot where+  parseJSON (Object v) =+    Snapshot <$> v .: "ghc"+              <*> v .: "created"+              <*> v .: "name"+  parseJSON invalid = typeMismatch "Snapshot" invalid++instance FromJSON PackageList where+  parseJSON (Object v) = do+    s <- v .: "snapshot"+    pkgs <- v .: "packages"+    pure $ PackageList (ghc s) (created s) (name s) $ mkPackageMap pkgs++  parseJSON invalid = typeMismatch "PackageList" invalid++mkPackageMap :: [Package] -> Map Text PackageInfo+mkPackageMap =+  DM.fromList . fmap convert+  where+    convert (Package nam ver syn core) =+      (nam, PackageInfo ver syn core)+++lookupPackages :: PackageList -> [Text] -> [Either Text (Text, PackageInfo)]+lookupPackages plist deps =+  fmap plookup deps+  where+    pmap = packageMap plist+    plookup k =+      case DM.lookup k pmap of+        Nothing -> Left k+        Just x -> Right (k, x)

@@ -0,0 +1,28 @@+module Jenga.Stack+  ( readResolver+  ) where++-- Read the resolver from the stack.yaml file in the current directory.+-- This is unashamedly savage.++import           Data.Char (isSpace)+import qualified Data.List as DL++import           Jenga.HTTP+++readResolver :: IO (Maybe StackResolver)+readResolver = -- Is this the *only* file name?+  extract <$> readFile "stack.yaml"+++extract :: String -> Maybe StackResolver+extract xs =+  case filter (DL.isPrefixOf "resolver:") (lines xs) of+    [x] -> Just .StackResolver $ cleanup x+    _ -> Nothing+  where+    cleanup = DL.takeWhile (not . isSpace)+            . DL.dropWhile (isSpace)+            . DL.drop 1+            . DL.dropWhile (/= ':')

@@ -0,0 +1,26 @@+Copyright (c) 2017, Erik de Castro Lopo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,49 @@+-- Initial jenga.cabal generated by cabal init.  For further documentation,+--  see http://haskell.org/cabal/users-guide/++name:                	jenga+version:             	0.1.0.0+synopsis:            	Generate a cabal freeze file from a stack.yaml+-- description:+homepage:            	https://github.com/erikd/jenga+license:             	BSD2+license-file:        	LICENSE+author:              	Erik de Castro Lopo+maintainer:          	erikd@mega-nerd.com+-- copyright:+category:            	Development+build-type:          	Simple+extra-source-files:  	ChangeLog.md+cabal-version:       	>= 1.10++library+  ghc-options:         	-Wall -fwarn-tabs+  default-language:    	Haskell2010++  build-depends:       	base					>= 4.8			&& < 4.10+                      , aeson                   == 1.1.*+                      , Cabal                   == 1.24.*+                      , containers              == 0.5.*+                      , bytestring              == 0.10.*+                      , http-conduit            == 2.2.*+                      , http-types              == 0.9.*+                      , text                    == 1.2.*+++  exposed-modules:      Jenga.Cabal+                      , Jenga.PackageList+                      , Jenga.HTTP+                      , Jenga.Stack++  other-extensions:     OverloadedStrings+++executable jenga+  ghc-options:         	-Wall -fwarn-tabs+  default-language:    	Haskell2010+  hs-source-dirs:       main+  main-is:              jenga.hs++  build-depends:       	base+                      , jenga+                      , text

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++import           Control.Monad (unless)++import           Data.Either (partitionEithers)+import qualified Data.List as DL+import           Data.Text (Text)+import qualified Data.Text.IO as T++import           Jenga.Cabal+import           Jenga.HTTP+import           Jenga.PackageList+import           Jenga.Stack++import           System.IO (hPutStrLn, stderr)+import           System.Environment (getArgs)+++main :: IO ()+main = do+  args <- getArgs+  case args of+    [cf] -> process cf+    _ -> usageExit+++usageExit :: IO ()+usageExit =+  putStrLn $ "\nUsage: jenga <cabal file>\n"++process :: FilePath -> IO ()+process cabalFile = do+  deps <- fmap dependencyName <$> readPackageDependencies cabalFile+  mr <- readResolver+  case mr of+    Nothing -> putStrLn "Not able to find resolver version in 'stack.yaml' file."+    Just r -> processResolver deps r++processResolver :: [Text] -> StackResolver -> IO ()+processResolver deps sr = do+  mpl <- getStackageResolverPkgList sr+  case mpl of+    Left s -> putStrLn $ "Error parse JSON: " ++ s+    Right pl -> processPackageList deps pl+++processPackageList :: [Text] -> PackageList -> IO ()+processPackageList deps plist = do+  let (missing, found) = partitionEithers $ lookupPackages plist deps+  unless (DL.null missing) $+    reportMissing missing+  printCabalFreeze found+++reportMissing :: [Text] -> IO ()+reportMissing [] = putStrLn "No missing packages found."+reportMissing xs =+  hPutStrLn stderr $ "The packages " ++ show xs ++ " could not be found in the specified stack resolver data."++printCabalFreeze :: [(Text, PackageInfo)] -> IO ()+printCabalFreeze xs = do+  putStr "constraints:"+  T.putStrLn . mconcat . DL.intersperse ",\n" $ DL.map render xs+  where+    render (name, pkg) =+      mconcat [ " ", name, " == ", packageVersion pkg ]+