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

Support for "installed" core packages #68

Browse Source
This commit is contained in:
Michael Snoyman 2014-12-22 23:04:13 +02:00
parent b06424463e
commit 9d745c9c42
3 changed files with 27 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
Handler/StackageHome.hs
View File

@ -88,10 +88,10 @@ getStackageMetadataR slug = do
, Asc PackageVersion , Asc PackageVersion
] $= mapC (Chunk . toBuilder . showPackage) ] $= mapC (Chunk . toBuilder . showPackage)
showPackage (Entity _ (Package _ name version _ _)) = concat showPackage (Entity _ p) = concat
[ toPathPiece name [ toPathPiece $ packageName' p
, "-" , "-"
, toPathPiece version , toPathPiece $ packageVersion p
, "\n" , "\n"
] ]
@ -128,17 +128,20 @@ getStackageCabalConfigR slug = do
toBuilder '\n' toBuilder '\n'
goFirst = do goFirst = do
mx <- await mx <- await
forM_ mx $ \(Entity _ (Package _ name version _ _)) -> yield $ Chunk $ forM_ mx $ \(Entity _ p) -> yield $ Chunk $
toBuilder (asText "constraints: ") ++ toBuilder (asText "constraints: ") ++
toBuilder (toPathPiece name) ++ toBuilder (toPathPiece $ packageName' p) ++
toBuilder (asText " ==") ++ constraint p
toBuilder (toPathPiece version)
showPackage (Entity _ (Package _ name version _ _)) = constraint p
| packageCore p = toBuilder $ asText " installed"
| otherwise = toBuilder (asText " ==") ++
toBuilder (toPathPiece $ packageVersion p)
showPackage (Entity _ p) =
toBuilder (asText ",\n ") ++ toBuilder (asText ",\n ") ++
toBuilder (toPathPiece name) ++ toBuilder (toPathPiece $ packageName' p) ++
toBuilder (asText " ==") ++ constraint p
toBuilder (toPathPiece version)
yearMonthDay :: FormatTime t => t -> String yearMonthDay :: FormatTime t => t -> String
yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d" yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d"

14
Handler/UploadStackage.hs
View File

@ -13,7 +13,7 @@ import qualified Data.Text as T
import Filesystem.Path (splitExtension) import Filesystem.Path (splitExtension)
import Data.BlobStore import Data.BlobStore
import Filesystem (createTree) import Filesystem (createTree)
import Control.Monad.State.Strict (execStateT, get, put) import Control.Monad.State.Strict (execStateT, get, put, modify)
import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.GZip as GZip
import Control.Monad.Trans.Resource (allocate) import Control.Monad.Trans.Resource (allocate)
import System.Directory (removeFile, getTemporaryDirectory) import System.Directory (removeFile, getTemporaryDirectory)
@ -127,12 +127,13 @@ putUploadStackageR = do
-- Evil lazy I/O thanks to tar package -- Evil lazy I/O thanks to tar package
lbs <- readFile $ fpFromString fp lbs <- readFile $ fpFromString fp
withSystemTempDirectory "build00index." $ \dir -> do withSystemTempDirectory "build00index." $ \dir -> do
LoopState _ stackage files _ contents <- execStateT (loop isAdmin update (Tar.read lbs)) LoopState LoopState _ stackage files _ contents cores <- execStateT (loop isAdmin update (Tar.read lbs)) LoopState
{ lsRoot = fpFromString dir { lsRoot = fpFromString dir
, lsStackage = initial , lsStackage = initial
, lsFiles = mempty , lsFiles = mempty
, lsIdent = ident , lsIdent = ident
, lsContents = [] , lsContents = []
, lsCores = mempty
} }
withSystemTempFile "newindex" $ \fp' h -> do withSystemTempFile "newindex" $ \fp' h -> do
ec <- liftIO $ do ec <- liftIO $ do
@ -155,6 +156,7 @@ putUploadStackageR = do
, packageVersion = version , packageVersion = version
, packageOverwrite = overwrite , packageOverwrite = overwrite
, packageHasHaddocks = False , packageHasHaddocks = False
, packageCore = name `member` cores
} }
setAlias setAlias
@ -215,6 +217,13 @@ putUploadStackageR = do
Just src -> addFile False name version src Just src -> addFile False name version src
Nothing -> return () Nothing -> return ()
"core" -> forM_ (lines $ decodeUtf8 $ toStrict lbs) $ \name ->
modify $ \ls -> ls
{ lsCores = insertSet (PackageName name)
$ lsCores ls
}
fp | (base1, Just "gz") <- splitExtension fp fp | (base1, Just "gz") <- splitExtension fp
, (fpToText -> base, Just "tar") <- splitExtension base1 -> do , (fpToText -> base, Just "tar") <- splitExtension base1 -> do
ident <- lsIdent <$> get ident <- lsIdent <$> get
@ -266,6 +275,7 @@ data LoopState = LoopState
, lsIdent :: !PackageSetIdent , lsIdent :: !PackageSetIdent
, lsContents :: ![(PackageName, Version, IsOverride)] -- FIXME use SnocVector when ready , lsContents :: ![(PackageName, Version, IsOverride)] -- FIXME use SnocVector when ready
, lsCores :: !(Set PackageName) -- ^ core packages
} }
type IsOverride = Bool type IsOverride = Bool

1
config/models
View File

@ -44,6 +44,7 @@ Package
version Version version Version
hasHaddocks Bool default=true hasHaddocks Bool default=true
overwrite Bool overwrite Bool
core Bool default=false
Tag Tag
package PackageName package PackageName