mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
95 lines
2.9 KiB
Haskell
95 lines
2.9 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
module Import
|
|
( module Import
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod as Import hiding (getCurrentTime)
|
|
import Foundation as Import
|
|
import Settings as Import
|
|
import Settings.StaticFiles as Import
|
|
import Types as Import
|
|
import Yesod.Auth as Import
|
|
import Data.WebsiteContent as Import (WebsiteContent (..), Post (..))
|
|
import Data.Text.Read (decimal)
|
|
import RIO.Time (diffUTCTime, getCurrentTime)
|
|
--import qualified Prometheus as P
|
|
import Stackage.Database.Types (ModuleListingInfo(..))
|
|
import Formatting (format)
|
|
import Formatting.Time (diff)
|
|
import Yesod.GitRepo (grContent)
|
|
|
|
parseLtsPair :: Text -> Maybe (Int, Int)
|
|
parseLtsPair t1 = do
|
|
(x, t2) <- either (const Nothing) Just $ decimal t1
|
|
t3 <- stripPrefix "." t2
|
|
(y, "") <- either (const Nothing) Just $ decimal t3
|
|
Just (x, y)
|
|
|
|
packageUrl :: SnapName -> PackageNameP -> VersionP -> Route App
|
|
packageUrl sname pkgname pkgver = SnapshotR sname sdistR
|
|
where
|
|
sdistR = StackageSdistR (PNVNameVersion pkgname pkgver)
|
|
|
|
haddockUrl :: SnapName -> ModuleListingInfo -> Route App
|
|
haddockUrl sname mli =
|
|
HaddockR
|
|
sname
|
|
[toPathPiece (mliPackageIdentifier mli), toPathPiece (mliModuleName mli) <> ".html"]
|
|
|
|
hoogleHaddockUrl :: SnapName -> PackageNameP -> ModuleNameP -> Route App
|
|
hoogleHaddockUrl sname pname mname = HaddockR sname [toPathPiece pname, toPathPiece mname <> ".html"]
|
|
|
|
track
|
|
:: MonadIO m
|
|
=> String -> m a -> m a
|
|
track _ = id
|
|
{- FIXME prometheus isn't in Stackage anymore
|
|
track name inner = do
|
|
start <- liftIO getCurrentTime
|
|
result <- inner
|
|
end <- liftIO getCurrentTime
|
|
let latency = fromRational $ toRational (end `diffUTCTime` start) * 1000000
|
|
liftIO (P.withLabel name (P.observe latency) duration)
|
|
return result
|
|
where
|
|
{-# NOINLINE duration #-}
|
|
duration :: P.Metric (P.Vector P.Label1 P.Histogram)
|
|
duration =
|
|
P.unsafeRegisterIO
|
|
(P.vector
|
|
"fn"
|
|
(P.histogram
|
|
(P.Info
|
|
"stackage_server_fn"
|
|
"Stackage Server function call (duration in microseconds).")
|
|
P.defaultBuckets))
|
|
-}
|
|
|
|
dateDiff :: UTCTime -- ^ now
|
|
-> Day -- ^ target
|
|
-> LText
|
|
dateDiff (UTCTime now' _) target
|
|
| now' == target = "today"
|
|
| otherwise = format (diff True) $ diffUTCTime
|
|
(UTCTime target 0)
|
|
(UTCTime now' 0)
|
|
|
|
getPosts :: Handler (Vector Post)
|
|
getPosts = do
|
|
now <- getCurrentTime
|
|
posts <- getYesod >>= fmap wcPosts . liftIO . grContent . appWebsiteContent
|
|
mpreview <- lookupGetParam "preview"
|
|
case mpreview of
|
|
Just "true" -> return posts
|
|
_ -> return $ filter (\p -> postTime p <= now) posts
|
|
|
|
postYear :: Post -> Year
|
|
postYear p =
|
|
let (y, _, _) = toGregorian $ utctDay $ postTime p
|
|
in fromInteger y
|
|
|
|
postMonth :: Post -> Month
|
|
postMonth p =
|
|
let (_, m, _) = toGregorian $ utctDay $ postTime p
|
|
in Month m
|