-- | Upload to Stackage and Hackage
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE FlexibleContexts           #-}
module Stackage.Upload
    ( uploadHackageDistro
    , uploadBundleV2
    , UploadBundleV2 (..)
    , def
    , StackageServer
    , unStackageServer
    ) where

import Control.Monad.Writer.Strict           (execWriter, tell)
import Data.Default.Class                    (Default (..))
import Data.Function                         (fix)
import Filesystem                            (isDirectory, isFile)
import Network.HTTP.Client
import qualified Network.HTTP.Client.Conduit as HCC
import Network.HTTP.Client.MultipartFormData
import Stackage.BuildPlan                    (BuildPlan)
import Stackage.Prelude
import Stackage.ServerBundle                 (bpAllPackages, docsListing, writeIndexStyle)
import System.IO.Temp                        (withSystemTempFile)
import qualified System.IO as IO
import qualified Data.Yaml as Y

newtype StackageServer = StackageServer { unStackageServer :: Text }
    deriving (Show, Eq, Ord, Hashable, IsString)
instance Default StackageServer where
    def = "https://www.stackage.org"

uploadHackageDistro
    :: Text -- ^ distro name
    -> BuildPlan
    -> ByteString -- ^ Hackage username
    -> ByteString -- ^ Hackage password
    -> Manager
    -> IO (Response LByteString)
uploadHackageDistro name bp username password manager = do
    req1 <- parseUrl $ concat
        [ "https://hackage.haskell.org/distro/"
        , unpack name
        , "/packages.csv"
        ]
    let req2 = req1
                { requestHeaders = [("Content-Type", "text/csv")]
                , requestBody = RequestBodyLBS csv
                , checkStatus = \_ _ _ -> Nothing
                , method = "PUT"
                }
    httpLbs (applyBasicAuth username password req2) manager
  where
    csv = encodeUtf8
        $ builderToLazy
        $ mconcat
        $ intersperse "\n"
        $ map go
        $ mapToList
        $ bpAllPackages bp
    go (name, version) =
        "\"" ++
        (toBuilder $ display name) ++
        "\",\"" ++
        (toBuilder $ display version) ++
        "\",\"https://www.stackage.org/package/" ++
        (toBuilder $ display name) ++
        "\""

data UploadBundleV2 = UploadBundleV2
    { ub2Server :: StackageServer
    , ub2AuthToken :: Text
    , ub2Bundle :: FilePath
    }

uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text
uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do
    size <- IO.hFileSize h
    putStrLn $ "Bundle size: " ++ tshow size
    req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"
    let req2 = req1
            { method = "PUT"
            , requestHeaders =
                [ ("Authorization", encodeUtf8 ub2AuthToken)
                , ("Accept", "application/json")
                , ("Content-Type", "application/x-tar")
                ]
            , requestBody = HCC.requestBodySource (fromIntegral size)
                          $ sourceHandle h $= printProgress size
            }
        sink = decodeUtf8C =$ fix (\loop -> do
            mx <- peekC
            case mx of
                Nothing -> error $ "uploadBundleV2: premature end of stream"
                Just _ -> do
                    l <- lineC $ takeCE 4096 =$ foldC
                    let (cmd, msg') = break (== ':') l
                        msg = dropWhile (== ' ') $ dropWhile (== ':') msg'
                    case cmd of
                        "CONT" -> do
                            putStrLn msg
                            loop
                        "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg
                        "SUCCESS" -> return msg
                        _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd
            )
    withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink
  where
    printProgress total =
        loop 0 0
      where
        loop sent lastPercent =
            await >>= maybe (putStrLn "Upload complete") go
          where
            go bs = do
                yield bs
                let sent' = sent + fromIntegral (length bs)
                    percent = sent' * 100 `div` total
                when (percent /= lastPercent)
                    $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%"
                loop sent' percent