More SnapshotInfo changes

Handler/StackageHome.hs

@@ -12,6 +12,12 @@ import Stackage.BuildPlan (bpSystemInfo, bpPackages, ppVersion)
 import Stackage.BuildConstraints (siCorePackages)
 import Stackage.Prelude (display)
 
+allPackageVersions :: SnapshotInfo -> Map Text Text
+allPackageVersions SnapshotInfo {..} =
+    mapKeysWith const display $ map display $
+    fmap ppVersion (bpPackages siPlan) ++
+    siCorePackages (bpSystemInfo siPlan)
+
 getStackageHomeR :: SnapSlug -> Handler Html
 getStackageHomeR slug = do
     (Entity sid stackage, msi) <- getStackage slug
@@ -28,59 +34,99 @@ getStackageHomeR slug = do
     defaultLayout $ do
         setTitle $ toHtml $ stackageTitle stackage
         cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
-            let maxPackages = 5000
+            (packages, packageListClipped) <- handlerToWidget $ case msi of
-            (packageListClipped, packages') <- handlerToWidget $ runDB $ do
+                Nothing -> packagesFromDB sid
-                packages' <- E.select $ E.from $ \(u,m,p) -> do
+                Just si -> packagesFromSI si
-                    E.where_ $
-                        (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
-                        (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
-                        (p E.^. PackageStackage E.==. E.val sid)
-                    E.orderBy [E.asc $ u E.^. UploadedName]
-                    E.groupBy ( u E.^. UploadedName
-                              , m E.^. MetadataSynopsis
-                              )
-                    E.limit maxPackages
-                    return
-                        ( u E.^. UploadedName
-                        , m E.^. MetadataSynopsis
-                        , E.max_ (p E.^. PackageVersion)
-                        , E.max_ $ E.case_
-                            [ ( p E.^. PackageHasHaddocks
-                              , p E.^. PackageVersion
-                              )
-                            ]
-                            (E.val (Version ""))
-                        )
-                packageCount <- count [PackageStackage ==. sid]
-                let packageListClipped = packageCount > maxPackages
-                return (packageListClipped, packages')
-            let packages = flip map packages' $ \(name, syn, latestVersion, forceNotNull -> mversion) ->
-                    ( E.unValue name
-                    , fmap unVersion $ E.unValue latestVersion
-                    , strip $ E.unValue syn
-                    , (<$> mversion) $ \version -> HaddockR slug $ return $ concat
-                        [ toPathPiece $ E.unValue name
-                        , "-"
-                        , version
-                        ]
-                    )
-                forceNotNull (E.Value Nothing) = Nothing
-                forceNotNull (E.Value (Just (Version v)))
-                    | null v = Nothing
-                    | otherwise = Just v
             $(widgetFile "stackage-home")
-  where strip x = fromMaybe x (stripSuffix "." x)
+  where
+    strip x = fromMaybe x (stripSuffix "." x)
+
+    -- name, maybe version, synopsis, maybe doc route
+    packagesFromSI :: SnapshotInfo -> Handler ([(PackageName, Maybe Text, Text, Maybe (Route App))], Bool)
+    packagesFromSI si@SnapshotInfo {..} =
+        fmap (, False) $ runDB $ mapM go $ mapToList $ allPackageVersions si
+      where
+        go :: (Text, Text) -> YesodDB App (PackageName, Maybe Text, Text, Maybe (Route App))
+        go (name, version) = do
+            let name' = PackageName name
+            -- FIXME cache the synopsis metadata somewhere
+            s <- E.select $ E.from $ \m -> do
+                E.where_ $ m E.^. MetadataName E.==. E.val name'
+                return $ m E.^. MetadataSynopsis
+            return
+                ( name'
+                , Just version
+                , fromMaybe "No synopsis available" $ listToMaybe $ map E.unValue $ s
+                , case lookup name siDocMap of
+                    Nothing -> Nothing
+                    Just _ -> Just $ SnapshotR slug $ StackageSdistR
+                            $ PNVNameVersion name' (Version version)
+                )
+
+    packagesFromDB :: StackageId -> Handler ([(PackageName, Maybe Text, Text, Maybe (Route App))], Bool)
+    packagesFromDB sid = do
+        let maxPackages = 5000
+        (packageListClipped, packages') <- runDB $ do
+            packages' <- E.select $ E.from $ \(u,m,p) -> do
+                E.where_ $
+                    (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
+                    (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
+                    (p E.^. PackageStackage E.==. E.val sid)
+                E.orderBy [E.asc $ u E.^. UploadedName]
+                E.groupBy ( u E.^. UploadedName
+                          , m E.^. MetadataSynopsis
+                          )
+                E.limit maxPackages
+                return
+                    ( u E.^. UploadedName
+                    , m E.^. MetadataSynopsis
+                    , E.max_ (p E.^. PackageVersion)
+                    , E.max_ $ E.case_
+                        [ ( p E.^. PackageHasHaddocks
+                          , p E.^. PackageVersion
+                          )
+                        ]
+                        (E.val (Version ""))
+                    )
+            packageCount <- count [PackageStackage ==. sid]
+            let packageListClipped = packageCount > maxPackages
+            return (packageListClipped, packages')
+        let packages = flip map packages' $ \(name, syn, latestVersion, forceNotNull -> mversion) ->
+                ( E.unValue name
+                , fmap unVersion $ E.unValue latestVersion
+                , strip $ E.unValue syn
+                , (<$> mversion) $ \version -> HaddockR slug $ return $ concat
+                    [ toPathPiece $ E.unValue name
+                    , "-"
+                    , version
+                    ]
+                )
+            forceNotNull (E.Value Nothing) = Nothing
+            forceNotNull (E.Value (Just (Version v)))
+                | null v = Nothing
+                | otherwise = Just v
+        return (packages, packageListClipped)
 
 getStackageMetadataR :: SnapSlug -> Handler TypedContent
 getStackageMetadataR slug = do
     (Entity sid _, msi) <- getStackage slug
-    respondSourceDB typePlain $ do
+    respondSourceDB typePlain $
-        sendChunkBS "Override packages\n"
+        case msi of
-        sendChunkBS "=================\n"
+            Nothing -> do
-        stream sid True
+                sendChunkBS "Override packages\n"
-        sendChunkBS "\nPackages from Hackage\n"
+                sendChunkBS "=================\n"
-        sendChunkBS   "=====================\n"
+                stream sid True
-        stream sid False
+                sendChunkBS "\nPackages from Hackage\n"
+                sendChunkBS   "=====================\n"
+                stream sid False
+            Just si -> do
+                sendChunkBS "Packages from Hackage\n"
+                sendChunkBS "=====================\n"
+                forM_ (mapToList $ allPackageVersions si) $ \(name, version) -> do
+                    sendChunkText name
+                    sendChunkBS "-"
+                    sendChunkText version
+                    sendChunkBS "\n"
   where
     stream sid isOverwrite =
         selectSource
@@ -196,48 +242,10 @@ getOldStackageR ident pieces = do
         Nothing -> notFound
         Just route -> redirect (route :: Route App)
 
+-- | Just here for historical reasons, this functionality has been merged into
+-- the snapshot homepage.
 getSnapshotPackagesR :: SnapSlug -> Handler Html
-getSnapshotPackagesR slug = do
+getSnapshotPackagesR = getStackageHomeR
-    (Entity sid _stackage, msi) <- getStackage slug
-    defaultLayout $ do
-        setTitle $ toHtml $ "Package list for " ++ toPathPiece slug
-        cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
-            packages' <- handlerToWidget $ runDB $ E.select $ E.from $ \(u,m,p) -> do
-                E.where_ $
-                    (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
-                    (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
-                    (p E.^. PackageStackage E.==. E.val sid)
-                E.orderBy [E.asc $ u E.^. UploadedName]
-                E.groupBy ( u E.^. UploadedName
-                          , m E.^. MetadataSynopsis
-                          )
-                return
-                    ( u E.^. UploadedName
-                    , m E.^. MetadataSynopsis
-                    , E.max_ $ E.case_
-                        [ ( p E.^. PackageHasHaddocks
-                          , p E.^. PackageVersion
-                          )
-                        ]
-                        (E.val (Version ""))
-                    )
-            let packages = flip map packages' $ \(name, syn, forceNotNull -> mversion) ->
-                    ( E.unValue name
-                    , mversion
-                    , strip $ E.unValue syn
-                    , (<$> mversion) $ \version -> HaddockR slug $ return $ concat
-                        [ toPathPiece $ E.unValue name
-                        , "-"
-                        , version
-                        ]
-                    )
-                forceNotNull (E.Value Nothing) = Nothing
-                forceNotNull (E.Value (Just (Version v)))
-                    | null v = Nothing
-                    | otherwise = Just v
-            $(widgetFile "package-list")
-  where strip x = fromMaybe x (stripSuffix "." x)
-        mback = Just (SnapshotR slug StackageHomeR, "Return to snapshot")
 
 getDocsR :: SnapSlug -> Handler Html
 getDocsR slug = do

Import.hs

@@ -50,7 +50,7 @@ getStackage slug = do
     return (ent, msi)
 
 getSnapshotInfoByIdent :: PackageSetIdent -> Handler SnapshotInfo
-getSnapshotInfoByIdent ident = do
+getSnapshotInfoByIdent ident = withCache $ do
     dirs <- getDirs
     let sourceDocFile rest = do
             let rawfp = fpToString $ dirRawFp dirs ident rest
@@ -68,10 +68,24 @@ getSnapshotInfoByIdent ident = do
             bs <- sourceDocFile [name] $$ takeCE maxFileSize =$ foldC
             either throwM return $ decodeEither' bs
 
+    master <- getYesod
+    liftIO $ haddockUnpacker master False ident
+
     siType <- yaml "build-type.yaml"
     siPlan <- yaml "build-plan.yaml"
     siDocMap <- yaml "docs-map.yaml"
     return SnapshotInfo {..}
+  where
+    withCache inner = do
+        cacheRef <- snapshotInfoCache <$> getYesod
+        cache <- readIORef cacheRef
+        case lookup ident cache of
+            Just x -> return x
+            Nothing -> do
+                x <- inner
+                atomicModifyIORef' cacheRef $ \m ->
+                    (insertMap ident x m, x)
+
 
 data Dirs = Dirs
     { dirRawRoot :: !FilePath

stackage-server.cabal

@@ -82,6 +82,7 @@ library
                 RecordWildCards
                 ScopedTypeVariables
                 BangPatterns
+                TupleSections
 
     build-depends:
                     base                          >= 4