From 26af5d29ed5fe31b0274f34f30cf63ed679080a8 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Tue, 2 Feb 2016 05:21:33 +0200 Subject: [PATCH 1/3] Upgrade to lts-5 --- Handler/Feed.hs | 2 ++ Stackage/Database/Cron.hs | 43 +++++++++++++++++++++------------------ stack.yaml | 5 +---- stackage-server.cabal | 32 ++++++++++++++--------------- 4 files changed, 42 insertions(+), 40 deletions(-) diff --git a/Handler/Feed.hs b/Handler/Feed.hs index 4a7d298..717ae62 100644 --- a/Handler/Feed.hs +++ b/Handler/Feed.hs @@ -28,6 +28,7 @@ mkFeed mBranch snaps = do , feedEntryUpdated = UTCTime (snapshotCreated snap) 0 , feedEntryTitle = prettyName (snapshotName snap) (snapshotGhc snap) , feedEntryContent = content + , feedEntryEnclosure = Nothing } updated <- case entries of @@ -42,6 +43,7 @@ mkFeed mBranch snaps = do , feedLanguage = "en" , feedUpdated = updated , feedEntries = entries + , feedLogo = Nothing } where branchTitle NightlyBranch = "Nightly" diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs index 26307a6..4788097 100644 --- a/Stackage/Database/Cron.hs +++ b/Stackage/Database/Cron.hs @@ -21,12 +21,15 @@ import Control.Monad.State.Strict (StateT, get, put) import Network.HTTP.Types (status200) import Data.Streaming.Network (bindPortTCP) import Network.AWS (Credentials (Discover), - Region (NorthVirginia), getEnv, - send, sourceFileIO, envManager) -import Network.AWS.Data (toBody) -import Network.AWS.S3 (ObjectCannedACL (PublicRead), - poACL, - putObject) + Region (NorthVirginia), newEnv, + send, chunkedFile, defaultChunkSize, + envManager, runAWS) +import Control.Monad.Trans.AWS (trying, _Error) +import Network.AWS.Data.Body (toBody) +import Network.AWS.S3 (ObjectCannedACL (OPublicRead), + poACL, putObject, + BucketName(BucketName), + ObjectKey(ObjectKey)) import Control.Lens (set, view) import qualified Data.Conduit.Binary as CB import Data.Conduit.Zlib (WindowBits (WindowBits), @@ -154,37 +157,37 @@ stackageServerCron = do void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ -> error $ "cabal loader process already running, exiting" - env <- getEnv NorthVirginia Discover - let upload :: FilePath -> Text -> IO () + env <- newEnv NorthVirginia Discover + let upload :: FilePath -> ObjectKey -> IO () upload fp key = do let fpgz = fp <.> "gz" runResourceT $ sourceFile fp $$ compress 9 (WindowBits 31) =$ CB.sinkFile fpgz - body <- sourceFileIO fpgz + body <- chunkedFile defaultChunkSize fpgz let po = - set poACL (Just PublicRead) - $ putObject body "haddock.stackage.org" key - putStrLn $ "Uploading: " ++ key - eres <- runResourceT $ send env po + set poACL (Just OPublicRead) + $ putObject "haddock.stackage.org" key body + putStrLn $ "Uploading: " ++ tshow key + eres <- runResourceT $ runAWS env $ trying _Error $ send po case eres of Left e -> error $ show (fp, key, e) Right _ -> putStrLn "Success" let dbfp = fromText keyName createStackageDatabase dbfp - upload (encodeString dbfp) keyName + upload (encodeString dbfp) (ObjectKey keyName) db <- openStackageDatabase dbfp do snapshots <- runReaderT snapshotsJSON db - let key = "snapshots.json" :: Text + let key = ObjectKey "snapshots.json" po = - set poACL (Just PublicRead) - $ putObject (toBody snapshots) "haddock.stackage.org" key - putStrLn $ "Uploading: " ++ key - eres <- runResourceT $ send env po + set poACL (Just OPublicRead) + $ putObject (BucketName "haddock.stackage.org") key (toBody snapshots) + putStrLn $ "Uploading: " ++ tshow key + eres <- runResourceT $ runAWS env $ trying _Error $ send po case eres of Left e -> error $ show (key, e) Right _ -> putStrLn "Success" @@ -199,7 +202,7 @@ stackageServerCron = do mfp' <- createHoogleDB db manager name forM_ mfp' $ \fp -> do let key = hoogleKey name - upload fp key + upload fp (ObjectKey key) let dest = unpack key createTree $ parent (fromString dest) rename (fromString fp) (fromString dest) diff --git a/stack.yaml b/stack.yaml index c4bcc1f..7124ff4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,4 @@ -resolver: lts-3.9 -extra-deps: - - these-0.6.1.0 - - barrier-0.1.0 +resolver: lts-5.1 image: container: name: snoyberg/stackage-server diff --git a/stackage-server.cabal b/stackage-server.cabal index 247e67c..55ba76c 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -90,9 +90,9 @@ library build-depends: base >= 4.8 && < 4.9 - , aeson >= 0.8 && < 0.9 - , aeson-extra >= 0.2 && < 0.3 - , aws >= 0.12 && < 0.13 + , aeson >= 0.9 && < 0.10 + , aeson-extra >= 0.3 && < 0.4 + , aws >= 0.13 && < 0.14 , barrier >= 0.1 && < 0.2 , base16-bytestring >= 0.1 && < 0.2 , blaze-markup >= 0.7 && < 0.8 @@ -106,7 +106,7 @@ library , cryptohash-conduit >= 0.1.1 && < 0.2 , data-default >= 0.5 && < 0.6 , directory >= 1.2 && < 1.3 - , email-validate >= 2.1 && < 2.2 + , email-validate >= 2.2 && < 2.3 , esqueleto >= 2.4 && < 2.5 , exceptions >= 0.8 && < 0.9 , fast-logger >= 2.4 && < 2.5 @@ -125,15 +125,15 @@ library , shakespeare >= 2.0 && < 2.1 , system-fileio >= 0.3 && < 0.4 , system-filepath >= 0.4 && < 0.5 - , tar >= 0.4 && < 0.5 + , tar >= 0.5 && < 0.6 , template-haskell >= 2.10 && < 2.11 , temporary-rc >= 1.2 && < 1.3 , text >= 1.2 && < 1.3 , these >= 0.6 && < 0.7 - , wai >= 3.0 && < 3.1 + , wai >= 3.2 && < 3.3 , wai-extra >= 3.0 && < 3.1 , wai-logger >= 2.2 && < 2.3 - , warp >= 3.1 && < 3.2 + , warp >= 3.2 && < 3.3 , xml-conduit >= 1.3 && < 1.4 , yaml >= 0.8 && < 0.9 , yesod >= 1.4 && < 1.5 @@ -142,12 +142,12 @@ library , yesod-form >= 1.4 && < 1.5 , yesod-newsfeed , yesod-static >= 1.5 && < 1.6 - , zlib >= 0.5 && < 0.6 + , zlib >= 0.6 && < 0.7 , unordered-containers >= 0.2 && < 0.3 , hashable >= 1.2 && < 1.3 , Cabal >= 1.22 && < 1.23 , lifted-base >= 0.2 && < 0.3 - , mono-traversable >= 0.9 && < 0.10 + , mono-traversable >= 0.10 && < 0.11 , time >= 1.5 && < 1.6 , process >= 1.2 && < 1.3 , old-locale >= 1.0 && < 1.1 @@ -158,14 +158,14 @@ library , formatting >= 6.2 && < 6.3 , blaze-html >= 0.8 && < 0.9 , haddock-library >= 1.2.0 && < 1.3 - , async >= 2.0 && < 2.1 + , async >= 2.1 && < 2.2 , yesod-gitrepo >= 0.2 && < 0.3 , hoogle >= 4.2 && < 4.3 , spoon >= 0.3 && < 0.4 , deepseq >= 1.4 && < 1.5 , deepseq-generics >= 0.1 && < 0.2 , auto-update >= 0.1 && < 0.2 - , stackage-types >= 1.1 && < 1.2 + , stackage-types >= 1.2 && < 1.3 , stackage-build-plan >= 0.1.1 && < 0.2 , yesod-sitemap >= 1.4 && < 1.5 , streaming-commons >= 0.1 && < 0.2 @@ -175,11 +175,11 @@ library , stackage-metadata >= 0.3 && < 0.4 , filepath >= 1.4 && < 1.5 , http-client >= 0.4 && < 0.5 - , http-types >= 0.8 && < 0.9 - , amazonka >= 0.3 && < 0.4 - , amazonka-core >= 0.3 && < 0.4 - , amazonka-s3 >= 0.3 && < 0.4 - , lens >= 4.12 && < 4.13 + , http-types >= 0.9 && < 0.10 + , amazonka >= 1.3 && < 1.4 + , amazonka-core >= 1.3 && < 1.4 + , amazonka-s3 >= 1.3 && < 1.4 + , lens >= 4.13 && < 4.14 executable stackage-server if flag(library-only) From 9cc7f662b3a92958971bccd9cb86b341d1567f32 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Tue, 2 Feb 2016 15:08:15 +0200 Subject: [PATCH 2/3] Bumped test dependencies --- stackage-server.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stackage-server.cabal b/stackage-server.cabal index 55ba76c..ba80e71 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -211,14 +211,14 @@ test-suite test build-depends: base >= 4.8 && < 4.9 , stackage-server - , yesod-test >= 1.4 && < 1.5 + , yesod-test >= 1.5 && < 1.6 , yesod-core >= 1.4 && < 1.5 , yesod >= 1.4 && < 1.5 , persistent >= 2.2 && < 2.3 , resourcet >= 1.1.6 && < 1.2 , monad-logger >= 0.3.13 && < 0.4 , transformers >= 0.4 && < 0.5 - , hspec >= 2.1 && < 2.2 + , hspec >= 2.2 && < 2.3 , classy-prelude-yesod >= 0.12 && < 0.13 , mtl >= 2.2 && < 2.3 , mwc-random >= 0.13 && < 0.14 From 912a0175d445128f52e530d9f5179febf7119c72 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Tue, 2 Feb 2016 03:08:49 +0200 Subject: [PATCH 3/3] Provide snapshot content as JSON ```json $ http --json http://localhost:4000/lts-5.1 { "snapshot": { "ghc": "7.10.3", "created": "2016-01-30", "name": "lts-5.1" }, "packages": [ { "isCore": false, "name": "abstract-deque", "version": "0.3", "synopsis": "Abstract, parameterized interface to mutable Deques." }, { "isCore": false, "name": "abstract-par", "version": "0.3.3", "synopsis": "Type classes generalizing the functionality of the 'monad-par' library." }, ... ] } ``` --- Handler/StackageHome.hs | 24 +++++++++++++++++++----- Stackage/Database.hs | 15 +++++++++++++++ Stackage/Database/Types.hs | 3 +++ 3 files changed, 37 insertions(+), 5 deletions(-) diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index c8626e6..9e1fc79 100644 --- a/Handler/StackageHome.hs +++ b/Handler/StackageHome.hs @@ -13,7 +13,7 @@ import Stackage.Database import Stackage.Database.Types (isLts) import Stackage.Snapshot.Diff -getStackageHomeR :: SnapName -> Handler Html +getStackageHomeR :: SnapName -> Handler TypedContent getStackageHomeR name = do Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return previousSnapName <- fromMaybe name . map snd <$> snapshotBefore (snapshotName snapshot) @@ -22,12 +22,26 @@ getStackageHomeR name = do exact = False in $(widgetFile "hoogle-form") packageCount <- getPackageCount sid - defaultLayout $ do - setTitle $ toHtml $ snapshotTitle snapshot - packages <- getPackages sid - $(widgetFile "stackage-home") + packages <- getPackages sid + selectRep $ do + provideRep $ do + defaultLayout $ do + setTitle $ toHtml $ snapshotTitle snapshot + $(widgetFile "stackage-home") + provideRep $ pure $ toJSON $ SnapshotInfo snapshot packages + + where strip x = fromMaybe x (stripSuffix "." x) +data SnapshotInfo + = SnapshotInfo { snapshot :: Snapshot + , packages :: [PackageListingInfo] + } +instance ToJSON SnapshotInfo where + toJSON SnapshotInfo{..} = object [ "snapshot" .= snapshot + , "packages" .= packages + ] + getStackageDiffR :: SnapName -> SnapName -> Handler TypedContent getStackageDiffR name1 name2 = do Entity sid1 _ <- lookupSnapshot name1 >>= maybe notFound return diff --git a/Stackage/Database.hs b/Stackage/Database.hs index d1d9c54..a6ef073 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -129,6 +129,13 @@ Deprecated UniqueDeprecated package |] +instance A.ToJSON Snapshot where + toJSON Snapshot{..} = + A.object [ "name" A..= snapshotName + , "ghc" A..= snapshotGhc + , "created" A..= formatTime defaultTimeLocale "%F" snapshotCreated + ] + _hideUnusedWarnings :: ( SnapshotPackageId , SchemaId @@ -490,6 +497,14 @@ data PackageListingInfo = PackageListingInfo , pliIsCore :: !Bool } +instance A.ToJSON PackageListingInfo where + toJSON PackageListingInfo{..} = + A.object [ "name" A..= pliName + , "version" A..= pliVersion + , "synopsis" A..= pliSynopsis + , "isCore" A..= pliIsCore + ] + getPackages :: GetStackageDatabase m => SnapshotId -> m [PackageListingInfo] getPackages sid = liftM (map toPLI) $ run $ do E.select $ E.from $ \(p,sp) -> do diff --git a/Stackage/Database/Types.hs b/Stackage/Database/Types.hs index 19a8f56..f63d45b 100644 --- a/Stackage/Database/Types.hs +++ b/Stackage/Database/Types.hs @@ -26,6 +26,9 @@ isNightly SNNightly{} = True instance ToJSONKey SnapName where toJSONKey = toPathPiece +instance ToJSON SnapName where + toJSON = String . toPathPiece + instance PersistField SnapName where toPersistValue = toPersistValue . toPathPiece fromPersistValue v = do