Permalink
Browse files

GPG support and code beautification for HackPort

  • Loading branch information...
der_eq@freenet.de
der_eq@freenet.de committed Sep 11, 2005
1 parent f02e7f7 commit 29a2daa93f2e21a066236de4f69ce598842fa85d
Showing with 137 additions and 56 deletions.
  1. +35 −0 HackPort/Error.hs
  2. +54 −19 HackPort/Fetch.hs
  3. +27 −25 HackPort/GenerateEbuild.hs
  4. +16 −10 HackPort/Main.hs
  5. +5 −2 HackPort/TarUtils.hs
View
@@ -0,0 +1,35 @@
+{-# OPTIONS -fglasgow-exts #-}
+module Error where
+
+import Data.Typeable
+import Distribution.Package
+
+data HackPortError
+ = ConnectionFailed String
+ | PackageNotFound
+ | InvalidTarballURL String String
+ | InvalidSignatureURL String String
+ | VerificationFailed String String
+ | DownloadFailed String String
+ | UnknownCompression String
+ | UnpackingFailed String Int
+ | NoCabalFound String
+ | ExtractionFailed String String Int
+ | CabalParseFailed String String
+ deriving (Typeable)
+
+type HackPortResult a = Either
+
+hackPortShowError :: String -> Maybe PackageIdentifier -> HackPortError -> String
+hackPortShowError server package err = case err of
+ ConnectionFailed reason -> "Connection to hackage server '"++server++"' failed: "++reason
+ PackageNotFound -> "Package '"++(maybe "" show package)++"' not found on server"
+ InvalidTarballURL url reason -> "Error while downloading tarball '"++url++"': "++reason
+ InvalidSignatureURL url reason -> "Error while downloading signature '"++url++"': "++reason
+ VerificationFailed file signature -> "Error while checking signature('"++signature++"') of '"++file++"'"
+ DownloadFailed url reason -> "Error while downloading '"++url++"': "++reason
+ UnknownCompression tarball -> "Couldn't guess compression type of '"++tarball++"'"
+ UnpackingFailed tarball code -> "Unpacking '"++tarball++"' failed with exit code '"++show code++"'"
+ NoCabalFound tarball -> "Tarball '"++tarball++"' doesn't contain a cabal file"
+ ExtractionFailed tarball file code -> "Extracting '"++file++"' from '"++tarball++"' failed with '"++show code++"'"
+ CabalParseFailed file reason -> "Error while parsing cabal file '"++file++"': "++reason
View
@@ -1,39 +1,74 @@
-module Fetch(downloadFile) where
+module Fetch(downloadTarball,downloadFileVerify) where
+
+import Prelude hiding (catch)
import Network.HTTP (ConnError(..),Request(..),simpleHTTP
,Response(..),RequestMethod(..))
import Network.URI (URI,uriPath,parseURI)
import Text.Regex (Regex,mkRegex,matchRegex)
+import System.GPG
+import Control.Exception
+import System.Directory
+import Data.Typeable
+
+import Error
filenameRegex :: Regex
filenameRegex = mkRegex "^.*?/([^/]*?)"
uriToFileName :: URI -> Maybe FilePath
uriToFileName uri = maybe Nothing (\x->Just (head x)) (matchRegex filenameRegex (uriPath uri))
-downloadURI :: FilePath --where to put(directory)
- -> URI --where to get
- -> IO (Either ConnError FilePath)
+downloadURI :: FilePath -- ^ a directory to store the file
+ -> URI -- ^ the url
+ -> IO FilePath -- ^ the path of the downloaded file
downloadURI path uri = do
- case uriToFileName uri of
- Nothing -> return (Left (ErrorMisc ("URI doesn't contain a failname")))
- Just name -> do
- result <- simpleHTTP request
- case result of
- Left err -> return (Left err)
- Right rsp
- | rspCode rsp == (2,0,0) -> let respath=path++"/"++name in writeFile respath (rspBody rsp) >> return (Right respath)
- | otherwise -> return (Left (ErrorMisc ("Invalid HTTP code: " ++ show (rspCode rsp))))
+ fileName <- maybe (throwDyn $ InvalidTarballURL (show uri) "URL doesn't contain a filename") return (uriToFileName uri)
+ httpResult <- simpleHTTP request
+ Response {rspCode=code,rspBody=body,rspReason=reason} <- either (\x->throwDyn $ DownloadFailed (show uri) "Connection failed") return httpResult
+ if code==(2,0,0) then (do
+ let writePath=path++"/"++fileName
+ writeFile writePath body
+ return writePath) else throwDyn $ DownloadFailed (show uri) ("Code "++show code++":"++reason)
where
request = Request
{rqURI=uri
,rqMethod=GET
,rqHeaders=[]
,rqBody=""}
-downloadFile :: FilePath
- -> String
- -> IO (Either ConnError FilePath)
-downloadFile path url = case parseURI url of
- Just parsed -> downloadURI path parsed
- Nothing -> return (Left (ErrorMisc ("Failed to parse url: " ++ show url)))
+
+downloadFileVerify ::
+ FilePath -> -- ^ the directory to store the files
+ String -> -- ^ the url of the tarball
+ String -> -- ^ the url of the signature
+ IO (FilePath,FilePath) -- ^ the tarballs and signatures path
+downloadFileVerify path url sigurl = do
+ tarballPath <- downloadTarball path url
+ sigPath <- downloadSig path sigurl `catch` (\x->removeFile tarballPath >> throwDyn x)
+ verified <- verifyFile stdOptions tarballPath sigPath
+ if verified then return (tarballPath,sigPath) else (do
+ removeFile tarballPath
+ removeFile sigPath
+ throwDyn $ VerificationFailed url sigurl)
+
+downloadTarball ::
+ FilePath ->
+ String ->
+ IO FilePath
+downloadTarball dir url = download dir url InvalidTarballURL
+
+downloadSig ::
+ FilePath ->
+ String ->
+ IO FilePath
+downloadSig dir url = download dir url InvalidSignatureURL
+
+download :: Typeable x =>
+ FilePath -> -- ^ the folder to store the file in
+ String -> -- ^ the url
+ (String -> String -> x) -> -- ^ a function to construct an error
+ IO FilePath -- ^ the resulting file's path
+download dir url errFunc = do
+ parsedURL <- maybe (throwDyn $ errFunc url "Parsing failed") return (parseURI url)
+ downloadURI dir parsedURL
View
@@ -3,6 +3,10 @@ module GenerateEbuild where
import Cabal2Ebuild
import Fetch
import TarUtils
+import Error
+
+import Prelude hiding (catch)
+import Control.Exception
import Network.Hackage.Client as Hackage
import Distribution.PackageDescription
import Distribution.Package
@@ -14,28 +18,26 @@ mergeEbuild target category ebuild = do
createDirectoryIfMissing True epath
writeFile (epath++"/"++(name ebuild)++"-"++(version ebuild)++".ebuild") (showEBuild ebuild)
-hackage2ebuild :: FilePath -> String -> FilePath -> PackageIdentifier -> IO (Either String EBuild)
--- | | | \the package
--- | | \a temp path to store the tarball
--- | \the server
--- \the tar executable
-hackage2ebuild tarCommand server store pkg = do
- result <- Hackage.getPkgLocation server pkg
- case result of
- Nothing -> return (Left "Package not found on Hackage Server")
- Just (tarball,sig) -> do
- downloadres <- downloadFile store tarball
- case downloadres of
- Left err -> return (Left (show err))
- Right tarballloc -> do
- case tarballGetType tarball of
- Nothing -> return $ Left "Couldn't guess compression type of tarball"
- Just tarType -> do
- files <- tarballGetFiles tarCommand tarballloc tarType
- case findCabal files of
- Nothing -> return $ Left "No cabal file found in tarball"
- Just (caballoc,cabalname) -> do
- cabalfile <- tarballExtractFile tarCommand tarballloc tarType (caballoc++"/"++cabalname)
- case parseDescription cabalfile of
- ParseFailed err -> return $ Left ("Parsing '"++cabalname++"' failed: "++(showError err))
- ParseOk descr -> return $ Right ((cabal2ebuild descr) {src_uri=tarball,cabalPath=Just caballoc})
+hackage2ebuild ::
+ FilePath -> -- ^ the tar executable
+ String -> -- ^ the hackage server
+ FilePath -> -- ^ a temp path to store the tarball
+ Bool -> -- ^ gpg verify the package?
+ PackageIdentifier -> -- ^ the package
+ IO EBuild
+hackage2ebuild tarCommand server store verify pkg = do
+ resolvedPackage <- Hackage.getPkgLocation server pkg `catch` (\x->throwDyn $ ConnectionFailed (show x))
+ (tarball,sig) <- maybe (throwDyn PackageNotFound) return resolvedPackage
+ tarballPath <- if verify then (do
+ (tarPath,sigPath) <- downloadFileVerify store tarball sig
+ removeFile sigPath
+ return tarPath) else downloadTarball store tarball
+ tarType <- maybe (removeFile tarballPath >> throwDyn (UnknownCompression tarball)) return (tarballGetType tarballPath)
+ filesInTarball <- tarballGetFiles tarCommand tarballPath tarType `catch` (\x->removeFile tarballPath >> throw x)
+ (cabalDir,cabalName) <- maybe (throwDyn $ NoCabalFound tarball) return (findCabal filesInTarball)
+ cabalFile <- tarballExtractFile tarCommand tarballPath tarType (cabalDir++"/"++cabalName)
+ packageDescription <- case parseDescription cabalFile of
+ ParseFailed err -> throwDyn $ CabalParseFailed cabalName (showError err)
+ ParseOk descr -> return descr
+ let ebuild=cabal2ebuild (packageDescription{pkgUrl=tarball}) --we don't trust the cabal file as we just successfully downloaded the tarbal somewhere
+ return $ ebuild {cabalPath=Just cabalDir}
View
@@ -5,6 +5,9 @@ import System.Environment
import System.Exit
import Distribution.Package
import Data.Version
+import Control.Exception
+import Data.Typeable
+import Error
import Query
import GenerateEbuild
import Cabal2Ebuild
@@ -15,6 +18,7 @@ data HackPortOptions
| Category String
| Server String
| TempDir String
+ | Verify
data OperationMode
= Query String
@@ -28,6 +32,7 @@ data Config = Config
, portageCategory ::String
, server ::String
, tmp ::String
+ , verify ::Bool
}
defaultConfig :: Config
@@ -37,24 +42,27 @@ defaultConfig = Config
, portageCategory = "dev-haskell"
, server = "http://hackage.haskell.org/ModHackage/Hackage.hs?action=xmlrpc"
, tmp = "/tmp"
+ , verify = False
}
options :: [OptDescr HackPortOptions]
-options = [Option ['t'] ["tar"] (ReqArg TarCommand "PATH") "Path to the \"tar\" executable"
- ,Option ['p'] ["portage-tree"] (ReqArg PortageTree "PATH") "The portage tree to merge to"
+options = [Option ['p'] ["portage-tree"] (ReqArg PortageTree "PATH") "The portage tree to merge to"
,Option ['c'] ["portage-category"] (ReqArg Category "CATEGORY") "The cateory the program belongs to"
,Option ['s'] ["server"] (ReqArg Server "URL") "The Hackage server to query"
- ,Option [] ["temp-dir"] (ReqArg TempDir "PATH") "A temp directory where tarballs can be stored"
+ ,Option ['t'] ["temp-dir"] (ReqArg TempDir "PATH") "A temp directory where tarballs can be stored"
+ ,Option [] ["tar"] (ReqArg TarCommand "PATH") "Path to the \"tar\" executable"
+ ,Option [] ["verify"] (NoArg Verify) "Verify downloaded tarballs using GnuPG"
]
optionsToConfig :: Config -> [HackPortOptions] -> Config
optionsToConfig cfg [] = cfg
-optionsToConfig cfg (x:xs) = case x of
+optionsToConfig cfg (x:xs) = optionsToConfig (case x of
TarCommand str -> cfg { tarCommand = str }
PortageTree str -> cfg { portageTree = str }
Category str -> cfg { portageCategory = str }
Server str -> cfg { server = str }
TempDir str -> cfg { tmp = str }
+ Verify -> cfg { verify = True }) xs
parseConfig :: [String] -> Either String (Config,OperationMode)
parseConfig opts = case getOpt Permute options opts of
@@ -85,10 +93,8 @@ merge cfg name vers = do
case parseVersion' vers of
Nothing -> putStr ("Error: couldn't parse version number '"++vers++"'\n")
Just realvers -> do
- result <- hackage2ebuild (tarCommand cfg) (server cfg) (tmp cfg) (PackageIdentifier {pkgName=name,pkgVersion=realvers})
- case result of
- Left err -> putStr ("Error: "++err)
- Right ebuild -> mergeEbuild (portageTree cfg) (portageCategory cfg) ebuild
+ ebuild <- hackage2ebuild (tarCommand cfg) (server cfg) (tmp cfg) (verify cfg) (PackageIdentifier {pkgName=name,pkgVersion=realvers})
+ mergeEbuild (portageTree cfg) (portageCategory cfg) ebuild
main :: IO ()
main = do
@@ -97,8 +103,8 @@ main = do
Left err -> do
putStr err
exitWith (ExitFailure 1)
- Right (config,mode) -> case mode of
+ Right (config,mode) -> (case mode of
ShowHelp -> usage
ListAll -> listAll config
Query pkg -> query config pkg
- Merge pkg vers -> merge config pkg vers
+ Merge pkg vers -> merge config pkg vers) `catchDyn` (\x->putStr ((hackPortShowError (server config) Nothing x)++"\n"))
View
@@ -6,6 +6,9 @@ module TarUtils
,tarballExtractFile
) where
+import Error
+
+import Control.Exception
import System.Process (runInteractiveProcess, waitForProcess)
import System.IO (hClose, hGetContents)
import Text.Printf (printf)
@@ -48,7 +51,7 @@ tarballGetFiles tarCommand tarball tartype = do
length files `seq` hClose outch
exitCode <- waitForProcess handle
case exitCode of
- ExitFailure err -> error $ printf "Failed to get filelist from '%s': %s." tarball (show err)
+ ExitFailure err -> throwDyn $ UnpackingFailed tarball err
ExitSuccess -> return (lines files)
where
args = ["--list"
@@ -74,7 +77,7 @@ tarballExtractFile tarCommand tarball tarType file = do
length res `seq` hClose outch
exitCode <- waitForProcess handle
case exitCode of
- ExitFailure err -> error $ printf "Failed to extract file '%s' from '%s': %s." file tarball (show err)
+ ExitFailure err -> throwDyn $ ExtractionFailed file tarball err
ExitSuccess -> return res
where
args = ["--to-stdout"

0 comments on commit 29a2daa

Please sign in to comment.