From d1b640ff30ec273faf3ac5afb6c892ff4eb74cbe Mon Sep 17 00:00:00 2001
From: audreyt <audreyt@audreyt.org>
Date: Sat, 24 Jun 2006 23:31:56 +0000
Subject: [PATCH] finish interaction with remote HTTP servers
---
Network/Hackage/CabalInstall/Dependency.hs | 2 +-
Network/Hackage/CabalInstall/Fetch.hs | 25 ++++++++++++++++------
Network/Hackage/Client.hs | 13 +++++------
3 files changed, 27 insertions(+), 13 deletions(-)
diff --git a/Network/Hackage/CabalInstall/Dependency.hs b/Network/Hackage/CabalInstall/Dependency.hs
index 789737fb3e..bc939ad04a 100644
--- a/Network/Hackage/CabalInstall/Dependency.hs
+++ b/Network/Hackage/CabalInstall/Dependency.hs
@@ -144,7 +144,7 @@ getDependency ps (UnresolvedDependency { dependency=dep@(Dependency pkgname vran
{ fulfilling = dep
, resolvedData = Nothing
, pkgOptions = opts }
- qs -> let PkgInfo pkg deps location _ = maximumBy versions qs
+ qs -> let PkgInfo { infoId = pkg, infoDeps = deps, infoURL = location } = maximumBy versions qs
versions a b = pkgVersion (infoId a) `compare` pkgVersion (infoId b)
in ResolvedPackage
{ fulfilling = dep
diff --git a/Network/Hackage/CabalInstall/Fetch.hs b/Network/Hackage/CabalInstall/Fetch.hs
index ab4292803a..36e4f653a6 100644
--- a/Network/Hackage/CabalInstall/Fetch.hs
+++ b/Network/Hackage/CabalInstall/Fetch.hs
@@ -19,6 +19,7 @@ module Network.Hackage.CabalInstall.Fetch
, packageFile
, packagesDirectory
, isFetched
+ , readURI
) where
import Network.URI (URI,parseURI,uriScheme,uriPath)
@@ -40,15 +41,27 @@ import Text.ParserCombinators.ReadP (readP_to_S)
import Distribution.ParseUtils (parseDependency)
+readURI :: URI -> IO String
+readURI uri
+ | uriScheme uri == "file:" = (readFile $ uriPath uri)
+ | otherwise = do
+ eitherResult <- simpleHTTP (Request uri GET [] "")
+ case eitherResult of
+ Left err -> fail $ printf "Failed to download '%s': %s" (show uri) (show err)
+ Right rsp
+ | rspCode rsp == (2,0,0) -> return (rspBody rsp)
+ | otherwise -> fail $ "Failed to download '" ++ show uri ++ "': Invalid HTTP code: " ++ show (rspCode rsp)
+
downloadURI :: FilePath -- ^ Where to put it
-> URI -- ^ What to download
-> IO (Maybe ConnError)
-downloadURI path uri | uriScheme uri == "file:" = do
- copyFile (uriPath uri) path
- return Nothing
downloadURI path uri
- = do eitherResult <- simpleHTTP request
- case eitherResult of
+ | uriScheme uri == "file:" = do
+ copyFile (uriPath uri) path
+ return Nothing
+ | otherwise = do
+ eitherResult <- simpleHTTP request
+ case eitherResult of
Left err -> return (Just err)
Right rsp
| rspCode rsp == (2,0,0) -> writeFile path (rspBody rsp) >> return Nothing
@@ -70,7 +83,7 @@ downloadPackage :: ConfigFlags -> PackageIdentifier -> String -> IO String
downloadPackage cfg pkg url
= do mbError <- downloadFile path url
case mbError of
- Just err -> error $ printf "Failed to download '%s': %s" (showPackageId pkg) (show err)
+ Just err -> fail $ printf "Failed to download '%s': %s" (showPackageId pkg) (show err)
Nothing -> return path
where path = configConfPath cfg `joinFileName` packagesDirectoryName `joinFileName` showPackageId pkg
diff --git a/Network/Hackage/Client.hs b/Network/Hackage/Client.hs
index 08232e5560..c41f0e8ebe 100644
--- a/Network/Hackage/Client.hs
+++ b/Network/Hackage/Client.hs
@@ -1,5 +1,6 @@
module Network.Hackage.Client where
+import Network.URI (URI,parseURI,uriScheme,uriPath)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Version
@@ -8,6 +9,7 @@ import Data.Maybe
import Text.ParserCombinators.ReadP
import Distribution.ParseUtils
import Network.Hackage.CabalInstall.Types
+import Network.Hackage.CabalInstall.Fetch (readURI)
type PathName = String
@@ -62,13 +64,12 @@ getPkgLocation url pkgId = return . Just $ url ++ "/" ++ pathOf pkgId "tar.gz"
getServerVersion :: String -> IO Version
getServerVersion url = fail "getServerVersion not implemented" -- remote url "getServerVersion"
-
getFrom :: String -> String -> IO String
-getFrom ('f':'i':'l':'e':':':'/':'/':base) path = do
- readFile $ base ++ "/" ++ path
-getFrom base path = fail $ "Cannot handle " ++ base ++ "/" ++ path
-
-
+getFrom base path = case parseURI uri of
+ Just parsed -> readURI parsed
+ Nothing -> fail $ "Failed to parse url: " ++ show uri
+ where
+ uri = base ++ "/" ++ path
{-
isCompatible :: String -> IO Bool
--
GitLab