diff --git a/elm-get.cabal b/elm-get.cabal --- a/elm-get.cabal +++ b/elm-get.cabal @@ -1,5 +1,5 @@ Name: elm-get -Version: 0.1.1.2 +Version: 0.1.1.3 Synopsis: Tool for sharing and using Elm libraries Description: elm-get lets you install, update, and publish Elm libraries @@ -21,32 +21,59 @@ type: git location: git://github.com/elm-lang/elm-get.git -Executable elm-get - Main-is: Get/Main.hs +Library ghc-options: -threaded -O2 -W Hs-Source-Dirs: src + exposed-modules: Utils.Commands, + Utils.Http, + Utils.Paths + Build-depends: aeson, + base >=4.2 && <5, + binary, + bytestring, + containers, + directory, + Elm >= 0.12, + filepath, + HTTP, + http-client >= 0.3, + http-client-tls, + http-types, + json, + mtl, + network, + optparse-applicative, + pretty, + process, + resourcet, + text, + vector - other-modules: Get.Install, +Executable elm-get + ghc-options: -threaded -O2 -W + Hs-Source-Dirs: src + Main-is: Get/Main.hs + other-modules: Get.Dependencies, + Get.Install, Get.Library, Get.Options, Get.Publish, Get.Registry, - Paths_elm_get, Utils.Commands, Utils.Http, - Utils.Paths, - Utils.PrettyJson - + Utils.Paths Build-depends: aeson, + aeson-pretty, base >=4.2 && <5, binary, bytestring, containers, directory, - Elm >= 0.10.1, + Elm >= 0.12, filepath, HTTP, - http-client, + http-client >= 0.3, + http-client-tls, http-types, json, mtl, diff --git a/src/Get/Dependencies.hs b/src/Get/Dependencies.hs new file mode 100644 --- /dev/null +++ b/src/Get/Dependencies.hs @@ -0,0 +1,18 @@ +module Get.Dependencies where + +import Elm.Internal.Dependencies +import qualified Elm.Internal.Name as N +import qualified Elm.Internal.Version as V + +defaultDeps :: Deps +defaultDeps = Deps + { name = N.Name "USER" "PROJECT" + , version = V.V [0,1] "" + , summary = "concise, helpful summary of your project" + , description = "full description of this project, describe your use case" + , license = "BSD3" + , repo = "https://github.com/USER/PROJECT.git" + , exposed = [] + , elmVersion = V.elmVersion + , dependencies = [] + } diff --git a/src/Get/Install.hs b/src/Get/Install.hs --- a/src/Get/Install.hs +++ b/src/Get/Install.hs @@ -1,220 +1,208 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Get.Install (install) where +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Get.Install (install, installAll) where import Control.Applicative ((<$>)) import Control.Monad.Error -import Control.Monad.Reader -import Data.Function (on) -import qualified Data.List as List +import Control.Monad.Writer +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as Map import qualified Data.Maybe as Maybe import System.Directory -import System.Exit import System.FilePath -import System.IO -import Text.JSON +import qualified Elm.Internal.Dependencies as D import qualified Elm.Internal.Name as N import qualified Elm.Internal.Paths as EPath import qualified Elm.Internal.Version as V +import Get.Dependencies (defaultDeps) import Get.Library (Library) import qualified Get.Library as Lib import qualified Get.Registry as R import qualified Utils.Commands as Cmd import qualified Utils.Paths as Path -import qualified Utils.PrettyJson as Pretty -type InstallM l = ReaderT l (ErrorT String IO) +-- | Builds up the final transformation on the dependency file using +-- WriterT +type InstallM = + (WriterT Update -- ^ The updates that need to be run on the deps + (ErrorT String IO)) -install :: Maybe Library -> ErrorT String IO () -install maybeLib = case maybeLib of - Just l -> runReaderT install1 l - Nothing -> do - massoc <- readDepsFile - case massoc of - Nothing -> throwError msg - Just asc -> do - case List.lookup "dependencies" asc of - Just (JSObject entries) -> do - mapM_ (runReaderT install1 <=< mkLib) . fromJSObject $ entries - Just _ -> throwError $ "dependencies field should be an object in" ++ EPath.dependencyFile - _ -> throwError $ "no dependencies field found in " ++ EPath.dependencyFile - where msg = "Could not find dependency file: " ++ EPath.dependencyFile - mkLib (name, jsv) = do - name' <- N.fromString' name - case jsv of - JSString vsn -> return $ Lib.Library' name' (Just . fromJSString $ vsn) - _ -> throwError $ "Invalid version number " ++ show jsv +execInstallM :: InstallM a -> ErrorT String IO Update +execInstallM = fmap snd . runWriterT -install1 :: InstallM Library () -install1 = do - vsn <- Cmd.inDir EPath.dependencyDirectory $ do - (repo,version) <- Cmd.inDir Path.internals get - liftIO $ createDirectoryIfMissing True repo - Cmd.copyDir (Path.internals repo) (repo show version) - return version - withReaderT (\l -> l {Lib.version = vsn}) addToDepsFile - Cmd.out "Success!" +-- | updates to the dependencies +type DepsMap = Map.Map N.Name V.Version -get :: InstallM Library (FilePath, V.Version) -get = - do directory <- N.toFilePath . Lib.lib <$> ask - exists <- liftIO $ doesDirectoryExist directory - (if exists then update else clone) directory - version <- getVersion - Cmd.inDir directory (checkout version) - return (directory, version) +-- | Nothing means don't update the file +-- | Just f means apply f to the old dependencies and replace the user's deps file. +newtype Update = Update (Maybe (Endo DepsMap)) + deriving Monoid + +update :: (DepsMap -> DepsMap) -> Update +update = Update . Just . Endo + +-- | External Interface +installAll :: ErrorT String IO () +installAll = installMay Nothing + +install :: Library -> ErrorT String IO () +install = installMay . Just + +data InstallFlag = Create + | NoCreate + | Unknown + deriving (Show, Read, Eq, Ord) + +installMay :: Maybe Library -> ErrorT String IO () +installMay mlib = + do (shouldCreate, deps) <- (withUnknown $ D.depsAt depsFile) `catchError` askCreate + ups <- + execInstallM $ do when (shouldCreate == Create) $ tell (update id) + libs <- toInstall deps + forM_ libs $ install1 (shouldCreate /= NoCreate) deps + liftIO $ + do writeUpdates deps ups + putStrLn "Done!" + where - update directory = do - name <- Lib.lib <$> ask - Cmd.out $ "Getting updates for repo " ++ show name - Cmd.inDir directory $ do Cmd.git ["checkout", "master"] - Cmd.git ["pull"] - return () + depsFile = EPath.dependencyFile + withUnknown = fmap ((,) Unknown) - clone directory = do - name <- Lib.lib <$> ask - Cmd.out $ "Cloning repo " ++ show name - Cmd.git [ "clone", "--progress", "https://github.com/" ++ show name ++ ".git" ] - liftIO $ renameDirectory (N.project name) directory + toInstall deps = case mlib of + Nothing -> + do liftIO $ putStrLn "Installing all declared dependencies..." + return $ map (\(n, v) -> Lib.Library n (Just v)) . D.dependencies $ deps + Just l -> return [l] + + askCreate _ = + do yes <- + liftIO $ do putStr createMsg + Cmd.yesOrNo + unless yes . liftIO . putStr $ didntUpdateMsg + let create = if yes then Create else NoCreate + return (create, defaultDeps) + where + createMsg = + "Your project does not have a " ++ depsFile ++ " file, which the Elm\n" ++ + "compiler needs to detect dependencies. Should I create it? (y/n): " - checkout version = - do let tag = show version - Cmd.out $ "Checking out version " ++ tag - Cmd.git [ "checkout", "tags/" ++ tag ] +writeUpdates :: D.Deps -> Update -> IO () +writeUpdates deps ups = case applyUpdates deps ups of + Nothing -> return () + Just newDeps -> BS.writeFile EPath.dependencyFile (D.prettyJSON newDeps) -{-| Check to see that the requested version number exists. In the case that no -version number is requested, use the latest tagless version number in the registry. -If the repo is not in the registry, warn the user and check on github. --} -getVersion :: InstallM Lib.Library V.Version -getVersion = - do maybeVersion <- withReaderT Lib.version validateVersion - versions <- withReaderT Lib.lib getVersions - case maybeVersion of - Nothing -> - case filter V.tagless versions of - [] -> errorNoTags - vs -> return $ maximum vs - Just version - | version `notElem` versions -> errorNoMatch version - | otherwise -> return version - where - validateVersion :: InstallM (Maybe String) (Maybe V.Version) - validateVersion = do - version <- ask - case (version, V.fromString =<< version) of - (Just tag, Nothing) -> - throwError $ unlines $ - [ "tag " ++ tag ++ " is not a valid version number." - , "It must have the following format: 0.1.2 or 0.1.2-tag" - ] - (_, result) -> return result +applyUpdates :: D.Deps -> Update -> Maybe D.Deps +applyUpdates d up = (updateDeps . wrapAssoc) (unwrap up) d + where + updateDeps :: Functor f => ([(N.Name, V.Version)] -> f [(N.Name, V.Version)]) -> D.Deps -> f D.Deps + updateDeps upper d = case d of + D.Deps { D.dependencies = deps } -> + (\deps' -> d { D.dependencies = deps'}) <$> upper deps - getVersions :: InstallM N.Name [V.Version] - getVersions = do - name <- ask - registryVersions <- lift $ R.versions name - case registryVersions of - Just vs -> return vs - Nothing -> do - Cmd.out $ "Warning: library " ++ show name ++ - " is not registered publicly. Checking github..." - tags <- lines <$> Cmd.git [ "tag", "--list" ] - return $ Maybe.mapMaybe V.fromString tags + wrapAssoc :: (Ord k, Functor f) => (Map.Map k v -> f (Map.Map k v)) -> [(k,v)] -> f [(k,v)] + wrapAssoc upper = fmap Map.toList . upper . Map.fromList - errorNoTags = - throwError $ unlines - [ "did not find any properly tagged releases of this library." - , "Libraries have at least one tag (like 0.1.2 or 1.0) to ensure that your build" - , "process is stable and repeatable. These tags should follow Semantic Versioning." - ] + unwrap :: Update -> DepsMap -> Maybe DepsMap + unwrap (Update m) d = + do (Endo f) <- m + return $ f d - errorNoMatch version = - throwError $ unlines - [ "could not find version " ++ show version ++ " on github." - ] +install1 :: Bool -> D.Deps -> Library -> InstallM () +install1 shouldAsk oldDeps l@(Lib.Library name _) = + do finalVsn <- Cmd.inDir EPath.dependencyDirectory $ + do (repo,version) <- lift $ Cmd.inDir Path.internals $ getRepo l + liftIO $ createDirectoryIfMissing True repo + Cmd.copyDir (Path.internals repo) (repo show version) + return version -addToDepsFile :: InstallM Lib.VsnLibrary () -addToDepsFile = - do exists <- liftIO $ doesFileExist file - add (if exists then yesFile else noFile) - where - file = EPath.dependencyFile + when shouldAsk $ mkUpdate (Map.fromList . D.dependencies $ oldDeps) name finalVsn + Cmd.out "Success!" + +mkUpdate :: DepsMap -> N.Name -> V.Version -> InstallM () +mkUpdate oldDeps n v = case Map.lookup n oldDeps of + Just v' | v == v' -> return () + m -> + do let (askMsg, noMsg) = case m of + Nothing -> (notInstalledAsk, didntUpdateMsg) + Just v' -> (updateAsk v' v, updateNo) + yes <- shouldI askMsg + if yes + then tell $ update $ Map.insert n v + else liftIO $ putStr noMsg - add msg = do - yes <- liftIO $ do - hPutStr stdout $ msg ++ " (y/n): " - Cmd.yesOrNo - if yes - then liftIO . writeFile file =<< newDependencies - else liftIO $ hPutStrLn stdout oddChoice + where + shouldI msg = liftIO $ do putStr msg + Cmd.yesOrNo - oddChoice = - "Okay, but if you decide to make this library visible to the compiler\n\ - \later, add the dependency to your " ++ file ++ " file." + notInstalledAsk = "Should I add this library to your " ++ depsFile ++ " file? (y/n): " + updateAsk old new = show old ++ " is already in " ++ depsFile ++ ".\nDo you want to replace it " ++ "with version " ++ show new ++ "? (y/n): " + updateNo = "Okay, but be sure to change the version number if\nyou want to use the library you just installed." + depsFile = EPath.dependencyFile - yesFile = "Should I add this library to your " ++ file ++ " file?" - noFile = - concat - [ "Your project does not have a " ++ file ++ " file yet.\n" - , "Should I create it and add the library you just installed?" ] + +getRepo :: Library -> ErrorT String IO (FilePath, V.Version) +getRepo l = + do let directory = N.toFilePath . Lib.lib $ l + exists <- liftIO $ doesDirectoryExist directory + (if exists then update else clone) (Lib.lib l) directory + version <- getVersion l + Cmd.inDir directory (checkout version) + return (directory, version) + where + update name directory = + do Cmd.out $ "Getting updates for repo " ++ show name + Cmd.inDir directory $ do Cmd.git ["checkout", "master"] + Cmd.git ["pull"] + return () --- | Returns Nothing if the dependency file doesn't exist, throws an --- error if its ill-formed -readDepsFile :: (MonadError String m, MonadIO m) => m (Maybe [(String, JSValue)]) -readDepsFile = do - exists <- liftIO $ doesFileExist EPath.dependencyFile - if not exists - then return Nothing - else do - raw <- liftIO $ withFile EPath.dependencyFile ReadMode $ \handle -> - do stuff <- hGetContents handle - length stuff `seq` return stuff - case decode raw of - Error msg -> liftIO $ do - hPutStrLn stderr $ "Error reading " ++ EPath.dependencyFile ++ ":\n" ++ msg - exitFailure - Ok obj -> return . Just $ fromJSObject obj + clone name directory = + do Cmd.out $ "Cloning repo " ++ show name + Cmd.git [ "clone", "--progress", "https://github.com/" ++ show name ++ ".git" ] + liftIO $ renameDirectory (N.project name) directory -newDependencies :: InstallM Lib.VsnLibrary String -newDependencies = do - assocs <- maybe [] id <$> readDepsFile - lib <- ask - case List.lookup "dependencies" assocs of - Just (JSObject entries) -> do - entries' <- liftIO $ updateEntries lib (fromJSObject entries) - return $ addDeps assocs entries' - _ -> return $ addDeps assocs [entry lib] + checkout version = + do let tag = show version + Cmd.out $ "Checking out version " ++ tag + Cmd.git [ "checkout", "tags/" ++ tag ] - where - entry l = (show $ Lib.lib l, JSString . toJSString . show $ Lib.version l) +{-| Check to see that the requested version number exists. In the case that no +version number is requested, use the latest tagless version number in the registry. +If the repo is not in the registry, warn the user and check on github. +-} +getVersion :: Library -> ErrorT String IO V.Version +getVersion (Lib.Library name mayVsn) = + do versions <- getVersions name + case mayVsn of + Nothing -> + case filter V.tagless versions of + [] -> errorNoTags + vs -> return $ maximum vs + Just version + | version `notElem` versions -> errorNoMatch version + | otherwise -> return version + where + getVersions :: N.Name -> ErrorT String IO [V.Version] + getVersions name = + do registryVersions <- R.versions name + case registryVersions of + Just vs -> return vs + Nothing -> + do Cmd.out $ "Warning: library " ++ show name ++ " is not registered publicly. Checking github..." + tags <- lines <$> Cmd.git [ "tag", "--list" ] + return $ Maybe.mapMaybe V.fromString tags - addDeps assocs entries = show $ Pretty.object obj - where - assocs' = filter ((/=) "dependencies" . fst) assocs - obj = assocs' ++ [("dependencies", JSObject $ toJSObject entries)] + errorNoTags = + throwError $ unlines + [ "did not find any properly tagged releases of this library." + , "Libraries have at least one tag (like 0.1.2 or 1.0) to ensure that your build" + , "process is stable and repeatable. These tags should follow Semantic Versioning." + ] - updateEntries :: Lib.VsnLibrary -> [(String, JSValue)] -> IO [(String, JSValue)] - updateEntries l entries = - let name = Lib.lib l - vsn = Lib.version l - name' = show name - entries' = List.insertBy (compare `on` fst) (entry l) $ - filter ((/=) name' . fst) entries - in - case List.lookup name' entries of - Just (JSString oldVersion) -> do - hPutStr stdout $ - name' ++ " " ++ fromJSString oldVersion ++ " is already in " ++ - EPath.dependencyFile ++ ".\nDo you want to replace it " ++ - "with version " ++ show vsn ++ "? (y/n): " - yes <- Cmd.yesOrNo - case yes of - True -> return entries' - False -> hPutStrLn stdout msg >> return entries - where msg = "Okay, but be sure to change the version number if\n\ - \you want to use the library you just installed." + errorNoMatch version = + throwError $ "could not find version " ++ show version ++ " on github." - _ -> return entries' +didntUpdateMsg :: String +didntUpdateMsg = + "Okay, but if you decide to make this library visible to the compiler later, add\n\ + \the dependency to your " ++ EPath.dependencyFile ++ " file." diff --git a/src/Get/Library.hs b/src/Get/Library.hs --- a/src/Get/Library.hs +++ b/src/Get/Library.hs @@ -6,18 +6,20 @@ import Elm.Internal.Version as V type RawLibrary = Library' String (Maybe String) -type Library = Library' N.Name (Maybe String) +type Library = Library' N.Name (Maybe V.Version) type VsnLibrary = Library' N.Name V.Version -data Library' name version - = Library' + +data Library' name vsn + = Library { lib :: name - , version :: version + , version :: vsn } deriving (Show, Eq) +-- | Convenience lenses updateName :: (Functor f) => (n1 -> f n2) -> Library' n1 v -> f (Library' n2 v) updateName upper l = case l of - Library' { lib = n } -> + Library { lib = n } -> (\name -> l { lib = name } ) @@ -26,7 +28,7 @@ updateVersion :: (Functor f) => (v1 -> f v2) -> Library' n v1 -> f (Library' n v2) updateVersion upper l = case l of - Library' { version = v } -> + Library { version = v } -> (\vsn -> l { version = vsn } ) diff --git a/src/Get/Main.hs b/src/Get/Main.hs --- a/src/Get/Main.hs +++ b/src/Get/Main.hs @@ -1,21 +1,19 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -W #-} +{-# OPTIONS_GHC -W #-} module Main where import Control.Applicative import Control.Monad.Error -import Data.Version (showVersion) import System.Directory (findExecutable) import System.Exit import System.IO import qualified Elm.Internal.Name as N +import qualified Elm.Internal.Version as V import qualified Get.Install as Install import Get.Library import Get.Options as Options import qualified Get.Publish as Publish -import qualified Paths_elm_get as This import qualified Utils.Commands as Cmd main :: IO () @@ -34,29 +32,43 @@ handle :: Command -> ErrorT String IO () handle options = case options of - Version -> - liftIO $ putStrLn $ "elm-get " ++ showVersion This.version Install mLib -> - Install.install =<< (updateMaybe . updateName) N.fromString' mLib + case mLib of + Nothing -> Install.installAll + Just rawL -> do + namedL <- updateName N.fromString' rawL + vsndL <- (updateVersion . updateMaybe) parseVsn namedL + Install.install vsndL Publish -> Publish.publish Update _ -> Cmd.out "Not implemented yet!" where + parseVsn s = case V.fromString s of + Nothing -> throwError $ unlines $ + [ "tag " ++ s ++ " is not a valid version number." + , "It must have the following format: 0.1.2 or 0.1.2-tag" + ] + Just s -> return s + updateMaybe :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) updateMaybe up m = case m of Nothing -> pure Nothing Just x -> Just <$> up x +errExit :: String -> IO () +errExit msg = do + hPutStrLn stderr msg + exitFailure + gitCheck :: IO () gitCheck = do maybePath <- findExecutable "git" case maybePath of Just _ -> return () - Nothing -> - do hPutStrLn stderr gitNotInstalledMessage - exitFailure + Nothing -> errExit gitNotInstalledMessage + where gitNotInstalledMessage = "\n\ diff --git a/src/Get/Options.hs b/src/Get/Options.hs --- a/src/Get/Options.hs +++ b/src/Get/Options.hs @@ -1,8 +1,5 @@ -{-# OPTIONS_GHC -W #-} -module Get.Options ( parse - , Command(..) - ) - where +{-# OPTIONS_GHC -W #-} +module Get.Options ( parse, Command(..) ) where import Control.Applicative import Data.Monoid @@ -16,55 +13,66 @@ = Install (Maybe RawLibrary) | Update { libs :: [String] } | Publish - | Version deriving (Show, Eq) parse :: IO Command parse = customExecParser prefs parser - where prefs = Opt.prefs $ mempty <> showHelpOnError + where + prefs = Opt.prefs $ mempty <> showHelpOnError parser :: ParserInfo Command -parser = info (helper <*> commands) - ( fullDesc - <> header top - <> progDesc "install and publish elm libraries" - <> footer moreHelp - ) - where top = unwords [ "elm-get" - , showVersion This.version ++ ":" - , " The Elm Package Manager " - , "(c) Evan Czaplicki 2013-2014\n"] - moreHelp = unlines - ["To learn more about a command called COMMAND, just do" - , " elm-get COMMAND --help" - ] +parser = info (helper <*> commands) infoMod + where + infoMod = mconcat + [ fullDesc + , header top + , progDesc "install and publish elm libraries" + , footer moreHelp + ] + top = unwords + [ "elm-get", showVersion This.version ++ ":" + , "The Elm Package Manager (c) Evan Czaplicki 2013-2014\n" + ] + + moreHelp = unlines + [ "To learn more about a command called COMMAND, just do:" + , " elm-get COMMAND --help" + ] + commands :: Parser Command -commands = hsubparser $ - command "install" installOpts - <> command "publish" publishOpts - <> command "version" versionOpts --- <> command "update" updateOpts -- TODO: implement update +commands = + hsubparser $ mconcat + [ command "install" installOpts + , command "publish" publishOpts +-- , command "update" updateOpts -- TODO: implement update + ] installOpts :: ParserInfo Command -installOpts = info - (Install <$> optional library) - ( fullDesc - <> progDesc "Install libraries in the local project." - <> footer examples - ) - where library = - Library' <$> (argument str (metavar "LIBRARY" - <> help "Library to install")) - <*> (optional $ - argument str (metavar "VERSION" - <> help "Specific version of a project to install")) - examples = unlines - [ "Examples:" - , " elm-get install # install everything needed by elm_dependencies.json" - , " elm-get install tom/Array # install a specific github repo" - , " elm-get install tom/Array 1.2 # install a specific version tag github repo" ] +installOpts = info (Install <$> optional library) infoMod + where + infoMod = mconcat + [ fullDesc + , progDesc "Install libraries in the local project." + , footer examples + ] + examples = unlines + [ "Examples:" + , " elm-get install # install everything needed by elm_dependencies.json" + , " elm-get install tom/Array # install a specific github repo" + , " elm-get install tom/Array 1.2 # install a specific version tag github repo" + ] + +library :: Parser RawLibrary +library = Library <$> lib <*> optional ver + where + lib = argument str (metavar "LIBRARY" + <> help "A specific library (e.g. evancz/automaton)") + + ver = argument str (metavar "VERSION" + <> help "Specific version of a project to install") + -- | TODO: restore when update is actually implemented -- updateOpts :: ParserInfo Command -- updateOpts = info @@ -79,11 +87,6 @@ -- , " elm-get update tom/Array # update from a specific github repo" ] publishOpts :: ParserInfo Command -publishOpts = info - (pure Publish) - (fullDesc <> progDesc "Publish project to the central repository") - -versionOpts :: ParserInfo Command -versionOpts = info - (pure Version) - (fullDesc <> progDesc "Display the project version") +publishOpts = + info (pure Publish) + (fullDesc <> progDesc "Publish project to the central repository") diff --git a/src/Get/Publish.hs b/src/Get/Publish.hs --- a/src/Get/Publish.hs +++ b/src/Get/Publish.hs @@ -5,22 +5,20 @@ import Control.Monad.Error import qualified Data.ByteString as BS import qualified Data.List as List -import qualified Data.Map as Map import qualified Data.Maybe as Maybe import System.Directory import System.Exit import System.IO -import Text.JSON import qualified Elm.Internal.Dependencies as D import qualified Elm.Internal.Name as N import qualified Elm.Internal.Paths as EPath import qualified Elm.Internal.Version as V +import Get.Dependencies (defaultDeps) import qualified Get.Registry as R import qualified Utils.Commands as Cmd import qualified Utils.Paths as Path -import qualified Utils.PrettyJson as Pretty publish :: ErrorT String IO () publish = @@ -31,7 +29,8 @@ Cmd.out $ unwords [ "Verifying", show name, show version, "..." ] verifyNoDependencies (D.dependencies deps) verifyElmVersion (D.elmVersion deps) - verifyExposedModules exposedModules + verifyMetadata deps + verifyExposedModulesExist exposedModules verifyVersion name version withCleanup $ do generateDocs exposedModules @@ -46,43 +45,8 @@ Left err -> liftIO $ do hPutStrLn stderr $ "\nError: " ++ err - hPutStr stdout $ "\nWould you like me to add the missing fields? (y/n) " - yes <- Cmd.yesOrNo - case yes of - False -> hPutStrLn stdout "Okay, maybe next time!" - True -> do - addMissing =<< readFields - hPutStrLn stdout $ "Done! Now go through " ++ EPath.dependencyFile ++ - " and check that\neach field is filled in with valid and helpful information." exitFailure -addMissing :: Map.Map String JSValue -> IO () -addMissing existingFields = - writeFile EPath.dependencyFile $ show $ Pretty.object obj' - where - obj' = map (\(f,v) -> (f, Maybe.fromMaybe v (Map.lookup f existingFields))) obj - - str = JSString . toJSString - obj = [ ("version", str "0.1") - , ("summary", str "concise, helpful summary of your project") - , ("description", str "full description of this project, describe your use case") - , ("license", str "BSD3") - , ("repository", str "https://github.com/USER/PROJECT.git") - , ("exposed-modules", JSArray []) - , ("elm-version", str $ show V.elmVersion) - , ("dependencies", JSObject $ toJSObject []) - ] - -readFields :: IO (Map.Map String JSValue) -readFields = - do exists <- doesFileExist EPath.dependencyFile - case exists of - False -> return Map.empty - True -> do raw <- readFile EPath.dependencyFile - return $ case decode raw of - Error _ -> Map.empty - Ok obj -> Map.fromList $ fromJSObject obj - withCleanup :: ErrorT String IO () -> ErrorT String IO () withCleanup action = do existed <- liftIO $ doesDirectoryExist "docs" @@ -96,9 +60,8 @@ verifyNoDependencies [] = return () verifyNoDependencies _ = throwError - "elm-get is not able to publish projects with dependencies\n\ - \yet. This is obviously a very high proirity, and I am working as\n\ - \fast as I can! For now, let people know about your library on the\n\ + "elm-get is not able to publish projects with dependencies yet. This is a\n\ + \very high proirity, we are working on it! For now, announce your library on the\n\ \mailing list: " verifyElmVersion :: V.Version -> ErrorT String IO () @@ -111,18 +74,35 @@ where V.V ns' _ = V.elmVersion -verifyExposedModules :: [String] -> ErrorT String IO () -verifyExposedModules modules = - do when (null modules) $ throwError $ - "There are no exposed modules in " ++ EPath.dependencyFile ++ - "!\nAll libraries must make at least one module available to users." - mapM_ verifyExists modules +verifyExposedModulesExist :: [String] -> ErrorT String IO () +verifyExposedModulesExist modules = + mapM_ verifyExists modules where verifyExists modul = let path = Path.moduleToElmFile modul in do exists <- liftIO $ doesFileExist path when (not exists) $ throwError $ "Cannot find module " ++ modul ++ " at " ++ path + +verifyMetadata :: D.Deps -> ErrorT String IO () +verifyMetadata deps = + case problems of + [] -> return () + _ -> throwError $ "Some of the fields in " ++ EPath.dependencyFile ++ + " have not been filled in yet:\n\n" ++ unlines problems ++ + "\nFill these in and try to publish again!" + where + problems = Maybe.catMaybes + [ verify D.repo " repository - must refer to a valid repo on GitHub" + , verify D.summary " summary - a quick summary of your project, 80 characters or less" + , verify D.description " description - extended description, how to get started, any useful references" + , verify D.exposed " exposed-modules - list modules your project exposes to users" + ] + + verify what msg = + if what deps == what defaultDeps + then Just msg + else Nothing verifyVersion :: N.Name -> V.Version -> ErrorT String IO () verifyVersion name version = diff --git a/src/Get/Registry.hs b/src/Get/Registry.hs --- a/src/Get/Registry.hs +++ b/src/Get/Registry.hs @@ -26,27 +26,29 @@ metadata :: N.Name -> ErrorT String IO (Maybe D.Deps) metadata name = - Http.send domain $ \manager -> - do request <- parseUrl $ libraryUrl "metadata" [("library", show name)] - response <- httpLbs request manager + Http.send url $ \request manager -> + do response <- httpLbs request manager return $ Json.decode $ responseBody response + where + url = libraryUrl "metadata" [("library", show name)] versions :: N.Name -> ErrorT String IO (Maybe [V.Version]) versions name = - Http.send domain $ \manager -> - do request <- parseUrl $ libraryUrl "versions" [("library", show name)] - response <- httpLbs request manager + Http.send url $ \request manager -> + do response <- httpLbs request manager return $ Binary.decode $ responseBody response + where + url = libraryUrl "versions" [("library", show name)] register :: N.Name -> V.Version -> FilePath -> ErrorT String IO () register name version path = - Http.send domain $ \manager -> - do request <- parseUrl $ libraryUrl "register" vars - request' <- formDataBody files request + Http.send url $ \request manager -> + do request' <- formDataBody files request let request'' = request' { responseTimeout = Nothing } httpLbs request'' manager return () where + url = libraryUrl "register" vars vars = [ ("library", show name), ("version", show version) ] files = [ partFileSource "docs" path , partFileSource "deps" Path.dependencyFile diff --git a/src/Utils/Http.hs b/src/Utils/Http.hs --- a/src/Utils/Http.hs +++ b/src/Utils/Http.hs @@ -10,18 +10,21 @@ import qualified Data.Vector as Vector import Network import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types import qualified Elm.Internal.Name as N -send :: String -> (Manager -> IO a) -> ErrorT String IO a -send domain request = - do result <- liftIO $ E.catch (Right `fmap` mkRequest) handler +send :: String -> (Request -> Manager -> IO a) -> ErrorT String IO a +send url handler = + do result <- liftIO $ E.catch (Right `fmap` sendRequest) handleError either throwError return result where - mkRequest = withSocketsDo $ withManager defaultManagerSettings request + sendRequest = do + request <- parseUrl url + withSocketsDo $ withManager tlsManagerSettings (handler request) - handler exception = + handleError exception = case exception of StatusCodeException (Status _code err) headers _ -> let details = case List.lookup "X-Response-Body-Start" headers of @@ -30,13 +33,12 @@ in return . Left $ BSC.unpack details _ -> return . Left $ - "probably unable to connect to <" ++ domain ++ "> (" ++ - show exception ++ ")" + "failed with '" ++ show exception ++ "' when sending request to\n" ++ + " <" ++ url ++ ">" githubTags :: N.Name -> ErrorT String IO Tags githubTags name = - do response <- send "https://api.github.com" $ \manager -> do - request <- parseUrl url + do response <- send url $ \request manager -> httpLbs (request {requestHeaders = headers}) manager case Json.eitherDecode $ responseBody response of Left err -> throwError err diff --git a/src/Utils/Paths.hs b/src/Utils/Paths.hs --- a/src/Utils/Paths.hs +++ b/src/Utils/Paths.hs @@ -12,7 +12,6 @@ json = "docs.json" index = "index.elm" listing = "public" "libraries.json" -listingBits = "listing.bits" library name = libDir N.toFilePath name diff --git a/src/Utils/PrettyJson.hs b/src/Utils/PrettyJson.hs deleted file mode 100644 --- a/src/Utils/PrettyJson.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Utils.PrettyJson where - -import Text.JSON -import Text.JSON.Pretty - -value :: JSValue -> Doc -value val = - case val of - JSNull -> pp_null - JSBool b -> pp_boolean b - JSRational asf x -> pp_number asf x - JSString s -> pp_js_string s - JSArray vs -> array vs - JSObject obj -> object (fromJSObject obj) - -array :: [JSValue] -> Doc -array [] = lbrack <> rbrack -array vs = - (if length vs < 2 then sep else vcat) (entries ++ [rbrack]) - where - entries = zipWith (<+>) (lbrack : repeat comma) (map value vs) - -object :: [(String, JSValue)] -> Doc -object [] = lbrace <> rbrace -object assocs = - (if length assocs < 2 then sep else vcat) (entries ++ [rbrace]) - where - entries = zipWith (<+>) (lbrace : repeat comma) fields - fields = map (\(f,v) -> hang (pp_string f <> colon) 4 (value v)) assocs