From 835ac70815ed6d5a6cf1e6a79bd6e8c3c17ac091 Mon Sep 17 00:00:00 2001 From: Juan Pedro Villa Isaza Date: Sat, 20 Aug 2016 14:23:19 -0500 Subject: [PATCH] Add licensor library --- Main.hs | 123 +------------------------------------- licensor.cabal | 21 ++++++- src/Licensor.hs | 153 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 174 insertions(+), 123 deletions(-) create mode 100644 src/Licensor.hs diff --git a/Main.hs b/Main.hs index b171903..d0d1920 100644 --- a/Main.hs +++ b/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module Main @@ -7,58 +5,23 @@ module Main ) where +-- licensor +import Licensor + -- base import Control.Monad import Data.List import Data.Monoid ((<>)) import qualified System.Exit as Exit -import System.IO -- Cabal -import Distribution.License -import Distribution.Package import Distribution.PackageDescription -import Distribution.PackageDescription.Parse -import Distribution.Simple.Utils import Distribution.Text -import Distribution.Verbosity -- containers -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Set (Set) import qualified Data.Set as Set --- directory -import System.Directory - --- HTTP -import Network.HTTP - ( getRequest - , getResponseBody - , simpleHTTP - ) - --- process -import System.Process - - --- | --- --- - -newtype License' = License' { _getLicense :: License } - deriving (Eq, Read, Show, Text) - - --- | --- --- - -instance Ord License' where - compare = - comparing display - -- | -- @@ -106,83 +69,3 @@ main = do <> display license <> ": " <> intercalate ", " (Set.toList n) - - --- | --- --- - -getPackage :: IO (Maybe PackageDescription) -getPackage = do - currentDirectory <- getCurrentDirectory - fmap getPackageDescription <$> findPackageDesc currentDirectory - >>= either (const (return Nothing)) (fmap Just) - - --- | --- --- - -getPackageDescription :: FilePath -> IO PackageDescription -getPackageDescription = - fmap packageDescription . readPackageDescription silent - - --- | --- --- - -getDependencies :: IO (Maybe (Set PackageIdentifier)) -getDependencies = - fmap Set.fromList . sequence . fmap simpleParse . lines - <$> readProcess "stack" ["list-dependencies", "--separator", "-"] "" - - --- | --- --- - -getPackageLicense :: PackageIdentifier -> IO License' -getPackageLicense p@PackageIdentifier{..} = do - let - url = - "http://hackage.haskell.org/package/" - <> display p - <> "/" - <> unPackageName pkgName - <> ".cabal" - pd <- simpleHTTP (getRequest url) >>= getResponseBody - (file, handle) <- openTempFile "/tmp" "licensor" - hClose handle - writeFile file pd - PackageDescription{license} <- getPackageDescription file - hClose handle - removeFile file - return (License' license) - - --- | --- --- - -orderPackagesByLicense - :: PackageIdentifier - -> Set PackageIdentifier - -> IO (Map License' (Set PackageIdentifier)) -orderPackagesByLicense p = - let - insertPackage package orderedPackages' = do - license <- getPackageLicense package - orderedPackages <- orderedPackages' - return $ - if p == package - then - orderedPackages - else - Map.insertWith - Set.union - license - (Set.singleton package) - orderedPackages - in - foldr insertPackage (pure mempty) diff --git a/licensor.cabal b/licensor.cabal index e5eb656..503d50b 100644 --- a/licensor.cabal +++ b/licensor.cabal @@ -14,9 +14,11 @@ extra-source-files: README.md build-type: Simple cabal-version: >= 1.10 -executable licensor - main-is: - Main.hs +library + hs-source-dirs: + src + exposed-modules: + Licensor build-depends: base >= 4.8 && < 5.0 , Cabal >= 1.22 && < 1.25 @@ -26,6 +28,19 @@ executable licensor , process default-language: Haskell2010 + ghc-options: + -Wall + +executable licensor + main-is: + Main.hs + build-depends: + base >= 4.8 && < 5.0 + , Cabal >= 1.22 && < 1.25 + , containers + , licensor + default-language: + Haskell2010 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Licensor.hs b/src/Licensor.hs new file mode 100644 index 0000000..094d3c1 --- /dev/null +++ b/src/Licensor.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Licensor + ( LiLicense(..) + , LiPackage(..) + , getDependencies + , getPackage + , orderPackagesByLicense + ) + where + +-- base +import Data.Monoid ((<>)) +import System.IO + +-- Cabal +import Distribution.License +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse +import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Verbosity + +-- containers +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set + +-- directory +import System.Directory + +-- HTTP +import Network.HTTP + ( getRequest + , getResponseBody + , simpleHTTP + ) + +-- process +import System.Process + + +-- | +-- +-- + +newtype LiLicense = LiLicense { getLicense :: License } + deriving (Eq, Read, Show, Text) + + +-- | +-- +-- + +instance Ord LiLicense where + compare = + comparing display + + +-- | +-- +-- + +data LiPackage = + LiPackage + { liPackageId :: PackageIdentifier + , liPackageDependencies :: Set LiPackage + , liPackageLicense :: License + } + + +-- | +-- +-- + +getPackage :: IO (Maybe PackageDescription) +getPackage = do + currentDirectory <- getCurrentDirectory + fmap getPackageDescription <$> findPackageDesc currentDirectory + >>= either (const (return Nothing)) (fmap Just) + + +-- | +-- +-- + +getPackageDescription :: FilePath -> IO PackageDescription +getPackageDescription = + fmap packageDescription . readPackageDescription silent + + +-- | +-- +-- + +getDependencies :: IO (Maybe (Set PackageIdentifier)) +getDependencies = + fmap Set.fromList . sequence . fmap simpleParse . lines + <$> readProcess "stack" ["list-dependencies", "--separator", "-"] "" + + +-- | +-- +-- + +getPackageLicense :: PackageIdentifier -> IO LiLicense +getPackageLicense p@PackageIdentifier{..} = do + let + url = + "http://hackage.haskell.org/package/" + <> display p + <> "/" + <> unPackageName pkgName + <> ".cabal" + pd <- simpleHTTP (getRequest url) >>= getResponseBody + (file, handle) <- openTempFile "/tmp" "licensor" + hClose handle + writeFile file pd + PackageDescription{license} <- getPackageDescription file + hClose handle + removeFile file + return (LiLicense license) + + +-- | +-- +-- + +orderPackagesByLicense + :: PackageIdentifier + -> Set PackageIdentifier + -> IO (Map LiLicense (Set PackageIdentifier)) +orderPackagesByLicense p = + let + insertPackage package orderedPackages' = do + license <- getPackageLicense package + orderedPackages <- orderedPackages' + return $ + if p == package + then + orderedPackages + else + Map.insertWith + Set.union + license + (Set.singleton package) + orderedPackages + in + foldr insertPackage (pure mempty)