elm-get 0.1 → 0.1.1
raw patch · 11 files changed
+355/−210 lines, 11 filesdep +http-clientdep +http-client-multipartdep +optparse-applicativedep −cmdargsdep −http-conduit
Dependencies added: http-client, http-client-multipart, optparse-applicative
Dependencies removed: cmdargs, http-conduit
Files
- elm-get.cabal +9/−6
- src/Get/Install.hs +114/−75
- src/Get/Library.hs +34/−0
- src/Get/Main.hs +46/−58
- src/Get/Options.hs +88/−0
- src/Get/Publish.hs +18/−21
- src/Get/Registry.hs +10/−10
- src/Utils/Commands.hs +20/−21
- src/Utils/Http.hs +10/−14
- src/Utils/Paths.hs +1/−0
- src/Utils/PrettyJson.hs +5/−5
elm-get.cabal view
@@ -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,
src/Get/Install.hs view
@@ -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'
+ src/Get/Library.hs view
@@ -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
src/Get/Main.hs view
@@ -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 <http://git-scm.com/downloads> to continue."
+ src/Get/Options.hs view
@@ -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")
src/Get/Publish.hs view
@@ -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
src/Get/Registry.hs view
@@ -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"
src/Utils/Commands.hs view
@@ -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
src/Utils/Http.hs view
@@ -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
src/Utils/Paths.hs view
@@ -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
src/Utils/PrettyJson.hs view
@@ -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])