diff --git a/Handler/Snapshots.hs b/Handler/Snapshots.hs index 998f828..565e0e5 100644 --- a/Handler/Snapshots.hs +++ b/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 - E.on (stackage E.^. StackageUser E.==. user E.^. UserId) - E.orderBy [E.desc $ stackage E.^. StackageUploaded] - return - ( stackage E.^. StackageIdent - , stackage E.^. StackageTitle - , stackage E.^. StackageUploaded - , user E.^. UserDisplay - , user E.^. UserHandle - ) + now <- liftIO getCurrentTime + groups <- fmap (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now)) $ + runDB $ E.select $ E.from $ \(stackage `E.InnerJoin` user) -> do + E.on (stackage E.^. StackageUser E.==. user E.^. UserId) + E.orderBy [E.desc $ stackage E.^. StackageUploaded] + return + ( stackage E.^. StackageIdent + , stackage E.^. StackageTitle + , 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) diff --git a/stackage-server.cabal b/stackage-server.cabal index b23f2f5..4ad4b54 100644 --- a/stackage-server.cabal +++ b/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 diff --git a/templates/all-snapshots.hamlet b/templates/all-snapshots.hamlet index a608a65..39d13d0 100644 --- a/templates/all-snapshots.hamlet +++ b/templates/all-snapshots.hamlet @@ -1,8 +1,14 @@
-

All Snapshots -