PackageList

Handler/PackageList.hs

@@ -1,52 +1,13 @@
 module Handler.PackageList where
 
-import qualified Data.HashMap.Strict as M
+import Import
-import           Data.Time (NominalDiffTime)
+import Stackage.Database
-import qualified Database.Esqueleto as E
-import           Import
 
 
 -- FIXME maybe just redirect to the LTS or nightly package list
 getPackageListR :: Handler Html
 getPackageListR = defaultLayout $ do
-    error "getPackageListR"
-    {-
     setTitle "Package list"
-    cachedWidget (20 * 60) "package-list" $ do
+    packages <- getAllPackages
-        let clean (x, y) =
+    $(widgetFile "package-list")
-                ( E.unValue x
-                , strip $ E.unValue y
-                )
-            addDocs (x, y) = (x, Nothing, y, Nothing)
-        packages <- fmap (map addDocs . uniqueByKey . map clean) $ handlerToWidget $ runDB $
-            E.selectDistinct $ E.from $ \m -> do
-              E.orderBy [E.asc $ m E.^. MetadataName]
-              return $ (m E.^. MetadataName
-                       ,m E.^. MetadataSynopsis)
-        $(widgetFile "package-list")
   where strip x = fromMaybe x (stripSuffix "." x)
-        uniqueByKey = sortBy (comparing fst) . M.toList . M.fromList
-        mback = Nothing
-
--- FIXME move somewhere else, maybe even yesod-core
-cachedWidget :: NominalDiffTime -> Text -> Widget -> Widget
-cachedWidget _diff _key widget = do
-    -- Temporarily disabled, seems to be eating up too much memory
-    widget
-    {-
-    ref <- widgetCache <$> getYesod
-    now <- liftIO getCurrentTime
-    mpair <- lookup key <$> readIORef ref
-    case mpair of
-        Just (expires, gw) | expires > now -> do
-            $logDebug "Using cached widget"
-            WidgetT $ \_ -> return ((), gw)
-        _ -> do
-            $logDebug "Not using cached widget"
-            WidgetT $ \hd -> do
-                ((), gw) <- unWidgetT widget hd
-                -- FIXME render the builders in gw for more efficiency
-                atomicModifyIORef' ref $ \m -> (insertMap key (addUTCTime diff now, gw) m, ())
-                return ((), gw)
-                -}
-                -}

Stackage/Database.hs

@@ -9,6 +9,7 @@ module Stackage.Database
     , lookupSnapshot
     , snapshotTitle
     , PackageListingInfo (..)
+    , getAllPackages
     , getPackages
     , createStackageDatabase
     , openStackageDatabase
@@ -390,6 +391,18 @@ prettyName name ghc =
             SNLts x y -> concat ["LTS Haskell ", tshow x, ".", tshow y]
             SNNightly d -> "Stackage Nightly " ++ tshow d
 
+getAllPackages :: GetStackageDatabase m => m [(Text, Text, Text)]
+getAllPackages = liftM (map toPair) $ run $ do
+    E.select $ E.from $ \p -> do
+        E.orderBy [E.asc $ p E.^. PackageName]
+        return
+            ( p E.^. PackageName
+            , p E.^. PackageLatest
+            , p E.^. PackageSynopsis
+            )
+  where
+    toPair (E.Value x, E.Value y, E.Value z) = (x, y, z)
+
 data PackageListingInfo = PackageListingInfo
     { pliName :: !Text
     , pliVersion :: !Text

templates/package-list.hamlet

@@ -1,24 +1,14 @@
 <div .container .content>
     <h1>Packages
-    $maybe (back, backText) <- mback
-        <p>
-            <a href=@{back}>#{asText backText}
     <div .packages>
         <table .table>
             <thead>
                 <th>Package
-                <th>Docs
                 <th>Synopsis
             <tbody>
-                $forall (name,mversion,synopsis,mdoc) <- packages
+                $forall (name, version, synopsis) <- packages
                     <tr>
                         <td>
-                            <a href=@{PackageR name}>
+                            <a href=@{PackageR $ PackageName name}>#{name}-#{version}
-                                #{name}
-                                $maybe version <- mversion
-                                    -#{asText version}
                         <td>
-                            $maybe doc <- mdoc
+                            #{strip synopsis}
-                                <a href=@{doc}>Docs
-                        <td>
-                            #{synopsis}