git.iko.soy/stackage
on 67adda6 help sign in
stackage/Stackage/PackageIndex.hs
127 lines 5.4 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE NoImplicitPrelude #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE ViewPatterns #-}
7-- | Dealing with the 00-index file and all its cabal files.
8module Stackage.PackageIndex
9 ( sourcePackageIndex
10 , UnparsedCabalFile (..)
11 , getLatestDescriptions
12 ) where
14import qualified Codec.Archive.Tar as Tar
15import Data.Conduit.Lazy (MonadActive,
16 lazyConsume)
17import qualified Data.Text as T
18import Distribution.PackageDescription (package,
19 packageDescription)
20import Distribution.PackageDescription.Parse (ParseResult (..),
21 parsePackageDescription)
22import Distribution.ParseUtils (PError)
23import Stackage.Prelude
24import System.Directory (getAppUserDataDirectory)
26-- | Name of the 00-index.tar downloaded from Hackage.
27getPackageIndexPath :: MonadIO m => m FilePath
28getPackageIndexPath = liftIO $ do
29 c <- getCabalRoot
30 configLines <- runResourceT $ sourceFile (c </> "config")
31 $$ decodeUtf8C
32 =$ linesUnboundedC
33 =$ concatMapC getRemoteCache
34 =$ sinkList
35 case configLines of
36 [x] -> return $ x </> "hackage.haskell.org" </> "00-index.tar"
37 [] -> error $ "No remote-repo-cache found in Cabal config file"
38 _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file"
39 where
40 getCabalRoot :: IO FilePath
41 getCabalRoot = fpFromString <$> getAppUserDataDirectory "cabal"
43 getRemoteCache s = do
44 ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s
45 Just $ fpFromText $ T.strip v
47-- | A cabal file with name and version parsed from the filepath, and the
48-- package description itself ready to be parsed. It's left in unparsed form
49-- for efficiency.
50data UnparsedCabalFile = UnparsedCabalFile
51 { ucfName :: PackageName
52 , ucfVersion :: Version
53 , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription
54 }
56-- | Stream all of the cabal files from the 00-index tar file.
57sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m)
58 => Producer m UnparsedCabalFile
59sourcePackageIndex = do
60 fp <- getPackageIndexPath
61 -- yay for the tar package. Use lazyConsume instead of readFile to get some
62 -- kind of resource protection
63 lbs <- lift $ fromChunks <$> lazyConsume (sourceFile fp)
64 loop (Tar.read lbs)
65 where
66 loop (Tar.Next e es) = goE e >> loop es
67 loop Tar.Done = return ()
68 loop (Tar.Fail e) = throwM e
70 goE e
71 | Just front <- stripSuffix ".cabal" $ pack $ Tar.entryPath e
72 , Tar.NormalFile lbs _size <- Tar.entryContent e = do
73 (name, version) <- parseNameVersion front
74 yield UnparsedCabalFile
75 { ucfName = name
76 , ucfVersion = version
77 , ucfParse = goContent (Tar.entryPath e) name version lbs
78 }
79 | otherwise = return ()
81 goContent fp name version lbs =
82 case parsePackageDescription $ unpack $ decodeUtf8 lbs of
83 ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e
84 ParseOk _warnings gpd -> do
85 let pd = packageDescription gpd
86 PackageIdentifier name' version' = package pd
87 when (name /= name' || version /= version') $
88 throwM $ MismatchedNameVersion (fpFromString fp)
89 name name' version version'
90 return gpd
92 parseNameVersion t1 = do
93 let (p', t2) = break (== '/') $ T.replace "\\" "/" t1
94 p <- simpleParse p'
95 t3 <- maybe (throwM $ InvalidCabalPath t1 "no slash") return
96 $ stripPrefix "/" t2
97 let (v', t4) = break (== '/') t3
98 v <- simpleParse v'
99 when (t4 /= cons '/' p') $ throwM $ InvalidCabalPath t1 $ "Expected at end: " ++ p'
100 return (p, v)
102data InvalidCabalPath = InvalidCabalPath Text Text
103 deriving (Show, Typeable)
104instance Exception InvalidCabalPath
106data CabalParseException = CabalParseException FilePath PError
107 | MismatchedNameVersion FilePath PackageName PackageName Version Version
108 deriving (Show, Typeable)
109instance Exception CabalParseException
111-- | Get all of the latest descriptions for name/version pairs matching the
112-- given criterion.
113getLatestDescriptions :: MonadIO m
114 => (PackageName -> Version -> Bool)
115 -> (GenericPackageDescription -> IO desc)
116 -> m (Map PackageName desc)
117getLatestDescriptions f parseDesc = liftIO $ do
118 m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty
119 forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc
120 where
121 f' ucf = f (ucfName ucf) (ucfVersion ucf)
122 add m ucf =
123 case lookup name m of
124 Just ucf' | ucfVersion ucf < ucfVersion ucf' -> m
125 _ -> insertMap name ucf m
126 where
127 name = ucfName ucf