Add /package-counts

Application.hs

@@ -71,6 +71,7 @@ import           Handler.BannedTags
 import           Handler.RefreshDeprecated
 import           Handler.Hoogle
 import           Handler.BuildVersion
+import           Handler.PackageCounts
 
 -- 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

Handler/PackageCounts.hs

@@ -0,0 +1,39 @@
+module Handler.PackageCounts
+    ( getPackageCountsR
+    ) where
+
+import Import hiding (Value (..), groupBy, (==.))
+import Data.Slug (mkSlug)
+import Database.Esqueleto
+
+data Count = Count
+    { name :: Text
+    , date :: Day
+    , packages :: Int
+    }
+
+toCount :: (Value Text, Value UTCTime, Value Int) -> Count
+toCount (Value x, Value y, Value z) =
+    Count x (utctDay y) z
+
+getPackageCountsR :: Handler Html
+getPackageCountsR = do
+    admins <- adminUsers <$> getExtra
+    counts <- runDB $ do
+        let slugs = mapMaybe mkSlug $ setToList admins
+        adminUids <- selectKeysList [UserHandle <-. slugs] []
+        fmap (map toCount) $ select $ from $ \(s, p) -> do
+            where_ $
+                (not_ $ s ^. StackageTitle `like` val "%inclusive") &&.
+                (s ^. StackageId ==. p ^. PackageStackage) &&.
+                (s ^. StackageUser `in_` valList adminUids)
+            groupBy (s ^. StackageTitle, s ^. StackageUploaded)
+            orderBy [desc $ s ^. StackageUploaded]
+            return
+                ( s ^. StackageTitle
+                , s ^. StackageUploaded
+                , countRows
+                )
+    defaultLayout $ do
+        setTitle "Package counts"
+        $(widgetFile "package-counts")

config/routes

@@ -55,3 +55,4 @@
 
 /refresh-deprecated RefreshDeprecatedR GET
 /build-version BuildVersionR GET
+/package-counts PackageCountsR GET

stackage-server.cabal

@@ -54,6 +54,7 @@ library
                      Handler.BannedTags
                      Handler.RefreshDeprecated
                      Handler.BuildVersion
+                     Handler.PackageCounts
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT

templates/package-counts.hamlet

@@ -0,0 +1,20 @@
+<div .container>
+    <h1>Package counts
+
+    <p>
+        This page provides historical information on the number of packages included
+        in Stackage Nightly and LTS Haskell snapshots, purely for the sake of
+        curiosity.
+
+    <table>
+        <thead>
+            <tr>
+                <th .name>Title
+                <th .count>Count
+                <th .date>Date
+        <tbody>
+            $forall c <- counts
+                <tr>
+                    <td .name>#{name c}
+                    <td .count>#{packages c}
+                    <td .date>#{show $ date c}

templates/package-counts.lucius

@@ -0,0 +1,12 @@
+th {
+    font-size: 1.2em;
+}
+
+td, th {
+    padding: 0.5em;
+}
+
+.name {
+    text-align: right;
+    font-weight: bold;
+}