Untested Hackage views

2026-01-12 04:08:29 +01:00 · 2014-04-13 08:48:58 +03:00 · 2014-04-13 08:48:58 +03:00 · 4f122f6282
commit 4f122f6282
parent 8296c4ad57
5 changed files with 180 additions and 26 deletions
--- a/Application.hs
+++ b/Application.hs
@ -5,7 +5,7 @@ module Application
    , makeFoundation
    ) where

-import Import
+import Import hiding (catch)
 import Settings
 import Yesod.Default.Config
 import Yesod.Default.Main
@ -22,8 +22,14 @@ import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
 import Network.Wai.Logger (clockDateCacher)
 import Yesod.Core.Types (loggerSet, Logger (Logger))
 import qualified System.Random.MWC as MWC
-import Data.BlobStore (fileStore)
+import Data.BlobStore (fileStore, storeWrite)
 import Data.Hackage
+import Data.Hackage.Views
+import Data.Conduit.Lazy (MonadActive, monadActive)
+import Control.Monad.Catch (MonadCatch (..))
+import Database.Persist.Sql (SqlPersistT (..))
+import Control.Monad.Trans.Resource.Internal (ResourceT (..))
+import Control.Monad.Reader (MonadReader (..))

 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@ -35,6 +41,8 @@ import Handler.UploadStackage
 import Handler.StackageHome
 import Handler.StackageIndex
 import Handler.StackageSdist
+import Handler.HackageViewIndex
+import Handler.HackageViewSdist

 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@ -113,8 +121,8 @@ makeFoundation conf = do
    -- Start the cabal file loader
    void $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
        when development $ liftIO $ threadDelay $ 5 * 60 * 1000000
-        eres <- tryAny $ flip runReaderT foundation $ loadCabalFiles
-            $ \name version mmtime ->
+        eres <- tryAny $ flip runReaderT foundation $ do
+            loadCabalFiles $ \name version mmtime ->
                runResourceT $ flip (Database.Persist.runPool dbconf) p $ do
                    mx <- getBy $ UniqueUploaded name version
                    case mx of
@ -122,6 +130,17 @@ makeFoundation conf = do
                        Nothing -> do
                            mtime <- lift $ lift mmtime
                            forM_ mtime $ void . insertBy . Uploaded name version
+            let views =
+                    [ ("pvp", viewPVP)
+                    , ("no-bounds", viewNoBounds)
+                    , ("unchanged", viewUnchanged)
+                    ]
+            forM_ views $ \(name, func) ->
+                runResourceT $ flip (Database.Persist.runPool dbconf) p $ createView
+                    name
+                    func
+                    (selectSource [] [])
+                    (storeWrite $ HackageViewIndex name)
        case eres of
            Left e -> $logError $ tshow e
            Right () -> return ()
@ -129,6 +148,19 @@ makeFoundation conf = do

    return foundation

+instance MonadActive m => MonadActive (SqlPersistT m) where -- FIXME orphan upstream
+    monadActive = lift monadActive
+deriving instance MonadCatch m => MonadCatch (SqlPersistT m)
+instance MonadCatch m => MonadCatch (ResourceT m) where
+  catch (ResourceT m) c = ResourceT $ \r -> m r `catch` \e -> unResourceT (c e) r
+  mask a = ResourceT $ \e -> mask $ \u -> unResourceT (a $ q u) e
+    where q u (ResourceT b) = ResourceT (u . b)
+  uninterruptibleMask a =
+    ResourceT $ \e -> uninterruptibleMask $ \u -> unResourceT (a $ q u) e
+      where q u (ResourceT b) = ResourceT (u . b)
+instance MonadReader env m => MonadReader env (SqlPersistT m) where
+    ask = lift ask
+
 -- for yesod devel
 getApplicationDev :: IO (Int, Application)
 getApplicationDev =
--- a/Data/Hackage.hs
+++ b/Data/Hackage.hs
@ -1,9 +1,10 @@
 module Data.Hackage
    ( loadCabalFiles
    , sourceHackageSdist
+    , createView
    ) where

