Commit 65a2260a authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Use proper URI type rather than String

parent 20ce7327
......@@ -28,9 +28,11 @@ import Control.Monad (when)
import Data.Monoid (Monoid(..))
import System.Directory (createDirectoryIfMissing, getAppUserDataDirectory)
import System.FilePath ((</>), takeDirectory)
import Network.URI (parseAbsoluteURI, uriToString)
import Text.PrettyPrint.HughesPJ (text)
import Distribution.Compat.ReadP (ReadP, char, munch1)
import Distribution.Compat.ReadP as ReadP
( ReadP, char, munch1, pfail )
import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor)
import Distribution.ParseUtils
( FieldDescr(..), simpleField, listField, liftField, field
......@@ -150,9 +152,9 @@ defaultSavedConfig =
}
defaultRemoteRepo :: RemoteRepo
defaultRemoteRepo =
RemoteRepo "hackage.haskell.org"
"http://hackage.haskell.org/packages/archive"
defaultRemoteRepo = RemoteRepo "hackage.haskell.org" uri
where
Just uri = parseAbsoluteURI "http://hackage.haskell.org/packages/archive"
--
-- * Config file reading
......@@ -262,11 +264,16 @@ modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a
modifyFieldName f d = d { fieldName = f (fieldName d) }
showRepo :: RemoteRepo -> String
showRepo repo = remoteRepoName repo ++ ":" ++ remoteRepoURL repo
showRepo repo = remoteRepoName repo ++ ":"
++ uriToString id (remoteRepoURI repo) []
parseRepo :: ReadP r RemoteRepo
parseRepo = do name <- munch1 (\c -> isAlphaNum c || c `elem` "_-.")
char ':'
url <- munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")
return $ RemoteRepo { remoteRepoName = name, remoteRepoURL = url }
uriStr <- munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")
uri <- maybe ReadP.pfail return (parseAbsoluteURI uriStr)
return $ RemoteRepo {
remoteRepoName = name,
remoteRepoURI = uri
}
......@@ -20,12 +20,13 @@ module Hackage.Fetch
, downloadIndex
) where
import Network.URI (URI,parseURI,uriScheme,uriPath)
import Network.URI
( URI(uriScheme, uriPath) )
import Network.HTTP (ConnError(..), Response(..))
import Hackage.Types
( UnresolvedDependency (..), AvailablePackage(..)
, AvailablePackageSource(..), Repo(..), repoURL )
, AvailablePackageSource(..), Repo(..), repoURI )
import Hackage.Dependency
( resolveDependencies, PackagesVersionPreference(..) )
import qualified Hackage.IndexUtils as IndexUtils
......@@ -72,25 +73,15 @@ downloadURI verbosity path uri
>> return Nothing
| otherwise -> return (Just (ErrorMisc ("Invalid HTTP code: " ++ show (rspCode rsp))))
downloadFile :: Verbosity
-> FilePath
-> String
-> IO (Maybe ConnError)
downloadFile verbosity path url
= case parseURI url of
Just parsed -> downloadURI verbosity path parsed
Nothing -> return (Just (ErrorMisc ("Failed to parse url: " ++ show url)))
-- Downloads a package to [config-dir/packages/package-id] and returns the path to the package.
downloadPackage :: Verbosity -> AvailablePackage -> IO String
downloadPackage verbosity pkg
= do let url = packageURL pkg
= do let uri = packageURI pkg
dir = packageDir pkg
path = packageFile pkg
debug verbosity $ "GET " ++ show url
debug verbosity $ "GET " ++ show uri
createDirectoryIfMissing True dir
mbError <- downloadFile verbosity path url
mbError <- downloadURI verbosity path uri
case mbError of
Just err -> die $ "Failed to download '" ++ display (packageId pkg) ++ "': " ++ show err
Nothing -> return path
......@@ -98,11 +89,14 @@ downloadPackage verbosity pkg
-- Downloads an index file to [config-dir/packages/serv-id].
downloadIndex :: Verbosity -> Repo -> IO FilePath
downloadIndex verbosity repo
= do let url = repoURL repo ++ "/" ++ "00-index.tar.gz"
= do let uri = (repoURI repo) {
uriPath = uriPath (repoURI repo)
++ "/" ++ "00-index.tar.gz"
}
dir = repoCacheDir repo
path = dir </> "00-index" <.> "tar.gz"
createDirectoryIfMissing True dir
mbError <- downloadFile verbosity path url
mbError <- downloadURI verbosity path uri
case mbError of
Just err -> die $ "Failed to download index '" ++ show err ++ "'"
Nothing -> return path
......@@ -162,11 +156,13 @@ packageDir AvailablePackage { packageInfoId = p
</> pkgName p
</> display (pkgVersion p)
-- | Generate the URL of the tarball for a given package.
packageURL :: AvailablePackage -> String
packageURL AvailablePackage { packageInfoId = p
-- | Generate the URI of the tarball for a given package.
packageURI :: AvailablePackage -> URI
packageURI AvailablePackage { packageInfoId = p
, packageSource = RepoTarballPackage repo } =
intercalate "/"
[repoURL repo,
pkgName p, display (pkgVersion p),
display p ++ ".tar.gz"]
(repoURI repo) {
uriPath = intercalate "/"
[uriPath (repoURI repo) ,
pkgName p, display (pkgVersion p),
display p ++ ".tar.gz"]
}
......@@ -59,7 +59,7 @@ data BuildReport
-- | Which hackage server this package is from and thus which server this
-- report should be sent to.
-- server :: String,
-- server :: URI,
-- | The OS and Arch the package was built on
os :: OS,
......
......@@ -18,6 +18,7 @@ import Distribution.Package
import Distribution.PackageDescription
( GenericPackageDescription, FlagAssignment )
import Network.URI (URI)
import Control.Exception
( Exception )
......@@ -46,7 +47,7 @@ instance PackageFixedDeps ConfiguredPackage where
-- | We re-use @GenericPackageDescription@ and use the @package-url@
-- field to store the tarball URL.
-- field to store the tarball URI.
data AvailablePackage = AvailablePackage {
packageInfoId :: PackageIdentifier,
packageDescription :: GenericPackageDescription,
......@@ -75,7 +76,7 @@ data AvailablePackageSource =
data RemoteRepo = RemoteRepo {
remoteRepoName :: String,
remoteRepoURL :: String
remoteRepoURI :: URI
}
deriving (Show,Eq)
......@@ -88,8 +89,8 @@ data Repo = Repo {
repoName :: Repo -> String
repoName = remoteRepoName . repoRemote
repoURL :: Repo -> String
repoURL = remoteRepoURL . repoRemote
repoURI :: Repo -> URI
repoURI = remoteRepoURI . repoRemote
data UnresolvedDependency
= UnresolvedDependency
......
......@@ -31,7 +31,7 @@ update verbosity = mapM_ (updateRepo verbosity)
updateRepo :: Verbosity -> Repo -> IO ()
updateRepo verbosity repo = do
notice verbosity $ "Downloading package list from server '"
++ repoURL repo ++ "'"
++ show (repoURI repo) ++ "'"
indexPath <- downloadIndex verbosity repo
BS.writeFile (dropExtension indexPath) . GZip.decompress
=<< BS.readFile indexPath
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment