diff --git a/elm-get.cabal b/elm-get.cabal --- a/elm-get.cabal +++ b/elm-get.cabal @@ -1,9 +1,9 @@ Name: elm-get -Version: 0.1 +Version: 0.1.1 Synopsis: Tool for sharing and using Elm libraries Description: elm-get lets you install, update, and publish Elm libraries -Homepage: http://elm-lang.org +Homepage: http://github.com/elm-lang/elm-get License: BSD3 License-file: LICENSE @@ -19,14 +19,16 @@ source-repository head type: git - location: git://github.com/evancz/elm-get.git + location: git://github.com/elm-lang/elm-get.git Executable elm-get Main-is: Get/Main.hs - ghc-options: -threaded -O2 + ghc-options: -threaded -O2 -W Hs-Source-Dirs: src other-modules: Get.Install, + Get.Library, + Get.Options, Get.Publish, Get.Registry, Paths_elm_get, @@ -39,17 +41,18 @@ base >=4.2 && <5, binary, bytestring, - cmdargs, containers, directory, Elm >= 0.10.1, filepath, HTTP, - http-conduit >= 1.9, http-conduit < 2.0, + http-client >= 0.2 && <0.3, + http-client-multipart, http-types, json, mtl, network, + optparse-applicative, pretty, process, resourcet, diff --git a/src/Get/Install.hs b/src/Get/Install.hs --- a/src/Get/Install.hs +++ b/src/Get/Install.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Get.Install (install) where import Control.Applicative ((<$>)) -import Control.Monad (zipWithM_, when) import Control.Monad.Error +import Control.Monad.Reader import Data.Function (on) import qualified Data.List as List import qualified Data.Maybe as Maybe @@ -11,45 +13,68 @@ import System.FilePath import System.IO import Text.JSON -import qualified Utils.PrettyJson as Pretty -import qualified Get.Registry as R -import qualified Utils.Paths as Path -import qualified Utils.Commands as Cmd -import qualified Utils.Http as Http -import qualified Elm.Internal.Dependencies as D -import qualified Elm.Internal.Paths as EPath import qualified Elm.Internal.Name as N +import qualified Elm.Internal.Paths as EPath import qualified Elm.Internal.Version as V -install :: N.Name -> Maybe String -> ErrorT String IO () -install name maybeVersion = - do version <- - Cmd.inDir EPath.dependencyDirectory $ do - (repo,version) <- Cmd.inDir Path.internals (get name maybeVersion) - liftIO $ createDirectoryIfMissing True repo - Cmd.copyDir (Path.internals repo) (repo show version) - return version - liftIO $ addToDepsFile name version - Cmd.out "Success!" +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 -get :: N.Name -> Maybe String -> ErrorT String IO (FilePath, V.Version) -get name maybeVersion = - do exists <- liftIO $ doesDirectoryExist directory - if exists then update else clone - version <- getVersion name maybeVersion +type InstallM l = ReaderT l (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 + +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!" + +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) where - directory = N.toFilePath name - - update = do + 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 () - clone = do + 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 @@ -63,10 +88,10 @@ 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 :: N.Name -> Maybe String -> ErrorT String IO V.Version -getVersion name maybeVersion' = - do maybeVersion <- validateVersion maybeVersion' - versions <- getVersions name +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 @@ -76,19 +101,21 @@ | version `notElem` versions -> errorNoMatch version | otherwise -> return version where - validateVersion :: Maybe String -> ErrorT String IO (Maybe V.Version) - validateVersion version = - 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 + 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 - getVersions :: N.Name -> ErrorT String IO [V.Version] - getVersions name = do - registryVersions <- R.versions name + getVersions :: InstallM N.Name [V.Version] + getVersions = do + name <- ask + registryVersions <- lift $ R.versions name case registryVersions of Just vs -> return vs Nothing -> do @@ -98,7 +125,7 @@ return $ Maybe.mapMaybe V.fromString tags errorNoTags = - throwError $ unlines + 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." @@ -109,18 +136,20 @@ [ "could not find version " ++ show version ++ " on github." ] -addToDepsFile :: N.Name -> V.Version -> IO () -addToDepsFile name version = - do exists <- doesFileExist file +addToDepsFile :: InstallM Lib.VsnLibrary () +addToDepsFile = + do exists <- liftIO $ doesFileExist file add (if exists then yesFile else noFile) where file = EPath.dependencyFile add msg = do - hPutStr stdout $ msg ++ " (y/n): " - yes <- Cmd.yesOrNo - if yes then writeFile file =<< newDependencies name version - else hPutStrLn stdout oddChoice + yes <- liftIO $ do + hPutStr stdout $ msg ++ " (y/n): " + Cmd.yesOrNo + if yes + then liftIO . writeFile file =<< newDependencies + else liftIO $ hPutStrLn stdout oddChoice oddChoice = "Okay, but if you decide to make this library visible to the compiler\n\ @@ -132,37 +161,47 @@ [ "Your project does not have a " ++ file ++ " file yet.\n" , "Should I create it and add the library you just installed?" ] -newDependencies :: N.Name -> V.Version -> IO String -newDependencies name version = - do exists <- doesFileExist EPath.dependencyFile - raw <- if not exists then return "{}" else - withFile EPath.dependencyFile ReadMode $ \handle -> - do stuff <- hGetContents handle - length stuff `seq` return stuff - case decode raw of - Error msg -> do - hPutStrLn stderr $ "Error reading " ++ EPath.dependencyFile ++ ":\n" ++ msg - exitFailure - Ok obj -> - let assocs = fromJSObject obj in - case List.lookup "dependencies" assocs of - Just (JSObject entries) -> do - entries' <- updateEntries (fromJSObject entries) - return $ addDeps assocs entries' - _ -> return $ addDeps assocs [entry] +-- | 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 +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] + where - entry = (show name, JSString $ toJSString $ show version) + entry l = (show $ Lib.lib l, JSString . toJSString . show $ Lib.version l) addDeps assocs entries = show $ Pretty.object obj where assocs' = filter ((/=) "dependencies" . fst) assocs obj = assocs' ++ [("dependencies", JSObject $ toJSObject entries)] - updateEntries ::[(String,JSValue)] -> IO [(String,JSValue)] - updateEntries entries = - let name' = show name - entries' = List.insertBy (compare `on` fst) entry $ + 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 @@ -170,7 +209,7 @@ hPutStr stdout $ name' ++ " " ++ fromJSString oldVersion ++ " is already in " ++ EPath.dependencyFile ++ ".\nDo you want to replace it " ++ - "with version " ++ show version ++ "? (y/n): " + "with version " ++ show vsn ++ "? (y/n): " yes <- Cmd.yesOrNo case yes of True -> return entries' diff --git a/src/Get/Library.hs b/src/Get/Library.hs new file mode 100644 --- /dev/null +++ b/src/Get/Library.hs @@ -0,0 +1,34 @@ +module Get.Library where + +import Control.Applicative + +import Elm.Internal.Name as N +import Elm.Internal.Version as V + +type RawLibrary = Library' String (Maybe String) +type Library = Library' N.Name (Maybe String) +type VsnLibrary = Library' N.Name V.Version +data Library' name version + = Library' + { lib :: name + , version :: version + } + deriving (Show, Eq) + +updateName :: (Functor f) => (n1 -> f n2) -> Library' n1 v -> f (Library' n2 v) +updateName upper l = case l of + Library' { lib = n } -> + (\name -> + l { lib = name } + ) + <$> + upper n + +updateVersion :: (Functor f) => (v1 -> f v2) -> Library' n v1 -> f (Library' n v2) +updateVersion upper l = case l of + Library' { version = v } -> + (\vsn -> + l { version = vsn } + ) + <$> + upper v diff --git a/src/Get/Main.hs b/src/Get/Main.hs --- a/src/Get/Main.hs +++ b/src/Get/Main.hs @@ -1,61 +1,28 @@ -{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -W #-} module Main where - -import System.Console.CmdArgs -import System.Environment (getArgs, withArgs) -import System.Exit -import System.IO + +import Control.Applicative import Control.Monad.Error -import qualified Paths_elm_get as This -import qualified Data.Maybe as Maybe import Data.Version (showVersion) - -import qualified Get.Install as Install -import qualified Get.Publish as Publish -import qualified Get.Registry as Registry -import qualified Utils.Commands as Cmd -import qualified Elm.Internal.Name as N - -data Commands - = Install { lib :: String, version :: Maybe String } - | Update { libs :: [String] } - | Publish - deriving (Data, Typeable, Show, Eq) +import System.Directory (findExecutable) +import System.Exit +import System.IO -commands = - [ Install { lib = def &= argPos 0 &= typ "LIBRARY" - , version = Nothing &= args &= typ "VERSION" - } - &= help "Install libraries in the local project." - &= details [ "Examples:" - , " elm-get install # install everything needed by build.json" - , " elm-get install tom/Array # install a specific github repo" ] - , Update { libs = [] &= args &= typ "LIBRARY" } - &= help "Check for updates to any local libraries, ask to upgrade." - &= details [ "Examples:" - , " elm-get update # check for updates to local libraries" - , " elm-get update tom/Array # update from a specific github repo" ] - , Publish - &= help "Publish project to the central repository." - &= details [] - ] +import qualified Elm.Internal.Name as N -myModes :: Mode (CmdArgs Commands) -myModes = cmdArgsMode $ modes commands - &= versionArg [explicit, name "version", name "v", summary info] - &= summary (info ++ ", (c) Evan Czaplicki 2013") - &= help "install, update, and publish elm libraries" - &= helpArg [explicit, name "help", name "h"] - &= program "elm-get" - -info = "elm-get " ++ showVersion This.version +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 () main = do - args <- getArgs - -- If the user did not specify any arguments, pretend as "--help" was given - opts <- (if null args then withArgs ["--help"] else id) $ cmdArgsRun myModes - result <- runErrorT (handle opts) + gitCheck + cmd <- parse + result <- runErrorT (handle cmd) case result of Right _ -> return () Left err -> @@ -64,14 +31,35 @@ where newline = if last err == '\n' then "" else "\n" -handle :: Commands -> ErrorT String IO () +handle :: Command -> ErrorT String IO () handle options = - case options of - Install { lib=library, version=maybeVersion } -> - do name <- N.fromString' library - Install.install name maybeVersion + case options of + Version -> + liftIO $ putStrLn $ "elm-get " ++ showVersion This.version + Install mLib -> + Install.install =<< (updateMaybe . updateName) N.fromString' mLib - Publish -> Publish.publish + Publish -> Publish.publish - _ -> do Cmd.out "Not implemented yet!" - liftIO $ print options + _ -> Cmd.out "Not implemented yet!" + where + 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 + +gitCheck :: IO () +gitCheck = + do maybePath <- findExecutable "git" + case maybePath of + Just _ -> return () + Nothing -> + do hPutStrLn stderr gitNotInstalledMessage + exitFailure + where + gitNotInstalledMessage = + "\n\ + \The REPL relies on git to download libraries and manage versions.\n\ + \ It appears that you do not have git installed though!\n\ + \ Get it from to continue." diff --git a/src/Get/Options.hs b/src/Get/Options.hs new file mode 100644 --- /dev/null +++ b/src/Get/Options.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_GHC -W #-} +module Get.Options ( parse + , Command(..) + ) + where + +import Control.Applicative +import Data.Monoid +import Data.Version (showVersion) +import Options.Applicative as Opt + +import Get.Library +import qualified Paths_elm_get as This + +data Command + = Install (Maybe RawLibrary) + | Update { libs :: [String] } + | Publish + | Version + deriving (Show, Eq) + +parse :: IO Command +parse = customExecParser prefs parser + where prefs = Opt.prefs $ mempty <> showHelpOnError + +parser :: ParserInfo Command +parser = info (helper <*> commands) + ( fullDesc + <> header top + <> progDesc "install, update, and publish elm libraries" + <> footer moreHelp + ) + where top = unwords [ "elm-get" + , showVersion This.version ++ ":" + , " The Elm Package Manager " + , "(c) Evan Czaplicki 2013"] + 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 "update" updateOpts + <> command "publish" publishOpts + <> command "version" versionOpts + +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" ] + +updateOpts :: ParserInfo Command +updateOpts = info + (Update <$> many (argument str (metavar "LIBRARY" <> help "Library to update"))) + ( fullDesc + <> progDesc "Check for updates to any local libraries, ask to upgrade." + <> footer examples + ) + where examples = unlines + [ "Examples:" + , " elm-get update # check for updates to local libraries" + , " 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") diff --git a/src/Get/Publish.hs b/src/Get/Publish.hs --- a/src/Get/Publish.hs +++ b/src/Get/Publish.hs @@ -2,29 +2,26 @@ module Get.Publish where import Control.Applicative ((<$>)) -import Control.Monad (when) 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.FilePath (replaceExtension, ()) import System.IO -import qualified Data.Maybe as Maybe -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.ByteString as BS import Text.JSON -import qualified Utils.PrettyJson as Pretty -import Data.Version -import qualified Get.Registry as R -import qualified Utils.Paths as Path -import qualified Utils.Commands as Cmd -import qualified Utils.Http as Http import qualified Elm.Internal.Dependencies as D -import qualified Elm.Internal.Paths as EPath -import qualified Elm.Internal.Name as N -import qualified Elm.Internal.Version as V +import qualified Elm.Internal.Name as N +import qualified Elm.Internal.Paths as EPath +import qualified Elm.Internal.Version as V +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 = do deps <- getDeps @@ -55,10 +52,10 @@ False -> hPutStrLn stdout "Okay, maybe next time!" True -> do addMissing =<< readFields - hPutStrLn stdout $ "Done! Now go through " ++ EPath.dependencyFile ++ + 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' @@ -82,9 +79,9 @@ case exists of False -> return Map.empty True -> do raw <- readFile EPath.dependencyFile - case decode raw of - Error err -> return Map.empty - Ok obj -> return (Map.fromList $ fromJSObject obj) + return $ case decode raw of + Error _ -> Map.empty + Ok obj -> Map.fromList $ fromJSObject obj withCleanup :: ErrorT String IO () -> ErrorT String IO () withCleanup action = @@ -161,7 +158,7 @@ ] generateDocs :: [String] -> ErrorT String IO () -generateDocs modules = +generateDocs modules = do forM elms $ \path -> Cmd.run "elm-doc" [path] liftIO $ do let path = Path.combinedJson diff --git a/src/Get/Registry.hs b/src/Get/Registry.hs --- a/src/Get/Registry.hs +++ b/src/Get/Registry.hs @@ -1,21 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Get.Registry where -import Network.HTTP -import Network.HTTP.Conduit -import Network.HTTP.Conduit.MultipartFormData - import Control.Monad.Error import qualified Data.Aeson as Json import qualified Data.Binary as Binary - import Data.Version (showVersion) -import qualified Paths_elm_get as This +import Network.HTTP +import Network.HTTP.Client +import Network.HTTP.Client.MultipartFormData + import qualified Elm.Internal.Dependencies as D -import qualified Elm.Internal.Name as N -import qualified Elm.Internal.Version as V -import qualified Elm.Internal.Paths as Path -import qualified Utils.Http as Http +import qualified Elm.Internal.Name as N +import qualified Elm.Internal.Paths as Path +import qualified Elm.Internal.Version as V +import qualified Paths_elm_get as This + +import qualified Utils.Http as Http domain = "http://library.elm-lang.org" diff --git a/src/Utils/Commands.hs b/src/Utils/Commands.hs --- a/src/Utils/Commands.hs +++ b/src/Utils/Commands.hs @@ -1,6 +1,7 @@ -module Utils.Commands where - -import Control.Monad (forM_) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Utils.Commands where + import Control.Monad.Error import System.Directory import System.Exit @@ -18,7 +19,7 @@ _ -> do putStr "Must type 'y' for yes or 'n' for no: " yesOrNo -inDir :: FilePath -> ErrorT String IO a -> ErrorT String IO a +inDir :: (MonadError String m, MonadIO m) => FilePath -> m a -> m a inDir dir doStuff = do here <- liftIO $ getCurrentDirectory liftIO $ createDirectoryIfMissing True dir @@ -27,7 +28,7 @@ liftIO $ setCurrentDirectory here return result -copyDir :: FilePath -> FilePath -> ErrorT String IO () +copyDir :: (MonadError String m, MonadIO m) => FilePath -> FilePath -> m () copyDir src dst = do exists <- liftIO $ doesDirectoryExist src if exists @@ -45,10 +46,10 @@ isDirectory <- doesDirectoryExist srcPath (if isDirectory then copyDir' else copyFile) srcPath dstPath -git :: [String] -> ErrorT String IO String +git :: (MonadError String m, MonadIO m) => [String] -> m String git = run "git" -run :: String -> [String] -> ErrorT String IO String +run :: (MonadError String m, MonadIO m) => String -> [String] -> m String run command args = do result <- liftIO runCommand case result of @@ -57,22 +58,20 @@ "failure when running:" ++ concatMap (' ':) (command:args) ++ "\n" ++ err where runCommand = do - (_, Just out, Just err, handle) <- - createProcess (proc command args) { std_out = CreatePipe - , std_err = CreatePipe } - exitCode <- waitForProcess handle - result <- case exitCode of - ExitSuccess -> readFrom out Right - ExitFailure _ -> readFrom err Left - hClose out - hClose err - return result + (exitCode, stdout, stderr) <- readProcessWithExitCode command args "" + return $ case exitCode of + ExitSuccess -> Right stdout + ExitFailure code + | code == 127 -> Left missingExe -- UNIX + | code == 9009 -> Left missingExe -- Windows + | otherwise -> Left stderr - readFrom handle label = do - msg <- hGetContents handle - length msg `seq` return (label msg) + missingExe = + "Could not find command '" ++ command ++ "'. Do you have it installed?\n\ + \ Can it be run from anywhere? I.e. is it on your PATH?" -out :: String -> ErrorT String IO () + +out :: (MonadError String m, MonadIO m) => String -> m () out string = liftIO $ hPutStrLn stdout string' where string' = if not (null string) && last string == '\n' then init string else string diff --git a/src/Utils/Http.hs b/src/Utils/Http.hs --- a/src/Utils/Http.hs +++ b/src/Utils/Http.hs @@ -1,33 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} module Utils.Http where -import Network -import Network.HTTP -import Network.HTTP.Types -import Network.HTTP.Conduit - -import Control.Monad.Error -import Control.Monad.Trans.Resource import qualified Control.Exception as E - +import Control.Monad.Error import Data.Aeson as Json -import Data.Monoid ((<>)) +import qualified Data.ByteString.Char8 as BSC import qualified Data.List as List +import Data.Monoid ((<>)) import qualified Data.Vector as Vector -import qualified Data.ByteString.Char8 as BSC +import Network +import Network.HTTP.Client +import Network.HTTP.Types + import qualified Elm.Internal.Name as N -import qualified Elm.Internal.Version as V -send :: String -> (Manager -> ResourceT IO a) -> ErrorT String IO a +send :: String -> (Manager -> IO a) -> ErrorT String IO a send domain request = do result <- liftIO $ E.catch (Right `fmap` mkRequest) handler either throwError return result where - mkRequest = withSocketsDo $ withManager request + mkRequest = withSocketsDo $ withManager defaultManagerSettings request handler exception = case exception of - sce@(StatusCodeException (Status code err) headers _) -> + StatusCodeException (Status _code err) headers _ -> let details = case List.lookup "X-Response-Body-Start" headers of Just msg | not (BSC.null msg) -> msg _ -> err diff --git a/src/Utils/Paths.hs b/src/Utils/Paths.hs --- a/src/Utils/Paths.hs +++ b/src/Utils/Paths.hs @@ -1,6 +1,7 @@ module Utils.Paths where import System.FilePath + import qualified Elm.Internal.Name as N import qualified Elm.Internal.Version as V diff --git a/src/Utils/PrettyJson.hs b/src/Utils/PrettyJson.hs --- a/src/Utils/PrettyJson.hs +++ b/src/Utils/PrettyJson.hs @@ -1,13 +1,11 @@ - module Utils.PrettyJson where import Text.JSON import Text.JSON.Pretty -import Data.Ratio -import Text.PrettyPrint -value value = - case value of +value :: JSValue -> Doc +value val = + case val of JSNull -> pp_null JSBool b -> pp_boolean b JSRational asf x -> pp_number asf x @@ -15,12 +13,14 @@ 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])