-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (get)
 import Types
 import Data.BlobStore
 import Data.Conduit.Lazy (MonadActive (..), lazyConsume)
@ -12,7 +13,7 @@ import qualified Codec.Archive.Tar as Tar
 import Control.Monad.Reader (MonadReader, ask)
 import Control.Monad.Trans.Resource (release)
 import qualified Data.Text as T
-import Data.Conduit.Zlib (ungzip)
+import Data.Conduit.Zlib (ungzip, gzip)
 import Text.XML.Cursor (($//), (&/), content, fromDocument, element, followingSibling)
 import Text.HTML.DOM (sinkDoc)
 import System.IO.Temp (withSystemTempFile, withSystemTempDirectory)
@ -20,8 +21,12 @@ import System.IO (IOMode (ReadMode), openBinaryFile)
 import Control.Monad.Catch (MonadCatch)
 import Model (Uploaded (Uploaded))
 import Filesystem (createTree)
-import Distribution.PackageDescription.Parse (showPackageDescription, parsePackageDescription, ParseResult (ParseOk))
-import Distribution.PackageDescription (GenericPackageDescription, PackageDescription)
+import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk))
+import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
+import Distribution.PackageDescription (GenericPackageDescription, PackageDescription, packageDescription)
+import Control.Exception (throw)
+import Control.Monad.State (modify, put, get)
+import Control.Concurrent.Lifted (fork)

 loadCabalFiles :: ( MonadActive m
                  , MonadBaseControl IO m
@ -46,14 +51,10 @@ loadCabalFiles addUpload = do
        liftIO $ hClose handleOut
        withBinaryFile tempIndex ReadMode $ \handleIn -> do
            bss <- lazyConsume $ sourceHandle handleIn $= ungzip
-            loop $ Tar.read $ fromChunks bss
+            tarSource (Tar.read $ fromChunks bss) $$ parMapMC 32 go =$ sinkNull -- FIXME parMapM_C
  where
    withBinaryFile fp mode = bracket (liftIO $ openBinaryFile fp mode) (liftIO . hClose)

-    loop (Tar.Next entry entries) = go entry >> loop entries
-    loop Tar.Done = return ()
-    loop (Tar.Fail e) = throwM e
-
    go entry = do
        case Tar.entryContent entry of
            Tar.NormalFile lbs _
@ -66,6 +67,10 @@ loadCabalFiles addUpload = do
                    setUploadDate name version addUpload
            _ -> return ()

+tarSource Tar.Done = return ()
+tarSource (Tar.Fail e) = throwM e
+tarSource (Tar.Next e es) = yield e >> tarSource es
+
 setUploadDate :: ( MonadBaseControl IO m
                 , MonadThrow m
                 , MonadIO m
@ -148,17 +153,62 @@ sourceHackageSdist name version = do
                then storeRead key
                else return Nothing

+sourceHackageViewSdist viewName name version = do
+    let key = HackageViewSdist viewName name version
+    msrc1 <- storeRead key
+    case msrc1 of
+        Just src -> return $ Just src
+        Nothing -> do
+            mcabalSrc <- storeRead $ HackageViewCabal viewName name version
+            case mcabalSrc of
+                Nothing -> return Nothing
+                Just cabalSrc -> do
+                    cabalLBS <- cabalSrc $$ sinkLazy
+                    msrc <- storeRead $ HackageSdist name version
+                    case msrc of
+                        Nothing -> return Nothing
+                        Just src -> do
+                            lbs <- fromChunks <$> lazyConsume src
+                            let lbs' = Tar.write $ replaceCabal cabalLBS $ Tar.read lbs
+                            sourceLazy lbs' $$ storeWrite key
+                            storeRead key
+  where
+    cabalName = unpack $ concat
+        [ toPathPiece name
+        , "-"
+        , toPathPiece version
+        , "/"
+        , toPathPiece name
+        , ".cabal"
+        ]
+
+    replaceCabal _ Tar.Done = []
+    replaceCabal _ (Tar.Fail e) = throw e -- עבירה גוררת עבירה
+    replaceCabal lbs (Tar.Next e es) = replaceCabal' lbs e : replaceCabal lbs es
+
+    replaceCabal' lbs e
+        | Tar.entryPath e == cabalName = e { Tar.entryContent = Tar.NormalFile lbs (olength64 lbs) }
+        | otherwise = e
+
 createView :: ( MonadResource m
              , MonadCatch m
              , MonadReader env m
              , HasBlobStore env StoreKey
+              , MonadBaseControl IO m
+              , MonadLogger m
              )
-           => (PackageName -> Version -> UTCTime -> GenericPackageDescription -> m PackageDescription)
+           => HackageView
+           -> (PackageName -> Version -> UTCTime -> GenericPackageDescription -> m GenericPackageDescription)
           -> Source m (Entity Uploaded)
           -> Sink ByteString m ()
           -> m ()
-createView modifyCabal src sink = withSystemTempDirectory "createview" $ \dir -> do
-    rels <- src $$ mapMC (\(Entity _ (Uploaded name version time)) -> do
+createView viewName modifyCabal src sink = withSystemTempDirectory "createview" $ \dir -> do
+    $logDebug $ "Creating view: " ++ tshow viewName
+    rels <- src $$ parMapMC 32 (uploadedConduit dir) =$ foldC
+    entries <- liftIO $ Tar.pack dir (map fpToString $ setToList rels)
+    sourceLazy (Tar.write entries) $$ gzip =$ sink
+  where
+    uploadedConduit dir (Entity _ (Uploaded name version time)) = do
        let relfp = fpFromText (toPathPiece name)
                </> fpFromText (toPathPiece version)
                </> fpFromText (concat
@ -176,18 +226,59 @@ createView modifyCabal src sink = withSystemTempDirectory "createview" $ \dir ->
                    case parsePackageDescription $ unpack $ decodeUtf8 orig of
                        ParseOk _ gpd -> do
                            gpd' <- modifyCabal name version time gpd
-                            return $ encodeUtf8 $ pack $ showPackageDescription gpd'
+                            return $ encodeUtf8 $ pack $ showGenericPackageDescription gpd'
                        _ -> return orig
+                sourceLazy new $$ storeWrite (HackageViewCabal viewName name version)
                let fp = fpFromString dir </> relfp
                liftIO $ createTree $ directory fp
                writeFile fp new
                return $ asSet $ singletonSet relfp
-        ) =$ foldC
-    entries <- liftIO $ Tar.pack dir (map fpToString $ setToList rels)
-    sourceLazy (Tar.write entries) $$ sink

-viewNoBounds :: Monad m
-             => packageName -> version -> time
-             -> GenericPackageDescription
-             -> m GenericPackageDescription
-viewNoBounds gpd = undefined
+-- FIXME put in conduit-combinators
+parMapMC :: (MonadIO m, MonadBaseControl IO m)
+         => Int
+         -> (i -> m o)
+         -> Conduit i m o
+parMapMC threads f = evalStateC 0 $ do
+    incoming <- liftIO $ newTBQueueIO $ threads * 8
+    outgoing <- liftIO newTChanIO
+    lift $ lift $ replicateM_ threads (addWorker incoming outgoing)
+    awaitForever $ \x -> do
+        cnt <- get
+        ys <- atomically $ do
+            writeTBQueue incoming (Just x)
+            readWholeTChan outgoing
+        put $ cnt + 1 - length ys
+        yieldMany ys
+    atomically $ writeTBQueue incoming Nothing
+    let loop = do
+            togo <- get
+            when (togo > 0) $ do
+                y <- atomically $ readTChan outgoing
+                put $ togo - 1
+                yield y
+    loop
+  where
+    addWorker incoming outgoing =
+        fork loop
+      where
+        loop = join $ atomically $ do
+            mx <- readTBQueue incoming
+            case mx of
+                Nothing -> do
+                    writeTBQueue incoming Nothing
+                    return $ return ()
+                Just x -> return $ do
+                    y <- f x
+                    atomically $ writeTChan outgoing y
+                    loop
+
+    readWholeTChan chan =
+        go id
+      where
+        go front = do
+            mx <- tryReadTChan chan
+            case mx of
+                Nothing -> return $ front []
+                Just x -> go $ front . (x:)
+
--- a/Types.hs
+++ b/Types.hs
@ -7,11 +7,13 @@ import Database.Persist.Sql (PersistFieldSql)
 import qualified Data.Text as T

 newtype PackageName = PackageName { unPackageName :: Text }
-    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql)
+    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql, IsString)
 newtype Version = Version { unVersion :: Text }
    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql)
 newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text }
    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql)
