Upgrade snapshots

This commit is contained in:
Michael Snoyman 2018-06-21 17:26:58 +03:00
parent f8aa5bc4de
commit cf14304ee3
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
10 changed files with 39 additions and 43 deletions

View File

@ -14,7 +14,6 @@ dependencies:
- base - base
- yesod - yesod
- aeson - aeson
- aws
- barrier - barrier
- base16-bytestring - base16-bytestring
- blaze-markup - blaze-markup
@ -24,8 +23,8 @@ dependencies:
- classy-prelude-yesod - classy-prelude-yesod
- conduit - conduit
- conduit-extra - conduit-extra
- cryptohash - cryptonite
- cryptohash-conduit - cryptonite-conduit
- data-default - data-default
- directory - directory
- email-validate - email-validate
@ -41,8 +40,8 @@ dependencies:
- monad-logger - monad-logger
- mtl - mtl
- mwc-random - mwc-random
- prometheus-client #- prometheus-client
- prometheus-metrics-ghc #- prometheus-metrics-ghc
- persistent - persistent
- persistent-template - persistent-template
- resourcet - resourcet
@ -55,10 +54,11 @@ dependencies:
- temporary-rc - temporary-rc
- text - text
- these - these
- unliftio
- wai - wai
- wai-extra - wai-extra
- wai-logger - wai-logger
- wai-middleware-prometheus #- wai-middleware-prometheus
- warp - warp
- xml-conduit - xml-conduit
- xml-types - xml-types

View File

@ -36,6 +36,7 @@ import System.Process (rawSystem)
import Stackage.Database (openStackageDatabase, PostgresConf (..)) import Stackage.Database (openStackageDatabase, PostgresConf (..))
import Stackage.Database.Cron (newHoogleLocker, singleRun) import Stackage.Database.Cron (newHoogleLocker, singleRun)
import Control.AutoUpdate import Control.AutoUpdate
import Control.Concurrent (threadDelay)
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
@ -60,9 +61,9 @@ import Handler.DownloadStack
import Handler.MirrorStatus import Handler.MirrorStatus
import Handler.Blog import Handler.Blog
import Network.Wai.Middleware.Prometheus (prometheus) --import Network.Wai.Middleware.Prometheus (prometheus)
import Prometheus (register) --import Prometheus (register)
import Prometheus.Metric.GHC (ghcMetrics) --import Prometheus.Metric.GHC (ghcMetrics)
-- This line actually creates our YesodDispatch instance. It is the second half -- 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 -- 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 -- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation appPlain <- toWaiAppPlain foundation
let middleware = prometheus def let middleware = id -- prometheus def
. forceSSL' (appSettings foundation) . forceSSL' (appSettings foundation)
. logWare . logWare
. defaultMiddlewaresNoLogging . defaultMiddlewaresNoLogging
void (register ghcMetrics) -- FIXME prometheus void (register ghcMetrics)
return (middleware appPlain) return (middleware appPlain)

View File

