elm-get 0.1.1.2 → 0.1.1.3
raw patch · 11 files changed
+360/−356 lines, 11 filesdep +aeson-prettydep +http-client-tlsdep ~Elmdep ~http-client
Dependencies added: aeson-pretty, http-client-tls
Dependency ranges changed: Elm, http-client
Files
- elm-get.cabal +37/−10
- src/Get/Dependencies.hs +18/−0
- src/Get/Install.hs +171/−183
- src/Get/Library.hs +8/−6
- src/Get/Main.hs +22/−10
- src/Get/Options.hs +54/−51
- src/Get/Publish.hs +28/−48
- src/Get/Registry.hs +11/−9
- src/Utils/Http.hs +11/−9
- src/Utils/Paths.hs +0/−1
- src/Utils/PrettyJson.hs +0/−29
elm-get.cabal view
@@ -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,
+ src/Get/Dependencies.hs view
@@ -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 = []+ }
src/Get/Install.hs view
@@ -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."
src/Get/Library.hs view
@@ -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 } )
src/Get/Main.hs view
@@ -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\
src/Get/Options.hs view
@@ -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")
src/Get/Publish.hs view
@@ -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: <https://groups.google.com/forum/#!forum/elm-discuss>" 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 =
src/Get/Registry.hs view
@@ -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
src/Utils/Http.hs view
@@ -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
src/Utils/Paths.hs view
@@ -12,7 +12,6 @@ json = "docs.json" index = "index.elm" listing = "public" </> "libraries.json"-listingBits = "listing.bits" library name = libDir </> N.toFilePath name
− src/Utils/PrettyJson.hs
@@ -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