+newtype HackageView = HackageView { unHackageView :: Text }
+    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql, IsString)

 data PackageNameVersion = PackageNameVersion !PackageName !Version
    deriving (Show, Read, Typeable, Eq, Ord)
@ -29,6 +31,9 @@ data StoreKey = HackageCabal !PackageName !Version
              | HackageSdist !PackageName !Version
              | CabalIndex !PackageSetIdent
              | CustomSdist !PackageSetIdent !PackageName !Version
+              | HackageViewCabal !HackageView !PackageName !Version
+              | HackageViewSdist !HackageView !PackageName !Version
+              | HackageViewIndex !HackageView

 instance ToPath StoreKey where
    toPath (HackageCabal name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".cabal"]
@ -40,6 +45,23 @@ instance ToPath StoreKey where
        , toPathPiece name
        , toPathPiece version ++ ".tar.gz"
        ]
+    toPath (HackageViewCabal viewName name version) =
+        [ "hackage-view"
+        , toPathPiece viewName
+        , toPathPiece name
+        , toPathPiece version ++ ".cabal"
+        ]
+    toPath (HackageViewSdist viewName name version) =
+        [ "hackage-view"
+        , toPathPiece viewName
+        , toPathPiece name
+        , toPathPiece version ++ ".tar.gz"
+        ]
+    toPath (HackageViewIndex viewName) =
+        [ "hackage-view"
+        , toPathPiece viewName
+        , "00-index.tar.gz"
+        ]

 newtype HackageRoot = HackageRoot { unHackageRoot :: Text }
    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)