@ -29,7 +29,7 @@ data App = App
, appHoogleLock :: MVar () , appHoogleLock :: MVar ()
-- ^ Avoid concurrent Hoogle queries, see -- ^ Avoid concurrent Hoogle queries, see
-- https://github.com/fpco/stackage-server/issues/172 -- https://github.com/fpco/stackage-server/issues/172
, appMirrorStatus :: IO (Status, WidgetT App IO ()) , appMirrorStatus :: IO (Status, WidgetFor App ())
, appGetHoogleDB :: SnapName -> IO (Maybe FilePath) , appGetHoogleDB :: SnapName -> IO (Maybe FilePath)
} }
@ -94,6 +94,8 @@ instance Yesod App where
defaultLayout = defaultLayoutWithContainer True 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 -- Ideally we would just have an approot that always includes https, and
-- redirect users from non-SSL to SSL connections. However, cabal-install -- redirect users from non-SSL to SSL connections. However, cabal-install
-- is broken, and does not support TLS. Therefore, we *don't* force the -- 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{} = urlRenderOverride y route@StaticR{} =
Just $ uncurry (joinPath y "") $ renderRoute route Just $ uncurry (joinPath y "") $ renderRoute route
urlRenderOverride _ _ = Nothing urlRenderOverride _ _ = Nothing
-}
{- Temporarily disable to allow for horizontal scaling {- Temporarily disable to allow for horizontal scaling
-- This function creates static content files in the static folder -- 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 -- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production. -- in development, and warnings and errors in production.
shouldLog _ "CLEANUP" _ = False shouldLogIO _ "CLEANUP" _ = pure False
shouldLog app _source level = shouldLogIO app _source level = pure $
appShouldLogAll (appSettings app) appShouldLogAll (appSettings app)
|| level == LevelWarn || level == LevelWarn
|| level == LevelError || level == LevelError
@ -156,5 +159,5 @@ instance RenderMessage App FormMessage where
instance GetStackageDatabase Handler where instance GetStackageDatabase Handler where
getStackageDatabase = appStackageDatabase <$> getYesod getStackageDatabase = appStackageDatabase <$> getYesod
instance GetStackageDatabase (WidgetT App IO) where instance GetStackageDatabase (WidgetFor App) where
getStackageDatabase = appStackageDatabase <$> getYesod getStackageDatabase = appStackageDatabase <$> getYesod

View File

@ -35,7 +35,8 @@ getHaddockR slug rest
, "'>" , "'>"
] ]
req <- parseRequest $ unpack $ makeURL slug rest req <- parseRequest $ unpack $ makeURL slug rest
(_, res) <- acquireResponse req >>= allocateAcquire man <- getHttpManager <$> getYesod
(_, res) <- runReaderT (acquireResponse req >>= allocateAcquire) man
mstyle <- lookupGetParam "style" mstyle <- lookupGetParam "style"
case mstyle of case mstyle of
Just "plain" -> respondSource "text/html; charset=utf-8" Just "plain" -> respondSource "text/html; charset=utf-8"

View File

@ -11,7 +11,7 @@ import Yesod.Auth as Import
import Data.WebsiteContent as Import (WebsiteContent (..)) import Data.WebsiteContent as Import (WebsiteContent (..))
import Data.Text.Read (decimal) import Data.Text.Read (decimal)
import Data.Time.Clock (diffUTCTime) import Data.Time.Clock (diffUTCTime)
import qualified Prometheus as P --import qualified Prometheus as P
import Stackage.Database (SnapName) import Stackage.Database (SnapName)
import Formatting (format) import Formatting (format)
import Formatting.Time (diff) import Formatting.Time (diff)
@ -43,6 +43,8 @@ haddockUrl sname pkgver name = HaddockR sname
track track
:: MonadIO m :: MonadIO m
=> String -> m a -> m a => String -> m a -> m a
track _ = id
{- FIXME prometheus isn't in Stackage anymore
track name inner = do track name inner = do
start <- liftIO getCurrentTime start <- liftIO getCurrentTime
result <- inner result <- inner
@ -62,6 +64,7 @@ track name inner = do
"stackage_server_fn" "stackage_server_fn"
"Stackage Server function call (duration in microseconds).") "Stackage Server function call (duration in microseconds).")
P.defaultBuckets)) P.defaultBuckets))
-}
dateDiff :: UTCTime -- ^ now dateDiff :: UTCTime -- ^ now
-> Day -- ^ target -> Day -- ^ target

View File

@ -188,7 +188,7 @@ sourceBuildPlans root = do
sourceDirectory (encodeString docdir) =$= concatMapMC (go Right . fromString) sourceDirectory (encodeString docdir) =$= concatMapMC (go Right . fromString)
where where
go wrapper fp | Just name <- nameFromFP fp = liftIO $ do 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) return $ Just (name, fp, wrapper bp)
go _ _ = return Nothing go _ _ = return Nothing

View File

@ -31,8 +31,6 @@ import Data.Conduit.Zlib (WindowBits (WindowBits),
compress, ungzip) compress, ungzip)
import qualified Hoogle import qualified Hoogle
import System.Directory (getAppUserDataDirectory) import System.Directory (getAppUserDataDirectory)
import System.IO (withBinaryFile, IOMode (ReadMode))
import System.IO.Temp (withSystemTempDirectory)
import Control.SingleRun import Control.SingleRun
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import System.FilePath (splitPath) 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" let indexTar = stackDir </> "indices" </> "Hackage" </> "00-index.tar"
withBinaryFile indexTar ReadMode $ \h -> do withBinaryFile indexTar ReadMode $ \h -> do
let loop Tar.Done = return () 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 loop (Tar.Next e es) = go e >> loop es
go e = go e =

View File

