Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
69 lines (54 sloc) 2.08 KB
module CabalIndex
( buildDatabase
, queryPackages)
where
import Control.Monad
import System.Directory (renameFile)
import System.FilePath ((</>))
import System.Process (readProcess)
import Database.HDBC
import Database.HDBC.Sqlite3
import qualified Data.List as L
{-| Insert packages into table -}
populate :: IConnection c => c -> [(String, String)] -> IO ()
populate conn ps =
do stmt <- prepare conn "INSERT INTO packages VALUES (?, ?)"
executeMany stmt $ map (\(n,m) -> [toSql n, toSql m]) ps
{-| Create table for packages -}
createTable :: IConnection c => c -> IO ()
createTable conn =
void $ run conn "CREATE TABLE packages (name VARCHAR(16) PRIMARY KEY, meta VARCHAR(128))" []
{-| Create and populate a new database, replacing the old -}
buildDatabase :: FilePath -> String -> IO ()
buildDatabase dbDir dbName =
do -- place tmp file in same dir as db to allow atomic move
let tmpDb = dbDir </> dbName ++ "-partial"
-- build database in temporary path
conn <- connectSqlite3 tmpDb
createTable conn
populate conn =<< parseCabal
-- commit and disconnect
commit conn
disconnect conn
-- move new database over old one
renameFile tmpDb $ dbDir </> dbName
{-| Query a database, using the output from Cabal -}
queryPackages :: FilePath -> String -> IO [(String, String)]
queryPackages db term =
do conn <- connectSqlite3 db
rows <- quickQuery conn "SELECT * FROM packages WHERE name LIKE ?" [toSql $ '%':term++"%"]
return $ map (\[n,m] -> (fromSql n :: String, fromSql m :: String)) rows
{-| List packages using Cabal and parse the result to (name, meta) -}
parseCabal :: IO [(String, String)]
parseCabal = go `fmap` lines `fmap` readProcess "cabal" ["list"] []
where
go [] = []
go (('*':' ':name):rest) =
let (meta, rest') = gm [] rest
in (name, L.intercalate "\n" meta) : go rest'
go l = error $ "Unexpected cabal output" ++ show l
gm m [] = (m, [])
gm m (rest@(('*':_):_)) = (m, rest)
gm m (x:xs)
| L.null x = gm m xs
| otherwise = gm (m ++ [x]) xs
Something went wrong with that request. Please try again.