--- a/config/routes
+++ b/config/routes
@ -12,3 +12,5 @@
 /stackage/#PackageSetIdent StackageHomeR GET
 /stackage/#PackageSetIdent/00-index.tar.gz StackageIndexR GET
 /stackage/#PackageSetIdent/package/#PackageNameVersion StackageSdistR GET
+/hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET
+/hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET
--- a/stackage-server.cabal
+++ b/stackage-server.cabal
@ -22,6 +22,7 @@ library
                     Data.Slug
                     Data.BlobStore
                     Data.Hackage
+                     Data.Hackage.Views
                     Types
                     Handler.Home
                     Handler.Profile
@ -31,6 +32,8 @@ library
                     Handler.StackageHome
                     Handler.StackageIndex
                     Handler.StackageSdist
+                     Handler.HackageViewIndex
+                     Handler.HackageViewSdist

    if flag(dev) || flag(library-only)
        cpp-options:   -DDEVELOPMENT
@ -57,6 +60,8 @@ library
                RankNTypes
                FunctionalDependencies
                PatternGuards
+                StandaloneDeriving
+                UndecidableInstances

    build-depends: base                          >= 4          && < 5
                 , yesod                         >= 1.2.5      && < 1.3
@ -107,6 +112,8 @@ library
                 , xml-conduit
                 , html-conduit
                 , Cabal
+                 , lifted-base
+                 , mono-traversable

 executable         stackage-server
    if flag(library-only)