Merge pull request #13 from bendlas/master

Fix various downloading options; error messages

melpa-packages.sh

@@ -1,6 +1,9 @@
 #!/usr/bin/env nix-shell
-#!nix-shell --pure -i bash -A env
+#!nix-shell -i bash -A env
 
 # usage: ./melpa-packages.sh --melpa PATH_TO_MELPA_CLONE
 
+## env var for curl
+export SSL_CERT_FILE=/etc/ssl/certs/ca-certificates.crt
+
 cabal run melpa2nix -- --work /tmp/melpa2nix "$@"

melpa-stable-packages.sh

@@ -3,4 +3,7 @@
 
 # usage: ./melpa-packages.sh --melpa PATH_TO_MELPA_CLONE
 
+## env var for curl
+export SSL_CERT_FILE=/etc/ssl/certs/ca-certificates.crt
+
 cabal run melpa2nix -- --stable --work /tmp/melpa2nix "$@"

shell.nix

@@ -11,8 +11,6 @@ let
         enableLibraryProfiling = profiling;
       });
 
-      aeson = self.aeson_0_11_1_4;
-      bifunctors = lib.dontHaddock self.bifunctors_5_2_1;
       comonad = lib.doJailbreak (lib.dontCheck super.comonad);
       distributive = lib.dontCheck super.distributive;
       fail = lib.dontHaddock super.fail;
@@ -22,7 +20,6 @@ let
       parsers = lib.doJailbreak super.parsers;
       reducers = lib.doJailbreak super.reducers;
       semigroupoids = lib.dontCheck super.semigroupoids;
-      transformers-compat = self.transformers-compat_0_5_1_4;
       trifecta = lib.doJailbreak (lib.dontCheck super.trifecta);
       unordered-containers = lib.doJailbreak super.unordered-containers;
     };

src/Distribution/Nix/Fetch.hs

@@ -36,6 +36,10 @@ import Data.Typeable (Typeable)
 import Nix.Expr
 import System.Environment (getEnvironment)
 import qualified System.IO.Streams as S
+import qualified System.IO.Streams.Attoparsec as S
+import Data.Aeson ( parseJSON, Value, Object, (.:!), withObject )
+import Data.Aeson.Parser ( json' )
+import Data.Aeson.Types ( parseEither )
 
 import Util (runInteractiveProcess)
 
@@ -113,11 +117,12 @@ prefetchHelper :: String -> [String]
 prefetchHelper fetcher args go = mapException FetchError helper
   where
     helper = do
-      env <- addToEnv "PRINT_PATH" "1"
+      env <- addToEnv [("PRINT_PATH",    "1"),
+                       ("SSL_CERT_FILE", "/etc/ssl/certs/ca-certificates.crt")]
       runInteractiveProcess fetcher args Nothing (Just env) go
 
-addToEnv :: MonadIO m => String -> String -> m [(String, String)]
-addToEnv var val = liftIO $ M.toList . M.insert var val . M.fromList <$> getEnvironment
+addToEnv :: [(String, String)] -> IO [(String, String)]
+addToEnv env = (++ env) <$> getEnvironment
 
 data BadPrefetchOutput = BadPrefetchOutput
   deriving (Show, Typeable)
@@ -142,10 +147,13 @@ prefetch _ fetch@(Git {..}) = do
     branch = do
       name <- branchName
       pure ["--branch-name", T.unpack name]
+    jsonp = withObject "need an object" (\o -> o .:! "sha256")
   prefetchHelper "nix-prefetch-git" args $ \out -> do
-    hashes <- liftIO (S.lines out >>= S.decodeUtf8 >>= S.toList)
-    case hashes of
-      (_:_:hash:path:_) -> pure (T.unpack path, fetch { sha256 = Just hash })
+    sha256 <- liftIO $ parseEither jsonp <$> S.parseFromStream json' out
+    pathes <- liftIO (S.lines out >>= S.decodeUtf8 >>= S.toList)
+    case (sha256, pathes) of
+      (Right sha,(_:path:_)) -> pure (T.unpack path,
+                                      fetch { sha256 = sha })
       _ -> throwIO BadPrefetchOutput
 
 prefetch _ fetch@(Bzr {..}) = do
@@ -161,7 +169,7 @@ prefetch _ fetch@(Hg {..}) = do
   prefetchHelper "nix-prefetch-hg" args $ \out -> do
     hashes <- liftIO (S.lines out >>= S.decodeUtf8 >>= S.toList)
     case hashes of
-      (_:hash:path:_) -> pure (T.unpack path, fetch { sha256 = Just hash })
+      (hash:path:_) -> pure (T.unpack path, fetch { sha256 = Just hash })
       _ -> throwIO BadPrefetchOutput
 
 prefetch name fetch@(CVS {..}) = do

src/Util.hs

@@ -33,6 +33,7 @@ import Data.Typeable (Typeable)
 import System.Exit (ExitCode(..))
 import System.IO.Streams (InputStream)
 import qualified System.IO.Streams as S
+import Debug.Trace
 
 data Died = Died Int Text
   deriving (Show, Typeable)
@@ -44,6 +45,14 @@ data ProcessFailed = ProcessFailed String [String] SomeException
 
 instance Exception ProcessFailed
 
+data ProcessingFailed = ProcessingFailed Text Text SomeException
+  deriving (Show, Typeable)
+
+instance Exception ProcessingFailed
+
+slurp :: InputStream ByteString -> IO Text
+slurp stream = S.fold (<>) T.empty =<< S.decodeUtf8 stream
+
 runInteractiveProcess
   :: String -> [String] -> Maybe FilePath -> Maybe [(String, String)]
   -> (InputStream ByteString -> IO a)
@@ -52,14 +61,25 @@ runInteractiveProcess cmd args cwd env withOutput
   = mapExceptionIO (ProcessFailed cmd args) $ do
     (_, out, err, pid) <- S.runInteractiveProcess cmd args cwd env
     let
-      getOutput = Concurrently (withOutput out)
-      getErrors = Concurrently (S.fold (<>) T.empty =<< S.decodeUtf8 err)
+      getOutput =
+        Concurrently
+         (catch
+          (fmap Right $ withOutput out)
+          (\e -> (fmap (Left . ((,) e)) (slurp out))))
+          ---- Maybe catch exceptions that might occur by just slurping the input stream
+          ---- couldn't get this to type (Ambigous exception type)
+          -- (\e -> catch
+          --        (fmap (Left . ((,) e)) (slurp out))
+          --        -- (Left (e, slurp out))
+          --        (\ei -> pure $ Left (e, T.pack $ "INPUT ERROR " ++ show ei))))
+      getErrors = Concurrently $ slurp err
       wait = Concurrently (S.waitForProcess pid)
-    (result, errorMessage, exit) <- runConcurrently
-                                    ((,,) <$> getOutput <*> getErrors <*> wait)
-    case exit of
-      ExitSuccess -> pure result
-      ExitFailure code -> throwIO (Died code errorMessage)
+    (output, errorMessage, exit) <- runConcurrently ((,,) <$> getOutput <*> getErrors <*> wait)
+    case (exit, output) of
+      (ExitSuccess, Right v) -> pure v
+      (ExitSuccess, Left (ex, leftover)) -> throwIO $ ProcessingFailed leftover errorMessage ex
+      (ExitFailure code, Left info) -> throwIO $ trace (show info) $ Died code errorMessage
+      (ExitFailure code, Right v) -> throwIO $ Died code "WTF successful parse of error'd program"
 
 showExceptions :: IO b -> IO (Maybe b)
 showExceptions go = catch (Just <$> go) handler