packages feed

hellage (empty) → 0.1

raw patch · 5 files changed

+255/−0 lines, 5 filesdep +HTTPdep +Lucudep +basesetup-changed

Dependencies added: HTTP, Lucu, base, bytestring, containers, directory, hellnet, hjpath, hjson, mtl, network, regex-pcre, safe, stm, tar, utf8-string, zlib

Files

+ COPYING view
@@ -0,0 +1,13 @@+Copyright (c) 2009, Voker57++All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++The name of author may not be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runghc+import Distribution.Simple+main = defaultMain
+ hellage-genmeta.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE ViewPatterns, BangPatterns #-}++import qualified Codec.Compression.GZip as GZip+import qualified Codec.Archive.Tar as Tar+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.UTF8 as BUL+import qualified Data.Map as Map+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM+import Control.Exception (evaluate)+import Control.Monad+import Data.List+import Data.Maybe+import Hellnet.Meta+import Hellnet.Network+import Hellnet.Storage+import Hellnet.Utils+import Network.HTTP+import Hellnet+import Safe+import System.Directory+import System.Environment+import System.IO+import Text.HJson as JSON+import Text.JSON.JPath+++filterNormals a xs = xs ++ [Tar.entryPath a]++queryNodeG :: String -> Node -> IO (Maybe BS.ByteString)+queryNodeG s node = do+	rep <- ((return . Just) =<< simpleHTTP (mkRequest GET $ mkUrl node s)) `catch` const (return Nothing)+	return $ maybe Nothing (either (const Nothing) (\rsp -> if rspCode rsp == (2,0,0) then Just (rspBody rsp) else Nothing)) rep++main = do+	hSetBuffering stdout NoBuffering+	args <- getArgs+	let tempFileName = "/tmp/hellage-temp.json"+	case args of+		[keyname, metaname] -> do+			keyId <- resolveKeyName $ keyname+			putStrLn "Getting index..."+			targz <- queryNodeGet "/packages/archive/00-index.tar.gz" ("hackage.haskell.org", 80) >>= (return . fromMaybe (error "Couldn't download index"))+			indexLink <- insertData Nothing targz+			let tar = GZip.decompress targz+			let entries = Tar.foldEntries (filterNormals) [] (error "Tar unpacking error") $ Tar.read tar+			hellageMetaM <- getMeta keyId metaname+			let hellageMeta = fromMaybe (emptyMeta {+				metaName = metaname,+				keyID = keyId+				}) hellageMetaM+			metaContentM <- findMetaContent hellageMeta+			let metaContentClean = fromMaybe (JObject Map.empty) metaContentM+			let metaContent = jPathModify' "index" (const $ JString $ show indexLink) metaContentClean+			!jsP <- catch (readFile tempFileName) (const $ return "{}")+			let jsParsed = fromMaybe (either (const JNull) (id) $ fromString jsP)+				$ headMay $ jPath' "packages" metaContent+			metaVar <- atomically $ newTVar jsParsed+			let getPackageTar _ path = case explode '/' path of+				[".", package, version, _] -> do+					js <- atomically $ readTVar metaVar+					case jPath' (intercalate "/" [package,version]) js of+						[_] -> do+							putStrLn $ "Found in temp:" ++ show (package, version)+						[] -> do+							let queryString = "/packages/archive/" ++ package ++ "/" ++ version ++ "/" ++ package ++ "-" ++ version ++ ".tar.gz"+							putStr $ "Getting " ++ queryString ++ "..."+							packagetarM <- queryNodeG queryString ("hackage.haskell.org", 80)+							putStrLn "got."+							case packagetarM of+								Just packagetar -> do+									putStr $ "Inserting " ++ show (package, version) ++ "..."+									packageURI <- insertData Nothing $ BSL.pack $ BS.unpack $ packagetar+									putStr "Writing JSON..."+									let js' = jPathModify' (intercalate "/" [package,version]) (const $ JString $ show $ packageURI) js+									writeFile tempFileName $ JSON.toString js'+									atomically $ writeTVar metaVar js'+									putStrLn "wrote."+									return ()+								otherwise -> return ()+							return ()+				otherwise -> return ()+			foldM (getPackageTar) () entries+			finalJs <- catch (readFile tempFileName) (const $ return $ JSON.toString metaContent) >>= return . either (const $ JObject Map.empty) (id) . JSON.fromString+			newMetaURI <- insertData Nothing $ BUL.fromString $ JSON.toString $ jPathModify' "packages" (const finalJs) metaContent+			newMeta <- regenMeta hellageMeta { contentURI = newMetaURI }+			case newMeta of+				Nothing -> error "Failed to sign meta. Check if you have private key."+				Just m -> do+					storeMeta m+					catch (removeFile tempFileName) (const $ return ())+					putStrLn "Success."+		otherwise -> error "Usage: genMeta.hs <key id or alias> <meta name>"
+ hellage.cabal view
@@ -0,0 +1,18 @@+Name: hellage+Version: 0.1+Synopsis: Distributed hackage mirror+Author: Voker57+Maintainer: voker57@gmail.com+Build-type: Simple+Cabal-version: >= 1.4+Stability: experimental+License: BSD3+License-file: COPYING+Category: Distribution, Network+Description: Distributed hackage mirror, based on Hellnet.+Executable hellage+ Main-is: hellage.hs+ Build-Depends: hellnet >= 0.1, Lucu >= 0.3.2, network, base >= 4.2 && < 5, hjson >= 1.1.1, hjpath >= 2.0, regex-pcre, safe, mtl, bytestring+Executable hellage-genmeta+ Main-is: hellage-genmeta.hs+ Build-Depends: hellnet >= 0.1, hjpath >= 2.0, hjson >= 1.1.1, base (>= 4.2), mtl, safe, bytestring, HTTP, stm, containers, utf8-string, tar, zlib, directory, safe
+ hellage.hs view
@@ -0,0 +1,127 @@+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Trans+import Data.List+import qualified Data.Map as Map+import Data.Maybe+import Hellnet.Meta+import Hellnet.Storage+import Hellnet.Network+import Hellnet.URI+import Hellnet.Utils+import Network.HTTP.Lucu+import Network.HTTP.Lucu.MIMEType+import qualified Data.ByteString.Lazy as BSL+import Network+import Safe+import System.Console.GetOpt+import System.Environment+import Text.JSON.JPath+import Text.HJson+import Text.Regex.PCRE++data Opts = Opts { serverPort :: PortNumber }++defaultOptions = Opts { serverPort = 6609 }++options :: [OptDescr (Opts -> Opts)]+options = [+	Option ['p'] ["port"]+		(ReqArg (\s o -> o {serverPort = maybe (error "Couldn't parse port number") (fromIntegral) $ readMay s}) "<port>") "Server port to listen on"+	]++main = do+	(optz, argz, errs) <- return . getOpt Permute options =<< getArgs+	let opts = processOptions defaultOptions optz+	case argz of+		[keyIdHex, mname] -> do+			keyid <- resolveKeyName keyIdHex+			runHellage keyid mname $ serverPort opts++serve jsDataVar packageName packageVersion = do+	jsData <- liftIO $ atomically $ readTVar jsDataVar+	case jPath' (intercalate "/" ["packages", packageName, packageVersion]) jsData of+		[] -> setStatus NotFound+		[JString uS] -> do+			case parseHellnetURI uS of+				Nothing -> error "Broken hellnet URI!"+				Just u -> do+					datM <- liftIO $ findURI u+					case datM of+						Nothing -> setStatus InternalServerError+						Just d -> do+							setContentType $ parseMIMEType "application/x-gzip"+							outputLBS d+++packageHandler jsDataVar = do+	pInfo <- getPathInfo+	case pInfo of+		[packageTar] -> do+			case headMay $ (packageTar =~ "(.*)-(.*)\\.tar\\.gz" :: [[String]]) of+				Just [_, packageName, packageVersion] -> serve jsDataVar packageName packageVersion+				otherwise -> setStatus BadRequest+		otherwise -> do+			setStatus NotFound++indexHandler jsDataVar = do+	jsData <- liftIO $ atomically $ readTVar jsDataVar+	case jPath' "index" jsData of+		[] -> setStatus InternalServerError+		[JString uS] -> case parseHellnetURI uS of+			Nothing -> error "Broken hellnet URI!"+			Just u -> do+				datM <- liftIO $ findURI u+				case datM of+					Nothing -> setStatus InternalServerError+					Just d -> do+						setContentType $ parseMIMEType "application/x-gzip"+						outputLBS d++updateHandler jsDataVar keyid mname = do+	liftIO $ fetchMeta keyid mname+	jsDataM <- liftIO $ findMetaContentByName keyid mname+	case jsDataM of+		Nothing -> output "Failed"+		Just jsData -> do+			liftIO $ atomically $ writeTVar jsDataVar jsData+			output "Success"++runHellage keyid mname serverPort = do+	jsData <- findMetaContentByName keyid mname >>=+		return . fromMaybe (JObject $ Map.empty)+	jsDataVar <- atomically $ newTVar jsData+	let packageRes = ResourceDef {+		resUsesNativeThread = False,+		resIsGreedy = True,+		resGet = Just $ packageHandler jsDataVar,+		resHead = Nothing,+		resPost = Nothing,+		resPut = Nothing,+		resDelete = Nothing+		}+	let indexRes = ResourceDef {+		resUsesNativeThread = False,+		resIsGreedy = False,+		resGet = Just $ indexHandler jsDataVar,+		resHead = Nothing,+		resPost = Nothing,+		resPut = Nothing,+		resDelete = Nothing+		}+	let updateRes = ResourceDef {+		resUsesNativeThread = False,+		resIsGreedy = False,+		resGet = Just $ updateHandler jsDataVar keyid mname,+		resHead = Nothing,+		resPost = Nothing,+		resPut = Nothing,+		resDelete = Nothing+		}+	let resources = mkResTree [+		(["package"], packageRes),+		(["00-index.tar.gz"], indexRes),+		(["update"], updateRes)+		]+	let config = defaultConfig { cnfServerPort = PortNumber serverPort };+	runHttpd config resources []