diff --git a/Data/WebsiteContent.hs b/Data/WebsiteContent.hs index f4d30b4..44b3325 100644 --- a/Data/WebsiteContent.hs +++ b/Data/WebsiteContent.hs @@ -34,7 +34,7 @@ loadWebsiteContent dir = do readMarkdown fp = fmap (markdown def { msXssProtect = False , msAddHeadingId = True - }) + } . fromStrict . decodeUtf8) $ readFile $ dir fp data StackRelease = StackRelease diff --git a/Handler/BuildPlan.hs b/Handler/BuildPlan.hs index 45aa039..d1dfd39 100644 --- a/Handler/BuildPlan.hs +++ b/Handler/BuildPlan.hs @@ -3,7 +3,7 @@ module Handler.BuildPlan where import Import hiding (get, PackageName (..), Version (..), DList) import Stackage.Types -import Stackage.BuildPlan +import Stackage.ShowBuildPlan import Stackage.Database getBuildPlanR :: SnapName -> Handler TypedContent diff --git a/Handler/DownloadStack.hs b/Handler/DownloadStack.hs index 0d2f83f..59e62c0 100644 --- a/Handler/DownloadStack.hs +++ b/Handler/DownloadStack.hs @@ -9,7 +9,6 @@ import Yesod.GitRepo import Data.WebsiteContent import Data.Aeson.Parser (json) import Data.Conduit.Attoparsec (sinkParser) -import Data.Monoid (First (..)) getDownloadStackListR :: Handler Html getDownloadStackListR = track "Handler.DownloadStack.getDownloadStackListR" $ do diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 84cf43a..5712d2f 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -48,7 +48,7 @@ getHaddockR slug rest ] addExtra t@(EventBeginElement "body" _) = [t] addExtra t = [t] - req <- parseUrl $ unpack $ makeURL slug rest + req <- parseRequest $ unpack $ makeURL slug rest (_, res) <- acquireResponse req >>= allocateAcquire doc <- responseBody res $$ eventConduit diff --git a/Settings.hs b/Settings.hs index 036df55..eae0ba3 100644 --- a/Settings.hs +++ b/Settings.hs @@ -6,7 +6,6 @@ module Settings where import ClassyPrelude.Yesod -import Control.Exception (throw) import Data.Aeson (Result (..), fromJSON, withObject, (.!=), (.:?)) import Data.FileEmbed (embedFile) @@ -108,7 +107,7 @@ configSettingsYmlBS = $(embedFile configSettingsYml) -- | @config/settings.yml@, parsed to a @Value@. configSettingsYmlValue :: Value -configSettingsYmlValue = either throw id $ decodeEither' configSettingsYmlBS +configSettingsYmlValue = either impureThrow id $ decodeEither' configSettingsYmlBS -- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. compileTimeAppSettings :: AppSettings diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index 856ad7a..9458517 100644 --- a/Stackage/Database/Cron.hs +++ b/Stackage/Database/Cron.hs @@ -17,8 +17,7 @@ import Web.PathPieces (toPathPiece) import Filesystem.Path.CurrentOS (parent, fromText, encodeString) import Network.HTTP.Types (status200) import Data.Streaming.Network (bindPortTCP) -import Network.AWS (Credentials (Discover), - Region (NorthVirginia), newEnv, +import Network.AWS (Credentials (Discover), newEnv, send, chunkedFile, defaultChunkSize, envManager, runAWS) import Control.Monad.Trans.AWS (trying, _Error) @@ -66,7 +65,7 @@ loadFromS3 develMode man = do unless develMode $ handleIO print $ removeTree root createTree root - req <- parseUrl $ unpack url + req <- parseRequest $ unpack url let download = do suffix <- atomically $ do x <- readTVar currSuffixVar @@ -139,11 +138,8 @@ newHoogleLocker toPrint man = mkSingleRun $ \name -> do if exists then return $ Just (encodeString fp) else do - req' <- parseUrl $ unpack $ hoogleUrl name - let req = req' - { checkStatus = \_ _ _ -> Nothing - , decompress = const False - } + req' <- parseRequest $ unpack $ hoogleUrl name + let req = req' { decompress = const False } withResponse req man $ \res -> if responseStatus res == status200 then do createTree $ parent (fromString fptmp) @@ -162,7 +158,7 @@ stackageServerCron = do void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ -> error $ "cabal loader process already running, exiting" - env <- newEnv NorthVirginia Discover + env <- newEnv Discover let upload :: FilePath -> ObjectKey -> IO () upload fp key = do let fpgz = fp <.> "gz" @@ -219,7 +215,7 @@ stackageServerCron = do createHoogleDB :: StackageDatabase -> Manager -> SnapName -> IO (Maybe FilePath) createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do putStrLn $ "Creating Hoogle DB for " ++ toPathPiece name - req' <- parseUrl $ unpack tarUrl + req' <- parseRequest $ unpack tarUrl let req = req' { decompress = const True } unlessM (isFile (fromString tarFP)) $ withResponse req man $ \res -> do @@ -253,7 +249,9 @@ createHoogleDB db man name = handleAny (\e -> print e $> Nothing) $ do , Just pkg2 <- stripSuffix ".cabal" (pack pkgcabal') , pkg == pkg2 , lookup pkg allPackagePairs == Just ver -> - writeFile (tmpdir unpack pkg <.> "cabal") cabalLBS + runConduitRes + $ sourceLazy cabalLBS + .| sinkFile (tmpdir unpack pkg <.> "cabal") _ -> return () L.hGetContents h >>= loop . Tar.read @@ -300,7 +298,7 @@ singleDB db sname tmpdir e@(Tar.entryContent -> Tar.NormalFile lbs _) = do Just (Entity _ sp) -> do let out = tmpdir unpack pkg <.> "txt" -- FIXME add @url directive - writeFile out lbs + runConduitRes $ sourceLazy lbs .| sinkFile out return $ singletonMap pkg (snapshotPackageVersion sp) {- docsUrl = concat diff --git a/Stackage/Database/Haddock.hs b/Stackage/Database/Haddock.hs index 7ced9be..372247f 100644 --- a/Stackage/Database/Haddock.hs +++ b/Stackage/Database/Haddock.hs @@ -56,3 +56,5 @@ hToHtml = wrapper 4 = H.h4 wrapper 5 = H.h5 wrapper _ = H.h6 + go (DocMathInline x) = H.pre $ H.code $ toHtml x + go (DocMathDisplay x) = H.pre $ H.code $ toHtml x diff --git a/Stackage/Database/Types.hs b/Stackage/Database/Types.hs index f63d45b..a5acbdd 100644 --- a/Stackage/Database/Types.hs +++ b/Stackage/Database/Types.hs @@ -6,7 +6,7 @@ module Stackage.Database.Types import ClassyPrelude.Conduit import Web.PathPieces -import Data.Aeson.Extra +import Data.Aeson import Data.Text.Read (decimal) import Database.Persist import Database.Persist.Sql @@ -23,8 +23,7 @@ isNightly :: SnapName -> Bool isNightly SNLts{} = False isNightly SNNightly{} = True -instance ToJSONKey SnapName where - toJSONKey = toPathPiece +instance ToJSONKey SnapName instance ToJSON SnapName where toJSON = String . toPathPiece diff --git a/Stackage/Snapshot/Diff.hs b/Stackage/Snapshot/Diff.hs index 1180d1c..5900e05 100644 --- a/Stackage/Snapshot/Diff.hs +++ b/Stackage/Snapshot/Diff.hs @@ -9,7 +9,7 @@ module Stackage.Snapshot.Diff ) where import Data.Align -import Data.Aeson.Extra +import Data.Aeson import qualified Data.HashMap.Strict as HashMap import Control.Arrow import ClassyPrelude @@ -30,7 +30,7 @@ newtype SnapshotDiff instance ToJSON (WithSnapshotNames SnapshotDiff) where toJSON (WithSnapshotNames nameA nameB (SnapshotDiff diff)) = object [ "comparing" .= [toPathPiece nameA, toPathPiece nameB] - , "diff" .= Object (toJSONMap (WithSnapshotNames nameA nameB <$> diff)) + , "diff" .= toJSON (WithSnapshotNames nameA nameB <$> diff) ] toDiffList :: SnapshotDiff -> [(PackageName, VersionChange)] @@ -45,7 +45,7 @@ newtype VersionChange = VersionChange { unVersionChange :: These Version Version deriving (Show, Eq, Generic, Typeable) instance ToJSON (WithSnapshotNames VersionChange) where - toJSON (WithSnapshotNames (toJSONKey -> aKey) (toJSONKey -> bKey) change) = + toJSON (WithSnapshotNames (toPathPiece -> aKey) (toPathPiece -> bKey) change) = case change of VersionChange (This a) -> object [ aKey .= a ] VersionChange (That b) -> object [ bKey .= b ] diff --git a/Types.hs b/Types.hs index f0481d1..568c68b 100644 --- a/Types.hs +++ b/Types.hs @@ -1,7 +1,7 @@ module Types where import ClassyPrelude.Yesod -import Data.Aeson.Extra +import Data.Aeson import Data.Hashable (hashUsing) import Text.Blaze (ToMarkup) import Database.Persist.Sql (PersistFieldSql (sqlType)) @@ -31,8 +31,7 @@ newtype PackageName = PackageName { unPackageName :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString) instance ToJSON PackageName where toJSON = toJSON . unPackageName -instance ToJSONKey PackageName where - toJSONKey = unPackageName +instance ToJSONKey PackageName instance PersistFieldSql PackageName where sqlType = sqlType . liftM unPackageName newtype Version = Version { unVersion :: Text } diff --git a/stack.yaml b/stack.yaml index 933f7f3..201b8b0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,15 +1,14 @@ -resolver: lts-6.17 +resolver: lts-8.12 packages: - . - location: git: https://github.com/chrisdone/tagstream-conduit.git commit: bacd7444596b2391b0ac302ad649b994b258d271 extra-dep: true +- location: + git: https://github.com/commercialhaskell/all-cabal-metadata-tool + commit: 1a4d8cff4e796ea0049537a38e38ec0a739caf64 + extra-dep: true extra-deps: - - prometheus-client-0.1.0.1 - - prometheus-metrics-ghc-0.1.0.1 - - wai-middleware-prometheus-0.1.0.1 - - hoogle-5.0.6 - - haskell-src-exts-1.19.0 - - persistent-sqlite-2.2.1.1 - - yesod-bin-1.5.2.2 +- aws-0.16 +- barrier-0.1.1 diff --git a/stackage-server.cabal b/stackage-server.cabal index 52b0aa1..e8656b0 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -89,7 +89,6 @@ library build-depends: base , aeson - , aeson-extra , aws , barrier , base16-bytestring @@ -168,8 +167,7 @@ library , deepseq , deepseq-generics , auto-update - , stackage-types - , stackage-build-plan + , stackage-curator , yesod-sitemap , streaming-commons , classy-prelude-conduit