diff --git a/Application.hs b/Application.hs
index 81cec14..53cb233 100644
--- a/Application.hs
+++ b/Application.hs
@@ -10,7 +10,7 @@ import qualified Aws
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (catch)
import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr)
-import Data.BlobStore (fileStore, storeWrite, cachedS3Store)
+import Data.BlobStore (fileStore, cachedS3Store)
import Data.Hackage
import Data.Hackage.DeprecationInfo
import Data.Unpacking (newDocUnpacker, createHoogleDatabases)
@@ -29,7 +29,7 @@ import Network.Wai.Middleware.RequestLogger
)
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import Settings
-import System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, flushLogStr, fromLogStr)
+import System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, fromLogStr)
import qualified System.Random.MWC as MWC
import Yesod.Core.Types (loggerSet, Logger (Logger))
import Yesod.Default.Config
@@ -67,6 +67,7 @@ import Handler.CompressorStatus
import Handler.Tag
import Handler.BannedTags
import Handler.RefreshDeprecated
+import Handler.UploadV2
import Handler.Hoogle
import Handler.BuildVersion
import Handler.PackageCounts
@@ -311,7 +312,6 @@ appLoadCabalFiles updateDB forceUpdate env dbconf p = do
insertMany_ (suggestions info)
$logInfo "Finished updating deprecation tags"
- uploadHistory0 <- runDB' $ selectSource [] [] $$ sinkUploadHistory
let toMDPair (E.Value name, E.Value version, E.Value hash') =
(name, (version, hash'))
metadata0 <- fmap (mapFromList . map toMDPair)
@@ -320,9 +320,7 @@ appLoadCabalFiles updateDB forceUpdate env dbconf p = do
, m E.^. MetadataVersion
, m E.^. MetadataHash
)
- UploadState uploadHistory newUploads _ newMD <- loadCabalFiles updateDB forceUpdate uploadHistory0 metadata0
- $logInfo "Inserting to new uploads"
- runDB' $ insertMany_ newUploads
+ UploadState _ newMD <- loadCabalFiles updateDB forceUpdate metadata0
$logInfo $ "Updating metadatas: " ++ tshow (length newMD)
runDB' $ do
let newMD' = toList newMD
diff --git a/Data/Hackage.hs b/Data/Hackage.hs
index 4c5a466..358a732 100644
--- a/Data/Hackage.hs
+++ b/Data/Hackage.hs
@@ -1,10 +1,7 @@
module Data.Hackage
( loadCabalFiles
, sourceHackageSdist
- , sinkUploadHistory
, UploadState (..)
- , UploadHistory
- , sourceHistory
) where
import ClassyPrelude.Yesod hiding (get)
@@ -17,7 +14,7 @@ import qualified Data.Text as T
import Data.Conduit.Zlib (ungzip)
import System.IO.Temp (withSystemTempFile)
import System.IO (IOMode (ReadMode), openBinaryFile)
-import Model (Uploaded (Uploaded), Metadata (..))
+import Model (Metadata (..))
import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk))
import qualified Distribution.PackageDescription as PD
import qualified Distribution.Package as PD
@@ -38,15 +35,6 @@ import qualified Documentation.Haddock.Parser as Haddock
import Documentation.Haddock.Types (DocH (..), Hyperlink (..), Picture (..), Header (..), Example (..))
import qualified Data.HashMap.Lazy as HM
-sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory
-sinkUploadHistory =
- foldlC go mempty
- where
- go history (Entity _ (Uploaded name version time)) =
- case lookup name history of
- Nothing -> insertMap name (singletonMap version time) history
- Just vhistory -> insertMap name (insertMap version time vhistory) history
-
loadCabalFiles :: ( MonadActive m
, MonadBaseControl IO m
, MonadThrow m
@@ -60,10 +48,9 @@ loadCabalFiles :: ( MonadActive m
)
=> Bool -- ^ do the database updating
-> Bool -- ^ force updates regardless of hash value?
- -> UploadHistory -- ^ initial
-> HashMap PackageName (Version, ByteString)
-> m (UploadState Metadata)
-loadCabalFiles dbUpdates forceUpdate uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata1 mempty) $ do
+loadCabalFiles dbUpdates forceUpdate metadata0 = (>>= T.mapM liftIO) $ flip execStateT (UploadState metadata1 mempty) $ do
HackageRoot root <- liftM getHackageRoot ask
$logDebug $ "Entering loadCabalFiles, root == " ++ root
req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
@@ -110,8 +97,6 @@ loadCabalFiles dbUpdates forceUpdate uploadHistory0 metadata0 = (>>= runUploadSt
when toStore $ withAcquire (storeWrite' store key) $ \sink ->
sourceLazy lbs $$ sink
when dbUpdates $ do
- setUploadDate name version
-
case readVersion version of
Nothing -> return ()
Just dataVersion -> setMetadata
@@ -129,9 +114,6 @@ readVersion v =
(dv, _):_ -> Just $ pack $ Data.Version.versionBranch dv
[] -> Nothing
-runUploadState :: MonadIO m => UploadState (IO a) -> m (UploadState a)
-runUploadState (UploadState w x y z) = liftIO $ UploadState w x y <$> T.sequence z
-
tarSource :: (Exception e, MonadThrow m)
=> Tar.Entries e
-> Producer m Tar.Entry
@@ -139,55 +121,17 @@ tarSource Tar.Done = return ()
tarSource (Tar.Fail e) = throwM e
tarSource (Tar.Next e es) = yield e >> tarSource es
-type UploadHistory = HashMap PackageName (HashMap Version UTCTime)
data UploadState md = UploadState
- { usHistory :: !UploadHistory
- , usChanges :: ![Uploaded]
- , usMetadata :: !(HashMap PackageName MetaSig)
+ { usMetadata :: !(HashMap PackageName MetaSig)
, usMetaChanges :: (HashMap PackageName md)
}
+ deriving (Functor, Foldable, Traversable)
data MetaSig = MetaSig
{-# UNPACK #-} !Version
{-# UNPACK #-} !(UVector Int) -- versionBranch
{-# UNPACK #-} !ByteString -- hash
-setUploadDate :: ( MonadBaseControl IO m
- , MonadThrow m
- , MonadIO m
- , MonadReader env m
- , MonadState (UploadState (IO Metadata)) m
- , HasHttpManager env
- , MonadLogger m
- )
- => PackageName
- -> Version
- -> m ()
-setUploadDate name version = do
- UploadState history changes us3 us4 <- get
- case lookup name history >>= lookup version of
- Just _ -> return ()
- Nothing -> do
- req <- parseUrl url
- $logDebug $ "Requesting: " ++ tshow req
- lbs <- withResponse req $ \res -> responseBody res $$ sinkLazy
- let uploadDateT = decodeUtf8 $ toStrict lbs
- case parseTime defaultTimeLocale "%c" $ unpack uploadDateT of
- Nothing -> return ()
- Just time -> do
- let vhistory = insertMap version time $ fromMaybe mempty $ lookup name history
- history' = insertMap name vhistory history
- changes' = Uploaded name version time : changes
- put $ UploadState history' changes' us3 us4
- where
- url = unpack $ concat
- [ "http://hackage.haskell.org/package/"
- , toPathPiece name
- , "-"
- , toPathPiece version
- , "/upload-time"
- ]
-
setMetadata :: ( MonadBaseControl IO m
, MonadThrow m
, MonadIO m
@@ -207,7 +151,7 @@ setMetadata :: ( MonadBaseControl IO m
-> ParseResult PD.GenericPackageDescription
-> m ()
setMetadata forceUpdate name version dataVersion hash' gpdRes = do
- UploadState us1 us2 mdMap mdChanges <- get
+ UploadState mdMap mdChanges <- get
let toUpdate =
case lookup name mdMap of
Just (MetaSig _currVersion currDataVersion currHash) ->
@@ -220,7 +164,7 @@ setMetadata forceUpdate name version dataVersion hash' gpdRes = do
then case gpdRes of
ParseOk _ gpd -> do
!md <- getMetadata name version hash' gpd
- put $! UploadState us1 us2
+ put $! UploadState
(insertMap name (MetaSig version dataVersion hash') mdMap)
(HM.insert name md mdChanges)
_ -> return ()
@@ -427,15 +371,6 @@ sourceHackageSdist name version = do
then storeRead key
else return Nothing
-sourceHistory :: Monad m => UploadHistory -> Producer m Uploaded
-sourceHistory =
- mapM_ go . mapToList
- where
- go (name, vhistory) =
- mapM_ go' $ mapToList vhistory
- where
- go' (version, time) = yield $ Uploaded name version time
-
-- FIXME put in conduit-combinators
parMapMC :: (MonadIO m, MonadBaseControl IO m)
=> Int
diff --git a/Data/Slug.hs b/Data/Slug.hs
index d517cfa..12c301a 100644
--- a/Data/Slug.hs
+++ b/Data/Slug.hs
@@ -17,11 +17,14 @@ import qualified System.Random.MWC as MWC
import GHC.Prim (RealWorld)
import Text.Blaze (ToMarkup)
-newtype Slug = Slug { unSlug :: Text }
+newtype Slug = Slug Text
deriving (Show, Read, Eq, Typeable, PersistField, ToMarkup, Ord, Hashable)
instance PersistFieldSql Slug where
sqlType = sqlType . liftM unSlug
+unSlug :: Slug -> Text
+unSlug (Slug t) = t
+
mkSlug :: MonadThrow m => Text -> m Slug
mkSlug t
| length t < minLen = throwM $ InvalidSlugException t "Too short"
diff --git a/Foundation.hs b/Foundation.hs
index 5aae958..5787c41 100644
--- a/Foundation.hs
+++ b/Foundation.hs
@@ -23,6 +23,8 @@ import Yesod.Core.Types (Logger, GWData)
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.GitRepo
+import Stackage.ServerBundle (SnapshotType, DocMap)
+import Stackage.BuildPlan (BuildPlan)
-- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
@@ -158,6 +160,7 @@ instance Yesod App where
maximumContentLength _ (Just UploadStackageR) = Just 50000000
maximumContentLength _ (Just UploadHaddockR{}) = Just 100000000
+ maximumContentLength _ (Just UploadV2R) = Just 100000000
maximumContentLength _ _ = Just 2000000
instance ToMarkup (Route App) where
diff --git a/Handler/Alias.hs b/Handler/Alias.hs
index c3657ec..c47baf2 100644
--- a/Handler/Alias.hs
+++ b/Handler/Alias.hs
@@ -7,7 +7,7 @@ module Handler.Alias
import Import
import Data.Slug (Slug)
import Handler.StackageHome (getStackageHomeR, getStackageMetadataR, getStackageCabalConfigR, getSnapshotPackagesR, getDocsR)
-import Handler.StackageIndex (getStackageIndexR, getStackageBundleR)
+import Handler.StackageIndex (getStackageIndexR)
import Handler.StackageSdist (getStackageSdistR)
import Handler.Hoogle (getHoogleR)
@@ -74,7 +74,6 @@ goSid sid pieces = do
StackageMetadataR -> getStackageMetadataR slug >>= sendResponse
StackageCabalConfigR -> getStackageCabalConfigR slug >>= sendResponse
StackageIndexR -> getStackageIndexR slug >>= sendResponse
- StackageBundleR -> getStackageBundleR slug >>= sendResponse
StackageSdistR pnv -> getStackageSdistR slug pnv >>= sendResponse
SnapshotPackagesR -> getSnapshotPackagesR slug >>= sendResponse
DocsR -> getDocsR slug >>= sendResponse
diff --git a/Handler/PackageList.hs b/Handler/PackageList.hs
index aab68ce..655f421 100644
--- a/Handler/PackageList.hs
+++ b/Handler/PackageList.hs
@@ -17,10 +17,9 @@ getPackageListR = defaultLayout $ do
)
addDocs (x, y) = (x, Nothing, y, Nothing)
packages <- fmap (map addDocs . uniqueByKey . map clean) $ handlerToWidget $ runDB $
- E.selectDistinct $ E.from $ \(u,m) -> do
- E.where_ (m E.^. MetadataName E.==. u E.^. UploadedName)
- E.orderBy [E.asc $ u E.^. UploadedName]
- return $ (u E.^. UploadedName
+ E.selectDistinct $ E.from $ \m -> do
+ E.orderBy [E.asc $ m E.^. MetadataName]
+ return $ (m E.^. MetadataName
,m E.^. MetadataSynopsis)
$(widgetFile "package-list")
where strip x = fromMaybe x (stripSuffix "." x)
diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs
index 24fa0e1..4a872ca 100644
--- a/Handler/StackageHome.hs
+++ b/Handler/StackageHome.hs
@@ -1,6 +1,5 @@
module Handler.StackageHome where
-import Data.BlobStore (storeExists)
import Import
import Data.Time (FormatTime)
import Data.Slug (SnapSlug)
@@ -13,7 +12,6 @@ getStackageHomeR slug = do
Entity _ stackage <- getBy404 $ UniqueSnapshot slug
return stackage
- hasBundle <- storeExists $ SnapshotBundle $ stackageIdent stackage
let minclusive =
if "inclusive" `isSuffixOf` stackageTitle stackage
then Just True
@@ -31,18 +29,17 @@ getStackageHomeR slug = do
cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
let maxPackages = 5000
(packageListClipped, packages') <- handlerToWidget $ runDB $ do
- packages' <- E.select $ E.from $ \(u,m,p) -> do
+ packages' <- E.select $ E.from $ \(m,p) -> do
E.where_ $
- (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
(m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
(p E.^. PackageStackage E.==. E.val sid)
- E.orderBy [E.asc $ u E.^. UploadedName]
- E.groupBy ( u E.^. UploadedName
+ E.orderBy [E.asc $ m E.^. MetadataName]
+ E.groupBy ( m E.^. MetadataName
, m E.^. MetadataSynopsis
)
E.limit maxPackages
return
- ( u E.^. UploadedName
+ ( m E.^. MetadataName
, m E.^. MetadataSynopsis
, E.max_ (p E.^. PackageVersion)
, E.max_ $ E.case_
@@ -188,17 +185,16 @@ getSnapshotPackagesR slug = do
defaultLayout $ do
setTitle $ toHtml $ "Package list for " ++ toPathPiece slug
cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
- packages' <- handlerToWidget $ runDB $ E.select $ E.from $ \(u,m,p) -> do
+ packages' <- handlerToWidget $ runDB $ E.select $ E.from $ \(m,p) -> do
E.where_ $
- (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
(m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
(p E.^. PackageStackage E.==. E.val sid)
- E.orderBy [E.asc $ u E.^. UploadedName]
- E.groupBy ( u E.^. UploadedName
+ E.orderBy [E.asc $ m E.^. MetadataName]
+ E.groupBy ( m E.^. MetadataName
, m E.^. MetadataSynopsis
)
return
- ( u E.^. UploadedName
+ ( m E.^. MetadataName
, m E.^. MetadataSynopsis
, E.max_ $ E.case_
[ ( p E.^. PackageHasHaddocks
diff --git a/Handler/StackageIndex.hs b/Handler/StackageIndex.hs
index 83a4585..cc2f065 100644
--- a/Handler/StackageIndex.hs
+++ b/Handler/StackageIndex.hs
@@ -16,19 +16,3 @@ getStackageIndexR slug = do
addHeader "content-disposition" "attachment; filename=\"00-index.tar.gz\""
neverExpires
respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
-
-getStackageBundleR :: SnapSlug -> Handler TypedContent
-getStackageBundleR slug = do
- Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
- let ident = stackageIdent stackage
- slug' = stackageSlug stackage
- msrc <- storeRead $ SnapshotBundle ident
- case msrc of
- Nothing -> notFound
- Just src -> do
- addHeader "content-disposition" $ mconcat
- [ "attachment; filename=\"bundle-"
- , toPathPiece slug'
- , ".tar.gz\""
- ]
- respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
diff --git a/Handler/UploadV2.hs b/Handler/UploadV2.hs
index 82076cc..b7caa5e 100644
--- a/Handler/UploadV2.hs
+++ b/Handler/UploadV2.hs
@@ -23,6 +23,7 @@ import Stackage.Prelude (display)
import Filesystem (createTree)
import Filesystem.Path (parent)
import Data.Conduit.Process
+import Data.Yaml (decodeEither')
putUploadV2R :: Handler TypedContent
putUploadV2R = do
@@ -94,10 +95,26 @@ doUpload status uid ident bundleFP = do
threadDelay 1000000 -- FIXME remove
say $ "Unpacking bundle"
- master <- getYesod
- liftIO $ haddockUnpacker master True ident
- SnapshotInfo {..} <- getSnapshotInfoByIdent ident
+ (siType, siPlan, siDocMap :: DocMap) <-
+ withSystemTempDirectory "uploadv2" $ \dir' -> do
+ let dir = fpFromString dir'
+ withCheckedProcess
+ (proc "tar" ["xf", fpToString bundleFP])
+ { cwd = Just dir'
+ } $ \ClosedStream ClosedStream ClosedStream -> return ()
+
+ let maxFileSize = 1024 * 1024 * 5
+ yaml :: FromJSON a => FilePath -> Handler a
+ yaml fp = do
+ say $ "Parsing " ++ fpToText fp
+ bs <- sourceFile (dir fp) $$ takeCE maxFileSize =$ foldC
+ either throwM return $ decodeEither' bs
+
+ (,,)
+ <$> yaml "build-type.yaml"
+ <*> yaml "build-plan.yaml"
+ <*> yaml "docs-map.yaml"
now <- liftIO getCurrentTime
let day = tshow $ utctDay now
@@ -127,9 +144,12 @@ doUpload status uid ident bundleFP = do
, tshow minor
, ", GHC "
, ghcVersion
- ]
+ ]
- slug <- SnapSlug <$> mkSlug slug'
+ slug <- do
+ slug2 <- mkSlug slug'
+ when (slug' /= unSlug slug2) $ error $ "Slug not available: " ++ show slug'
+ return $ SnapSlug slug2
say "Creating index tarball"
withSystemTempDirectory "buildindex.v2" $ \(fpFromString -> dir) -> do
@@ -183,7 +203,6 @@ doUpload status uid ident bundleFP = do
, stackageTitle = title
, stackageDesc = ""
, stackageHasHaddocks = True
- , stackageYaml = True
}
case siType of
STNightly -> insert_ Nightly
@@ -196,6 +215,30 @@ doUpload status uid ident bundleFP = do
, ltsMinor = minor
, ltsStackage = sid
}
+
+ let cores :: Set PackageName
+ cores = setFromList
+ $ map (PackageName . display . fst)
+ $ mapToList
+ $ siCorePackages
+ $ bpSystemInfo siPlan
+ forM_ (mapToList $ fmap ppVersion $ bpPackages siPlan) $ \(name', version') -> do
+ let nameT = display name'
+ mpair = (,)
+ <$> fromPathPiece nameT
+ <*> fromPathPiece (display version')
+ (name, version) <-
+ case mpair of
+ Nothing -> error $ "Could not parse: " ++ show (name', version')
+ Just pair -> return pair
+ insert_ Package
+ { packageStackage = sid
+ , packageName' = name
+ , packageVersion = version
+ , packageHasHaddocks = nameT `member` siDocMap
+ , packageOverwrite = False
+ , packageCore = Just $ name `member` cores
+ }
return sid
say $ concat
@@ -207,6 +250,19 @@ doUpload status uid ident bundleFP = do
]
render <- getUrlRender
+
+ say "Updating docmap"
+ runDB $ forM_ (mapToList siDocMap) $ \(package, PackageDocs version ms) -> do
+ did <- insert Docs
+ { docsName = PackageName package
+ , docsVersion = Version version
+ , docsUploaded = now
+ , docsSnapshot = Just sid
+ }
+ forM_ (mapToList ms) $ \(name, pieces) -> do
+ let url = render $ HaddockR slug pieces
+ insert_ $ Module did name url
+
return $ render $ SnapshotR slug StackageHomeR
where
say = atomically . writeTVar status
diff --git a/cabal.config b/cabal.config
index 237246f..d889975 100644
--- a/cabal.config
+++ b/cabal.config
@@ -691,7 +691,6 @@ constraints: abstract-deque ==0.3,
Spock-worker ==0.2.1.3,
spoon ==0.3.1,
sqlite-simple ==0.4.8.0,
- stackage ==0.3.1,
stateref ==0.3,
statestack ==0.2.0.3,
statistics ==0.13.2.1,
diff --git a/config/models b/config/models
index 6e2f388..e4cc69b 100644
--- a/config/models
+++ b/config/models
@@ -26,12 +26,6 @@ Stackage
UniqueStackage ident
UniqueSnapshot slug
-Uploaded
- name PackageName
- version Version
- uploaded UTCTime
- UniqueUploaded name version
-
Alias
user UserId
name Slug
diff --git a/config/routes b/config/routes
index 6797b26..76f35b5 100644
--- a/config/routes
+++ b/config/routes
@@ -21,7 +21,6 @@
/metadata StackageMetadataR GET
/cabal.config StackageCabalConfigR GET
/00-index.tar.gz StackageIndexR GET
- /bundle StackageBundleR GET
/package/#PackageNameVersion StackageSdistR GET
/packages SnapshotPackagesR GET
/docs DocsR GET
@@ -52,5 +51,6 @@
/older-releases OlderReleasesR GET
/refresh-deprecated RefreshDeprecatedR GET
+/upload2 UploadV2R PUT
/build-version BuildVersionR GET
/package-counts PackageCountsR GET
diff --git a/stackage-server.cabal b/stackage-server.cabal
index 695fb20..7035fae 100644
--- a/stackage-server.cabal
+++ b/stackage-server.cabal
@@ -1,4 +1,3 @@
--- Stackage snapshot: http://www.stackage.org/stackage/aecbf72b568a63e86a971311fee5475f076043cc
name: stackage-server
version: 0.0.0
cabal-version: >= 1.8
@@ -50,6 +49,7 @@ library
Handler.Tag
Handler.BannedTags
Handler.RefreshDeprecated
+ Handler.UploadV2
Handler.BuildVersion
Handler.PackageCounts
@@ -83,7 +83,11 @@ library
RecordWildCards
ScopedTypeVariables
BangPatterns
+ TupleSections
DeriveGeneric
+ DeriveFunctor
+ DeriveFoldable
+ DeriveTraversable
build-depends:
base >= 4
@@ -151,6 +155,8 @@ library
, formatting
, blaze-html
, haddock-library
+ , async
+ , stackage >= 0.4
, yesod-gitrepo >= 0.1.1
, hoogle
, spoon
diff --git a/templates/stackage-home.hamlet b/templates/stackage-home.hamlet
index cdd04e1..15f3b25 100644
--- a/templates/stackage-home.hamlet
+++ b/templates/stackage-home.hamlet
@@ -74,11 +74,3 @@ $newline never
Docs
|
#{synopsis}
-
-
- |