mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 12:18:29 +01:00
522d2228a9
This is not yet live. We'll have a link for all packages in each snapshot, which includes the version number, doc link if available, and synopsis.
47 lines
1.9 KiB
Haskell
47 lines
1.9 KiB
Haskell
module Handler.PackageList where
|
|
|
|
import qualified Data.HashMap.Strict as M
|
|
import Data.Time (NominalDiffTime, addUTCTime)
|
|
import qualified Database.Esqueleto as E
|
|
import Import
|
|
import Yesod.Core.Types (WidgetT (WidgetT), unWidgetT)
|
|
|
|
-- FIXME maybe just redirect to the LTS or nightly package list
|
|
getPackageListR :: Handler Html
|
|
getPackageListR = defaultLayout $ do
|
|
setTitle "Package list"
|
|
cachedWidget (20 * 60) "package-list" $ do
|
|
let clean (x, y) =
|
|
( E.unValue x
|
|
, strip $ E.unValue y
|
|
)
|
|
addDocs (x, y) = (x, Nothing, y, Nothing)
|
|
packages <- fmap (map addDocs . uniqueByKey . map clean) $ handlerToWidget $ runDB $
|
|
E.selectDistinct $ E.from $ \(u,m) -> do
|
|
E.where_ (m E.^. MetadataName E.==. u E.^. UploadedName)
|
|
E.orderBy [E.asc $ u E.^. UploadedName]
|
|
return $ (u E.^. UploadedName
|
|
,m E.^. MetadataSynopsis)
|
|
$(widgetFile "package-list")
|
|
where strip x = fromMaybe x (stripSuffix "." x)
|
|
uniqueByKey = sortBy (comparing fst) . M.toList . M.fromList
|
|
mback = Nothing
|
|
|
|
-- FIXME move somewhere else, maybe even yesod-core
|
|
cachedWidget :: NominalDiffTime -> Text -> Widget -> Widget
|
|
cachedWidget diff key widget = do
|
|
ref <- widgetCache <$> getYesod
|
|
now <- liftIO getCurrentTime
|
|
mpair <- lookup key <$> readIORef ref
|
|
case mpair of
|
|
Just (expires, gw) | expires > now -> do
|
|
$logDebug "Using cached widget"
|
|
WidgetT $ \_ -> return ((), gw)
|
|
_ -> do
|
|
$logDebug "Not using cached widget"
|
|
WidgetT $ \hd -> do
|
|
((), gw) <- unWidgetT widget hd
|
|
-- FIXME render the builders in gw for more efficiency
|
|
atomicModifyIORef' ref $ \m -> (insertMap key (addUTCTime diff now, gw) m, ())
|
|
return ((), gw)
|