haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-02-09 09:37:31 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Merge pull request #151 from fpco/lts-5

Browse Source 
Upgrade to lts-5
This commit is contained in:
Michael Snoyman 2016-02-03 10:43:46 +02:00
commit c50899bd65
7 changed files with 81 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Handler/Feed.hs
View File

@ -28,6 +28,7 @@ mkFeed mBranch snaps = do
, feedEntryUpdated = UTCTime (snapshotCreated snap) 0 , feedEntryUpdated = UTCTime (snapshotCreated snap) 0
, feedEntryTitle = prettyName (snapshotName snap) (snapshotGhc snap) , feedEntryTitle = prettyName (snapshotName snap) (snapshotGhc snap)
, feedEntryContent = content , feedEntryContent = content
, feedEntryEnclosure = Nothing
} }
updated <- updated <-
case entries of case entries of
@ -42,6 +43,7 @@ mkFeed mBranch snaps = do
, feedLanguage = "en" , feedLanguage = "en"
, feedUpdated = updated , feedUpdated = updated
, feedEntries = entries , feedEntries = entries
, feedLogo = Nothing
} }
where where
branchTitle NightlyBranch = "Nightly" branchTitle NightlyBranch = "Nightly"

24
Handler/StackageHome.hs
View File

@ -13,7 +13,7 @@ import Stackage.Database
import Stackage.Database.Types (isLts) import Stackage.Database.Types (isLts)
import Stackage.Snapshot.Diff import Stackage.Snapshot.Diff
getStackageHomeR :: SnapName -> Handler Html getStackageHomeR :: SnapName -> Handler TypedContent
getStackageHomeR name = do getStackageHomeR name = do
Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
previousSnapName <- fromMaybe name . map snd <$> snapshotBefore (snapshotName snapshot) previousSnapName <- fromMaybe name . map snd <$> snapshotBefore (snapshotName snapshot)
@ -22,12 +22,26 @@ getStackageHomeR name = do
exact = False exact = False
in $(widgetFile "hoogle-form") in $(widgetFile "hoogle-form")
packageCount <- getPackageCount sid packageCount <- getPackageCount sid
defaultLayout $ do packages <- getPackages sid
setTitle $ toHtml $ snapshotTitle snapshot selectRep $ do
packages <- getPackages sid provideRep $ do
$(widgetFile "stackage-home") defaultLayout $ do
setTitle $ toHtml $ snapshotTitle snapshot
$(widgetFile "stackage-home")
provideRep $ pure $ toJSON $ SnapshotInfo snapshot packages
where strip x = fromMaybe x (stripSuffix "." x) 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 :: SnapName -> SnapName -> Handler TypedContent
getStackageDiffR name1 name2 = do getStackageDiffR name1 name2 = do
Entity sid1 _ <- lookupSnapshot name1 >>= maybe notFound return Entity sid1 _ <- lookupSnapshot name1 >>= maybe notFound return

15
Stackage/Database.hs
View File

