Support for "installed" core packages #68

Handler/StackageHome.hs

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

Handler/UploadStackage.hs

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

config/models

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