diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index ca0c562..c188897 100644 --- a/Handler/StackageHome.hs +++ b/Handler/StackageHome.hs @@ -1,13 +1,18 @@ module Handler.StackageHome ( getStackageHomeR + , getStackageDiffR , getStackageCabalConfigR , getDocsR , getSnapshotPackagesR ) where import Import +import qualified Data.HashMap.Strict as HashMap +import Data.These import Data.Time (FormatTime) import Stackage.Database +import Stackage.Database.Types (sortNicely) +import Stackage.Snapshot.Diff getStackageHomeR :: SnapName -> Handler Html getStackageHomeR name = do @@ -23,6 +28,17 @@ getStackageHomeR name = do $(widgetFile "stackage-home") where strip x = fromMaybe x (stripSuffix "." x) +getStackageDiffR :: SnapName -> SnapName -> Handler Html +getStackageDiffR name1 name2 = do + Entity sid1 s1 <- lookupSnapshot name1 >>= maybe notFound return + Entity sid2 s2 <- lookupSnapshot name2 >>= maybe notFound return + snapNames <- sortNicely . map snapshotName . snd <$> getSnapshots 0 0 + snapDiff <- getSnapshotDiff sid1 sid2 + defaultLayout $ do + setTitle $ "Compare " ++ toHtml (toPathPiece name1) ++ " with " + ++ toHtml (toPathPiece name2) + $(widgetFile "stackage-diff") + getStackageCabalConfigR :: SnapName -> Handler TypedContent getStackageCabalConfigR name = do Entity sid _ <- lookupSnapshot name >>= maybe notFound return diff --git a/Stackage/Database/Types.hs b/Stackage/Database/Types.hs index b6875a0..6e9e067 100644 --- a/Stackage/Database/Types.hs +++ b/Stackage/Database/Types.hs @@ -1,5 +1,6 @@ module Stackage.Database.Types ( SnapName (..) + , sortNicely ) where import ClassyPrelude.Conduit @@ -10,7 +11,21 @@ import Database.Persist.Sql data SnapName = SNLts !Int !Int | SNNightly !Day - deriving (Eq, Read, Show) + deriving (Eq, Ord, Read, Show) + +isLTS :: SnapName -> Bool +isLTS SNLts{} = True +isLTS SNNightly{} = False + +-- | Sorts a list of SnapName's in a way suitable for rendering a select list. +-- Order: +-- 1. LTS snapshots (recent first) +-- 2. Nightly snapshots (recent first) +-- 3. Anything else +sortNicely :: [SnapName] -> [SnapName] +sortNicely ns = reverse (sort lts) ++ reverse (sort nightly) + where (lts, nightly) = partition isLTS ns + instance PersistField SnapName where toPersistValue = toPersistValue . toPathPiece fromPersistValue v = do diff --git a/config/routes b/config/routes index 65fd9b5..e2eedcd 100644 --- a/config/routes +++ b/config/routes @@ -24,6 +24,8 @@ /build-plan BuildPlanR GET /ghc-major-version GhcMajorVersionR GET +/diff/#SnapName/#SnapName StackageDiffR GET + /system SystemR GET /haddock/#SnapName/*Texts HaddockR GET /package/#PackageName PackageR GET diff --git a/templates/stackage-diff.hamlet b/templates/stackage-diff.hamlet new file mode 100644 index 0000000..dcc70f6 --- /dev/null +++ b/templates/stackage-diff.hamlet @@ -0,0 +1,33 @@ +
| + |
|---|