Badges

Handler/Package.hs

@@ -6,6 +6,7 @@ module Handler.Package
     ( getPackageR
     , getPackageSnapshotsR
     , packagePage
+    , getPackageBadgeR
     ) where
 
 import           Data.Char
@@ -13,15 +14,34 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Text.Lazy as LT
 import           Distribution.Package.ModuleForest
+import           Graphics.Badge.Barrier
+import           Control.Lens
 import           Import
 import qualified Text.Blaze.Html.Renderer.Text as LT
 import           Text.Email.Validate
-import Stackage.Database
+import           Stackage.Database
 
 -- | Page metadata package.
 getPackageR :: PackageName -> Handler Html
 getPackageR = packagePage Nothing
 
+getPackageBadgeR :: PackageName -> SnapshotBranch -> Handler TypedContent
+getPackageBadgeR pname branch = do
+    snapName     <- maybe notFound pure =<< newestSnapshot branch
+    Entity sid _ <- maybe notFound pure =<< lookupSnapshot snapName
+    mVersion <- do mSnapPackage <- lookupSnapshotPackage sid (unPackageName pname)
+                   pure (Version . snapshotPackageVersion . entityVal <$> mSnapPackage)
+    respond typeSvg $ renderStackageBadge snapName mVersion
+
+renderStackageBadge :: SnapName -> Maybe Version -> LByteString
+renderStackageBadge (badgeLabel -> label) = \case
+    Nothing          -> renderBadge (flat & right .~ red) label "not available"
+    Just (Version x) -> renderBadge flat label x
+
+badgeLabel :: SnapName -> Text
+badgeLabel (SNNightly _) = "stackage nightly"
+badgeLabel (SNLts x _)   = "stackage lts-" <> tshow x
+
 packagePage :: Maybe (SnapName, Version)
             -> PackageName
             -> Handler Html

config/routes

@@ -30,6 +30,7 @@
 /haddock/#SnapName/*Texts HaddockR GET
 /package/#PackageName PackageR GET
 /package/#PackageName/snapshots PackageSnapshotsR GET
+/package/#PackageName/badge/#SnapshotBranch PackageBadgeR GET
 /package PackageListR GET
 
 /authors AuthorsR GET

stack.yaml

@@ -1,3 +1,4 @@
 resolver: lts-3.8
 extra-deps:
     - these-0.6.1.0
+    - barrier-0.1.0

stackage-server.cabal

@@ -92,6 +92,7 @@ library
                     base                          >= 4.8         &&   < 4.9
                   , aeson                         >= 0.8         &&   < 0.9
                   , aws                           >= 0.12        &&   < 0.13
+                  , barrier                       >= 0.1         &&   < 0.2
                   , base16-bytestring             >= 0.1         &&   < 0.2
                   , blaze-markup                  >= 0.7         &&   < 0.8
                   , byteable                      >= 0.1         &&   < 0.2