From cf14304ee304d8c99998a80d682079c1ba08698d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 21 Jun 2018 17:26:58 +0300 Subject: [PATCH] Upgrade snapshots --- package.yaml | 12 ++++++------ src/Application.hs | 11 ++++++----- src/Foundation.hs | 11 +++++++---- src/Handler/Haddock.hs | 3 ++- src/Import.hs | 5 ++++- src/Stackage/Database.hs | 2 +- src/Stackage/Database/Cron.hs | 4 +--- src/Stackage/PackageIndex/Conduit.hs | 17 ++++++++--------- src/Types.hs | 1 + stack.yaml | 16 +++------------- 10 files changed, 39 insertions(+), 43 deletions(-) diff --git a/package.yaml b/package.yaml index 84d5ee0..f33683d 100644 --- a/package.yaml +++ b/package.yaml @@ -14,7 +14,6 @@ dependencies: - base - yesod - aeson -- aws - barrier - base16-bytestring - blaze-markup @@ -24,8 +23,8 @@ dependencies: - classy-prelude-yesod - conduit - conduit-extra -- cryptohash -- cryptohash-conduit +- cryptonite +- cryptonite-conduit - data-default - directory - email-validate @@ -41,8 +40,8 @@ dependencies: - monad-logger - mtl - mwc-random -- prometheus-client -- prometheus-metrics-ghc +#- prometheus-client +#- prometheus-metrics-ghc - persistent - persistent-template - resourcet @@ -55,10 +54,11 @@ dependencies: - temporary-rc - text - these +- unliftio - wai - wai-extra - wai-logger -- wai-middleware-prometheus +#- wai-middleware-prometheus - warp - xml-conduit - xml-types diff --git a/src/Application.hs b/src/Application.hs index 303208a..55f5695 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -36,6 +36,7 @@ import System.Process (rawSystem) import Stackage.Database (openStackageDatabase, PostgresConf (..)) import Stackage.Database.Cron (newHoogleLocker, singleRun) import Control.AutoUpdate +import Control.Concurrent (threadDelay) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! @@ -60,9 +61,9 @@ import Handler.DownloadStack import Handler.MirrorStatus import Handler.Blog -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 @@ -79,12 +80,12 @@ makeApplication foundation = do -- Create the WAI application and apply middlewares appPlain <- toWaiAppPlain foundation - let middleware = prometheus def + let middleware = id -- prometheus def . forceSSL' (appSettings foundation) . logWare . defaultMiddlewaresNoLogging - void (register ghcMetrics) + -- FIXME prometheus void (register ghcMetrics) return (middleware appPlain) diff --git a/src/Foundation.hs b/src/Foundation.hs index dce1d16..2638ee0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -29,7 +29,7 @@ data App = App , appHoogleLock :: MVar () -- ^ Avoid concurrent Hoogle queries, see -- https://github.com/fpco/stackage-server/issues/172 - , appMirrorStatus :: IO (Status, WidgetT App IO ()) + , appMirrorStatus :: IO (Status, WidgetFor App ()) , appGetHoogleDB :: SnapName -> IO (Maybe FilePath) } @@ -94,6 +94,8 @@ instance Yesod App where defaultLayout = defaultLayoutWithContainer True + {- MSS 2018-06-21 Not worrying about broken cabal-install anymore + -- Ideally we would just have an approot that always includes https, and -- redirect users from non-SSL to SSL connections. However, cabal-install -- is broken, and does not support TLS. Therefore, we *don't* force the @@ -106,6 +108,7 @@ instance Yesod App where urlRenderOverride y route@StaticR{} = Just $ uncurry (joinPath y "") $ renderRoute route urlRenderOverride _ _ = Nothing + -} {- Temporarily disable to allow for horizontal scaling -- This function creates static content files in the static folder @@ -126,8 +129,8 @@ instance Yesod App where -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog _ "CLEANUP" _ = False - shouldLog app _source level = + shouldLogIO _ "CLEANUP" _ = pure False + shouldLogIO app _source level = pure $ appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError @@ -156,5 +159,5 @@ instance RenderMessage App FormMessage where instance GetStackageDatabase Handler where getStackageDatabase = appStackageDatabase <$> getYesod -instance GetStackageDatabase (WidgetT App IO) where +instance GetStackageDatabase (WidgetFor App) where getStackageDatabase = appStackageDatabase <$> getYesod diff --git a/src/Handler/Haddock.hs b/src/Handler/Haddock.hs index 810e1f1..490d35a 100644 --- a/src/Handler/Haddock.hs +++ b/src/Handler/Haddock.hs @@ -35,7 +35,8 @@ getHaddockR slug rest , "'>" ] req <- parseRequest $ unpack $ makeURL slug rest - (_, res) <- acquireResponse req >>= allocateAcquire + man <- getHttpManager <$> getYesod + (_, res) <- runReaderT (acquireResponse req >>= allocateAcquire) man mstyle <- lookupGetParam "style" case mstyle of Just "plain" -> respondSource "text/html; charset=utf-8" diff --git a/src/Import.hs b/src/Import.hs index ede6d54..35a217d 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -11,7 +11,7 @@ import Yesod.Auth as Import import Data.WebsiteContent as Import (WebsiteContent (..)) import Data.Text.Read (decimal) import Data.Time.Clock (diffUTCTime) -import qualified Prometheus as P +--import qualified Prometheus as P import Stackage.Database (SnapName) import Formatting (format) import Formatting.Time (diff) @@ -43,6 +43,8 @@ haddockUrl sname pkgver name = HaddockR sname track :: MonadIO m => String -> m a -> m a +track _ = id +{- FIXME prometheus isn't in Stackage anymore track name inner = do start <- liftIO getCurrentTime result <- inner @@ -62,6 +64,7 @@ track name inner = do "stackage_server_fn" "Stackage Server function call (duration in microseconds).") P.defaultBuckets)) +-} dateDiff :: UTCTime -- ^ now -> Day -- ^ target diff --git a/src/Stackage/Database.hs b/src/Stackage/Database.hs index 17642df..5d8bc40 100644 --- a/src/Stackage/Database.hs +++ b/src/Stackage/Database.hs @@ -188,7 +188,7 @@ sourceBuildPlans root = do sourceDirectory (encodeString docdir) =$= concatMapMC (go Right . fromString) where go wrapper fp | Just name <- nameFromFP fp = liftIO $ do - let bp = decodeFileEither (encodeString fp) >>= either throwM return + let bp = decodeFileEither (encodeString fp) >>= either throwIO return return $ Just (name, fp, wrapper bp) go _ _ = return Nothing diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index 1bcd11b..a69bf6e 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -31,8 +31,6 @@ import Data.Conduit.Zlib (WindowBits (WindowBits), compress, ungzip) import qualified Hoogle import System.Directory (getAppUserDataDirectory) -import System.IO (withBinaryFile, IOMode (ReadMode)) -import System.IO.Temp (withSystemTempDirectory) import Control.SingleRun import qualified Data.ByteString.Lazy as L import System.FilePath (splitPath) @@ -170,7 +168,7 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do let indexTar = stackDir "indices" "Hackage" "00-index.tar" withBinaryFile indexTar ReadMode $ \h -> do let loop Tar.Done = return () - loop (Tar.Fail e) = throwM e + loop (Tar.Fail e) = throwIO e loop (Tar.Next e es) = go e >> loop es go e = diff --git a/src/Stackage/PackageIndex/Conduit.hs b/src/Stackage/PackageIndex/Conduit.hs index 846f68a..6405623 100644 --- a/src/Stackage/PackageIndex/Conduit.hs +++ b/src/Stackage/PackageIndex/Conduit.hs @@ -11,10 +11,9 @@ import qualified Codec.Archive.Tar as Tar import Codec.Compression.GZip (decompress) import Control.Monad (guard) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (MonadResource, throwM) +import Control.Monad.Trans.Resource (MonadResource) import qualified Data.ByteString.Lazy as L -import Data.Conduit (Producer, bracketP, - yield, (=$=)) +import Data.Conduit (ConduitT, bracketP, yield, (.|)) import qualified Data.Conduit.List as CL import Data.Version (Version) import Distribution.Compat.ReadP (readP_to_S) @@ -23,15 +22,15 @@ import Distribution.PackageDescription (GenericPackageDescriptio import Distribution.PackageDescription.Parsec (ParseResult, parseGenericPackageDescription) import Distribution.Text (disp, parse) import qualified Distribution.Text -import System.IO (IOMode (ReadMode), - hClose, openBinaryFile) +import System.IO (openBinaryFile) import Text.PrettyPrint (render) import Prelude +import UnliftIO sourceTarFile :: MonadResource m => Bool -- ^ ungzip? -> FilePath - -> Producer m Tar.Entry + -> ConduitT i Tar.Entry m () sourceTarFile toUngzip fp = do bracketP (openBinaryFile fp ReadMode) hClose $ \h -> do lbs <- liftIO $ L.hGetContents h @@ -41,7 +40,7 @@ sourceTarFile toUngzip fp = do | toUngzip = decompress | otherwise = id loop Tar.Done = return () - loop (Tar.Fail e) = throwM e + loop (Tar.Fail e) = throwIO e loop (Tar.Next e es) = yield e >> loop es data CabalFileEntry = CabalFileEntry @@ -55,10 +54,10 @@ data CabalFileEntry = CabalFileEntry sourceAllCabalFiles :: MonadResource m => IO FilePath - -> Producer m CabalFileEntry + -> ConduitT i CabalFileEntry m () sourceAllCabalFiles getIndexTar = do tarball <- liftIO $ getIndexTar - sourceTarFile False tarball =$= CL.mapMaybe go + sourceTarFile False tarball .| CL.mapMaybe go where go e = case (toPkgVer $ Tar.entryPath e, Tar.entryContent e) of diff --git a/src/Types.hs b/src/Types.hs index 5428852..293b429 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -11,6 +11,7 @@ import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy as LText import qualified Data.Text.Read as Reader import Data.Char (ord) +import Control.Monad.Catch (MonadThrow, throwM) data SnapshotBranch = LtsMajorBranch Int | LtsBranch diff --git a/stack.yaml b/stack.yaml index 027556a..dd9b8ba 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,16 +1,6 @@ -resolver: lts-10.5 +resolver: nightly-2018-06-20 extra-deps: - archive: https://github.com/chrisdone/tagstream-conduit/archive/bacd7444596b2391b0ac302ad649b994b258d271.tar.gz - archive: https://github.com/snoyberg/gitrev/archive/6a1a639f493ac08959eb5ddf540ca1937baaaaf9.tar.gz - -- Cabal-2.2.0.0@rev:1 -- cryptohash-conduit-0.1.1@rev:0 -- lens-4.16@rev:3 -- cabal-doctest-1.0.6@rev:1 -- entropy-0.4.1.1@rev:0 -- nonce-1.0.7@rev:0 -- stackage-curator-0.16.0.0@rev:0 -- happy-1.19.9@rev:2 - -# https://github.com/fizruk/http-api-data/issues/72 -- archive: https://github.com/snoyberg/http-api-data/archive/659dc4689355a5881acc2e037090d75391c673bb.tar.gz +- archive: https://github.com/bitemyapp/esqueleto/archive/b81e0d951e510ebffca03c5a58658ad884cc6fbd.tar.gz +- archive: https://github.com/fpco/stackage-curator/archive/7635cdc45fcc7c1b733957bce865c40ae8e22b0c.tar.gz