haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-26 02:41:56 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Don't recreate view cabal files

Browse Source
This commit is contained in:
Michael Snoyman 2014-04-16 17:38:48 +03:00
parent 45bac17582
commit 1e8dd991bc
1 changed files with 27 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
Data/Hackage.hs
View File

@ -262,29 +262,33 @@ createView viewName modifyCabal src sink = withSystemTempDirectory "createview"
, toPathPiece version , toPathPiece version
, ".cabal" , ".cabal"
]) ])
msrc <- storeRead $ HackageCabal name version let key = HackageViewCabal viewName name version
case msrc of exists <- storeExists key
Nothing -> return mempty if exists
Just src -> do then return mempty
-- FIXME only create a new file if the old one doesn't exist? else do
orig <- src $$ sinkLazy msrc <- storeRead $ HackageCabal name version
new <- case msrc of
case parsePackageDescription $ unpack $ decodeUtf8 orig of Nothing -> return mempty
ParseOk _ gpd -> do Just src -> do
gpd' <- modifyCabal name version time gpd orig <- src $$ sinkLazy
let str = showGenericPackageDescription gpd' new <-
-- sanity check case parsePackageDescription $ unpack $ decodeUtf8 orig of
case parsePackageDescription str of ParseOk _ gpd -> do
ParseOk _ _ -> return $ encodeUtf8 $ pack str gpd' <- modifyCabal name version time gpd
x -> do let str = showGenericPackageDescription gpd'
$logError $ "Created cabal file that could not be parsed: " ++ tshow (x, str) -- sanity check
return orig case parsePackageDescription str of
_ -> return orig ParseOk _ _ -> return $ encodeUtf8 $ pack str
sourceLazy new $$ storeWrite (HackageViewCabal viewName name version) x -> do
let fp = fpFromString dir </> relfp $logError $ "Created cabal file that could not be parsed: " ++ tshow (x, str)
liftIO $ createTree $ directory fp return orig
writeFile fp new _ -> return orig
return $ asSet $ singletonSet relfp sourceLazy new $$ storeWrite key
let fp = fpFromString dir </> relfp
liftIO $ createTree $ directory fp
writeFile fp new
return $ asSet $ singletonSet relfp
sourceHistory :: Monad m => UploadHistory -> Producer m Uploaded sourceHistory :: Monad m => UploadHistory -> Producer m Uploaded
sourceHistory = sourceHistory =