Untested Hackage views

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
+        eres <- tryAny $ flip runReaderT foundation $ do
-            $ \name version mmtime ->
+            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 =

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.Parse (parsePackageDescription, ParseResult (ParseOk))
-import Distribution.PackageDescription (GenericPackageDescription, PackageDescription)
+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
+createView viewName modifyCabal src sink = withSystemTempDirectory "createview" $ \dir -> do
-    rels <- src $$ mapMC (\(Entity _ (Uploaded name version time)) -> 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
+-- FIXME put in conduit-combinators
-             => packageName -> version -> time
+parMapMC :: (MonadIO m, MonadBaseControl IO m)
-             -> GenericPackageDescription
+         => Int
-             -> m GenericPackageDescription
+         -> (i -> m o)
-viewNoBounds gpd = undefined
+         -> 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:)
+

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)

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

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)