stackage-server/Handler/Snapshots.hs

{-# LANGUAGE TupleSections, OverloadedStrings #-}

module Handler.Snapshots where

import           Data.Time.Clock
import qualified Database.Esqueleto as E
import           Formatting
import           Formatting.Time
import           Import

snapshotsPerPage :: Integral a => a
snapshotsPerPage = 50

-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
getAllSnapshotsR :: Handler Html
getAllSnapshotsR = do
    now' <- liftIO getCurrentTime
    currentPageMay <- lookupGetParam "page"
    let currentPage :: Int
        currentPage = fromMaybe 1 (currentPageMay >>= readMay)
    (totalCount, groups) <- fmap (groupUp now') $ runDB $ do
        c <- count ([] :: [Filter Stackage])
        rs <- 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]
            E.limit snapshotsPerPage
            E.offset ((fromIntegral currentPage - 1) * snapshotsPerPage)
            return
                ( stackage E.^. StackageSlug
                , stackage E.^. StackageTitle
                , stackage E.^. StackageUploaded
                , user E.^. UserDisplay
                , user E.^. UserHandle
                )
        return (c, rs)

    let isFirstPage = currentPage == 1
        isLastPage = currentPage * snapshotsPerPage >= totalCount

    defaultLayout $ do
        setTitle "Stackage Server"
        let snapshotsNav = $(widgetFile "snapshots-nav")
        $(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')
        groupUp now' (c, rs) = (c, (groupBy (on (==) (\(_,_,uploaded,_,_) -> uploaded)) . map (uncrapify now')) rs)