diff --git a/.dir-locals.el b/.dir-locals.el index 46667e3..b6926e5 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -1,6 +1,6 @@ ((haskell-mode . ((haskell-indent-spaces . 4) - (hindent-style . "johan-tibell") - (haskell-process-type . cabal-repl) + ;;(hindent-style . "johan-tibell") + ;;(haskell-process-type . cabal-repl) (haskell-process-use-ghci . t))) (hamlet-mode . ((hamlet/basic-offset . 4) (haskell-process-use-ghci . t))) diff --git a/.ghci b/.ghci index 5677200..62a54d7 100755 --- a/.ghci +++ b/.ghci @@ -1,6 +1,6 @@ :set -fobject-code :set -i.:config:dist/build/autogen -:set -XCPP -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XDeriveDataTypeable -XRankNTypes -XNoImplicitPrelude -XFunctionalDependencies -XFlexibleInstances -XTemplateHaskell -XQuasiQuotes -XOverloadedStrings -XNoImplicitPrelude -XCPP -XMultiParamTypeClasses -XTypeFamilies -XGADTs -XGeneralizedNewtypeDeriving -XFlexibleContexts -XEmptyDataDecls -XNoMonomorphismRestriction -XDeriveDataTypeable -XViewPatterns -XTypeSynonymInstances -XFlexibleInstances -XRankNTypes -XFunctionalDependencies -XPatternGuards -XStandaloneDeriving -XUndecidableInstances -XBangPatterns -XScopedTypeVariables +:set -XOverloadedStrings :set -DDEVELOPMENT=1 :set -DINGHCI=1 :set -package foreign-store diff --git a/.gitignore b/.gitignore index 1c688a2..fda6213 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,5 @@ TAGS *~ *# /stackage-server.cabal +/hoogle/ +/hoogle-gen/ diff --git a/.hindent.yaml b/.hindent.yaml new file mode 100644 index 0000000..25fcc5f --- /dev/null +++ b/.hindent.yaml @@ -0,0 +1,3 @@ +indent-size: 4 +line-length: 100 +force-trailing-newline: true diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..e9b1892 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,229 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + - simple_align: + cases: true + top_level_patterns: true + records: true + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: none + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: right_after + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: false + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: false + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: false + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes diff --git a/app/DevelMain.hs b/app/DevelMain.hs index 20fd934..fe101e4 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -9,33 +9,41 @@ module DevelMain where -import Application (getApplicationDev) +import Application (App, withFoundationDev, makeApplication) import Control.Concurrent -import Data.IORef import Foreign.Store import Network.Wai.Handler.Warp import Yesod +import Data.IORef + + +data Command = Run (IO ()) + | Stop + +newtype Devel = Devel (Store (IORef (App -> IO Application))) -- | Start the web server. -main :: IO (Store (IORef Application)) -main = - do c <- newChan - (settings,app) <- getApplicationDev - ref <- newIORef app - tid <- forkIO - (runSettings - settings - (\req cont -> - do handler <- readIORef ref - handler req cont)) - _ <- newStore tid - ref' <- newStore ref - _ <- newStore c - return ref' +main :: IO Devel +main = do + c <- newChan + ref <- newIORef makeApplication + tid <- + forkIO $ + withFoundationDev $ \settings foundation -> + runSettings + settings + (\req cont -> do + mkApp <- readIORef ref + application <- mkApp foundation + application req cont) + _ <- newStore tid + ref' <- newStore ref + _ <- newStore c + return $ Devel ref' -- | Update the server, start it if not running. -update :: IO (Store (IORef Application)) +update :: IO Devel update = do m <- lookupStore 1 case m of @@ -44,6 +52,5 @@ update = do ref <- readStore store c <- readStore (Store 2) writeChan c () - (_,app) <- getApplicationDev - writeIORef ref app - return store + writeIORef ref makeApplication + return $ Devel store diff --git a/app/stackage-server-cron.hs b/app/stackage-server-cron.hs index 3cc6bb0..5305010 100644 --- a/app/stackage-server-cron.hs +++ b/app/stackage-server-cron.hs @@ -1,9 +1,85 @@ -import Prelude +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +import Options.Applicative +import RIO +import RIO.List as L +import RIO.Text as T import Stackage.Database.Cron -import System.IO +import Stackage.Database.Github + +readText :: ReadM T.Text +readText = T.pack <$> str + +readLogLevel :: ReadM LogLevel +readLogLevel = + maybeReader $ \case + "debug" -> Just LevelDebug + "info" -> Just LevelInfo + "warn" -> Just LevelWarn + "error" -> Just LevelError + _ -> Nothing + +readGithubRepo :: ReadM GithubRepo +readGithubRepo = + maybeReader $ \str' -> + case L.span (/= '/') str' of + (grAccount, '/':grName) + | not (L.null grName) -> Just GithubRepo {..} + _ -> Nothing + +optsParser :: Parser StackageCronOptions +optsParser = + StackageCronOptions <$> + switch + (long "force-update" <> short 'f' <> + help + "Initiate a force update, where all snapshots will be updated regardless if \ + \their yaml files from stackage-snapshots repo have been updated or not.") <*> + option + readText + (long "download-bucket" <> value haddockBucketName <> metavar "DOWNLOAD_BUCKET" <> + help + ("S3 Bucket name where things like haddock and current hoogle files should \ + \be downloaded from. Default is: " <> + T.unpack haddockBucketName)) <*> + option + readText + (long "upload-bucket" <> value haddockBucketName <> metavar "UPLOAD_BUCKET" <> + help + ("S3 Bucket where hoogle db and snapshots.json file will be uploaded to. Default is: " <> + T.unpack haddockBucketName)) <*> + switch + (long "do-not-upload" <> + help "Stop from hoogle db and snapshots.json from being generated and uploaded") <*> + option + readLogLevel + (long "log-level" <> metavar "LOG_LEVEL" <> short 'l' <> value LevelInfo <> + help "Verbosity level (debug|info|warn|error). Default level is 'info'.") <*> + option + readGithubRepo + (long "snapshots-repo" <> metavar "SNAPSHOTS_REPO" <> + value (GithubRepo repoAccount repoName) <> + help + ("Github repository with snapshot files. Default level is '" ++ + repoAccount ++ "/" ++ repoName ++ "'.")) + where + repoAccount = "commercialhaskell" + repoName = "stackage-snapshots" main :: IO () main = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering - stackageServerCron + opts <- + execParser $ + info + (optsParser <* + abortOption ShowHelpText (long "help" <> short 'h' <> help "Display this message.")) + (header "stackage-cron - Keep stackage.org up to date" <> + progDesc + "Uses github.com/commercialhaskell/stackage-snapshots repository as a source \ + \for keeping stackage.org up to date. Amongst other things are: update of hoogle db\ + \and it's upload to S3 bucket, use stackage-content for global-hints" <> + fullDesc) + stackageServerCron opts diff --git a/config/routes b/config/routes index 606540a..61d1506 100644 --- a/config/routes +++ b/config/routes @@ -31,12 +31,12 @@ /system SystemR GET /haddock/#SnapName/*Texts HaddockR GET !/haddock/*Texts HaddockBackupR GET -/package/#PackageName PackageR GET -/package/#PackageName/snapshots PackageSnapshotsR GET -/package/#PackageName/badge/#SnapshotBranch PackageBadgeR GET +/package/#PackageNameP PackageR GET +/package/#PackageNameP/snapshots PackageSnapshotsR GET +/package/#PackageNameP/badge/#SnapshotBranch PackageBadgeR GET /package PackageListR GET -/package/#PackageName/deps PackageDepsR GET -/package/#PackageName/revdeps PackageRevDepsR GET +/package/#PackageNameP/deps PackageDepsR GET +/package/#PackageNameP/revdeps PackageRevDepsR GET /authors AuthorsR GET /install InstallR GET diff --git a/config/settings.yml b/config/settings.yml index 486f7e7..ba559c3 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -19,7 +19,7 @@ approot: "_env:APPROOT:" # reload-templates: false # mutable-static: false # skip-combining: false -# force-ssl: true +force-ssl: false # dev-download: false postgres-string: "_env:PGSTRING:host=localhost port=5432 user=stackage dbname=stackage password=stackage" diff --git a/package.yaml b/package.yaml index aa612c5..f632f6c 100644 --- a/package.yaml +++ b/package.yaml @@ -21,13 +21,11 @@ dependencies: - classy-prelude-yesod - conduit - conduit-extra -- cryptonite - directory - email-validate - esqueleto - exceptions - fast-logger -- foreign-store - ghc-prim - html-conduit - http-conduit @@ -35,14 +33,17 @@ dependencies: - mtl #- prometheus-client #- prometheus-metrics-ghc +- pantry +- path - persistent - persistent-template - resourcet +- rio - shakespeare -- tar +- tar-conduit - template-haskell -- temporary - text +- transformers - these - unliftio - wai @@ -63,7 +64,6 @@ dependencies: - hashable - Cabal - mono-traversable -- time - process - cmark-gfm - formatting @@ -89,39 +89,9 @@ dependencies: - file-embed - resource-pool - containers -- pretty default-extensions: -- TemplateHaskell -- QuasiQuotes - OverloadedStrings -- NoImplicitPrelude -- CPP -- MultiParamTypeClasses -- TypeFamilies -- GADTs -- GeneralizedNewtypeDeriving -- FlexibleContexts -- EmptyDataDecls -- NoMonomorphismRestriction -- DeriveDataTypeable -- ViewPatterns -- TypeSynonymInstances -- FlexibleInstances -- RankNTypes -- FunctionalDependencies -- PatternGuards -- StandaloneDeriving -- UndecidableInstances -- RecordWildCards -- ScopedTypeVariables -- BangPatterns -- TupleSections -- DeriveGeneric -- DeriveFunctor -- DeriveFoldable -- DeriveTraversable -- LambdaCase library: source-dirs: src @@ -141,24 +111,33 @@ executables: stackage-server: main: main.hs source-dirs: app - ghc-options: -threaded -O2 -rtsopts "-with-rtsopts=-N -T" + ghc-options: -Wall -threaded -O2 -rtsopts "-with-rtsopts=-N -T" dependencies: - stackage-server when: - condition: flag(library-only) buildable: false - condition: flag(dev) - cpp-options: -DDEVELOPMENT + then: + other-modules: DevelMain + dependencies: + - foreign-store + else: + other-modules: [] stackage-server-cron: main: stackage-server-cron.hs source-dirs: app + other-modules: [] ghc-options: + - -Wall - -threaded - -O2 - -rtsopts - -with-rtsopts=-N dependencies: + - optparse-applicative + - rio - stackage-server when: - condition: flag(library-only) diff --git a/src/Application.hs b/src/Application.hs index 88c2c71..144c9dd 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,70 +1,79 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP#-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BlockArguments #-} + module Application - ( getApplicationDev + ( App + , withApplicationDev + , withFoundationDev + , makeApplication , appMain , develMain - , makeFoundation + , withFoundation , makeLogWare -- * for DevelMain - , getApplicationRepl - , shutdownApp + , withApplicationRepl -- * for GHCI , handler ) where -import Control.Monad.Logger (liftLoc) -import Language.Haskell.TH.Syntax (qLocation) -import Control.Concurrent (forkIO) -import Data.WebsiteContent -import Import hiding (catch) -import Network.Wai (Middleware, rawPathInfo) -import Network.Wai.Handler.Warp (Settings, defaultSettings, - defaultShouldDisplayException, - runSettings, setHost, - setOnException, setPort, getPort) -import Network.Wai.Middleware.ForceSSL (forceSSL) -import Network.Wai.Middleware.RequestLogger - ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination - , Destination (Logger) - ) -import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, toLogStr) -import Yesod.Core.Types (loggerSet) -import Yesod.Default.Config2 -import Yesod.Default.Handlers -import Yesod.GitRepo -import System.Process (rawSystem) -import Stackage.Database (openStackageDatabase, PostgresConf (..)) -import Stackage.Database.Cron (newHoogleLocker, singleRun) -import Control.AutoUpdate -import Control.Concurrent (threadDelay) -import Yesod.GitRev (tGitRev) +import Control.AutoUpdate +import Control.Concurrent (threadDelay) +import Control.Monad.Logger (liftLoc) +import Data.WebsiteContent +import Database.Persist.Postgresql (PostgresConf(..)) +import Import hiding (catch) +import Language.Haskell.TH.Syntax (qLocation) +import Network.Wai (Middleware, rawPathInfo) +import Network.Wai.Handler.Warp (Settings, defaultSettings, + defaultShouldDisplayException, getPort, + runSettings, setHost, setOnException, setPort) +import Network.Wai.Middleware.ForceSSL (forceSSL) +import Network.Wai.Middleware.RequestLogger (Destination(Logger), + IPAddrSource(..), OutputFormat(..), + destination, mkRequestLogger, + outputFormat) +import RIO (LogFunc, LogOptions, logOptionsHandle, withLogFunc, runRIO, logError) +import RIO.Prelude.Simple (runSimpleApp) +import Stackage.Database (withStackageDatabase) +import Stackage.Database.Cron (newHoogleLocker, singleRun) +import Stackage.Database.Github (getStackageContentDir) +import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +import Yesod.Core.Types (loggerSet) +import Yesod.Default.Config2 +import Yesod.Default.Handlers +import Yesod.GitRepo +import Yesod.GitRev (tGitRev) -- Import all relevant handler modules here. --- Don't forget to add new modules to your cabal file! -import Handler.Home -import Handler.Snapshots -import Handler.StackageHome -import Handler.StackageIndex -import Handler.StackageSdist -import Handler.System -import Handler.Haddock -import Handler.Package -import Handler.PackageDeps -import Handler.PackageList -import Handler.Hoogle -import Handler.Sitemap -import Handler.BuildPlan -import Handler.Download -import Handler.OldLinks -import Handler.Feed -import Handler.DownloadStack -import Handler.MirrorStatus -import Handler.Blog +import Handler.Blog +import Handler.BuildPlan +import Handler.Download +import Handler.DownloadStack +import Handler.Feed +import Handler.Haddock +import Handler.Home +import Handler.Hoogle +import Handler.MirrorStatus +import Handler.OldLinks +import Handler.Package +import Handler.PackageDeps +import Handler.PackageList +import Handler.Sitemap +import Handler.Snapshots +import Handler.StackageHome +import Handler.StackageIndex +import Handler.StackageSdist +import Handler.System ---import Network.Wai.Middleware.Prometheus (prometheus) ---import Prometheus (register) ---import Prometheus.Metric.GHC (ghcMetrics) +--import Network.Wai.Middleware.Prometheus (prometheus) +--import Prometheus (register) +--import Prometheus.Metric.GHC (ghcMetrics) -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -104,52 +113,52 @@ forceSSL' settings app -- | Loads up any necessary settings, creates your foundation datatype, and -- performs some initialization. -makeFoundation :: AppSettings -> IO App -makeFoundation appSettings = do - -- Some basic initializations: HTTP connection manager, logger, and static - -- subsite. +-- +-- Some basic initializations: HTTP connection manager, logger, and static +-- subsite. +withFoundation :: LogFunc -> AppSettings -> (App -> IO a) -> IO a +withFoundation appLogFunc appSettings inner = do appHttpManager <- newManager appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appStatic <- - (if appMutableStatic appSettings then staticDevel else static) - (appStaticDir appSettings) + (if appMutableStatic appSettings + then staticDevel + else static) + (appStaticDir appSettings) + appWebsiteContent <- + if appDevDownload appSettings + then do + fp <- runSimpleApp $ getStackageContentDir "." + gitRepoDev fp loadWebsiteContent + else gitRepo "https://github.com/fpco/stackage-content.git" "master" loadWebsiteContent + let pgConf = + PostgresConf {pgPoolSize = 2, pgConnStr = encodeUtf8 $ appPostgresString appSettings} + -- Temporary workaround to force content updates regularly, until + -- distribution of webhooks is handled via consul + runContentUpdates = + Concurrently $ + forever $ + void $ do + threadDelay $ 1000 * 1000 * 60 * 5 + handleAny (runRIO appLogFunc . RIO.logError . fromString . displayException) $ + grRefresh appWebsiteContent + withStackageDatabase (appShouldLogAll appSettings) pgConf $ \appStackageDatabase -> do + appLatestStackMatcher <- + mkAutoUpdate + defaultUpdateSettings + { updateFreq = 1000 * 1000 * 60 * 30 -- update every thirty minutes + , updateAction = getLatestMatcher appHttpManager + } + appHoogleLock <- newMVar () + appMirrorStatus <- mkUpdateMirrorStatus + hoogleLocker <- newHoogleLocker appLogFunc appHttpManager + let appGetHoogleDB = singleRun hoogleLocker + let appGitRev = $$tGitRev + runConcurrently $ runContentUpdates *> Concurrently (inner App {..}) - appWebsiteContent <- if appDevDownload appSettings - then do - void $ rawSystem "git" - [ "clone" - , "https://github.com/fpco/stackage-content.git" - ] - gitRepoDev "stackage-content" loadWebsiteContent - else gitRepo - "https://github.com/fpco/stackage-content.git" - "master" - loadWebsiteContent +getLogOpts :: AppSettings -> IO LogOptions +getLogOpts settings = logOptionsHandle stdout (appShouldLogAll settings) - appStackageDatabase <- openStackageDatabase PostgresConf - { pgPoolSize = 2 - , pgConnStr = encodeUtf8 $ appPostgresString appSettings - } - - -- Temporary workaround to force content updates regularly, until - -- distribution of webhooks is handled via consul - void $ forkIO $ forever $ void $ do - threadDelay $ 1000 * 1000 * 60 * 5 - handleAny print $ grRefresh appWebsiteContent - - appLatestStackMatcher <- mkAutoUpdate defaultUpdateSettings - { updateFreq = 1000 * 1000 * 60 * 30 -- update every thirty minutes - , updateAction = getLatestMatcher appHttpManager - } - - appHoogleLock <- newMVar () - - appMirrorStatus <- mkUpdateMirrorStatus - hoogleLocker <- newHoogleLocker True appHttpManager - let appGetHoogleDB = singleRun hoogleLocker - let appGitRev = $$tGitRev - - return App {..} makeLogWare :: App -> IO Middleware makeLogWare foundation = @@ -180,21 +189,26 @@ warpSettings foundation = (toLogStr $ "Exception from Warp: " ++ show e)) defaultSettings --- | For yesod devel, return the Warp settings and WAI Application. -getApplicationDev :: IO (Settings, Application) -getApplicationDev = do - settings <- getAppSettings - foundation <- makeFoundation settings - wsettings <- getDevSettings $ warpSettings foundation - app <- makeApplication foundation - return (wsettings, app) +-- | For yesod devel, apply an action to Warp settings, RIO's LogFunc and Foundation. +withFoundationDev :: (Settings -> App -> IO a) -> IO a +withFoundationDev inner = do + appSettings <- getAppSettings + logOpts <- getLogOpts appSettings + withLogFunc logOpts $ \logFunc -> + withFoundation logFunc appSettings $ \foundation -> do + settings <- getDevSettings $ warpSettings foundation + inner settings foundation -getAppSettings :: IO AppSettings -getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv + +withApplicationDev :: (Settings -> Application -> IO a) -> IO a +withApplicationDev inner = + withFoundationDev $ \ settings foundation -> do + application <- makeApplication foundation + inner settings application -- | main function for use by yesod devel develMain :: IO () -develMain = develMainHelper getApplicationDev +develMain = withApplicationDev $ \settings app -> develMainHelper (pure (settings, app)) -- | The @main@ function for an executable running this site. appMain :: IO () @@ -206,30 +220,30 @@ appMain = do -- allow environment variables to override useEnv + logOpts <- getLogOpts settings + withLogFunc logOpts $ \ logFunc -> do + -- Generate the foundation from the settings + withFoundation logFunc settings $ \ foundation -> do - -- Generate the foundation from the settings - foundation <- makeFoundation settings + -- Generate a WAI Application from the foundation + app <- makeApplication foundation - -- Generate a WAI Application from the foundation - app <- makeApplication foundation - - -- Run the application with Warp - runSettings (warpSettings foundation) app + -- Run the application with Warp + runSettings (warpSettings foundation) app -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the app from GHCi) -------------------------------------------------------------- -getApplicationRepl :: IO (Int, App, Application) -getApplicationRepl = do +withApplicationRepl :: (Int -> App -> Application -> IO ()) -> IO () +withApplicationRepl inner = do settings <- getAppSettings - foundation <- makeFoundation settings - wsettings <- getDevSettings $ warpSettings foundation - app1 <- makeApplication foundation - return (getPort wsettings, foundation, app1) - -shutdownApp :: App -> IO () -shutdownApp _ = return () + logOpts <- getLogOpts settings + withLogFunc logOpts $ \ logFunc -> + withFoundation logFunc settings $ \foundation -> do + wsettings <- getDevSettings $ warpSettings foundation + app1 <- makeApplication foundation + inner (getPort wsettings) foundation app1 --------------------------------------------- @@ -238,4 +252,8 @@ shutdownApp _ = return () -- | Run a handler handler :: Handler a -> IO a -handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h +handler h = do + logOpts <- logOptionsHandle stdout True + withLogFunc logOpts $ \ logFunc -> do + settings <- getAppSettings + withFoundation logFunc settings (`unsafeHandler` h) diff --git a/src/Control/SingleRun.hs b/src/Control/SingleRun.hs index 3be8ca0..776072e 100644 --- a/src/Control/SingleRun.hs +++ b/src/Control/SingleRun.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} -- | Ensure that a function is only being run on a given input in one -- thread at a time. All threads trying to make the call at once -- return the same result. @@ -7,10 +9,7 @@ module Control.SingleRun , singleRun ) where -import Control.Concurrent.MVar -import Control.Exception -import Control.Monad (join) -import Prelude +import RIO -- | Captures all of the locking machinery and the function which is -- run to generate results. Use 'mkSingleRun' to create this value. @@ -20,13 +19,13 @@ data SingleRun k v = SingleRun -- computations. More ideal would be to use a Map, but we're -- avoiding dependencies outside of base in case this moves into -- auto-update. - , srFunc :: k -> IO v + , srFunc :: forall m . MonadIO m => k -> m v } -- | Create a 'SingleRun' value out of a function. -mkSingleRun :: Eq k - => (k -> IO v) - -> IO (SingleRun k v) +mkSingleRun :: MonadIO m => Eq k + => (forall n . MonadIO n => k -> n v) + -> m (SingleRun k v) mkSingleRun f = do var <- newMVar [] return SingleRun @@ -52,7 +51,7 @@ toRes se = -- exception, we will rethrow that same synchronous exception. If, -- however, that other thread dies from an asynchronous exception, we -- will retry. -singleRun :: Eq k => SingleRun k v -> k -> IO v +singleRun :: (MonadUnliftIO m, Eq k) => SingleRun k v -> k -> m v singleRun sr@(SingleRun var f) k = -- Mask all exceptions so that we don't get killed between exiting -- the modifyMVar and entering the join, which could leave an diff --git a/src/Data/GhcLinks.hs b/src/Data/GhcLinks.hs index f3f7b3d..377213c 100644 --- a/src/Data/GhcLinks.hs +++ b/src/Data/GhcLinks.hs @@ -1,13 +1,19 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.GhcLinks ( GhcLinks(..) , readGhcLinks ) where -import ClassyPrelude.Yesod -import Control.Monad.State.Strict (modify, execStateT) +import Control.Monad.State.Strict (execStateT, modify) import qualified Data.HashMap.Strict as HashMap import qualified Data.Yaml as Yaml +import RIO +import RIO.FilePath +import RIO.Text (unpack) import System.Directory +import Web.PathPieces import Types @@ -21,23 +27,18 @@ supportedArches = [minBound .. maxBound] readGhcLinks :: FilePath -> IO GhcLinks readGhcLinks dir = do - let ghcMajorVersionsPath = dir "supported-ghc-major-versions.yaml" - Yaml.decodeFileEither ghcMajorVersionsPath >>= \case - Left _ -> return $ GhcLinks HashMap.empty - Right (ghcMajorVersions :: [GhcMajorVersion]) -> do - let opts = - [ (arch, ver) - | arch <- supportedArches - , ver <- ghcMajorVersions - ] - hashMap <- flip execStateT HashMap.empty - $ forM_ opts $ \(arch, ver) -> do - let verText = ghcMajorVersionToText ver - fileName = "ghc-" <> verText <> "-links.yaml" - path = dir - unpack (toPathPiece arch) - unpack fileName - whenM (liftIO $ doesFileExist path) $ do - text <- liftIO $ readFileUtf8 path - modify (HashMap.insert (arch, ver) text) - return $ GhcLinks hashMap + let ghcMajorVersionsPath = dir "supported-ghc-major-versions.yaml" + Yaml.decodeFileEither ghcMajorVersionsPath >>= \case + Left _ -> return $ GhcLinks HashMap.empty + Right (ghcMajorVersions :: [GhcMajorVersion]) -> do + let opts = [(arch, ver) | arch <- supportedArches, ver <- ghcMajorVersions] + hashMap <- + flip execStateT HashMap.empty $ + forM_ opts $ \(arch, ver) -> do + let verText = textDisplay ver + fileName = "ghc-" <> verText <> "-links.yaml" + path = dir unpack (toPathPiece arch) unpack fileName + whenM (liftIO $ doesFileExist path) $ do + text <- liftIO $ readFileUtf8 path + modify (HashMap.insert (arch, ver) text) + return $ GhcLinks hashMap diff --git a/src/Data/WebsiteContent.hs b/src/Data/WebsiteContent.hs index 490c86c..0d1a5bc 100644 --- a/src/Data/WebsiteContent.hs +++ b/src/Data/WebsiteContent.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Data.WebsiteContent ( WebsiteContent (..) , StackRelease (..) @@ -7,31 +11,31 @@ module Data.WebsiteContent import ClassyPrelude.Yesod import CMarkGFM -import Data.GhcLinks import Data.Aeson (withObject) +import Data.GhcLinks import Data.Yaml import System.FilePath (takeFileName) -import Types import Text.Blaze.Html (preEscapedToHtml) +import Types data WebsiteContent = WebsiteContent - { wcHomepage :: !Html - , wcAuthors :: !Html + { wcHomepage :: !Html + , wcAuthors :: !Html , wcOlderReleases :: !Html - , wcGhcLinks :: !GhcLinks + , wcGhcLinks :: !GhcLinks , wcStackReleases :: ![StackRelease] - , wcPosts :: !(Vector Post) - , wcSpamPackages :: !(Set PackageName) + , wcPosts :: !(Vector Post) + , wcSpamPackages :: !(Set PackageNameP) -- ^ Packages considered spam which should not be displayed. } data Post = Post - { postTitle :: !Text - , postSlug :: !Text - , postAuthor :: !Text - , postTime :: !UTCTime + { postTitle :: !Text + , postSlug :: !Text + , postAuthor :: !Text + , postTime :: !UTCTime , postDescription :: !Text - , postBody :: !Html + , postBody :: !Html } loadWebsiteContent :: FilePath -> IO WebsiteContent @@ -47,7 +51,7 @@ loadWebsiteContent dir = do putStrLn $ "Error loading posts: " ++ tshow e return mempty wcSpamPackages <- decodeFileEither (dir "spam-packages.yaml") - >>= either throwIO (return . setFromList . map PackageName) + >>= either throwIO (return . setFromList) return WebsiteContent {..} where readHtml fp = fmap preEscapedToMarkup $ readFileUtf8 $ dir fp @@ -93,7 +97,7 @@ instance (slug ~ Text, body ~ Html) => FromJSON (slug -> body -> Post) where return $ \postSlug postBody -> Post {..} data StackRelease = StackRelease - { srName :: !Text + { srName :: !Text , srPattern :: !Text } instance FromJSON StackRelease where diff --git a/src/Distribution/Package/ModuleForest.hs b/src/Distribution/Package/ModuleForest.hs index 1ca3643..0826d5c 100644 --- a/src/Distribution/Package/ModuleForest.hs +++ b/src/Distribution/Package/ModuleForest.hs @@ -1,5 +1,6 @@ -- Adopted from https://github.com/haskell/hackage-server/blob/master/Distribution/Server/Packages/ModuleForest.hs - +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} module Distribution.Package.ModuleForest ( moduleName , moduleForest @@ -8,9 +9,10 @@ module Distribution.Package.ModuleForest , NameComponent ) where -import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName -import Import +import RIO +import RIO.Text (pack, unpack) type NameComponent = Text diff --git a/src/Foundation.hs b/src/Foundation.hs index c3d152d..0aa8015 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,38 +1,46 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Foundation where -import ClassyPrelude.Yesod -import Data.WebsiteContent -import Settings -import Settings.StaticFiles -import Text.Blaze -import Text.Hamlet (hamletFile) -import Types -import Yesod.Core.Types (Logger) -import Yesod.AtomFeed -import Yesod.GitRepo +import ClassyPrelude.Yesod +import Data.WebsiteContent +import Settings +import Settings.StaticFiles import Stackage.Database +import Text.Blaze +import Text.Hamlet (hamletFile) +import Types +import Yesod.AtomFeed +import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe -import Yesod.GitRev (GitRev) +import Yesod.GitRepo +import Yesod.GitRev (GitRev) +import qualified RIO -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have -- access to the data present here. data App = App - { appSettings :: AppSettings - , appStatic :: Static -- ^ Settings for static file serving. - , appHttpManager :: Manager - , appLogger :: Logger - , appWebsiteContent :: GitRepo WebsiteContent - , appStackageDatabase :: StackageDatabase - , appLatestStackMatcher :: IO (Text -> Maybe Text) + { appSettings :: !AppSettings + , appStatic :: !Static -- ^ Settings for static file serving. + , appHttpManager :: !Manager + , appLogger :: !Logger + , appLogFunc :: !RIO.LogFunc + , appWebsiteContent :: !(GitRepo WebsiteContent) + , appStackageDatabase :: !StackageDatabase + , appLatestStackMatcher :: !(IO (Text -> Maybe Text)) -- ^ Give a pattern, get a URL - , appHoogleLock :: MVar () + , appHoogleLock :: !(MVar ()) -- ^ Avoid concurrent Hoogle queries, see -- https://github.com/fpco/stackage-server/issues/172 - , appMirrorStatus :: IO (Status, WidgetFor App ()) - , appGetHoogleDB :: SnapName -> IO (Maybe FilePath) - , appGitRev :: GitRev + , appMirrorStatus :: !(IO (Status, WidgetFor App ())) + , appGetHoogleDB :: !(SnapName -> IO (Maybe FilePath)) + , appGitRev :: !GitRev } instance HasHttpManager App where @@ -87,7 +95,7 @@ defaultLayoutWithContainer insideContainer widget = do instance Yesod App where approot = ApprootRequest $ \app req -> case appRoot $ appSettings app of - Nothing -> getApprootText guessApproot app req + Nothing -> getApprootText guessApproot app req Just root -> root -- Store session data on the client in encrypted cookies, @@ -145,8 +153,8 @@ instance ToMarkup (Route App) where toMarkup c = case c of AllSnapshotsR{} -> "Snapshots" - BlogHomeR -> "Blog" - _ -> "" + BlogHomeR -> "Blog" + _ -> "" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. @@ -160,7 +168,10 @@ instance RenderMessage App FormMessage where -- -- https://github.com/yesodweb/yesod/wiki/Sending-email -instance GetStackageDatabase Handler where +instance GetStackageDatabase App Handler where getStackageDatabase = appStackageDatabase <$> getYesod -instance GetStackageDatabase (WidgetFor App) where + getLogFunc = appLogFunc <$> getYesod + +instance GetStackageDatabase App (WidgetFor App) where getStackageDatabase = appStackageDatabase <$> getYesod + getLogFunc = appLogFunc <$> getYesod diff --git a/src/Handler/Blog.hs b/src/Handler/Blog.hs index b00f8dc..08f4a17 100644 --- a/src/Handler/Blog.hs +++ b/src/Handler/Blog.hs @@ -1,84 +1,89 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Handler.Blog ( getBlogHomeR , getBlogPostR , getBlogFeedR ) where -import Import import Data.WebsiteContent -import Yesod.GitRepo (grContent) +import Import import Yesod.AtomFeed (atomLink) +import Yesod.GitRepo (grContent) +import RIO.Time (getCurrentTime) getPosts :: Handler (Vector Post) getPosts = do - now <- liftIO 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 + 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 getAddPreview :: Handler (Route App -> (Route App, [(Text, Text)])) getAddPreview = do mpreview <- lookupGetParam "preview" case mpreview of Just "true" -> return $ \route -> (route, [("preview", "true")]) - _ -> return $ \route -> (route, []) + _ -> return $ \route -> (route, []) postYear :: Post -> Year postYear p = - let (y, _, _) = toGregorian $ utctDay $ postTime p - in fromInteger y + let (y, _, _) = toGregorian $ utctDay $ postTime p + in fromInteger y postMonth :: Post -> Month postMonth p = - let (_, m, _) = toGregorian $ utctDay $ postTime p - in Month m + let (_, m, _) = toGregorian $ utctDay $ postTime p + in Month m getBlogHomeR :: Handler () getBlogHomeR = do - posts <- getPosts - case headMay posts of - Nothing -> notFound - Just post -> do - addPreview <- getAddPreview - redirect $ addPreview $ BlogPostR (postYear post) (postMonth post) (postSlug post) + posts <- getPosts + case headMay posts of + Nothing -> notFound + Just post -> do + addPreview <- getAddPreview + redirect $ addPreview $ BlogPostR (postYear post) (postMonth post) (postSlug post) getBlogPostR :: Year -> Month -> Text -> Handler Html getBlogPostR year month slug = do - posts <- getPosts - post <- maybe notFound return $ find matches posts - now <- liftIO getCurrentTime - addPreview <- getAddPreview - defaultLayout $ do - setTitle $ toHtml $ postTitle post - atomLink BlogFeedR "Stackage Curator blog" - $(widgetFile "blog-post") - toWidgetHead [shamlet||] + posts <- getPosts + post <- maybe notFound return $ find matches posts + now <- getCurrentTime + addPreview <- getAddPreview + defaultLayout $ do + setTitle $ toHtml $ postTitle post + atomLink BlogFeedR "Stackage Curator blog" + $(widgetFile "blog-post") + toWidgetHead [shamlet||] where matches p = postYear p == year && postMonth p == month && postSlug p == slug getBlogFeedR :: Handler TypedContent getBlogFeedR = do - posts <- fmap (take 10) getPosts - latest <- maybe notFound return $ headMay posts - newsFeed Feed - { feedTitle = "Stackage Curator blog" - , feedLinkSelf = BlogFeedR - , feedLinkHome = HomeR - , feedAuthor = "The Stackage Curator team" - , feedDescription = "Messages from the Stackage Curators about the Stackage project" - , feedLanguage = "en" - , feedUpdated = postTime latest - , feedLogo = Nothing - , feedEntries = map toEntry $ toList posts - } + posts <- fmap (take 10) getPosts + latest <- maybe notFound return $ headMay posts + newsFeed + Feed + { feedTitle = "Stackage Curator blog" + , feedLinkSelf = BlogFeedR + , feedLinkHome = HomeR + , feedAuthor = "The Stackage Curator team" + , feedDescription = "Messages from the Stackage Curators about the Stackage project" + , feedLanguage = "en" + , feedUpdated = postTime latest + , feedLogo = Nothing + , feedEntries = map toEntry $ toList posts + } where - toEntry post = FeedEntry - { feedEntryLink = BlogPostR (postYear post) (postMonth post) (postSlug post) - , feedEntryUpdated = postTime post - , feedEntryTitle = postTitle post - , feedEntryContent = postBody post - , feedEntryEnclosure = Nothing - } + toEntry post = + FeedEntry + { feedEntryLink = BlogPostR (postYear post) (postMonth post) (postSlug post) + , feedEntryUpdated = postTime post + , feedEntryTitle = postTitle post + , feedEntryContent = postBody post + , feedEntryEnclosure = Nothing + } diff --git a/src/Handler/BuildPlan.hs b/src/Handler/BuildPlan.hs index be9ee74..4c53e59 100644 --- a/src/Handler/BuildPlan.hs +++ b/src/Handler/BuildPlan.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE ConstraintKinds #-} module Handler.BuildPlan where -import Import hiding (get, PackageName (..), Version (..), DList) +import Import --import Stackage.Types -import Stackage.Database +--import Stackage.Database getBuildPlanR :: SnapName -> Handler TypedContent getBuildPlanR _slug = track "Handler.BuildPlan.getBuildPlanR" $ do diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 5f953bb..35c9e9c 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Handler.Download ( getDownloadR , getDownloadSnapshotsJsonR @@ -6,11 +7,12 @@ module Handler.Download , getDownloadGhcLinksR ) where +import RIO (textDisplay) import Import import Data.GhcLinks import Yesod.GitRepo (grContent) import Stackage.Database -import qualified Data.Text as T +import Stackage.Database.Types (ghcVersion) getDownloadR :: Handler Html getDownloadR = track "Hoogle.Download.getDownloadR" $ @@ -21,16 +23,11 @@ getDownloadSnapshotsJsonR = track "Hoogle.Download.getDownloadSnapshotsJsonR" getDownloadLtsSnapshotsJsonR getDownloadLtsSnapshotsJsonR :: Handler Value -getDownloadLtsSnapshotsJsonR = track "Hoogle.Download.getDownloadLtsSnapshotsJsonR" - snapshotsJSON +getDownloadLtsSnapshotsJsonR = track "Hoogle.Download.getDownloadLtsSnapshotsJsonR" snapshotsJSON -- Print the ghc major version for the given snapshot. ghcMajorVersionText :: Snapshot -> Text -ghcMajorVersionText = - getMajorVersion . snapshotGhc - where - getMajorVersion :: Text -> Text - getMajorVersion = intercalate "." . take 2 . T.splitOn "." +ghcMajorVersionText = textDisplay . keepMajorVersion . ghcVersion . snapshotCompiler getGhcMajorVersionR :: SnapName -> Handler Text getGhcMajorVersionR name = track "Hoogle.Download.getGhcMajorVersionR" $ do @@ -38,15 +35,14 @@ getGhcMajorVersionR name = track "Hoogle.Download.getGhcMajorVersionR" $ do return $ ghcMajorVersionText $ entityVal snapshot getDownloadGhcLinksR :: SupportedArch -> Text -> Handler TypedContent -getDownloadGhcLinksR arch fileName = track "Hoogle.Download.getDownloadGhcLinksR" $ do - ver <- maybe notFound return - $ stripPrefix "ghc-" - >=> stripSuffix "-links.yaml" - >=> ghcMajorVersionFromText - $ fileName - ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . appWebsiteContent - case lookup (arch, ver) (ghcLinksMap ghcLinks) of - Just text -> return $ TypedContent yamlMimeType $ toContent text - Nothing -> notFound +getDownloadGhcLinksR arch fName = + track "Hoogle.Download.getDownloadGhcLinksR" $ do + ver <- + maybe notFound return $ + stripPrefix "ghc-" >=> stripSuffix "-links.yaml" >=> ghcMajorVersionFromText $ fName + ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . appWebsiteContent + case lookup (arch, ver) (ghcLinksMap ghcLinks) of + Just text -> return $ TypedContent yamlMimeType $ toContent text + Nothing -> notFound where yamlMimeType = "text/yaml" diff --git a/src/Handler/DownloadStack.hs b/src/Handler/DownloadStack.hs index fad692f..ecd8e14 100644 --- a/src/Handler/DownloadStack.hs +++ b/src/Handler/DownloadStack.hs @@ -1,14 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} module Handler.DownloadStack ( getDownloadStackListR , getDownloadStackR , getLatestMatcher ) where -import Import -import Yesod.GitRepo -import Data.WebsiteContent import Data.Aeson.Parser (json) import Data.Conduit.Attoparsec (sinkParser) +import Data.WebsiteContent +import Import +import Yesod.GitRepo getDownloadStackListR :: Handler Html getDownloadStackListR = track "Handler.DownloadStack.getDownloadStackListR" $ do @@ -18,9 +20,9 @@ getDownloadStackListR = track "Handler.DownloadStack.getDownloadStackListR" $ do $(widgetFile "download-stack-list") getDownloadStackR :: Text -> Handler () -getDownloadStackR pattern = track "Handler.DownloadStack.getDownloadStackR" $ do +getDownloadStackR pattern' = track "Handler.DownloadStack.getDownloadStackR" $ do matcher <- getYesod >>= liftIO . appLatestStackMatcher - maybe notFound redirect $ matcher pattern + maybe notFound redirect $ matcher pattern' -- | Creates a function which will find the latest release for a given pattern. getLatestMatcher :: Manager -> IO (Text -> Maybe Text) @@ -30,11 +32,11 @@ getLatestMatcher man = do } val <- flip runReaderT man $ withResponse req $ \res -> runConduit $ responseBody res .| sinkParser json - return $ \pattern -> do - let pattern' = pattern ++ "." + return $ \pattern' -> do + let pattern'' = pattern' ++ "." Object top <- return val Array assets <- lookup "assets" top - headMay $ preferZip $ catMaybes $ map (findMatch pattern') assets + headMay $ preferZip $ catMaybes $ map (findMatch pattern'') assets where findMatch pattern' (Object o) = do String name <- lookup "name" o @@ -44,5 +46,5 @@ getLatestMatcher man = do Just url findMatch _ _ = Nothing - preferZip = map snd . sortBy (comparing fst) . map + preferZip = map snd . sortOn fst . map (\x -> (if ".zip" `isSuffixOf` x then 0 else 1 :: Int, x)) diff --git a/src/Handler/Feed.hs b/src/Handler/Feed.hs index caa7207..49efc9d 100644 --- a/src/Handler/Feed.hs +++ b/src/Handler/Feed.hs @@ -1,13 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} module Handler.Feed ( getFeedR , getBranchFeedR ) where +import Data.These import Import import Stackage.Database -import Data.These import Stackage.Snapshot.Diff import Text.Blaze (text) +import RIO.Time (getCurrentTime) getFeedR :: Handler TypedContent getFeedR = track "Handler.Feed.getBranchFeedR" $ getBranchFeed Nothing @@ -26,13 +29,13 @@ mkFeed mBranch snaps = do return FeedEntry { feedEntryLink = SnapshotR (snapshotName snap) StackageHomeR , feedEntryUpdated = UTCTime (snapshotCreated snap) 0 - , feedEntryTitle = prettyName (snapshotName snap) (snapshotGhc snap) + , feedEntryTitle = snapshotTitle snap , feedEntryContent = content , feedEntryEnclosure = Nothing } updated <- case entries of - [] -> liftIO getCurrentTime + [] -> getCurrentTime x:_ -> return $ feedEntryUpdated x newsFeed Feed { feedTitle = title @@ -46,8 +49,8 @@ mkFeed mBranch snaps = do , feedLogo = Nothing } where - branchTitle NightlyBranch = "Nightly" - branchTitle LtsBranch = "LTS" + branchTitle NightlyBranch = "Nightly" + branchTitle LtsBranch = "LTS" branchTitle (LtsMajorBranch x) = "LTS-" <> tshow x title = "Recent Stackage " <> maybe "" branchTitle mBranch <> " snapshots" @@ -61,7 +64,7 @@ getContent sid2 snap = do let name2 = snapshotName snap withUrlRenderer [hamlet| -

Difference between #{prettyNameShort name1} and #{prettyNameShort $ snapshotName snap} +

Difference between #{snapshotPrettyNameShort name1} and #{snapshotPrettyNameShort $ snapshotName snap} @@ -69,9 +72,9 @@ getContent sid2 snap = do - $forall (pkgname@(PackageName name), VersionChange change, versionDiff) <- toVersionedDiffList snapDiff + $forall (pkgname, VersionChange change, versionDiff) <- toVersionedDiffList snapDiff -
Old New
#{name} + #{pkgname} $case change $of This old diff --git a/src/Handler/Haddock.hs b/src/Handler/Haddock.hs index 490d35a..6017f6a 100644 --- a/src/Handler/Haddock.hs +++ b/src/Handler/Haddock.hs @@ -1,51 +1,77 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Handler.Haddock ( getHaddockR , getHaddockBackupR ) where import Import +import qualified Data.Text as T (takeEnd) import Stackage.Database +import Stackage.Database.Types (haddockBucketName) makeURL :: SnapName -> [Text] -> Text -makeURL slug rest = concat - $ "https://s3.amazonaws.com/haddock.stackage.org/" - : toPathPiece slug +makeURL snapName rest = concat + $ "https://s3.amazonaws.com/" + : haddockBucketName + : "/" + : toPathPiece snapName : map (cons '/') rest shouldRedirect :: Bool shouldRedirect = False +data DocType = DocHtml | DocJson + getHaddockR :: SnapName -> [Text] -> Handler TypedContent -getHaddockR slug rest - | shouldRedirect = do - result <- redirectWithVersion slug rest - case result of - Just route -> redirect route - Nothing -> redirect $ makeURL slug rest - | final:_ <- reverse rest, ".html" `isSuffixOf` final = do - render <- getUrlRender - result <- redirectWithVersion slug rest - case result of - Just route -> redirect route - Nothing -> do - let extra = concat - [ "" - , "" - ] - req <- parseRequest $ unpack $ makeURL slug rest - man <- getHttpManager <$> getYesod - (_, res) <- runReaderT (acquireResponse req >>= allocateAcquire) man - mstyle <- lookupGetParam "style" - case mstyle of - Just "plain" -> respondSource "text/html; charset=utf-8" - $ responseBody res .| mapC (Chunk . toBuilder) - _ -> respondSource "text/html; charset=utf-8" $ responseBody res .| (do - takeUntilChunk "" - peekC >>= maybe (return ()) (const $ yield $ encodeUtf8 extra) - mapC id) .| mapC (Chunk . toBuilder) - | otherwise = redirect $ makeURL slug rest +getHaddockR snapName rest + | shouldRedirect = do + result <- redirectWithVersion snapName rest + case result of + Just route -> redirect route + Nothing -> redirect $ makeURL snapName rest + | Just docType <- mdocType = do + result <- redirectWithVersion snapName rest + case result of + Just route -> redirect route + Nothing -> do + (contentType, plain) <- + case docType of + DocHtml -> do + mstyle <- lookupGetParam "style" + return ("text/html; charset=utf-8", mstyle == Just "plain") + DocJson -> + return ("application/jsontml; charset=utf-8", True) + req <- parseRequest $ unpack $ makeURL snapName rest + man <- getHttpManager <$> getYesod + (_, res) <- runReaderT (acquireResponse req >>= allocateAcquire) man + if plain + then respondSource contentType $ responseBody res .| mapC (Chunk . toBuilder) + else do + extra <- getExtra + respondSource contentType $ + responseBody res .| + (do takeUntilChunk "" + peekC >>= maybe (return ()) (const $ yield $ encodeUtf8 extra) + mapC id) .| + mapC (Chunk . toBuilder) + | otherwise = redirect $ makeURL snapName rest + where + mdocType = + case T.takeEnd 5 <$> headMay (reverse rest) of + Just ".html" -> Just DocHtml + Just ".json" -> Just DocJson + _ -> Nothing + getExtra = do + render <- getUrlRender + return $ + concat + [ "" + , "" + ] + + takeUntilChunk :: Monad m => ByteString -> ConduitM ByteString ByteString m () takeUntilChunk fullNeedle = @@ -70,7 +96,13 @@ takeUntilChunk fullNeedle = Just needle' -> loop (front . (bs:)) needle' Nothing -> yieldMany (front [bs]) >> start -data CheckNeedle = CNNotFound | CNFound !ByteString !ByteString | CNPartial !ByteString !ByteString !ByteString +data CheckNeedle + = CNNotFound + | CNFound !ByteString + !ByteString + | CNPartial !ByteString + !ByteString + !ByteString checkNeedle :: ByteString -> ByteString -> CheckNeedle checkNeedle needle bs0 = @@ -88,18 +120,20 @@ checkNeedle needle bs0 = | Just needle' <- stripPrefix bs needle = CNPartial before bs needle' | otherwise = CNNotFound -redirectWithVersion - :: (GetStackageDatabase m,MonadHandler m,RedirectUrl (HandlerSite m) (Route App)) - => SnapName -> [Text] -> m (Maybe (Route App)) -redirectWithVersion slug rest = +redirectWithVersion :: + (GetStackageDatabase env m, MonadHandler m) => SnapName -> [Text] -> m (Maybe (Route App)) +redirectWithVersion snapName rest = case rest of - [pkg,file] -> do - Entity sid _ <- lookupSnapshot slug >>= maybe notFound return - mversion <- getPackageVersionBySnapshot sid pkg - case mversion of + [pkg, file] | Just pname <- fromPathPiece pkg -> do + mspi <- getSnapshotPackageInfo snapName pname + case mspi of -- TODO: Should `Nothing` cause a 404 here, since haddock will fail? Nothing -> return Nothing -- error "That package is not part of this snapshot." - Just version -> do - return (Just (HaddockR slug [pkg <> "-" <> version, file])) + Just spi -> do + return + (Just + (HaddockR + snapName + [toPathPiece $ PackageIdentifierP pname (spiVersion spi), file])) _ -> return Nothing getHaddockBackupR :: [Text] -> Handler () @@ -107,6 +141,6 @@ getHaddockBackupR (snap':rest) | Just branch <- fromPathPiece snap' = track "Handler.Haddock.getHaddockBackupR" $ do snapName <- newestSnapshot branch >>= maybe notFound pure redirect $ HaddockR snapName rest -getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat +getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat $ "https://s3.amazonaws.com/haddock.stackage.org" : map (cons '/') rest diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 4c8d664..66243b6 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE TupleSections, OverloadedStrings #-} - +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Handler.Home ( getHomeR , getAuthorsR @@ -7,7 +10,7 @@ module Handler.Home , getOlderReleasesR ) where -import Data.Time.Clock +import RIO.Time import Import import Stackage.Database import Yesod.GitRepo (grContent) @@ -21,7 +24,7 @@ import Yesod.GitRepo (grContent) -- inclined, or create a single monolithic file. getHomeR :: Handler Html getHomeR = track "Handler.Snapshots.getAllSnapshotsR" $ do - now' <- liftIO getCurrentTime + now' <- getCurrentTime currentPageMay <- lookupGetParam "page" let currentPage :: Int currentPage = fromMaybe 1 (currentPageMay >>= readMay) diff --git a/src/Handler/Hoogle.hs b/src/Handler/Hoogle.hs index 6914314..4d2c2fa 100644 --- a/src/Handler/Hoogle.hs +++ b/src/Handler/Hoogle.hs @@ -1,24 +1,30 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Handler.Hoogle where -import Control.DeepSeq (NFData(..)) -import Data.Data (Data) -import Data.Text.Read (decimal) -import qualified Hoogle -import Import -import Text.Blaze.Html (preEscapedToHtml) -import Stackage.Database +import Control.DeepSeq (NFData(..)) import qualified Data.Text as T +import Data.Text.Read (decimal) +import qualified Hoogle +import Import +import Stackage.Database +import Text.Blaze.Html (preEscapedToHtml) import qualified Text.HTML.DOM -import Text.XML.Cursor (fromDocument, ($//), content) +import Text.XML.Cursor (content, fromDocument, ($//)) getHoogleDB :: SnapName -> Handler (Maybe FilePath) -getHoogleDB name = track "Handler.Hoogle.getHoogleDB" $ do +getHoogleDB name = track "Handler.Hoogle.getHoogleDB" do app <- getYesod liftIO $ appGetHoogleDB app name getHoogleR :: SnapName -> Handler Html -getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do +getHoogleR name = track "Handler.Hoogle.getHoogleR" do Entity _ snapshot <- lookupSnapshot name >>= maybe notFound return mquery <- lookupGetParam "q" mPackageName <- lookupGetParam "package" @@ -28,11 +34,11 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do let count' = case decimal <$> mresults' of Just (Right (i, "")) -> min perPage i - _ -> perPage + _ -> perPage page = case decimal <$> mpage of Just (Right (i, "")) -> i - _ -> 1 + _ -> 1 offset = (page - 1) * perPage mdatabasePath <- getHoogleDB name dbPath <- maybe (hoogleDatabaseNotAvailableFor name) return mdatabasePath @@ -67,27 +73,30 @@ getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do [("page", tshow p)]) snapshotLink = SnapshotR name StackageHomeR hoogleForm = $(widgetFile "hoogle-form") - defaultLayout $ do + defaultLayout do setTitle "Hoogle Search" $(widgetFile "hoogle") getHoogleDatabaseR :: SnapName -> Handler Html -getHoogleDatabaseR name = track "Handler.Hoogle.getHoogleDatabaseR" $ do - mdatabasePath <- getHoogleDB name - case mdatabasePath of - Nothing -> hoogleDatabaseNotAvailableFor name - Just path -> sendFile "application/octet-stream" path +getHoogleDatabaseR name = + track "Handler.Hoogle.getHoogleDatabaseR" do + mdatabasePath <- getHoogleDB name + case mdatabasePath of + Nothing -> hoogleDatabaseNotAvailableFor name + Just path -> sendFile "application/octet-stream" path hoogleDatabaseNotAvailableFor :: SnapName -> Handler a -hoogleDatabaseNotAvailableFor name = track "Handler.Hoogle.hoogleDatabaseNotAvailableFor" $ do - (>>= sendResponse) $ defaultLayout $ do - setTitle "Hoogle database not available" - [whamlet| +hoogleDatabaseNotAvailableFor name = + track "Handler.Hoogle.hoogleDatabaseNotAvailableFor" do + sendResponse =<< + defaultLayout + (do setTitle "Hoogle database not available" + [whamlet|

The given Hoogle database is not available.

Return to snapshot homepage - |] + |]) getPageCount :: Int -> Int getPageCount totalCount = 1 + div totalCount perPage @@ -96,36 +105,36 @@ perPage :: Int perPage = 10 data HoogleQueryInput = HoogleQueryInput - { hqiQueryInput :: Text - , hqiLimitTo :: Int - , hqiOffsetBy :: Int - , hqiExact :: Bool + { hqiQueryInput :: !Text + , hqiLimitTo :: !Int + , hqiOffsetBy :: !Int + , hqiExact :: !Bool } - deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) + deriving (Eq, Show, Ord, Generic) data HoogleQueryOutput = HoogleQueryOutput [HoogleResult] (Maybe Int) -- ^ Int == total count - deriving (Read, Typeable, Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) instance NFData HoogleQueryOutput data HoogleResult = HoogleResult - { hrURL :: String - , hrSources :: [(PackageLink, [ModuleLink])] - , hrTitle :: String -- ^ HTML - , hrBody :: String -- ^ plain text + { hrURL :: !Text + , hrSources :: ![(PackageLink, [ModuleLink])] + , hrTitle :: !Text -- ^ HTML + , hrBody :: !String -- ^ plain text } - deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) + deriving (Eq, Show, Ord, Generic) data PackageLink = PackageLink - { plName :: String - , plURL :: String + { plName :: !PackageNameP + , plURL :: !Text } - deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) + deriving (Eq, Show, Ord, Generic) data ModuleLink = ModuleLink - { mlName :: String - , mlURL :: String + { mlName :: !ModuleNameP + , mlURL :: !Text } - deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) + deriving (Eq, Show, Ord, Generic) instance NFData HoogleResult instance NFData PackageLink @@ -136,69 +145,67 @@ runHoogleQuery :: (Route App -> Text) -> Hoogle.Database -> HoogleQueryInput -> HoogleQueryOutput -runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} = - HoogleQueryOutput targets mcount +runHoogleQuery renderUrl snapshot hoogledb HoogleQueryInput {..} = HoogleQueryOutput targets mcount where allTargets = Hoogle.searchDatabase hoogledb query - targets = take (min 100 hqiLimitTo) - $ drop hqiOffsetBy - $ map fixResult allTargets - query = unpack $ hqiQueryInput ++ if hqiExact then " is:exact" else "" - + targets = take (min 100 hqiLimitTo) $ drop hqiOffsetBy $ map fixResult allTargets + query = + unpack $ + hqiQueryInput ++ + if hqiExact + then " is:exact" + else "" mcount = limitedLength 0 allTargets - limitedLength x [] = Just x limitedLength x (_:rest) | x >= 20 = Nothing | otherwise = limitedLength (x + 1) rest + fixResult target@Hoogle.Target {..} = + HoogleResult + { hrURL = + case sources of + [(_, [ModuleLink _ m])] -> m <> haddockAnchorFromUrl targetURL + _ -> fromMaybe (T.pack targetURL) $ asum [mModuleLink, mPackageLink] + , hrSources = sources + , hrTitle + -- NOTE: from hoogle documentation: + -- HTML span of the item, using 0 for the name and 1 onwards for arguments + = T.replace "<0>" "" $ T.replace "" "" $ pack targetItem + , hrBody = targetDocs + } + where + sources = + toList do + (packageLink, mkModuleUrl) <- targetLinks renderUrl snapshot target + modName <- parseModuleNameP . fst =<< targetModule + Just (packageLink, [ModuleLink modName $ mkModuleUrl modName]) + item = + let doc = Text.HTML.DOM.parseLBS $ encodeUtf8 $ pack targetItem + cursor = fromDocument doc + in T.concat $ cursor $// content + mModuleLink = do + "module" <- Just targetType + (_packageLink, mkModuleUrl) <- targetLinks renderUrl snapshot target + modName <- parseModuleNameP . T.unpack =<< T.stripPrefix "module " item + pure $ mkModuleUrl modName + mPackageLink = do + guard $ isNothing targetPackage + "package" <- Just targetType + pnameTxt <- T.stripPrefix "package " item + pname <- fromPathPiece pnameTxt + return $ renderUrl $ SnapshotR snapshot $ StackageSdistR $ PNVName pname + haddockAnchorFromUrl = T.pack . ('#' :) . reverse . takeWhile (/= '#') . reverse - fixResult Hoogle.Target {..} = HoogleResult - { hrURL = case sources of - [(_,[ModuleLink _ m])] -> m ++ haddockAnchorFromUrl targetURL - _ -> fromMaybe targetURL $ asum - [ moduleLink - , packageLink - ] - , hrSources = sources - , hrTitle = -- FIXME find out why these replaces are necessary - unpack $ T.replace "<0>" "" $ T.replace "" "" $ pack - targetItem - , hrBody = targetDocs - } - where sources = toList $ do - (pname, _) <- targetPackage - (mname, _) <- targetModule - let p = PackageLink pname (makePackageLink pname) - m = ModuleLink - mname - (T.unpack - (renderUrl - (haddockUrl - snapshot - (T.pack pname) - (T.pack mname)))) - Just (p, [m]) +targetLinks :: + (Route App -> Text) + -> SnapName + -> Hoogle.Target + -> Maybe (PackageLink, ModuleNameP -> Text) +targetLinks renderUrl snapName Hoogle.Target {..} = do + (pname, _) <- targetPackage + packageName <- parsePackageNameP pname + let mkModuleUrl modName = renderUrl (hoogleHaddockUrl snapName packageName modName) + return (makePackageLink packageName, mkModuleUrl) - moduleLink = do - (pname, _) <- targetPackage - "module" <- Just targetType - let doc = Text.HTML.DOM.parseLBS $ encodeUtf8 $ pack targetItem - cursor = fromDocument doc - item = T.concat $ cursor $// content - mname <- T.stripPrefix "module " item - return $ T.unpack $ renderUrl $ haddockUrl snapshot (T.pack pname) mname - - packageLink = do - Nothing <- Just targetPackage - "package" <- Just targetType - let doc = Text.HTML.DOM.parseLBS $ encodeUtf8 $ pack targetItem - cursor = fromDocument doc - item = T.concat $ cursor $// content - pname <- T.stripPrefix "package " item - return $ T.unpack $ renderUrl $ SnapshotR snapshot $ StackageSdistR $ PNVName $ PackageName pname - - haddockAnchorFromUrl = - ('#':) . reverse . takeWhile (/='#') . reverse - -makePackageLink :: String -> String -makePackageLink pkg = "/package/" ++ pkg +makePackageLink :: PackageNameP -> PackageLink +makePackageLink packageName = PackageLink packageName ("/package/" <> toPathPiece packageName) diff --git a/src/Handler/MirrorStatus.hs b/src/Handler/MirrorStatus.hs index 1d558e4..77a978e 100644 --- a/src/Handler/MirrorStatus.hs +++ b/src/Handler/MirrorStatus.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} + module Handler.MirrorStatus ( getMirrorStatusR , mkUpdateMirrorStatus @@ -6,7 +8,7 @@ module Handler.MirrorStatus import Import import Control.AutoUpdate import Network.HTTP.Simple -import Data.Time (parseTimeM, diffUTCTime, addUTCTime) +import RIO.Time (parseTimeM, diffUTCTime, addUTCTime, getCurrentTime) import Text.XML.Stream.Parse import Data.XML.Types (Event (EventContent), Content (ContentText)) import qualified Prelude diff --git a/src/Handler/OldLinks.hs b/src/Handler/OldLinks.hs index 4a235f5..495dd2b 100644 --- a/src/Handler/OldLinks.hs +++ b/src/Handler/OldLinks.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Handler.OldLinks ( getOldSnapshotBranchR , getOldSnapshotR diff --git a/src/Handler/Package.hs b/src/Handler/Package.hs index 674530f..d1a31f3 100644 --- a/src/Handler/Package.hs +++ b/src/Handler/Package.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} -- | Lists the package page similar to Hackage. @@ -7,33 +13,34 @@ module Handler.Package , getPackageSnapshotsR , packagePage , getPackageBadgeR - , renderNoPackages + , renderNumPackages ) where -import Data.Char +import Control.Lens + +import Data.Coerce 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 Distribution.Package.ModuleForest +import Graphics.Badge.Barrier +import Import +import Stackage.Database +import Stackage.Database.PackageInfo (PackageInfo(..), Identifier(..), renderEmail) +import Stackage.Database.Types (HackageCabalInfo(..), LatestInfo(..), + ModuleListingInfo(..)) import qualified Text.Blaze.Html.Renderer.Text as LT -import Text.Email.Validate -import Stackage.Database -import Yesod.GitRepo +import Yesod.GitRepo -- | Page metadata package. -getPackageR :: PackageName -> Handler Html +getPackageR :: PackageNameP -> Handler Html getPackageR = track "Handler.Package.getPackageR" . packagePage Nothing -getPackageBadgeR :: PackageName -> SnapshotBranch -> Handler TypedContent +getPackageBadgeR :: PackageNameP -> SnapshotBranch -> Handler TypedContent getPackageBadgeR pname branch = track "Handler.Package.getPackageBadgeR" $ do cacheSeconds (3 * 60 * 60) 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) + mVersion <- getPackageVersionForSnapshot sid pname mLabel <- lookupGetParam "label" mStyle <- lookupGetParam "style" @@ -47,214 +54,108 @@ renderStackageBadge :: (Badge b, HasRightColor b) => b -- ^ Style -> Maybe Text -- ^ Label -> SnapName - -> Maybe Version + -> Maybe VersionP -> LByteString renderStackageBadge style mLabel snapName = \case - Nothing -> renderBadge (style & right .~ lightgray) badgeLabel "not available" - Just (Version x) -> renderBadge style badgeLabel x + Nothing -> renderBadge (style & right .~ lightgray) badgeLabel "not available" + Just v -> renderBadge style badgeLabel $ toPathPiece v where badgeLabel = fromMaybe ("stackage " <> badgeSnapName snapName) mLabel badgeSnapName (SNNightly _) = "nightly" badgeSnapName (SNLts x _) = "lts-" <> tshow x -checkSpam :: PackageName -> Handler Html -> Handler Html -checkSpam name inner = do +checkSpam :: PackageNameP -> Handler Html -> Handler Html +checkSpam pname inner = do wc <- getYesod >>= liftIO . grContent . appWebsiteContent - if name `member` wcSpamPackages wc + if pname `member` wcSpamPackages wc then defaultLayout $ do - setTitle $ "Spam package detected: " <> toHtml name + setTitle $ "Spam package detected: " <> toHtml pname $(widgetFile "spam-package") else inner -packagePage :: Maybe (SnapName, Version) - -> PackageName +packagePage :: Maybe SnapshotPackageInfo + -> PackageNameP -> Handler Html -packagePage mversion pname = track "Handler.Package.packagePage" $ checkSpam pname $ do - let pname' = toPathPiece pname - (deprecated, inFavourOf) <- getDeprecated pname' - latests <- getLatests pname' - deps' <- getDeps pname' $ Just maxDisplayedDeps - revdeps' <- getRevDeps pname' $ Just maxDisplayedDeps - (depsCount, revdepsCount) <- getDepsCount pname' - Entity _ package <- getPackage pname' >>= maybe notFound return +packagePage mspi pname = + track "Handler.Package.packagePage" $ + checkSpam pname $ + maybe (getSnapshotPackageLatestVersion pname) (return . Just) mspi >>= \case + Nothing -> do + hci <- run (getHackageLatestVersion pname) >>= maybe notFound pure + handlePackage $ Left hci + Just spi -> handlePackage $ Right spi - mdocs <- - case mversion of - Just (sname, version) -> do - ms <- getPackageModules sname pname' - return $ Just (sname, toPathPiece version, ms) - Nothing -> - case latests of - li:_ -> do - ms <- getPackageModules (liSnapName li) pname' - return $ Just (liSnapName li, liVersion li, ms) - [] -> return Nothing - let ixInFavourOf = zip [0::Int ..] inFavourOf - mdisplayedVersion = toPathPiece . snd <$> mversion - latestVersion = packageLatest package - let homepage = case T.strip (packageHomepage package) of - x | null x -> Nothing - | otherwise -> Just x - synopsis = packageSynopsis package - deps = enumerate deps' - revdeps = enumerate revdeps' - authors = enumerate (parseIdentitiesLiberally (packageAuthor package)) - maintainers = let ms = enumerate (parseIdentitiesLiberally (packageMaintainer package)) - in if ms == authors - then [] - else ms + +handlePackage :: Either HackageCabalInfo SnapshotPackageInfo -> Handler Html +handlePackage epi = do + (isDeprecated, inFavourOf) <- getDeprecated pname + (msppi, mhciLatest) <- + case epi of + Right spi -> do + sppi <- getSnapshotPackagePageInfo spi maxDisplayedDeps + return (Just sppi, sppiLatestHackageCabalInfo sppi) + Left hci -> pure (Nothing, Just hci) + PackageInfo {..} <- getPackageInfo epi + let authors = enumerate piAuthors + maintainers = + let ms = enumerate piMaintainers + in if ms == authors + then [] + else ms + mdisplayedVersion = msppi >>= sppiVersion defaultLayout $ do setTitle $ toHtml pname - $(combineScripts 'StaticR - [ js_highlight_js - ]) - $(combineStylesheets 'StaticR - [ css_font_awesome_min_css - , css_highlight_github_css - ]) - let pn = pname - toPkgVer x y = concat [x, "-", y] - hoogleForm name = - let exact = False - mPackageName = Just pname - queryText = "" :: Text - in $(widgetFile "hoogle-form") + $(combineScripts 'StaticR [js_highlight_js]) + $(combineStylesheets 'StaticR [css_font_awesome_min_css, css_highlight_github_css]) + let hoogleForm name = + let exact = False + mPackageName = Just pname + queryText = "" :: Text + in $(widgetFile "hoogle-form") $(widgetFile "package") - where enumerate = zip [0::Int ..] - renderModules sname version = renderForest [] . moduleForest . map moduleName - where - renderForest _ [] = mempty - renderForest pathRev trees = - [hamlet|