hellage-0.1: hellage.hs

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 []