mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
297 lines
10 KiB
Haskell
297 lines
10 KiB
Haskell
module Handler.UploadV2
|
|
( putUploadV2R
|
|
) where
|
|
|
|
import Import
|
|
import Data.BlobStore
|
|
import Control.Concurrent.Lifted (threadDelay)
|
|
import Data.Slug (unSlug, mkSlug, SnapSlug (..))
|
|
import Control.Monad.Trans.Resource (allocate)
|
|
import System.Directory (removeFile, getTemporaryDirectory)
|
|
import System.IO.Temp (openBinaryTempFile, withSystemTempDirectory, withSystemTempFile)
|
|
import Crypto.Hash.Conduit (sinkHash)
|
|
import Crypto.Hash (Digest, SHA1)
|
|
import Data.Byteable (toBytes)
|
|
import qualified Data.ByteString.Base16 as B16
|
|
import System.Timeout.Lifted (timeout)
|
|
import Control.Concurrent.Async (async, cancel, waitCatchSTM)
|
|
import Yesod.Core.Types (HandlerT (..))
|
|
import Stackage.Types
|
|
import Filesystem (createTree)
|
|
import Filesystem.Path (parent)
|
|
import Data.Conduit.Process
|
|
import Data.Yaml (decodeEither')
|
|
import Distribution.Version (versionBranch)
|
|
|
|
putUploadV2R :: Handler TypedContent
|
|
putUploadV2R = do
|
|
uid <- requireAuthIdOrToken
|
|
user <- runDB $ get404 uid
|
|
extra <- getExtra
|
|
when (unSlug (userHandle user) `notMember` adminUsers extra)
|
|
$ permissionDenied "Only admins can upload V2 bundles"
|
|
|
|
tempDir <- liftIO getTemporaryDirectory
|
|
(_releaseKey, (bundleFP, bundleHOut)) <- allocate
|
|
(openBinaryTempFile tempDir "upload.stackage2")
|
|
(\(fp, h) -> hClose h `finally` removeFile fp)
|
|
digest <- rawRequestBody $$ getZipSink
|
|
(ZipSink (sinkHandle bundleHOut) *>
|
|
ZipSink sinkHash)
|
|
liftIO $ hClose bundleHOut
|
|
|
|
let digestBS = toBytes (digest :: Digest SHA1)
|
|
ident = PackageSetIdent $ decodeUtf8 $ B16.encode digestBS
|
|
|
|
mstackage <- runDB $ getBy $ UniqueStackage ident
|
|
when (isJust mstackage) $ invalidArgs ["Bundle already uploaded"]
|
|
|
|
status <- liftIO $ newTVarIO ""
|
|
|
|
let cont text = do
|
|
sendChunkBS "CONT: "
|
|
sendChunkText text
|
|
sendChunkBS "\n"
|
|
sendFlush
|
|
|
|
-- Grab the internal HandlerT state to perform magic
|
|
hd <- HandlerT return
|
|
worker <- fmap snd $ flip allocate cancel $ async $ flip unHandlerT hd
|
|
$ doUpload status uid ident (fpFromString bundleFP)
|
|
|
|
respondSource "text/plain" $ do
|
|
let displayStatus prev = do
|
|
memsg <- liftIO $ timeout 20000000 $ atomically $ (do
|
|
msg <- readTVar status
|
|
checkSTM (msg /= prev)
|
|
return (Right msg)) <|> (Left <$> waitCatchSTM worker)
|
|
case memsg of
|
|
Nothing -> do
|
|
cont "Still working"
|
|
displayStatus prev
|
|
Just (Left (Left e)) -> do
|
|
sendChunkText "FAILURE: "
|
|
sendChunkText $ tshow e
|
|
sendChunkText "\n"
|
|
Just (Left (Right t)) -> do
|
|
sendChunkText "SUCCESS: "
|
|
sendChunkText t
|
|
sendChunkText "\n"
|
|
Just (Right t) -> do
|
|
cont t
|
|
displayStatus t
|
|
displayStatus ""
|
|
|
|
doUpload :: TVar Text
|
|
-> UserId
|
|
-> PackageSetIdent
|
|
-> FilePath -- ^ temporary bundle file
|
|
-> Handler Text
|
|
doUpload status uid ident bundleFP = do
|
|
say $ "Uploading to persistent storage with ident " ++ toPathPiece ident
|
|
sourceFile bundleFP $$ storeWrite (HaddockBundle ident)
|
|
threadDelay 1000000 -- FIXME remove
|
|
|
|
say $ "Unpacking bundle"
|
|
|
|
(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 theSiGhcVersion = siGhcVersion $ bpSystemInfo siPlan
|
|
ghcVersion = display theSiGhcVersion
|
|
ghcMajorVersionMay = case versionBranch theSiGhcVersion of
|
|
(a:b:_) -> Just (GhcMajorVersion a b)
|
|
_ -> Nothing
|
|
slug' <-
|
|
case siType of
|
|
STNightly -> invalidArgs ["No longer support STNightly, use STNightly2 (1)"]
|
|
STNightly2 day -> return $ "nightly-" ++ tshow day
|
|
STLTS major minor -> return $ concat
|
|
[ "lts-"
|
|
, tshow major
|
|
, "."
|
|
, tshow minor
|
|
]
|
|
title <-
|
|
case siType of
|
|
STNightly -> invalidArgs ["No longer support STNightly, use STNightly2 (2)"]
|
|
STNightly2 day -> return $ concat
|
|
[ "Stackage Nightly "
|
|
, tshow day
|
|
, ", GHC "
|
|
, ghcVersion
|
|
]
|
|
STLTS major minor -> return $ concat
|
|
[ "LTS Haskell "
|
|
, tshow major
|
|
, "."
|
|
, tshow minor
|
|
, ", GHC "
|
|
, ghcVersion
|
|
]
|
|
|
|
slug <- do
|
|
slug2 <- mkSlug slug'
|
|
when (slug' /= unSlug slug2) $ error $ "Slug not available: " ++ show slug'
|
|
return $ SnapSlug slug2
|
|
|
|
mexisting <- runDB $ getBy $ UniqueSnapshot slug
|
|
route <- case mexisting of
|
|
Just _ -> do
|
|
say "Snapshot already exists"
|
|
return $ SnapshotR slug StackageHomeR
|
|
Nothing -> finishUpload
|
|
title ident ghcVersion ghcMajorVersionMay slug now siType siPlan siDocMap
|
|
uid say
|
|
render <- getUrlRender
|
|
return $ render route
|
|
where
|
|
say = atomically . writeTVar status
|
|
|
|
finishUpload
|
|
:: Text
|
|
-> PackageSetIdent
|
|
-> Text
|
|
-> Maybe GhcMajorVersion
|
|
-> SnapSlug
|
|
-> UTCTime
|
|
-> SnapshotType
|
|
-> BuildPlan
|
|
-> Map Text PackageDocs
|
|
-> UserId
|
|
-> (Text -> Handler ())
|
|
-> Handler (Route App)
|
|
finishUpload
|
|
title ident ghcVersion ghcMajorVersionMay slug now siType siPlan siDocMap
|
|
uid say = do
|
|
say "Creating index tarball"
|
|
withSystemTempDirectory "buildindex.v2" $ \(fpFromString -> dir) -> do
|
|
files <- forM (mapToList $ fmap ppVersion $ bpPackages siPlan) $ \(name', version') -> do
|
|
let mpair = (,)
|
|
<$> fromPathPiece (display name')
|
|
<*> fromPathPiece (display version')
|
|
(name, version) <-
|
|
case mpair of
|
|
Nothing -> error $ "Could not parse: " ++ show (name', version')
|
|
Just pair -> return pair
|
|
|
|
msrc <- storeRead (HackageCabal name version)
|
|
src <-
|
|
case msrc of
|
|
Nothing -> error $ "Cabal file not found for: " ++ show (name, version)
|
|
Just src -> return src
|
|
|
|
let fp' = fpFromText (toPathPiece name)
|
|
</> fpFromText (toPathPiece version)
|
|
</> fpFromText (concat
|
|
[ toPathPiece name
|
|
, "-"
|
|
, toPathPiece version
|
|
, ".cabal"
|
|
])
|
|
let fp = dir </> fp'
|
|
|
|
liftIO $ createTree $ parent fp
|
|
src $$ sinkFile fp
|
|
return $ fpToString fp'
|
|
|
|
withSystemTempFile "newindex.v2" $ \fp' h -> do
|
|
liftIO $ do
|
|
hClose h
|
|
let args = "cfz"
|
|
: fp'
|
|
: files
|
|
cp = (proc "tar" args) { cwd = Just $ fpToString dir }
|
|
withCheckedProcess cp $ \ClosedStream Inherited Inherited ->
|
|
return ()
|
|
sourceFile (fpFromString fp') $$ storeWrite (CabalIndex ident)
|
|
|
|
say $ "Attempting: " ++ tshow (slug, title)
|
|
sid <- runDB $ do
|
|
sid <- insert Stackage
|
|
{ stackageUser = uid
|
|
, stackageIdent = ident
|
|
, stackageSlug = slug
|
|
, stackageUploaded = now
|
|
, stackageTitle = title
|
|
, stackageDesc = ""
|
|
, stackageHasHaddocks = True
|
|
, stackageGhcMajorVersion = ghcMajorVersionMay
|
|
}
|
|
case siType of
|
|
STNightly -> invalidArgs ["No longer support STNightly, use STNightly2 (3)"]
|
|
STNightly2 day -> insert_ Nightly
|
|
{ nightlyDay = day
|
|
, nightlyGhcVersion = ghcVersion
|
|
, nightlyStackage = sid
|
|
}
|
|
STLTS major minor -> insert_ Lts
|
|
{ ltsMajor = major
|
|
, ltsMinor = minor
|
|
, ltsStackage = sid
|
|
}
|
|
|
|
let cores, nonCores :: Map PackageName Version
|
|
cores = mapKeysWith const (PackageName . display)
|
|
$ fmap (Version . display)
|
|
$ siCorePackages
|
|
$ bpSystemInfo siPlan
|
|
nonCores
|
|
= mapKeysWith const (PackageName . display)
|
|
$ fmap (Version . display . ppVersion)
|
|
$ bpPackages siPlan
|
|
forM_ (mapToList $ cores ++ nonCores) $ \(name, version) -> do
|
|
let PackageName nameT = name
|
|
insert_ Package
|
|
{ packageStackage = sid
|
|
, packageName' = name
|
|
, packageVersion = version
|
|
, packageHasHaddocks = nameT `member` siDocMap
|
|
, packageOverwrite = False
|
|
, packageCore = Just $ name `member` cores
|
|
}
|
|
return sid
|
|
|
|
say $ concat
|
|
[ "New snapshot with ID "
|
|
, toPathPiece sid
|
|
, " and slug "
|
|
, toPathPiece slug
|
|
, " created"
|
|
]
|
|
|
|
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 $ SnapshotR slug StackageHomeR
|