{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module BDCS.Import.Repodata(RepoException,
loadFromURI,
loadRepoFromURI)
where
import Control.Applicative((<|>))
import Control.Exception(Exception)
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Reader(ReaderT)
import Control.Monad.Trans.Resource(MonadBaseControl, MonadThrow)
import Data.Conduit((.|), runConduitRes)
import Data.Data(Typeable)
import Data.Maybe(listToMaybe)
import qualified Data.Text as T
import Network.URI(URI(..))
import Text.XML(Document, sinkDoc)
import Text.XML.Cursor
import Text.XML.Stream.Parse(def)
import BDCS.Exceptions(throwIfNothing)
import qualified BDCS.Import.Comps as Comps
import BDCS.Import.Conduit(getFromURI, ungzipIfCompressed)
import qualified BDCS.Import.RPM as RPM
import BDCS.Import.State(ImportState(..))
import BDCS.Import.URI(appendURI, baseURI)
data RepoException = RepoException
deriving(Show, Typeable)
instance Exception RepoException
extractLocations :: Document -> [T.Text]
extractLocations doc = let
cursor = fromDocument doc
in
cursor $// laxElement "location"
>=> hasAttribute "href"
>=> attribute "href"
extractType :: Document -> T.Text -> Maybe T.Text
extractType doc dataType = let
cursor = fromDocument doc
in
listToMaybe $ cursor $/ laxElement "data" >=>
attributeIs "type" dataType &/
laxElement "location" >=>
attribute "href"
fetchAndParse :: (MonadThrow m, MonadIO m, MonadBaseControl IO m) => URI -> m Document
fetchAndParse uri = runConduitRes $ getFromURI uri .| ungzipIfCompressed .| sinkDoc def
addSlash :: URI -> URI
addSlash u = let
path = uriPath u
in
if last path /= '/' then
u { uriPath = path ++ "/" }
else
u
loadRepoFromURI :: URI -> ReaderT ImportState IO ()
loadRepoFromURI uri = do
repomd <- fetchAndParse (appendOrThrow "repodata/repomd.xml")
let primary = extractType repomd "primary" `throwIfNothing` RepoException
loadFromURI $ appendOrThrow primary
let group = extractType repomd "group_gz" <|> extractType repomd "group"
let groupURI = fmap appendOrThrow group
case groupURI of
Just u -> Comps.loadFromURI u
Nothing -> return ()
where
appendOrThrow :: T.Text -> URI
appendOrThrow path = appendURI (addSlash uri) (T.unpack path) `throwIfNothing` RepoException
loadFromURI :: URI -> ReaderT ImportState IO ()
loadFromURI metadataURI = do
document <- fetchAndParse metadataURI
let locations = map appendOrThrow $ extractLocations document
mapM_ RPM.loadFromURI locations
where
appendOrThrow :: T.Text -> URI
appendOrThrow path = appendURI (baseURI metadataURI) (T.unpack path) `throwIfNothing` RepoException