Restyle snapshots page

Handler/Snapshots.hs

@@ -2,8 +2,11 @@
 
 module Handler.Snapshots where
 
-import Import
+import           Data.Time.Clock
 import qualified Database.Esqueleto as E
+import           Formatting
+import           Formatting.Time
+import           Import
 
 -- This is a handler function for the GET request method on the HomeR
 -- resource pattern. All of your resource patterns are defined in
@@ -14,16 +17,18 @@ import qualified Database.Esqueleto as E
 -- inclined, or create a single monolithic file.
 getAllSnapshotsR :: Handler Html
 getAllSnapshotsR = do
-    stackages <- runDB $ E.select $ E.from $ \(stackage `E.InnerJoin` user) -> do
+    now <- liftIO getCurrentTime
-        E.on (stackage E.^. StackageUser E.==. user E.^. UserId)
+    groups <- fmap (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now)) $
-        E.orderBy [E.desc $ stackage E.^. StackageUploaded]
+        runDB $ E.select $ E.from $ \(stackage `E.InnerJoin` user) -> do
-        return
+          E.on (stackage E.^. StackageUser E.==. user E.^. UserId)
-            ( stackage E.^. StackageIdent
+          E.orderBy [E.desc $ stackage E.^. StackageUploaded]
-            , stackage E.^. StackageTitle
+          return
-            , stackage E.^. StackageUploaded
+              ( stackage E.^. StackageIdent
-            , user E.^. UserDisplay
+              , stackage E.^. StackageTitle
-            , user E.^. UserHandle
+              , stackage E.^. StackageUploaded
-            )
+              , user E.^. UserDisplay
+              , user E.^. UserHandle
+              )
     defaultLayout $ do
         setTitle "Stackage Server"
         $(combineStylesheets 'StaticR
@@ -31,3 +36,6 @@ getAllSnapshotsR = do
             , css_bootstrap_responsive_css
             ])
         $(widgetFile "all-snapshots")
+  where uncrapify now c =
+            let (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle) = c
+            in (ident,title,format (diff True) (diffUTCTime uploaded now),display,handle)

stackage-server.cabal

@@ -78,7 +78,7 @@ library
                 BangPatterns
 
     build-depends:
-                        base                          >= 4
+                    base                          >= 4
                   , aeson                         >= 0.6
                   , aws
                   , base16-bytestring
@@ -128,6 +128,7 @@ library
                   , yesod-form                    >= 1.3.14
                   , yesod-static                  >= 1.2
                   , zlib
+                  , unordered-containers
                  -- Avoid https://github.com/haskell/cabal/issues/1202
                  , Cabal >= 1.18
                  , lifted-base

templates/all-snapshots.hamlet

@@ -1,8 +1,14 @@
 <div .container>
-    <h1>All Snapshots
+    <h1>Snapshots
-    <ul .snapshots>
+    $forall stackages <- groups
-        $forall (E.Value ident, E.Value title, E.Value uploaded, E.Value display, E.Value handle) <- stackages
+        $forall (_, _, uploaded, _, _) <- take 1 stackages
-            <li>
+            <h3>
-                <a href=@{StackageHomeR ident}>
+                #{uploaded}
-                    #{title}
+        <ul .snapshots>
-                    <i>by #{display} (#{handle}) on #{show uploaded}
+            $forall (ident, title, uploaded, display, handle) <- stackages
+                <li>
+                    <strong>
+                        <a href=@{StackageHomeR ident}>
+                            #{title}
+                    <p>
+                        #{display} (#{handle})

templates/all-snapshots.lucius

@@ -1 +1,23 @@
-.snapshots > li { line-height: 1.5em; }
+.snapshots > li {
+  list-style-type: none;
+  margin: 0 0 1.5em 0;
+}
+
+.snapshots > li > p {
+  margin-top: 0.5em;
+  padding: 0;
+}
+
+.snapshots {
+  margin: 1em 0 0 0;
+  padding: 0;
+}
+
+h3 {
+  border-bottom: 1px solid #aaa;
+  padding-bottom: 0.25em;
+}
+
+h1 {
+  margin-bottom: 0.5em;
+}