@ -11,10 +11,9 @@ import qualified Codec.Archive.Tar as Tar
import Codec.Compression.GZip (decompress) import Codec.Compression.GZip (decompress)
import Control.Monad (guard) import Control.Monad (guard)
import Control.Monad.IO.Class (liftIO) 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 qualified Data.ByteString.Lazy as L
import Data.Conduit (Producer, bracketP, import Data.Conduit (ConduitT, bracketP, yield, (.|))
yield, (=$=))
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Data.Version (Version) import Data.Version (Version)
import Distribution.Compat.ReadP (readP_to_S) import Distribution.Compat.ReadP (readP_to_S)
@ -23,15 +22,15 @@ import Distribution.PackageDescription (GenericPackageDescriptio
import Distribution.PackageDescription.Parsec (ParseResult, parseGenericPackageDescription) import Distribution.PackageDescription.Parsec (ParseResult, parseGenericPackageDescription)
import Distribution.Text (disp, parse) import Distribution.Text (disp, parse)
import qualified Distribution.Text import qualified Distribution.Text
import System.IO (IOMode (ReadMode), import System.IO (openBinaryFile)
hClose, openBinaryFile)
import Text.PrettyPrint (render) import Text.PrettyPrint (render)
import Prelude import Prelude
import UnliftIO
sourceTarFile :: MonadResource m sourceTarFile :: MonadResource m
=> Bool -- ^ ungzip? => Bool -- ^ ungzip?
-> FilePath -> FilePath
-> Producer m Tar.Entry -> ConduitT i Tar.Entry m ()
sourceTarFile toUngzip fp = do sourceTarFile toUngzip fp = do
bracketP (openBinaryFile fp ReadMode) hClose $ \h -> do bracketP (openBinaryFile fp ReadMode) hClose $ \h -> do
lbs <- liftIO $ L.hGetContents h lbs <- liftIO $ L.hGetContents h
@ -41,7 +40,7 @@ sourceTarFile toUngzip fp = do
| toUngzip = decompress | toUngzip = decompress
| otherwise = id | otherwise = id
loop Tar.Done = return () 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 loop (Tar.Next e es) = yield e >> loop es
data CabalFileEntry = CabalFileEntry data CabalFileEntry = CabalFileEntry
@ -55,10 +54,10 @@ data CabalFileEntry = CabalFileEntry
sourceAllCabalFiles sourceAllCabalFiles
:: MonadResource m :: MonadResource m
=> IO FilePath => IO FilePath
-> Producer m CabalFileEntry -> ConduitT i CabalFileEntry m ()
sourceAllCabalFiles getIndexTar = do sourceAllCabalFiles getIndexTar = do
tarball <- liftIO $ getIndexTar tarball <- liftIO $ getIndexTar
sourceTarFile False tarball =$= CL.mapMaybe go sourceTarFile False tarball .| CL.mapMaybe go
where where
go e = go e =
case (toPkgVer $ Tar.entryPath e, Tar.entryContent e) of case (toPkgVer $ Tar.entryPath e, Tar.entryContent e) of

View File

@ -11,6 +11,7 @@ import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy as LText
import qualified Data.Text.Read as Reader import qualified Data.Text.Read as Reader
import Data.Char (ord) import Data.Char (ord)
import Control.Monad.Catch (MonadThrow, throwM)
data SnapshotBranch = LtsMajorBranch Int data SnapshotBranch = LtsMajorBranch Int
| LtsBranch | LtsBranch

View File

@ -1,16 +1,6 @@
resolver: lts-10.5 resolver: nightly-2018-06-20
extra-deps: extra-deps:
- archive: https://github.com/chrisdone/tagstream-conduit/archive/bacd7444596b2391b0ac302ad649b994b258d271.tar.gz - archive: https://github.com/chrisdone/tagstream-conduit/archive/bacd7444596b2391b0ac302ad649b994b258d271.tar.gz
- archive: https://github.com/snoyberg/gitrev/archive/6a1a639f493ac08959eb5ddf540ca1937baaaaf9.tar.gz - archive: https://github.com/snoyberg/gitrev/archive/6a1a639f493ac08959eb5ddf540ca1937baaaaf9.tar.gz
- archive: https://github.com/bitemyapp/esqueleto/archive/b81e0d951e510ebffca03c5a58658ad884cc6fbd.tar.gz
- Cabal-2.2.0.0@rev:1 - archive: https://github.com/fpco/stackage-curator/archive/7635cdc45fcc7c1b733957bce865c40ae8e22b0c.tar.gz
- 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