From ec640bb8ff0fd2f369fb3223521eab3e599d6b1c Mon Sep 17 00:00:00 2001
From: Juan Pedro Villa Isaza <jpvillaisaza@gmail.com>
Date: Sat, 10 Sep 2016 17:56:01 -0500
Subject: [PATCH] Add a report of errors

---
 Main.hs         | 10 +++++++--
 src/Licensor.hs | 59 +++++++++++++++++++++++++++++++++----------------
 2 files changed, 48 insertions(+), 21 deletions(-)

diff --git a/Main.hs b/Main.hs
index 5132a9f..d15dabd 100644
--- a/Main.hs
+++ b/Main.hs
@@ -95,8 +95,10 @@ main = do
       Exit.die "Error: ..."
 
     Just dependencies -> do
-      dependenciesByLicense <-
-        fmap (Set.map display) <$> orderPackagesByLicense pid dependencies
+      (dependenciesByLicense', failed) <-
+        orderPackagesByLicense pid dependencies
+
+      let dependenciesByLicense = fmap (Set.map display) dependenciesByLicense'
 
       forM_ (Map.keys dependenciesByLicense) $
         \license ->
@@ -111,3 +113,7 @@ main = do
                 <> display license
                 <> ": "
                 <> intercalate ", " (Set.toList n)
+
+      unless (null failed) $ do
+        putStr "Failed: "
+        print failed
diff --git a/src/Licensor.hs b/src/Licensor.hs
index 4acc487..24bc315 100644
--- a/src/Licensor.hs
+++ b/src/Licensor.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 ----------------------------------------------------------------------
 -- |
@@ -22,6 +23,7 @@ module Licensor
   where
 
 -- base
+import qualified Control.Exception as Exception
 import Data.Monoid ((<>))
 import Data.Version (Version)
 import System.IO
@@ -121,8 +123,9 @@ getDependencies =
 --
 --
 
-getPackageLicense :: PackageIdentifier -> IO LiLicense
+getPackageLicense :: PackageIdentifier -> IO (Maybe LiLicense)
 getPackageLicense p@PackageIdentifier{..} = do
+  putStr $ display p ++ "..."
   let
     url =
       "GET https://hackage.haskell.org/package/"
@@ -132,15 +135,24 @@ getPackageLicense p@PackageIdentifier{..} = do
         <> ".cabal"
 
   req <- parseRequest url
-  pd <- fmap getResponseBody (httpLBS req)
+  eitherPd <- Exception.try $ fmap getResponseBody (httpLBS req)
 
-  (file, handle) <- openTempFile "/tmp" "licensor"
-  hClose handle
-  ByteString.writeFile file pd
-  PackageDescription{license} <- getPackageDescription file
-  hClose handle
-  removeFile file
-  return (LiLicense license)
+  case eitherPd of
+    Left (_ :: HttpException) ->
+      return Nothing
+
+    Right pd -> do
+
+      (file, handle) <- openTempFile "/tmp" "licensor"
+      hClose handle
+      ByteString.writeFile file pd
+      PackageDescription{license} <- getPackageDescription file
+      hClose handle
+      removeFile file
+
+      putStrLn $ display license
+
+      return $ Just (LiLicense license)
 
 
 -- |
@@ -150,24 +162,33 @@ getPackageLicense p@PackageIdentifier{..} = do
 orderPackagesByLicense
   :: PackageIdentifier
   -> Set PackageIdentifier
-  -> IO (Map LiLicense (Set PackageIdentifier))
+  -> IO (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
 orderPackagesByLicense p =
   let
     insertPackage package orderedPackages' = do
-      license <- getPackageLicense package
-      orderedPackages <- orderedPackages'
+      maybeLicense <- getPackageLicense package
+
+      (orderedPackages, failed) <- orderedPackages'
       return $
         if p == package
           then
-            orderedPackages
+            (orderedPackages, failed)
           else
-            Map.insertWith
-              Set.union
-              license
-              (Set.singleton package)
-              orderedPackages
+            case maybeLicense of
+              Nothing ->
+                ( orderedPackages, Set.insert package failed
+                )
+
+              Just license ->
+                ( Map.insertWith
+                    Set.union
+                    license
+                    (Set.singleton package)
+                    orderedPackages
+                , failed
+                )
   in
-    foldr insertPackage (pure mempty)
+    foldr insertPackage (pure (mempty, mempty))
 
 
 -- |