From 1a2e963924df691b6bd656ea43a05e1081c12a40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Sun, 26 Jun 2022 21:45:39 +0200 Subject: [PATCH] Odd jobs tweaks (#140) * Refactor the jobs code * Don't throw an exception when there is no README * style and freeze * Beautiful CSS for package READMEs --- assets/css/app.css | 5 +- assets/css/package-readme.css | 59 +++++++++ cabal.project.freeze | 40 ++++++ environment.ci.sh | 2 +- flora.cabal | 3 + src/Flora/Environment/OddJobs.hs | 55 +++----- src/Flora/Import/Package.hs | 2 +- src/Flora/Model/Package/Types.hs | 3 - src/Flora/Model/Release/Update.hs | 11 +- src/Flora/OddJobs.hs | 157 +++++++---------------- src/Flora/OddJobs/Types.hs | 121 +++++++++++++++++ src/Flora/ThirdParties/Hackage/API.hs | 24 +++- src/Flora/ThirdParties/Hackage/Client.hs | 23 +++- src/FloraWeb/Server.hs | 22 +++- src/FloraWeb/Templates/Pages/Packages.hs | 87 +++++++++---- 15 files changed, 421 insertions(+), 193 deletions(-) create mode 100644 assets/css/package-readme.css create mode 100644 src/Flora/OddJobs/Types.hs diff --git a/assets/css/app.css b/assets/css/app.css index 0a03fea9..cc457215 100644 --- a/assets/css/app.css +++ b/assets/css/app.css @@ -2,6 +2,8 @@ @import "tailwindcss/components"; @import "tailwindcss/utilities"; +@import "package-readme.css"; + @layer components { .larger-container { @apply max-w-7xl mx-auto px-2; @@ -152,7 +154,8 @@ div[class="bullets"] { @apply bg-gray-7 dark:bg-blue-1; } .package-readme-column{ - margin: 0 2em; + margin: 0 2em; + overflow: auto; } ul.package-list a { diff --git a/assets/css/package-readme.css b/assets/css/package-readme.css new file mode 100644 index 00000000..4f6df172 --- /dev/null +++ b/assets/css/package-readme.css @@ -0,0 +1,59 @@ +.package-readme{ + overflow-wrap: break-word; + box-sizing: border-box; + + h1 { + border-bottom: 1px solid #354561; + padding-bottom: 0.3em; + margin-bottom: 16px; + font-size: 2em; + a { + display: inline-block; + } + } + + img { + max-width: 100%; + box-sizing: content-box; + } + + h2 { + border-bottom: 1px solid #354561; + margin-bottom: 16px; + padding-bottom: 0.3em; + font-size: 1.5em; + } + + ul { + margin-bottom: 16px; + + li { + overflow-wrap: break-word; + list-style-type: disc; + list-style-position: inside; + } + li + li { + margin-top: .25em; + } + } + + p { + overflow-wrap: break-word; + margin-bottom: 16px; + box-sizing: border-box; + a { + display: inline-block; + } + } + + pre { + line-height: 1.45; + padding: 16px; + font-family: monospace; + border-radius: 6px; + overflow: auto; + font-size: 90%; + background-color: #354561; + margin-bottom: 16px; + } +} diff --git a/cabal.project.freeze b/cabal.project.freeze index 9864d8b4..4499b96d 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -8,6 +8,7 @@ constraints: any.Cabal ==3.6.3.0, PyF -python_test, any.QuickCheck ==2.14.2, QuickCheck -old-random +templatehaskell, + any.RSA ==2.4.1, any.SHA ==1.6.4.4, SHA -exe, any.StateVar ==1.2.2, @@ -34,12 +35,14 @@ constraints: any.Cabal ==3.6.3.0, attoparsec -developer, any.attoparsec-iso8601 ==1.0.2.1, attoparsec-iso8601 -developer -fast, + any.authenticate-oauth ==1.7, any.auto-update ==0.1.6, any.barbies ==2.0.3.1, any.base ==4.14.3.0, any.base-compat ==0.12.1, any.base-compat-batteries ==0.12.1, any.base-orphans ==0.8.6, + any.base16-bytestring ==1.0.2.0, any.base64 ==0.4.2.4, any.base64-bytestring ==1.2.1.0, any.basement ==0.0.14, @@ -70,6 +73,8 @@ constraints: any.Cabal ==3.6.3.0, cmdargs +quotation -testprog, any.colour ==2.3.6, any.colourista ==0.1.0.1, + any.commonmark ==0.2.2, + any.commonmark-extensions ==0.2.3.2, any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, any.concurrent-output ==1.10.16, @@ -81,11 +86,15 @@ constraints: any.Cabal ==3.6.3.0, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, any.cookie ==0.4.5, + any.crypto-api ==0.13.3, + crypto-api -all_cpolys, + any.crypto-pubkey-types ==0.4.3, any.cryptohash ==0.11.9, any.cryptohash-md5 ==0.11.101.0, any.cryptohash-sha1 ==0.11.101.0, any.cryptonite ==0.30, cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, + any.daemons ==0.3.0, any.data-default ==0.7.1.1, any.data-default-class ==0.1.2.0, any.data-default-instances-containers ==0.0.1, @@ -102,6 +111,8 @@ constraints: any.Cabal ==3.6.3.0, any.dlist ==1.0, dlist -werror, any.easy-file ==0.2.2, + any.either ==5.0.2, + any.emojis ==0.1.2, any.entropy ==0.4.1.7, entropy -halvm, any.envparse ==0.5.0, @@ -113,7 +124,11 @@ constraints: any.Cabal ==3.6.3.0, any.filtrable ==0.1.6.0, filtrable +containers, flora -prod, + any.foreign-store ==0.2, any.free ==5.1.8, + any.friendly-time ==0.4.1, + any.generic-deriving ==1.14.1, + generic-deriving +base-4-9, any.ghc ==8.10.7, any.ghc-boot ==8.10.7, any.ghc-boot-th ==8.10.7, @@ -125,6 +140,7 @@ constraints: any.Cabal ==3.6.3.0, hashable +containers +integer-gmp -random-initial-seed, any.haskell-lexer ==1.1, any.hedgehog ==1.1.1, + any.hostname ==1.0, any.hourglass ==0.2.12, any.hpc ==0.6.1.0, any.hsc2hs ==0.68.8, @@ -150,6 +166,9 @@ constraints: any.Cabal ==3.6.3.0, any.invariant ==0.5.6, any.iproute ==1.7.12, any.kan-extensions ==5.2.4, + any.lens ==5.1.1, + lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, + any.lens-aeson ==1.2.1, any.lifted-async ==0.10.2.2, any.lifted-base ==0.2.3.12, any.log-base ==0.11.1.0, @@ -165,6 +184,10 @@ constraints: any.Cabal ==3.6.3.0, any.mime-types ==0.1.0.9, any.mmorph ==1.2.0, any.monad-control ==1.0.3.1, + any.monad-logger ==0.3.36, + monad-logger +template_haskell, + any.monad-loops ==0.4.3, + monad-loops +base4, any.monad-time ==0.3.1.0, any.mono-traversable ==1.0.15.3, any.mtl ==2.2.2, @@ -174,12 +197,14 @@ constraints: any.Cabal ==3.6.3.0, any.network-byte-order ==0.1.6, any.network-info ==0.2.1, any.network-uri ==2.6.4.1, + any.odd-jobs ==0.2.2, any.old-locale ==1.0.0.7, any.old-time ==1.1.0.3, any.optics-core ==0.4.1, optics-core -explicit-generic-labels, any.optparse-applicative ==0.17.0.0, optparse-applicative +process, + any.parallel ==3.2.2.0, any.parsec ==3.1.14.0, any.password ==3.0.1.0, any.password-types ==1.0.0.0, @@ -188,6 +213,7 @@ constraints: any.Cabal ==3.6.3.0, any.pg-entity ==0.0.1.0, pg-entity -prod, any.pg-transact ==0.3.2.0, + any.pipes ==4.3.16, any.postgresql-libpq ==0.9.4.3, postgresql-libpq -use-pkg-config, any.postgresql-migration ==0.2.1.3, @@ -208,6 +234,8 @@ constraints: any.Cabal ==3.6.3.0, any.psqueues ==0.2.7.3, any.random ==1.2.1.1, any.raven-haskell ==0.1.4.1, + any.reflection ==2.1.6, + reflection -slow +template-haskell, any.regex-applicative ==0.3.4, any.resource-pool ==0.3.0.0, any.resourcet ==1.2.5, @@ -223,10 +251,13 @@ constraints: any.Cabal ==3.6.3.0, any.semigroups ==0.20, semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, any.servant ==0.19, + any.servant-blaze ==0.9.1, any.servant-client ==0.19, any.servant-client-core ==0.19, any.servant-lucid ==0.9.0.5, any.servant-server ==0.19.1, + any.servant-static-th ==1.0.0.0, + servant-static-th -buildexample, any.servant-websockets ==2.0.0, any.simple-sendfile ==0.2.30, simple-sendfile +allow-bsd, @@ -241,11 +272,14 @@ constraints: any.Cabal ==3.6.3.0, any.splitmix ==0.1.0.4, splitmix -optimised-mixer, any.stm ==2.5.0.1, + any.stm-chans ==3.0.0.6, any.streaming ==0.2.3.1, any.streaming-commons ==0.2.2.4, streaming-commons -use-bytestring-builder, any.strict ==0.4.0.1, strict +assoc, + any.string-conv ==0.2.0, + string-conv -lib-werror, any.string-conversions ==0.4.0.1, any.tagged ==0.8.6.1, tagged +deepseq +transformers, @@ -257,6 +291,7 @@ constraints: any.Cabal ==3.6.3.0, any.terminal-size ==0.3.3, any.terminfo ==0.4.1.4, any.text ==1.2.4.1, + any.text-conversions ==0.3.1.1, any.text-display ==0.0.2.0, any.text-manipulate ==0.3.1.0, any.text-short ==0.1.5, @@ -268,7 +303,10 @@ constraints: any.Cabal ==3.6.3.0, any.time ==1.9.3, any.time-compat ==1.9.6.1, time-compat -old-locale, + any.time-locale-compat ==0.1.1.5, + time-locale-compat +old-locale, any.time-manager ==0.0.0, + any.timing-convenience ==0.1, any.tls ==1.6.0, tls +compat -hans +network, any.transformers ==0.5.6.2, @@ -324,6 +362,8 @@ constraints: any.Cabal ==3.6.3.0, any.witherable ==0.4.2, any.wl-pprint-annotated ==0.1.0.1, any.word8 ==0.1.3, + any.wreq ==0.5.3.3, + wreq -aws -developer +doctest -httpbin, any.x509 ==1.7.7, any.x509-store ==1.6.9, any.x509-system ==1.6.7, diff --git a/environment.ci.sh b/environment.ci.sh index 8b8c0d30..a068d59a 100755 --- a/environment.ci.sh +++ b/environment.ci.sh @@ -2,7 +2,7 @@ source environment.sh export FLORA_DB_DATABASE="flora_test" export FLORA_DB_PASSWORD="postgres" -export FLORA_DB_POOL_CONNECTIONS=10 +export FLORA_DB_POOL_CONNECTIONS=20 export FLORA_DB_PORT=5432 export FLORA_DB_HOST="localhost" export FLORA_DB_SUB_POOLS=10 diff --git a/flora.cabal b/flora.cabal index 1f4ee366..f06c05eb 100644 --- a/flora.cabal +++ b/flora.cabal @@ -116,6 +116,7 @@ library Flora.Model.User.Query Flora.Model.User.Update Flora.OddJobs + Flora.OddJobs.Types Flora.Publish Flora.Search Flora.ThirdParties.Hackage.API @@ -186,6 +187,7 @@ library , cmark-gfm ^>=0.2 , colourista ^>=0.1 , commonmark + , commonmark-extensions , containers ^>=0.6 , cookie ^>=0.4 , cryptohash ^>=0.11 @@ -195,6 +197,7 @@ library , filepath ^>=1.4 , http-api-data ^>=0.4 , http-client ==0.7.10 + , http-client-tls , http-types ^>=0.12 , lens , log-base ^>=0.11 diff --git a/src/Flora/Environment/OddJobs.hs b/src/Flora/Environment/OddJobs.hs index c33958ea..84720800 100644 --- a/src/Flora/Environment/OddJobs.hs +++ b/src/Flora/Environment/OddJobs.hs @@ -1,57 +1,32 @@ -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE GADTs #-} -- | Hook oddjobs into flora -module Flora.Environment.OddJobs - ( makeUIConfig - , makeConfig - ) -where +module Flora.Environment.OddJobs where -import Data.Aeson import Data.Pool hiding (PoolConfig) -import Data.Text (Text) -import qualified Data.Text as Text import qualified Database.PostgreSQL.Simple as PG -import Flora.Environment.Config -import Flora.OddJobs -import FloraWeb.Server.Logging import Log hiding (LogLevel) import OddJobs.ConfigBuilder -import OddJobs.Job -import OddJobs.Types - --- proly should upstream these, --- kinda dumb the "support" structured logging without the most --- common method being used -deriving instance ToJSON FailureMode -deriving instance ToJSON Job -instance ToJSON LogEvent where - toJSON = \case - LogJobStart job -> toJSON ("start" :: Text, job) - LogJobSuccess job time -> toJSON ("success" :: Text, job, time) - LogJobFailed job exception failuremode finishTime -> toJSON ("failed" :: Text, show exception, job, failuremode, finishTime) - LogJobTimeout job -> toJSON ("timed-out" :: Text, job) - LogPoll -> toJSON ("poll" :: Text) - LogWebUIRequest -> toJSON ("web-ui-request" :: Text) - LogText other -> toJSON ("other" :: Text, other) +import OddJobs.Job (Config (..)) +import OddJobs.Types (ConcurrencyControl (..), Job, UIConfig (..)) -structuredLogging :: FloraConfig -> Logger -> LogEvent -> LogLevel -> IO () -structuredLogging FloraConfig{..} logger b = - runLog environment logger . localDomain "odd-jobs" . \case - LevelDebug -> logTrace "LevelDebug" b - LevelInfo -> logInfo "LevelInfo" b - LevelWarn -> logAttention "LevelWarn" b - LevelError -> logAttention "LevelError" b - (LevelOther x) -> logAttention ("LevelOther " <> Text.pack (show x)) b +import Flora.Environment.Config +import Flora.OddJobs.Types -makeConfig :: FloraConfig -> Logger -> Pool PG.Connection -> Config -makeConfig cfg@FloraConfig{..} logger pool = +makeConfig :: + JobsRunnerEnv -> + FloraConfig -> + Logger -> + Pool PG.Connection -> + (Pool PG.Connection -> Job -> JobsRunnerM ()) -> + Config +makeConfig runnerEnv cfg logger pool runnerContinuation = mkConfig (flip $ structuredLogging cfg logger) jobTableName pool (MaxConcurrentJobs 1) - (runLog environment logger . runner pool) + (runJobRunnerM runnerEnv logger . runnerContinuation pool) (\x -> x{cfgDeleteSuccessfulJobs = False, cfgDefaultMaxAttempts = 3}) makeUIConfig :: FloraConfig -> Logger -> Pool PG.Connection -> UIConfig diff --git a/src/Flora/Import/Package.hs b/src/Flora/Import/Package.hs index 9bd93de4..f2a2eae5 100644 --- a/src/Flora/Import/Package.hs +++ b/src/Flora/Import/Package.hs @@ -44,7 +44,7 @@ import qualified Flora.Import.Categories.Tuning as Tuning import qualified Flora.Model.Category.Update as Update import Flora.Model.Package.Component as Component import Flora.Model.Package.Orphans () -import Flora.Model.Package.Types hiding (unPackageName) +import Flora.Model.Package.Types import qualified Flora.Model.Package.Update as Update import Flora.Model.Release import qualified Flora.Model.Release.Update as Update diff --git a/src/Flora/Model/Package/Types.hs b/src/Flora/Model/Package/Types.hs index c990ba9a..51c4ec22 100644 --- a/src/Flora/Model/Package/Types.hs +++ b/src/Flora/Model/Package/Types.hs @@ -53,9 +53,6 @@ newtype PackageName = PackageName Text (Eq, Ord, FromJSON, ToJSON, FromField, ToField, ToHtml, ToHttpApiData) via Text -unPackageName :: PackageName -> Text -unPackageName (PackageName txt) = txt - instance Pretty PackageName where pretty (PackageName txt) = PP.text $ unpack txt diff --git a/src/Flora/Model/Release/Update.hs b/src/Flora/Model/Release/Update.hs index b8f64a67..e30def6c 100644 --- a/src/Flora/Model/Release/Update.hs +++ b/src/Flora/Model/Release/Update.hs @@ -10,8 +10,9 @@ import Database.PostgreSQL.Transact (DBT) import Control.Monad (void) import Database.PostgreSQL.Entity.DBT (QueryNature (Update), execute) import Database.PostgreSQL.Entity.Types (field) +import Database.PostgreSQL.Simple (Only (..)) import Database.PostgreSQL.Simple.SqlQQ (sql) -import Flora.Model.Release (Release) +import Flora.Model.Release (Release, ReleaseId, TextHtml (..)) insertRelease :: MonadIO m => Release -> DBT m () insertRelease = insert @Release @@ -21,3 +22,11 @@ upsertRelease release = upsert @Release release [[field| updated_at |]] refreshLatestVersions :: MonadIO m => DBT m () refreshLatestVersions = void $ execute Update [sql| REFRESH MATERIALIZED VIEW CONCURRENTLY "latest_versions" |] () + +updateReadme :: MonadIO m => ReleaseId -> Maybe TextHtml -> DBT m () +updateReadme releaseId readmeBody = + void $ + updateFieldsBy @Release + [[field| readme |]] + ([field| release_id |], releaseId) + (Only readmeBody) diff --git a/src/Flora/OddJobs.hs b/src/Flora/OddJobs.hs index 25cf8469..a7953a33 100644 --- a/src/Flora/OddJobs.hs +++ b/src/Flora/OddJobs.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE QuasiQuotes #-} - -- | Represents the various jobs that can be run module Flora.OddJobs ( scheduleReadmeJob - , runner , jobTableName + , runner -- * exposed for testing @@ -18,57 +14,32 @@ module Flora.OddJobs where import qualified Commonmark +import Commonmark.Extensions (emojiSpec) import Control.Exception -import qualified Control.Lens as L -import Control.Monad import Control.Monad.IO.Class -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as Aes -import Data.ByteString.Lazy (ByteString, toStrict) +import Data.Aeson (Result (..), fromJSON) import Data.Pool import Data.Text -import Data.Text.Encoding -import Data.Text.Encoding.Error +import Data.Text.Display import qualified Data.Text.Lazy as TL -import Database.PostgreSQL.Entity (updateFieldsBy) import Database.PostgreSQL.Entity.DBT -import Database.PostgreSQL.Entity.Types (field) import qualified Database.PostgreSQL.Simple as PG -import Database.PostgreSQL.Simple.Types -import Distribution.Pretty import Distribution.Types.Version -import Flora.Model.Package -import Flora.Model.Release -import GHC.Generics import GHC.Stack import Log import qualified Lucid -import qualified Network.Wreq as Wreq -import OddJobs.Job - -newtype IntAesonVersion = MkIntAesonVersion {unIntAesonVersion :: Version} - deriving newtype (Pretty) - -instance ToJSON IntAesonVersion where - toJSON (MkIntAesonVersion x) = Aes.toJSON $ versionNumbers x +import Network.HTTP.Types (notFound404) +import OddJobs.Job (Job (..), createJob) +import Optics.Core +import Servant.Client (ClientError (..)) +import Servant.Client.Core (ResponseF (..)) -instance FromJSON IntAesonVersion where - parseJSON val = MkIntAesonVersion . mkVersion <$> Aes.parseJSON val - -data ReadmePayload = MkReadmePayload - { mpPackage :: PackageName - , mpReleaseId :: ReleaseId -- needed to write the readme in db - , mpVersion :: IntAesonVersion - } - deriving stock (Generic) - deriving anyclass (ToJSON, FromJSON) - --- these represent the possible odd jobs we can run. -data FloraOddJobs - = MkReadme ReadmePayload - | DoNothing -- needed to keep this type tagged - deriving stock (Generic) - deriving anyclass (ToJSON, FromJSON) +import Flora.Model.Package +import Flora.Model.Release +import Flora.Model.Release.Update (updateReadme) +import Flora.OddJobs.Types +import Flora.ThirdParties.Hackage.API (VersionedPackage (..)) +import qualified Flora.ThirdParties.Hackage.Client as Hackage scheduleReadmeJob :: Pool PG.Connection -> ReleaseId -> PackageName -> Version -> IO Job scheduleReadmeJob conn rid package version = @@ -78,72 +49,38 @@ scheduleReadmeJob conn rid package version = jobTableName (MkReadme $ MkReadmePayload package rid $ MkIntAesonVersion version) -jobTableName :: QualifiedIdentifier -jobTableName = "oddjobs" - -runner :: Pool PG.Connection -> Job -> LogT IO () +makeReadme :: HasCallStack => Pool PG.Connection -> ReadmePayload -> JobsRunnerM () +makeReadme pool pay@MkReadmePayload{..} = localDomain ("for-package " <> display mpPackage) $ do + logInfo "making readme" pay + let payload = VersionedPackage mpPackage mpVersion + gewt <- Hackage.request $ Hackage.getPackageReadme payload + case gewt of + Left e@(FailureResponse _ response) -> do + -- If the README simply doesn't exist, we skip it by marking it as successful. + if response ^. #responseStatusCode == notFound404 + then liftIO $ withPool pool $ updateReadme mpReleaseId Nothing + else throw e + Left e -> throw e + Right bodyText -> do + logInfo "got a body" bodyText + + htmlTxt <- do + -- let extensions = emojiSpec + -- Commonmark.commonmarkWith extensions ("readme " <> show mpPackage) bodyText + pure (Commonmark.commonmark ("readme " <> show mpPackage) bodyText) + >>= \case + Left exception -> throw (MarkdownFailed exception) + Right (y :: Commonmark.Html ()) -> pure $ Commonmark.renderHtml y + + let readmeBody :: Lucid.Html () + readmeBody = Lucid.toHtmlRaw @Text $ TL.toStrict htmlTxt + + liftIO $ withPool pool $ updateReadme mpReleaseId (Just $ MkTextHtml readmeBody) + +runner :: Pool PG.Connection -> Job -> JobsRunnerM () runner pool job = localDomain "job-runner" $ - case Aes.fromJSON (jobPayload job) of - Aes.Error str -> logAttention "decode error" str - Aes.Success val -> case val of + case fromJSON (jobPayload job) of + Error str -> logAttention "decode error" str + Success val -> case val of DoNothing -> logInfo "doing nothing" () MkReadme x -> makeReadme pool x - -makeReadme :: HasCallStack => Pool PG.Connection -> ReadmePayload -> LogT IO () -makeReadme pool pay@MkReadmePayload{..} = localDomain ("for-package " <> package) $ do - logInfo "making readme" pay - gewt <- - liftIO $ - Wreq.get $ - "https://hackage.haskell.org/package/" - <> unpack package - <> "-" - <> prettyShow mpVersion - <> "/readme.txt" - - logInfo "got a response" () - - let respBody :: ByteString - respBody = gewt L.^. Wreq.responseBody - - bodyText <- case decodeUtf8' (toStrict respBody) of - Left exception -> liftIO $ throwIO $ DecodeFailed exception - Right x -> pure x - - logInfo "got a body" bodyText - - htmlTxt <- case Commonmark.commonmark ("readme " <> unpack package) bodyText of - Left exception -> liftIO $ throwIO $ MarkdownFailed exception - Right (y :: Commonmark.Html ()) -> pure $ Commonmark.renderHtml y - - let readmeBody :: Lucid.Html () - readmeBody = Lucid.toHtmlRaw @Text $ TL.toStrict htmlTxt - - void $ - liftIO $ - withPool pool $ - updateFieldsBy @Release - [[field| readme |]] - ([field| release_id |], mpReleaseId) - (Only $ Just $ MkTextHtml readmeBody) - where - package = unPackageName mpPackage - -data OddJobException where - DecodeFailed :: HasCallStack => UnicodeException -> OddJobException - MarkdownFailed :: HasCallStack => Commonmark.ParseError -> OddJobException - deriving (Exception) - -instance Show OddJobException where - show (DecodeFailed x) = renderExceptionWithCallstack x "DecodeFailed" - show (MarkdownFailed x) = renderExceptionWithCallstack x "MarkdownFailed" - -renderExceptionWithCallstack :: (HasCallStack, Show a) => a -> String -> String -renderExceptionWithCallstack errors valueConstructor = - "(" - <> valueConstructor - <> " $ " - <> show errors - <> "/*" - <> prettyCallStack callStack - <> " */)" diff --git a/src/Flora/OddJobs/Types.hs b/src/Flora/OddJobs/Types.hs new file mode 100644 index 00000000..12770792 --- /dev/null +++ b/src/Flora/OddJobs/Types.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Flora.OddJobs.Types where + +import qualified Commonmark +import Control.Exception (Exception) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding.Error (UnicodeException) +import Database.PostgreSQL.Simple.Types (QualifiedIdentifier) +import Distribution.Pretty +import Distribution.Version (Version, mkVersion, versionNumbers) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack, callStack, prettyCallStack) +import Log hiding (LogLevel) +import Network.HTTP.Client +import OddJobs.Job (Job, LogEvent (..), LogLevel (..)) +import OddJobs.Types (FailureMode) + +import Data.Text.Display +import Flora.Environment.Config +import Flora.Model.Package (PackageName (..)) +import Flora.Model.Release (ReleaseId) +import FloraWeb.Server.Logging +import Servant (ToHttpApiData) + +newtype JobsRunnerM a = JobsRunnerM {getJobRunnerM :: ReaderT JobsRunnerEnv (LogT IO) a} + deriving newtype + ( Functor + , Applicative + , Monad + , MonadIO + , MonadLog + , MonadReader JobsRunnerEnv + ) + +runJobRunnerM :: JobsRunnerEnv -> Logger -> JobsRunnerM a -> IO a +runJobRunnerM runnerEnv logger jobRunner = + Log.runLogT "flora-jobs" logger defaultLogLevel (runReaderT (getJobRunnerM jobRunner) runnerEnv) + +data JobsRunnerEnv = JobsRunnerEnv + { httpManager :: Manager + } + deriving stock (Generic) + +data OddJobException where + DecodeFailed :: HasCallStack => UnicodeException -> OddJobException + MarkdownFailed :: HasCallStack => Commonmark.ParseError -> OddJobException + deriving (Exception) + +instance Show OddJobException where + show (DecodeFailed x) = renderExceptionWithCallstack x "DecodeFailed" + show (MarkdownFailed x) = renderExceptionWithCallstack x "MarkdownFailed" + +renderExceptionWithCallstack :: (HasCallStack, Show a) => a -> String -> String +renderExceptionWithCallstack errors valueConstructor = + "(" + <> valueConstructor + <> " $ " + <> show errors + <> "/*" + <> prettyCallStack callStack + <> " */)" + +newtype IntAesonVersion = MkIntAesonVersion {unIntAesonVersion :: Version} + deriving + (Pretty, ToHttpApiData, Display) + via Version + +instance ToJSON IntAesonVersion where + toJSON (MkIntAesonVersion x) = toJSON $ versionNumbers x + +instance FromJSON IntAesonVersion where + parseJSON val = MkIntAesonVersion . mkVersion <$> parseJSON val + +data ReadmePayload = MkReadmePayload + { mpPackage :: PackageName + , mpReleaseId :: ReleaseId -- needed to write the readme in db + , mpVersion :: IntAesonVersion + } + deriving stock (Generic) + deriving anyclass (ToJSON, FromJSON) + +-- these represent the possible odd jobs we can run. +data FloraOddJobs + = MkReadme ReadmePayload + | DoNothing -- needed to keep this type tagged + deriving stock (Generic) + deriving anyclass (ToJSON, FromJSON) + +jobTableName :: QualifiedIdentifier +jobTableName = "oddjobs" + +-- proly should upstream these, +-- kinda dumb the "support" structured logging without the most +-- common method being used +deriving instance ToJSON FailureMode +deriving instance ToJSON Job + +instance ToJSON LogEvent where + toJSON = \case + LogJobStart job -> toJSON ("start" :: Text, job) + LogJobSuccess job time -> toJSON ("success" :: Text, job, time) + LogJobFailed job exception failuremode finishTime -> toJSON ("failed" :: Text, show exception, job, failuremode, finishTime) + LogJobTimeout job -> toJSON ("timed-out" :: Text, job) + LogPoll -> toJSON ("poll" :: Text) + LogWebUIRequest -> toJSON ("web-ui-request" :: Text) + LogText other -> toJSON ("other" :: Text, other) + +structuredLogging :: FloraConfig -> Logger -> LogEvent -> LogLevel -> IO () +structuredLogging FloraConfig{..} logger b = + runLog environment logger . localDomain "odd-jobs" . \case + LevelDebug -> logTrace "LevelDebug" b + LevelInfo -> logInfo "LevelInfo" b + LevelWarn -> logAttention "LevelWarn" b + LevelError -> logAttention "LevelError" b + (LevelOther x) -> logAttention ("LevelOther " <> Text.pack (show x)) b diff --git a/src/Flora/ThirdParties/Hackage/API.hs b/src/Flora/ThirdParties/Hackage/API.hs index cbda2872..40e25b01 100644 --- a/src/Flora/ThirdParties/Hackage/API.hs +++ b/src/Flora/ThirdParties/Hackage/API.hs @@ -2,15 +2,35 @@ module Flora.ThirdParties.Hackage.API where import Data.Aeson import Data.Text - +import Data.Text.Display import Servant.API import Servant.API.Generic +import Flora.Model.Package.Types (PackageName) +import Flora.Model.Release.Orphans () +import Flora.OddJobs.Types (IntAesonVersion) + type HackageAPI = NamedRoutes HackageAPI' +data VersionedPackage = VersionedPackage + { package :: PackageName + , version :: IntAesonVersion + } + deriving stock (Generic) + +instance ToHttpApiData VersionedPackage where + toUrlPiece VersionedPackage{package, version} = + display package <> "-" <> display version + data HackageAPI' mode = HackageAPI' { listUsers :: mode :- "users" :> Get '[JSON] [HackageUserObject] - , withUser :: mode :- "user" :> Capture "username" Text :> ToServantApi HackageUserAPI + , withUser :: mode :- "user" :> Capture "username" Text :> NamedRoutes HackageUserAPI + , withPackage :: mode :- "package" :> Capture "versioned_package" VersionedPackage :> NamedRoutes HackagePackageAPI + } + deriving stock (Generic) + +data HackagePackageAPI mode = HackagePackageAPI + { getReadme :: mode :- "readme.txt" :> Get '[PlainText] Text } deriving stock (Generic) diff --git a/src/Flora/ThirdParties/Hackage/Client.hs b/src/Flora/ThirdParties/Hackage/Client.hs index e450fd21..5105dc80 100644 --- a/src/Flora/ThirdParties/Hackage/Client.hs +++ b/src/Flora/ThirdParties/Hackage/Client.hs @@ -5,16 +5,31 @@ module Flora.ThirdParties.Hackage.Client where import Servant.API () import Servant.Client -import Servant.Client.Generic +import Control.Monad.Reader +import Data.Proxy import Data.Text +import Flora.OddJobs.Types (JobsRunnerEnv (..), JobsRunnerM) import Flora.ThirdParties.Hackage.API as API -hackageClient :: HackageAPI' (AsClientT ClientM) -hackageClient = genericClient +request :: ClientM a -> JobsRunnerM (Either ClientError a) +request req = do + JobsRunnerEnv{httpManager} <- ask + let clientEnv = mkClientEnv httpManager BaseUrl{baseUrlScheme = Https, baseUrlHost = "hackage.haskell.org", baseUrlPort = 443, baseUrlPath = ""} + liftIO $ runClientM req clientEnv + +hackageClient :: Client ClientM HackageAPI +hackageClient = client (Proxy @HackageAPI) listHackageUsers :: ClientM [HackageUserObject] listHackageUsers = hackageClient // API.listUsers getHackageUser :: Text -> ClientM HackageUserDetailsObject -getHackageUser username = hackageClient // API.withUser /: username +getHackageUser username = hackageClient // API.withUser /: username // API.getUser + +getPackageReadme :: VersionedPackage -> ClientM Text +getPackageReadme versionedPackage = + hackageClient + // API.withPackage + /: versionedPackage + // API.getReadme diff --git a/src/FloraWeb/Server.hs b/src/FloraWeb/Server.hs index 3ff837fe..f6a6e413 100644 --- a/src/FloraWeb/Server.hs +++ b/src/FloraWeb/Server.hs @@ -13,6 +13,7 @@ import qualified Data.Pool as Pool import Data.Text.Display (display) import Log (Logger, defaultLogLevel) import qualified Log +import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Wai.Handler.Warp ( defaultSettings , runSettings @@ -40,6 +41,8 @@ import Control.Concurrent import qualified Control.Exception.Safe as Safe import Flora.Environment (DeploymentEnv, FloraEnv (..), LoggingEnv (..), getFloraEnv) import qualified Flora.Environment.OddJobs as OddJobs +import qualified Flora.OddJobs as OddJobs +import Flora.OddJobs.Types (JobsRunnerEnv (..)) import FloraWeb.Autoreload (AutoreloadRoute) import qualified FloraWeb.Autoreload as Autoreload import FloraWeb.Routes @@ -50,6 +53,7 @@ import FloraWeb.Server.Metrics import qualified FloraWeb.Server.Pages as Pages import FloraWeb.Server.Tracing import FloraWeb.Types +import qualified Network.HTTP.Client as HTTP import qualified OddJobs.Endpoints as OddJobs import OddJobs.Job (startJobRunner) import qualified OddJobs.Types as OddJobs @@ -77,8 +81,16 @@ logException env logger exception = runServer :: Logger -> FloraEnv -> IO () runServer appLogger floraEnv = do + httpManager <- HTTP.newManager tlsManagerSettings + let runnerEnv = JobsRunnerEnv httpManager let oddjobsUiCfg = OddJobs.makeUIConfig (floraEnv ^. #config) appLogger $ pool floraEnv - oddJobsCfg = OddJobs.makeConfig (floraEnv ^. #config) appLogger $ pool floraEnv + oddJobsCfg = + OddJobs.makeConfig + runnerEnv + (floraEnv ^. #config) + appLogger + (floraEnv ^. #pool) + OddJobs.runner forkIO $ Safe.withException (startJobRunner oddJobsCfg) (logException (floraEnv ^. #environment) appLogger) @@ -104,11 +116,11 @@ runServer appLogger floraEnv = do $ server mkServer :: Logger -> WebEnvStore -> FloraEnv -> OddJobs.UIConfig -> OddJobs.Env -> Application -mkServer logger webEnvStore floraEnv cfg env = do - genericServeTWithContext (naturalTransform logger webEnvStore) (floraServer cfg env) (genAuthServerContext logger floraEnv) +mkServer logger webEnvStore floraEnv cfg jobsRunnerEnv = do + genericServeTWithContext (naturalTransform logger webEnvStore) (floraServer cfg jobsRunnerEnv) (genAuthServerContext logger floraEnv) floraServer :: OddJobs.UIConfig -> OddJobs.Env -> Routes (AsServerT FloraM) -floraServer cfg env = +floraServer cfg jobsRunnerEnv = Routes { assets = serveDirectoryWebApp "./static" , pages = \sessionWithCookies -> @@ -116,7 +128,7 @@ floraServer cfg env = (Proxy @Pages.Routes) (Proxy @'[FloraAuthContext]) (\f -> withReaderT (const sessionWithCookies) f) - (Pages.server cfg env) + (Pages.server cfg jobsRunnerEnv) , autoreload = hoistServer (Proxy @AutoreloadRoute) diff --git a/src/FloraWeb/Templates/Pages/Packages.hs b/src/FloraWeb/Templates/Pages/Packages.hs index acbcb5b6..4216021f 100644 --- a/src/FloraWeb/Templates/Pages/Packages.hs +++ b/src/FloraWeb/Templates/Pages/Packages.hs @@ -46,10 +46,28 @@ showPackage :: Word -> Vector Category -> FloraHTML -showPackage latestRelease packageReleases numberOfReleases package@Package{namespace, name} dependents numberOfDependents dependencies numberOfDependencies categories = do - div_ [class_ "larger-container"] $ do - presentationHeader latestRelease namespace name (latestRelease ^. #metadata % #synopsis) - packageBody package latestRelease packageReleases numberOfReleases dependencies numberOfDependencies dependents numberOfDependents categories +showPackage + latestRelease + packageReleases + numberOfReleases + package@Package{namespace, name} + dependents + numberOfDependents + dependencies + numberOfDependencies + categories = + div_ [class_ "larger-container"] $ do + presentationHeader latestRelease namespace name (latestRelease ^. #metadata % #synopsis) + packageBody + package + latestRelease + packageReleases + numberOfReleases + dependencies + numberOfDependencies + dependents + numberOfDependents + categories presentationHeader :: Release -> Namespace -> PackageName -> Text -> FloraHTML presentationHeader release namespace name synopsis = do @@ -61,29 +79,48 @@ presentationHeader release namespace name synopsis = do div_ [class_ "synopsis lg:text-xl text-center"] $ p_ [class_ ""] (toHtml synopsis) -packageBody :: Package -> Release -> Vector Release -> Word -> Vector (Namespace, PackageName, Text) -> Word -> Vector Package -> Word -> Vector Category -> FloraHTML -packageBody Package{namespace, name = packageName} latestRelease@Release{metadata} packageReleases numberOfReleases dependencies numberOfDependencies dependents numberOfDependents categories = - div_ $ do - div_ [class_ "package-body md:flex"] $ do - div_ [class_ "package-left-column grow"] $ do - ul_ [class_ "package-left-rows grid-rows-3"] $ do - displayCategories categories - displayLicense (metadata ^. #license) - displayLinks packageName latestRelease metadata - displayVersions namespace packageName packageReleases numberOfReleases - div_ [class_ "package-readme-column grow"] $ do - ul_ [class_ "package-left-rows grid-rows-3"] $ do - displayReadme latestRelease - div_ [class_ "package-right-column md:max-w-xs"] $ do - ul_ [class_ "package-right-rows grid-rows-3"] $ do - displayInstructions packageName latestRelease - displayMaintainer (metadata ^. #maintainer) - displayDependencies (namespace, packageName) numberOfDependencies dependencies - displayDependents (namespace, packageName) numberOfDependents dependents +packageBody :: + Package -> + Release -> + Vector Release -> + Word -> + Vector (Namespace, PackageName, Text) -> + Word -> + Vector Package -> + Word -> + Vector Category -> + FloraHTML +packageBody + Package{namespace, name = packageName} + latestRelease@Release{metadata} + packageReleases + numberOfReleases + dependencies + numberOfDependencies + dependents + numberOfDependents + categories = + div_ $ do + div_ [class_ "package-body md:flex"] $ do + div_ [class_ "package-left-column grow"] $ do + ul_ [class_ "package-left-rows grid-rows-3"] $ do + displayCategories categories + displayLicense (metadata ^. #license) + displayLinks packageName latestRelease metadata + displayVersions namespace packageName packageReleases numberOfReleases + div_ [class_ "package-readme-column grow"] $ do + div_ [class_ "grid-rows-3 package-readme"] $ do + displayReadme latestRelease + div_ [class_ "package-right-column md:max-w-xs"] $ do + ul_ [class_ "package-right-rows grid-rows-3"] $ do + displayInstructions packageName latestRelease + displayMaintainer (metadata ^. #maintainer) + displayDependencies (namespace, packageName) numberOfDependencies dependencies + displayDependents (namespace, packageName) numberOfDependents dependents displayReadme :: Release -> FloraHTML -displayReadme release = li_ [class_ "mb-5"] $ do - ul_ [class_ "readme"] $ case readme release of +displayReadme release = + case readme release of Nothing -> toHtml @Text "no readme available" Just (MkTextHtml readme) -> relaxHtmlT readme