module Development.Iridium.Hackage ( retrieveLatestVersion , uploadPackage , uploadDocs ) where import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Control.Monad ( mzero, when ) import Data.Maybe ( listToMaybe, maybeToList ) import Control.Monad.Trans.MultiRWS import Control.Monad import Control.Exception import Data.Version import Distribution.Package ( PackageName(..) ) import qualified Turtle as Turtle import System.Exit import qualified Network.HTTP as HTTP import qualified Network.URI as URI import qualified Data.Text as Text import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HM import qualified Text.ParserCombinators.ReadP as ReadP import Data.List (find) import System.Process hiding ( cwd ) import Development.Iridium.UI.Console import Development.Iridium.Types import Development.Iridium.Config import Development.Iridium.Utils import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as ByteStringL retrieveLatestVersion :: ( MonadIO m , MonadMultiState LogState m , MonadPlus m ) => String -> String -> m (Maybe Version) retrieveLatestVersion remoteUrl pkgName = do let urlStr :: String = remoteUrl ++ "/package/" ++ pkgName ++ "/preferred" pushLog LogLevelInfo $ "Looking up latest version from hackage via url " ++ urlStr uri <- case URI.parseURI urlStr of Nothing -> do pushLog LogLevelError "bad URI" mzero Just u -> return u let request = HTTP.insertHeader HTTP.HdrAccept "application/json" $ HTTP.mkRequest HTTP.GET uri rawHtmlE <- liftIO $ HTTP.simpleHTTP request let parseError = do pushLog LogLevelError "Could not decode hackage response." mzero case rawHtmlE of Left{} -> return Nothing Right r -> case Aeson.decode $ HTTP.rspBody r of Just m -> case HM.lookup (Text.pack "normal-version") m of Nothing -> parseError Just [] -> pure Nothing Just (vs :: [String]) -> do let v :: Version = maximum $ parseVersionF <$> vs pure $ Just v Nothing -> parseError where parseVersionF s = case find (null . snd) $ ReadP.readP_to_S parseVersion s of Nothing -> error "parseVersionF" Just (v, _) -> v uploadPackage :: forall m . ( MonadIO m , MonadPlus m , MonadMultiReader Config m , MonadMultiReader Infos m , MonadMultiState LogState m ) => m () uploadPackage = do buildtool <- configReadStringM ["setup", "buildtool"] pushLog LogLevelPrint "Performing upload.." case buildtool of "cabal" -> do (PackageName pname) <- askPackageName pvers <- askPackageVersion username <- configReadStringMaybeM ["setup", "hackage", "username"] password <- configReadStringMaybeM ["setup", "hackage", "password"] let filePath = "dist/" ++ pname ++ "-" ++ showVersion pvers ++ ".tar.gz" mzeroIfNonzero $ liftIO $ runProcess "cabal" ["sdist"] Nothing Nothing Nothing Nothing Nothing >>= waitForProcess mzeroIfNonzero $ liftIO $ runProcess "cabal" ( [ "upload" , "--publish" , filePath ] ++ ["-u" ++ u | u <- maybeToList username] ++ ["-p" ++ p | p <- maybeToList password] ) Nothing Nothing Nothing Nothing Nothing >>= waitForProcess pushLog LogLevelPrint "Upload successful." "cabal-new" -> do (PackageName pname) <- askPackageName pvers <- askPackageVersion username <- configReadStringMaybeM ["setup", "hackage", "username"] password <- configReadStringMaybeM ["setup", "hackage", "password"] let filePath = "dist/" ++ pname ++ "-" ++ showVersion pvers ++ ".tar.gz" mzeroIfNonzero $ liftIO $ runProcess "cabal" ["sdist"] Nothing Nothing Nothing Nothing Nothing >>= waitForProcess mzeroIfNonzero $ liftIO $ runProcess "cabal" ( [ "upload" , "--publish" , filePath ] ++ ["-u" ++ u | u <- maybeToList username] ++ ["-p" ++ p | p <- maybeToList password] ) Nothing Nothing Nothing Nothing Nothing >>= waitForProcess pushLog LogLevelPrint "Upload successful." "stack" -> do pushLog LogLevelError "TODO: stack upload" mzero _ -> mzero uploadDocs :: forall m . ( MonadIO m , MonadPlus m , MonadMultiReader Config m , MonadMultiState LogState m ) => m () uploadDocs = do buildtool <- configReadStringM ["setup", "buildtool"] pushLog LogLevelPrint "Performing doc upload.." case buildtool of "cabal" -> do username <- configReadStringMaybeM ["setup", "hackage", "username"] password <- configReadStringMaybeM ["setup", "hackage", "password"] infoVerbEnabled <- isEnabledLogLevel LogLevelInfoVerbose mzeroIfNonzero $ liftIO $ runProcess "cabal" ( [ "upload" , "--doc" , "--publish" ] ++ ["-u" ++ u | u <- maybeToList username] ++ ["-p" ++ p | p <- maybeToList password] ++ ["-v0" | not infoVerbEnabled] ) Nothing Nothing Nothing Nothing Nothing >>= waitForProcess pushLog LogLevelPrint "Documentation upload successful." "stack" -> do pushLog LogLevelError "TODO: stack upload" mzero _ -> error "uploadDocs not supported in cabal-new"