hellage-0.1: hellage-genmeta.hs

{-# 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>"