Merge pull request #356 from commercialhaskell/bryan/split-SnapshotsR

Split out SnapshotsR API

config/routes

@@ -13,6 +13,7 @@
 
 /snapshot/#Text/*Texts OldSnapshotR GET
 
+/api/v1/snapshots ApiV1SnapshotsR GET
 /api/v1/snapshot/#ApiSnapshotName ApiV1SnapshotR GET
 
 !/#SnapName SnapshotR:

package.nix

@@ -40,6 +40,6 @@ in
   app = hlib.justStaticExecutables hpkgs.stackage-server;
   shell = hpkgs.shellFor {
     packages = p: [ p.stackage-server ];
-    buildInputs = [ pkgs.cabal-install pkgs.haskell-language-server pkgs.ghcid ];
+    buildInputs = [ pkgs.cabal-install pkgs.haskell-language-server pkgs.ghcid pkgs.haskellPackages.yesod-bin ];
   };
 }

src/Handler/Snapshots.hs

@@ -3,8 +3,11 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE FlexibleContexts #-}
 
-module Handler.Snapshots where
+module Handler.Snapshots (getAllSnapshotsR, getApiV1SnapshotsR) where
 
 import RIO.Time
 import Import
@@ -13,41 +16,74 @@ import Stackage.Database
 snapshotsPerPage :: Integral a => a
 snapshotsPerPage = 50
 
--- This is a handler function for the GET request method on the HomeR
+-- | Extracted from an earlier implementation that just used a big tuple.
--- resource pattern. All of your resource patterns are defined in
+data SnapshotInfo = SnapshotInfo
--- config/routes
+    { name :: SnapName
---
+    , title :: Text
--- The majority of the code you will write in Yesod lives in these handler
+    , prettyDate :: Text
--- functions. You can spread them across multiple files if you are so
+    } deriving (Eq, Show)
--- inclined, or create a single monolithic file.
+
-getAllSnapshotsR :: Handler TypedContent
+instance ToJSON SnapshotInfo where
-getAllSnapshotsR = track "Handler.Snapshots.getAllSnapshotsR" $ do
+    toJSON (SnapshotInfo name title prettyDate) =
+        array
+            [ toJSON name
+            , toJSON title
+            , toJSON prettyDate
+            ]
+
+-- | Extracted from an earlier implementation that just used a big tuple.
+data Paging = Paging
+    { totalCount :: Int
+    , currentPage :: Int
+    , isFirstPage :: Bool
+    , isLastPage :: Bool
+    } deriving (Eq, Show)
+
+-- | Fetch snapshot data from the DB that is used in these routes.
+fetchSnapshots :: Handler ([[SnapshotInfo]], Paging)
+fetchSnapshots = do
     cacheSeconds $ 60 * 60 * 6
-    now' <- getCurrentTime
+
     currentPageMay <- lookupGetParam "page"
     let currentPage :: Int
         currentPage = fromMaybe 1 (currentPageMay >>= readMay)
+
     totalCount <- countSnapshots Nothing
-    (map entityVal -> snapshots) <-
+
-        getSnapshots Nothing snapshotsPerPage
+    snapshots <- map entityVal <$>
-                             ((fromIntegral currentPage - 1) * snapshotsPerPage)
+        getSnapshots
+            Nothing
+            snapshotsPerPage
+            ((fromIntegral currentPage - 1) * snapshotsPerPage)
+
+    now' <- getCurrentTime
     let groups = groupUp now' snapshots
 
     let isFirstPage = currentPage == 1
         isLastPage = currentPage * snapshotsPerPage >= totalCount
 
-    selectRep $ do
+    pure (groups, Paging totalCount currentPage isFirstPage isLastPage)
-      provideRep $ defaultLayout $ do
+
+  where uncrapify now' snapshot =
+            SnapshotInfo
+                (snapshotName snapshot)
+                (snapshotTitle snapshot)
+                (dateDiff now' (snapshotCreated snapshot))
+        groupUp now' = groupBy (on (==) (.prettyDate))
+                     . map (uncrapify now')
+
+getAllSnapshotsR :: Handler Html
+getAllSnapshotsR = track "Handler.Snapshots.getAllSnapshotsR" $ do
+    (groups, Paging _ currentPage isFirstPage isLastPage) <- fetchSnapshots
+    defaultLayout $ do
         setTitle "Stackage Server"
         let snapshotsNav = $(widgetFile "snapshots-nav")
         $(widgetFile "all-snapshots")
 
-      provideRep $ return $ object ["snapshots" .= groups, "totalCount" .= totalCount]
+getApiV1SnapshotsR :: Handler Value
-
+getApiV1SnapshotsR = track "Handler.API.getApiV1SnapshotsR" $ do
-  where uncrapify now' snapshot =
+    (groups, paging) <- fetchSnapshots
-            ( snapshotName snapshot
+    pure $ object
-            , snapshotTitle snapshot
+        [ "snapshots" .= groups
-            , dateDiff now' (snapshotCreated snapshot)
+        , "totalCount" .= paging.totalCount
-            )
+        ]
-        groupUp now' = groupBy (on (==) (\(_,_,uploaded) -> uploaded))
-                     . map (uncrapify now')

src/Import.hs

@@ -67,10 +67,10 @@ track name inner = do
 
 dateDiff :: UTCTime -- ^ now
          -> Day -- ^ target
-         -> LText
+         -> Text
 dateDiff (UTCTime now' _) target
     | now' == target = "today"
-    | otherwise = format (diff True) $ diffUTCTime
+    | otherwise = toStrict $ format (diff True) $ diffUTCTime
         (UTCTime target 0)
         (UTCTime now' 0)
 

templates/all-snapshots.hamlet

@@ -1,13 +1,17 @@
 <div .container>
     <div .content>
         <h1>Snapshots
+        <p>
+            Looking for
+            <a href=@{ApiV1SnapshotsR}>
+              this data as JSON?
         ^{snapshotsNav}
         $forall stackages <- groups
-            $forall (_, _, uploaded) <- take 1 stackages
+            $forall groupLeader <- take 1 stackages
                 <h3>
-                    #{uploaded}
+                    #{groupLeader.prettyDate}
             <ul .snapshots>
-                $forall (ident, title, _uploaded) <- stackages
+                $forall SnapshotInfo ident title _ <- stackages
                     <li>
                         <strong>
                             <a href=@{SnapshotR ident StackageHomeR}>