diff --git a/Stackage2/ServerBundle.hs b/Stackage2/ServerBundle.hs
new file mode 100644
index 00000000..ea8bdac7
--- /dev/null
+++ b/Stackage2/ServerBundle.hs
@@ -0,0 +1,63 @@
+-- | Create a bundle to be uploaded to Stackage Server.
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Stackage2.ServerBundle
+ ( serverBundle
+ , epochTime
+ , bpAllPackages
+ ) where
+
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Entry as Tar
+import qualified Codec.Compression.GZip as GZip
+import qualified Data.Yaml as Y
+import Foreign.C.Types (CTime (CTime))
+import Stackage2.BuildConstraints
+import Stackage2.BuildPlan
+import Stackage2.Prelude
+import qualified System.PosixCompat.Time as PC
+
+-- | Get current time
+epochTime :: IO Tar.EpochTime
+epochTime = (\(CTime t) -> t) <$> PC.epochTime
+
+-- | All package/versions in a build plan, including core packages.
+--
+-- Note that this may include packages not available on Hackage.
+bpAllPackages :: BuildPlan -> Map PackageName Version
+bpAllPackages BuildPlan {..} =
+ siCorePackages bpSystemInfo ++ map ppVersion bpPackages
+
+serverBundle :: Tar.EpochTime
+ -> Text -- ^ title
+ -> Text -- ^ slug
+ -> BuildPlan
+ -> LByteString
+serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
+ [ fe "build-plan.yaml" (fromStrict $ Y.encode bp)
+ , fe "hackage" hackage
+ , fe "slug" (fromStrict $ encodeUtf8 slug)
+ , fe "desc" (fromStrict $ encodeUtf8 title)
+ ]
+ where
+ fe name contents =
+ case Tar.toTarPath False name of
+ Left s -> error s
+ Right name' -> (Tar.fileEntry name' contents)
+ { Tar.entryTime = time
+ }
+ hackage = builderToLazy $ foldMap goPair $ mapToList packageMap
+
+ -- need to remove some packages that don't exist on Hackage
+ packageMap = foldr deleteMap (bpAllPackages bp) $ map PackageName
+ [ "bin-package-db"
+ , "ghc"
+ , "rts"
+ ]
+
+ goPair (name, version) =
+ toBuilder (display name) ++
+ toBuilder (asText "-") ++
+ toBuilder (display version) ++
+ toBuilder (asText "\n")
diff --git a/Stackage2/Upload.hs b/Stackage2/Upload.hs
new file mode 100644
index 00000000..07686578
--- /dev/null
+++ b/Stackage2/Upload.hs
@@ -0,0 +1,229 @@
+-- | Upload to Stackage and Hackage
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+module Stackage2.Upload
+ ( UploadBundle (..)
+ , SnapshotIdent (..)
+ , uploadBundle
+ , UploadDocs (..)
+ , uploadDocs
+ , uploadHackageDistro
+ ) where
+
+import Control.Monad.Writer.Strict (execWriter, tell)
+import Data.Default.Class (Default (..))
+import Filesystem (isDirectory, isFile)
+import Network.HTTP.Client
+import Network.HTTP.Client.MultipartFormData
+import Stackage2.BuildPlan (BuildPlan)
+import Stackage2.Prelude
+import Stackage2.ServerBundle (bpAllPackages)
+import System.IO.Temp (withSystemTempFile)
+
+newtype StackageServer = StackageServer { unStackageServer :: Text }
+ deriving (Show, Eq, Ord, Hashable, IsString)
+instance Default StackageServer where
+ def = "http://www.stackage.org"
+
+data UploadBundle = UploadBundle
+ { ubServer :: StackageServer
+ , ubContents :: LByteString
+ , ubAlias :: Maybe Text
+ , ubNightly :: Maybe Text -- ^ should be GHC version
+ , ubLTS :: Maybe Text -- ^ e.g. 2.3
+ , ubAuthToken :: Text
+ }
+instance Default UploadBundle where
+ def = UploadBundle
+ { ubServer = def
+ , ubContents = mempty
+ , ubAlias = Nothing
+ , ubNightly = Nothing
+ , ubLTS = Nothing
+ , ubAuthToken = "no-auth-token-provided"
+ }
+
+newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text }
+ deriving (Show, Eq, Ord, Hashable, IsString)
+
+uploadBundle :: UploadBundle -> Manager -> IO SnapshotIdent
+uploadBundle UploadBundle {..} man = do
+ req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload"
+ req2 <- formDataBody formData req1
+ let req3 = req2
+ { method = "PUT"
+ , requestHeaders =
+ [ ("Authorization", encodeUtf8 ubAuthToken)
+ , ("Accept", "application/json")
+ ] ++ requestHeaders req2
+ , redirectCount = 0
+ , checkStatus = \_ _ _ -> Nothing
+ , responseTimeout = Just 300000000
+ }
+ res <- httpLbs req3 man
+ case lookup "x-stackage-ident" $ responseHeaders res of
+ Just snapid -> return $ SnapshotIdent $ decodeUtf8 snapid
+ Nothing -> error $ "An error occurred: " ++ show res
+ where
+ params = mapMaybe (\(x, y) -> (x, ) <$> y)
+ [ ("alias", ubAlias)
+ , ("nightly", ubNightly)
+ , ("lts", ubLTS)
+ ]
+ formData = ($ []) $ execWriter $ do
+ forM_ params $ \(key, value) ->
+ tell' $ partBS key $ encodeUtf8 value
+ tell' $ partFileRequestBody "stackage" "stackage"
+ $ RequestBodyLBS ubContents
+
+ tell' x = tell (x:)
+
+data UploadDocs = UploadDocs
+ { udServer :: StackageServer
+ , udDocs :: FilePath -- ^ may be a directory or a tarball
+ , udAuthToken :: Text
+ , udSnapshot :: SnapshotIdent
+ }
+
+uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do
+ fe <- isFile fp0
+ if fe
+ then uploadDocsFile $ fpToString fp0
+ else do
+ de <- isDirectory fp0
+ if de
+ then uploadDocsDir
+ else error $ "Path not found: " ++ fpToString fp0
+ where
+ uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do
+ hClose h
+ dirs <- fmap sort
+ $ runResourceT
+ $ sourceDirectory fp0
+ $$ filterMC (liftIO . isDirectory)
+ =$ mapC (fpToString . filename)
+ =$ sinkList
+ writeFile (fp0 "index.html") $ mkIndex
+ (unpack $ unSnapshotIdent ident)
+ dirs
+ writeFile (fp0 "style.css") styleCss
+ -- FIXME write index.html, style.css
+ let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)
+ { cwd = Just $ fpToString fp0
+ }
+ withCheckedProcess cp $ \Inherited Inherited Inherited -> return ()
+ uploadDocsFile fp
+ uploadDocsFile fp = do
+ req1 <- parseUrl $ unpack $ concat
+ [ host
+ , "/upload-haddock/"
+ , unSnapshotIdent ident
+ ]
+ let formData =
+ [ partFileSource "tarball" fp
+ ]
+ req2 <- formDataBody formData req1
+ let req3 = req2
+ { method = "PUT"
+ , requestHeaders =
+ [ ("Authorization", encodeUtf8 token)
+ , ("Accept", "application/json")
+ ] ++ requestHeaders req2
+ , redirectCount = 0
+ , checkStatus = \_ _ _ -> Nothing
+ , responseTimeout = Just 300000000
+ }
+ httpLbs req3 man
+
+uploadHackageDistro :: BuildPlan
+ -> ByteString -- ^ Hackage username
+ -> ByteString -- ^ Hackage password
+ -> Manager
+ -> IO (Response LByteString)
+uploadHackageDistro bp username password =
+ httpLbs (applyBasicAuth username password req)
+ where
+ csv = encodeUtf8
+ $ builderToLazy
+ $ mconcat
+ $ intersperse "\n"
+ $ map go
+ $ mapToList
+ $ bpAllPackages bp
+ go (name, version) =
+ "\"" ++
+ (toBuilder $ display name) ++
+ "\",\"" ++
+ (toBuilder $ display version) ++
+ "\",\"http://www.stackage.org/package/" ++
+ (toBuilder $ display name) ++
+ "\""
+
+ req = "http://hackage.haskell.org/distro/Stackage/packages.csv"
+ { requestHeaders = [("Content-Type", "text/csv")]
+ , requestBody = RequestBodyLBS csv
+ , checkStatus = \_ _ _ -> Nothing
+ , method = "PUT"
+ }
+
+mkIndex :: String -> [String] -> String
+mkIndex snapid dirs = concat
+ [ "\nHaddocks index"
+ , ""
+ , ""
+ , ""
+ , ""
+ , ""
+ , "
"
+ , "
Haddock documentation index
"
+ , "
Return to snapshot
"
+ , concatMap toLI dirs
+ , "