@ -129,6 +129,13 @@ Deprecated
UniqueDeprecated package UniqueDeprecated package
|] |]
instance A.ToJSON Snapshot where
toJSON Snapshot{..} =
A.object [ "name" A..= snapshotName
, "ghc" A..= snapshotGhc
, "created" A..= formatTime defaultTimeLocale "%F" snapshotCreated
]
_hideUnusedWarnings _hideUnusedWarnings
:: ( SnapshotPackageId :: ( SnapshotPackageId
, SchemaId , SchemaId
@ -490,6 +497,14 @@ data PackageListingInfo = PackageListingInfo
, pliIsCore :: !Bool , 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 :: GetStackageDatabase m => SnapshotId -> m [PackageListingInfo]
getPackages sid = liftM (map toPLI) $ run $ do getPackages sid = liftM (map toPLI) $ run $ do
E.select $ E.from $ \(p,sp) -> do E.select $ E.from $ \(p,sp) -> do

43
Stackage/Database/Cron.hs
View File

@ -21,12 +21,15 @@ import Control.Monad.State.Strict (StateT, get, put)
import Network.HTTP.Types (status200) import Network.HTTP.Types (status200)
import Data.Streaming.Network (bindPortTCP) import Data.Streaming.Network (bindPortTCP)
import Network.AWS (Credentials (Discover), import Network.AWS (Credentials (Discover),
Region (NorthVirginia), getEnv, Region (NorthVirginia), newEnv,
send, sourceFileIO, envManager) send, chunkedFile, defaultChunkSize,
import Network.AWS.Data (toBody) envManager, runAWS)
import Network.AWS.S3 (ObjectCannedACL (PublicRead), import Control.Monad.Trans.AWS (trying, _Error)
poACL, import Network.AWS.Data.Body (toBody)
putObject) import Network.AWS.S3 (ObjectCannedACL (OPublicRead),
poACL, putObject,
BucketName(BucketName),
ObjectKey(ObjectKey))
import Control.Lens (set, view) import Control.Lens (set, view)
import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Binary as CB
import Data.Conduit.Zlib (WindowBits (WindowBits), import Data.Conduit.Zlib (WindowBits (WindowBits),
@ -154,37 +157,37 @@ stackageServerCron = do
void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ -> void $ catchIO (bindPortTCP 17834 "127.0.0.1") $ \_ ->
error $ "cabal loader process already running, exiting" error $ "cabal loader process already running, exiting"
env <- getEnv NorthVirginia Discover env <- newEnv NorthVirginia Discover
let upload :: FilePath -> Text -> IO () let upload :: FilePath -> ObjectKey -> IO ()
upload fp key = do upload fp key = do
let fpgz = fp <.> "gz" let fpgz = fp <.> "gz"
runResourceT $ sourceFile fp runResourceT $ sourceFile fp
$$ compress 9 (WindowBits 31) $$ compress 9 (WindowBits 31)
=$ CB.sinkFile fpgz =$ CB.sinkFile fpgz
body <- sourceFileIO fpgz body <- chunkedFile defaultChunkSize fpgz
let po = let po =
set poACL (Just PublicRead) set poACL (Just OPublicRead)
$ putObject body "haddock.stackage.org" key $ putObject "haddock.stackage.org" key body
putStrLn $ "Uploading: " ++ key putStrLn $ "Uploading: " ++ tshow key
eres <- runResourceT $ send env po eres <- runResourceT $ runAWS env $ trying _Error $ send po
case eres of case eres of
Left e -> error $ show (fp, key, e) Left e -> error $ show (fp, key, e)
Right _ -> putStrLn "Success" Right _ -> putStrLn "Success"
let dbfp = fromText keyName let dbfp = fromText keyName
createStackageDatabase dbfp createStackageDatabase dbfp
upload (encodeString dbfp) keyName upload (encodeString dbfp) (ObjectKey keyName)
db <- openStackageDatabase dbfp db <- openStackageDatabase dbfp
do do
snapshots <- runReaderT snapshotsJSON db snapshots <- runReaderT snapshotsJSON db
let key = "snapshots.json" :: Text let key = ObjectKey "snapshots.json"
po = po =
set poACL (Just PublicRead) set poACL (Just OPublicRead)
$ putObject (toBody snapshots) "haddock.stackage.org" key $ putObject (BucketName "haddock.stackage.org") key (toBody snapshots)
putStrLn $ "Uploading: " ++ key putStrLn $ "Uploading: " ++ tshow key
eres <- runResourceT $ send env po eres <- runResourceT $ runAWS env $ trying _Error $ send po
case eres of case eres of
Left e -> error $ show (key, e) Left e -> error $ show (key, e)
Right _ -> putStrLn "Success" Right _ -> putStrLn "Success"
@ -199,7 +202,7 @@ stackageServerCron = do
mfp' <- createHoogleDB db manager name mfp' <- createHoogleDB db manager name
forM_ mfp' $ \fp -> do forM_ mfp' $ \fp -> do
let key = hoogleKey name let key = hoogleKey name
upload fp key upload fp (ObjectKey key)
let dest = unpack key let dest = unpack key
createTree $ parent (fromString dest) createTree $ parent (fromString dest)
rename (fromString fp) (fromString dest) rename (fromString fp) (fromString dest)

3
Stackage/Database/Types.hs
View File

@ -26,6 +26,9 @@ isNightly SNNightly{} = True
instance ToJSONKey SnapName where instance ToJSONKey SnapName where
toJSONKey = toPathPiece toJSONKey = toPathPiece
instance ToJSON SnapName where
toJSON = String . toPathPiece
instance PersistField SnapName where instance PersistField SnapName where
toPersistValue = toPersistValue . toPathPiece toPersistValue = toPersistValue . toPathPiece
fromPersistValue v = do fromPersistValue v = do

5
stack.yaml
View File

@ -1,7 +1,4 @@
resolver: lts-3.9 resolver: lts-5.1
extra-deps:
- these-0.6.1.0
- barrier-0.1.0
image: image:
container: container:
name: snoyberg/stackage-server name: snoyberg/stackage-server

36
stackage-server.cabal
View File

@ -90,9 +90,9 @@ library
build-depends: build-depends:
base >= 4.8 && < 4.9 base >= 4.8 && < 4.9
, aeson >= 0.8 && < 0.9 , aeson >= 0.9 && < 0.10
, aeson-extra >= 0.2 && < 0.3 , aeson-extra >= 0.3 && < 0.4
, aws >= 0.12 && < 0.13 , aws >= 0.13 && < 0.14
, barrier >= 0.1 && < 0.2 , barrier >= 0.1 && < 0.2
, base16-bytestring >= 0.1 && < 0.2 , base16-bytestring >= 0.1 && < 0.2
, blaze-markup >= 0.7 && < 0.8 , blaze-markup >= 0.7 && < 0.8
@ -106,7 +106,7 @@ library
, cryptohash-conduit >= 0.1.1 && < 0.2 , cryptohash-conduit >= 0.1.1 && < 0.2
, data-default >= 0.5 && < 0.6 , data-default >= 0.5 && < 0.6
, directory >= 1.2 && < 1.3 , directory >= 1.2 && < 1.3
, email-validate >= 2.1 && < 2.2 , email-validate >= 2.2 && < 2.3
, esqueleto >= 2.4 && < 2.5 , esqueleto >= 2.4 && < 2.5
, exceptions >= 0.8 && < 0.9 , exceptions >= 0.8 && < 0.9
, fast-logger >= 2.4 && < 2.5 , fast-logger >= 2.4 && < 2.5
@ -125,15 +125,15 @@ library
, shakespeare >= 2.0 && < 2.1 , shakespeare >= 2.0 && < 2.1
, system-fileio >= 0.3 && < 0.4 , system-fileio >= 0.3 && < 0.4
, system-filepath >= 0.4 && < 0.5 , system-filepath >= 0.4 && < 0.5
, tar >= 0.4 && < 0.5 , tar >= 0.5 && < 0.6
, template-haskell >= 2.10 && < 2.11 , template-haskell >= 2.10 && < 2.11
, temporary-rc >= 1.2 && < 1.3 , temporary-rc >= 1.2 && < 1.3
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
, these >= 0.6 && < 0.7 , these >= 0.6 && < 0.7
, wai >= 3.0 && < 3.1 , wai >= 3.2 && < 3.3
, wai-extra >= 3.0 && < 3.1 , wai-extra >= 3.0 && < 3.1
, wai-logger >= 2.2 && < 2.3 , wai-logger >= 2.2 && < 2.3
, warp >= 3.1 && < 3.2 , warp >= 3.2 && < 3.3
, xml-conduit >= 1.3 && < 1.4 , xml-conduit >= 1.3 && < 1.4
, yaml >= 0.8 && < 0.9 , yaml >= 0.8 && < 0.9
, yesod >= 1.4 && < 1.5 , yesod >= 1.4 && < 1.5
@ -142,12 +142,12 @@ library
, yesod-form >= 1.4 && < 1.5 , yesod-form >= 1.4 && < 1.5
, yesod-newsfeed , yesod-newsfeed
, yesod-static >= 1.5 && < 1.6 , yesod-static >= 1.5 && < 1.6
, zlib >= 0.5 && < 0.6 , zlib >= 0.6 && < 0.7
, unordered-containers >= 0.2 && < 0.3 , unordered-containers >= 0.2 && < 0.3
, hashable >= 1.2 && < 1.3 , hashable >= 1.2 && < 1.3
, Cabal >= 1.22 && < 1.23 , Cabal >= 1.22 && < 1.23
, lifted-base >= 0.2 && < 0.3 , lifted-base >= 0.2 && < 0.3
, mono-traversable >= 0.9 && < 0.10 , mono-traversable >= 0.10 && < 0.11
, time >= 1.5 && < 1.6 , time >= 1.5 && < 1.6
, process >= 1.2 && < 1.3 , process >= 1.2 && < 1.3
, old-locale >= 1.0 && < 1.1 , old-locale >= 1.0 && < 1.1
@ -158,14 +158,14 @@ library
, formatting >= 6.2 && < 6.3 , formatting >= 6.2 && < 6.3
, blaze-html >= 0.8 && < 0.9 , blaze-html >= 0.8 && < 0.9
, haddock-library >= 1.2.0 && < 1.3 , haddock-library >= 1.2.0 && < 1.3
, async >= 2.0 && < 2.1 , async >= 2.1 && < 2.2
, yesod-gitrepo >= 0.2 && < 0.3 , yesod-gitrepo >= 0.2 && < 0.3
, hoogle >= 4.2 && < 4.3 , hoogle >= 4.2 && < 4.3
, spoon >= 0.3 && < 0.4 , spoon >= 0.3 && < 0.4
, deepseq >= 1.4 && < 1.5 , deepseq >= 1.4 && < 1.5
, deepseq-generics >= 0.1 && < 0.2 , deepseq-generics >= 0.1 && < 0.2
, auto-update >= 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 , stackage-build-plan >= 0.1.1 && < 0.2
, yesod-sitemap >= 1.4 && < 1.5 , yesod-sitemap >= 1.4 && < 1.5
, streaming-commons >= 0.1 && < 0.2 , streaming-commons >= 0.1 && < 0.2
@ -175,11 +175,11 @@ library
, stackage-metadata >= 0.3 && < 0.4 , stackage-metadata >= 0.3 && < 0.4
, filepath >= 1.4 && < 1.5 , filepath >= 1.4 && < 1.5
, http-client >= 0.4 && < 0.5 , http-client >= 0.4 && < 0.5
, http-types >= 0.8 && < 0.9 , http-types >= 0.9 && < 0.10
, amazonka >= 0.3 && < 0.4 , amazonka >= 1.3 && < 1.4
, amazonka-core >= 0.3 && < 0.4 , amazonka-core >= 1.3 && < 1.4
, amazonka-s3 >= 0.3 && < 0.4 , amazonka-s3 >= 1.3 && < 1.4
, lens >= 4.12 && < 4.13 , lens >= 4.13 && < 4.14
executable stackage-server executable stackage-server
if flag(library-only) if flag(library-only)
@ -211,14 +211,14 @@ test-suite test
build-depends: base >= 4.8 && < 4.9 build-depends: base >= 4.8 && < 4.9
, stackage-server , stackage-server
, yesod-test >= 1.4 && < 1.5 , yesod-test >= 1.5 && < 1.6
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.4 && < 1.5
, yesod >= 1.4 && < 1.5 , yesod >= 1.4 && < 1.5
, persistent >= 2.2 && < 2.3 , persistent >= 2.2 && < 2.3
, resourcet >= 1.1.6 && < 1.2 , resourcet >= 1.1.6 && < 1.2
, monad-logger >= 0.3.13 && < 0.4 , monad-logger >= 0.3.13 && < 0.4
, transformers >= 0.4 && < 0.5 , transformers >= 0.4 && < 0.5
, hspec >= 2.1 && < 2.2 , hspec >= 2.2 && < 2.3
, classy-prelude-yesod >= 0.12 && < 0.13 , classy-prelude-yesod >= 0.12 && < 0.13
, mtl >= 2.2 && < 2.3 , mtl >= 2.2 && < 2.3
, mwc-random >= 0.13 && < 0.14 , mwc-random >= 0.13 && < 0.14