elm-get (empty) → 0.1
raw patch · 11 files changed
+787/−0 lines, 11 filesdep +Elmdep +HTTPdep +aesonsetup-changed
Dependencies added: Elm, HTTP, aeson, base, binary, bytestring, cmdargs, containers, directory, filepath, http-conduit, http-types, json, mtl, network, pretty, process, resourcet, text, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- elm-get.cabal +57/−0
- src/Get/Install.hs +181/−0
- src/Get/Main.hs +77/−0
- src/Get/Publish.hs +181/−0
- src/Get/Registry.hs +53/−0
- src/Utils/Commands.hs +79/−0
- src/Utils/Http.hs +67/−0
- src/Utils/Paths.hs +31/−0
- src/Utils/PrettyJson.hs +29/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Evan Czaplicki++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Evan Czaplicki nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ elm-get.cabal view
@@ -0,0 +1,57 @@+Name: elm-get+Version: 0.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++License: BSD3+License-file: LICENSE++Author: Evan Czaplicki+Maintainer: info@elm-lang.org+Copyright: Copyright: (c) 2013-2014 Evan Czaplicki++Category: Language++Build-type: Simple+Cabal-version: >=1.9++source-repository head+ type: git+ location: git://github.com/evancz/elm-get.git++Executable elm-get+ Main-is: Get/Main.hs+ ghc-options: -threaded -O2+ Hs-Source-Dirs: src++ other-modules: Get.Install,+ Get.Publish,+ Get.Registry,+ Paths_elm_get,+ Utils.Commands,+ Utils.Http,+ Utils.Paths,+ Utils.PrettyJson++ Build-depends: aeson,+ base >=4.2 && <5,+ binary,+ bytestring,+ cmdargs,+ containers,+ directory,+ Elm >= 0.10.1,+ filepath,+ HTTP,+ http-conduit >= 1.9, http-conduit < 2.0,+ http-types,+ json,+ mtl,+ network,+ pretty,+ process,+ resourcet,+ text,+ vector
+ src/Get/Install.hs view
@@ -0,0 +1,181 @@+module Get.Install (install) where++import Control.Applicative ((<$>))+import Control.Monad (zipWithM_, when)+import Control.Monad.Error+import Data.Function (on)+import qualified Data.List as List+import qualified Data.Maybe as Maybe+import System.Directory+import System.Exit+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.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!"++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+ Cmd.inDir directory (checkout version)+ return (directory, version)+ where+ directory = N.toFilePath name++ update = do+ Cmd.out $ "Getting updates for repo " ++ show name+ Cmd.inDir directory $ do Cmd.git ["checkout", "master"]+ Cmd.git ["pull"]+ return ()++ clone = do+ Cmd.out $ "Cloning repo " ++ show name+ Cmd.git [ "clone", "--progress", "https://github.com/" ++ show name ++ ".git" ]+ liftIO $ renameDirectory (N.project name) directory++ checkout version =+ do let tag = show version+ Cmd.out $ "Checking out version " ++ tag+ Cmd.git [ "checkout", "tags/" ++ tag ]++{-| 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 :: N.Name -> Maybe String -> ErrorT String IO V.Version+getVersion name maybeVersion' =+ do maybeVersion <- validateVersion maybeVersion'+ versions <- getVersions name+ 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 :: 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++ 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++ 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."+ ]++ errorNoMatch version =+ throwError $ unlines+ [ "could not find version " ++ show version ++ " on github."+ ]++addToDepsFile :: N.Name -> V.Version -> IO ()+addToDepsFile name version =+ do exists <- 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++ oddChoice =+ "Okay, but if you decide to make this library visible to the compiler\n\+ \later, add the dependency to your " ++ file ++ " file."++ 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?" ]++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]++ where+ entry = (show name, JSString $ toJSString $ show version)++ 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 $+ 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 version ++ "? (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."++ _ -> return entries'
+ src/Get/Main.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}+module Main where+ +import System.Console.CmdArgs+import System.Environment (getArgs, withArgs)+import System.Exit+import System.IO+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)++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 []+ ]++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++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)+ case result of+ Right _ -> return ()+ Left err ->+ do hPutStr stderr ("\nError: " ++ err ++ newline)+ exitFailure+ where+ newline = if last err == '\n' then "" else "\n"++handle :: Commands -> ErrorT String IO ()+handle options =+ case options of+ Install { lib=library, version=maybeVersion } ->+ do name <- N.fromString' library+ Install.install name maybeVersion++ Publish -> Publish.publish++ _ -> do Cmd.out "Not implemented yet!"+ liftIO $ print options
+ src/Get/Publish.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE OverloadedStrings #-}+module Get.Publish where++import Control.Applicative ((<$>))+import Control.Monad (when)+import Control.Monad.Error+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++publish :: ErrorT String IO ()+publish =+ do deps <- getDeps+ let name = D.name deps+ version = D.version deps+ exposedModules = D.exposed deps+ Cmd.out $ unwords [ "Verifying", show name, show version, "..." ]+ verifyNoDependencies (D.dependencies deps)+ verifyElmVersion (D.elmVersion deps)+ verifyExposedModules exposedModules+ verifyVersion name version+ withCleanup $ do+ generateDocs exposedModules+ R.register name version Path.combinedJson+ Cmd.out "Success!"++getDeps :: ErrorT String IO D.Deps+getDeps =+ do either <- liftIO $ runErrorT $ D.depsAt EPath.dependencyFile+ case either of+ Right deps -> return deps+ 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+ case decode raw of+ Error err -> return Map.empty+ Ok obj -> return (Map.fromList $ fromJSObject obj)++withCleanup :: ErrorT String IO () -> ErrorT String IO ()+withCleanup action =+ do existed <- liftIO $ doesDirectoryExist "docs"+ either <- liftIO $ runErrorT action+ when (not existed) $ liftIO $ removeDirectoryRecursive "docs"+ case either of+ Left err -> throwError err+ Right () -> return ()++verifyNoDependencies :: [(N.Name,V.Version)] -> ErrorT String IO ()+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\+ \mailing list: <https://groups.google.com/forum/#!forum/elm-discuss>"++verifyElmVersion :: V.Version -> ErrorT String IO ()+verifyElmVersion elmVersion@(V.V ns _)+ | ns == ns' = return ()+ | otherwise =+ throwError $ "elm_dependencies.json says this project depends on version " +++ show elmVersion ++ " of the compiler but the compiler you " +++ "have installed is version " ++ show V.elmVersion+ 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+ where+ verifyExists modul =+ let path = Path.moduleToElmFile modul in+ do exists <- liftIO $ doesFileExist path+ when (not exists) $ throwError $+ "Cannot find module " ++ modul ++ " at " ++ path++verifyVersion :: N.Name -> V.Version -> ErrorT String IO ()+verifyVersion name version =+ do response <- R.versions name+ case response of+ Nothing -> return ()+ Just versions ->+ do let maxVersion = maximum (version:versions)+ when (version < maxVersion) $ throwError $ unlines+ [ "a later version has already been released."+ , "Use a version number higher than " ++ show maxVersion ]+ checkSemanticVersioning maxVersion++ checkTag version++ where+ checkSemanticVersioning _ = return ()++ checkTag version = do+ tags <- lines <$> Cmd.git [ "tag", "--list" ]+ let v = show version+ when (show version `notElem` tags) $+ throwError (unlines (tagMessage v))++ tagMessage v =+ [ "Libraries must be tagged in git, but tag " ++ v ++ " was not found."+ , "These tags make it possible to find this specific version on github."+ , "To tag the most recent commit and push it to github, run this:"+ , ""+ , " git tag -a " ++ v ++ " -m \"release version " ++ v ++ "\""+ , " git push origin " ++ v+ , ""+ ]++generateDocs :: [String] -> ErrorT String IO ()+generateDocs modules = + do forM elms $ \path -> Cmd.run "elm-doc" [path]+ liftIO $ do+ let path = Path.combinedJson+ BS.writeFile path "[\n"+ let addCommas = List.intersperse (BS.appendFile path ",\n")+ sequence_ $ addCommas $ map append jsons+ BS.appendFile path "\n]"++ where+ elms = map Path.moduleToElmFile modules+ jsons = map Path.moduleToJsonFile modules++ append :: FilePath -> IO ()+ append path = do+ json <- BS.readFile path+ BS.length json `seq` return ()+ BS.appendFile Path.combinedJson json
+ src/Get/Registry.hs view
@@ -0,0 +1,53 @@+{-# 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 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++domain = "http://library.elm-lang.org"++libraryUrl path vars =+ domain ++ "/" ++ path ++ "?" ++ urlEncodeVars (version : vars)+ where+ version = ("elm-get-version", showVersion This.version)++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+ return $ Json.decode $ responseBody response++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+ return $ Binary.decode $ responseBody response++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+ let request'' = request' { responseTimeout = Nothing }+ httpLbs request'' manager+ return ()+ where+ vars = [ ("library", show name), ("version", show version) ]+ files = [ partFileSource "docs" path+ , partFileSource "deps" Path.dependencyFile+ ]
+ src/Utils/Commands.hs view
@@ -0,0 +1,79 @@+module Utils.Commands where + +import Control.Monad (forM_)+import Control.Monad.Error+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.Process++yesOrNo :: IO Bool+yesOrNo = do+ hFlush stdout+ input <- getLine+ case input of+ "y" -> return True+ "n" -> return False+ _ -> do putStr "Must type 'y' for yes or 'n' for no: "+ yesOrNo++inDir :: FilePath -> ErrorT String IO a -> ErrorT String IO a+inDir dir doStuff = do+ here <- liftIO $ getCurrentDirectory+ liftIO $ createDirectoryIfMissing True dir+ liftIO $ setCurrentDirectory dir+ result <- doStuff+ liftIO $ setCurrentDirectory here+ return result++copyDir :: FilePath -> FilePath -> ErrorT String IO ()+copyDir src dst = do+ exists <- liftIO $ doesDirectoryExist src+ if exists+ then liftIO $ copyDir' src dst+ else throwError $ "Directory " ++ src ++ " does not exist"++copyDir' :: FilePath -> FilePath -> IO ()+copyDir' src dst = do+ createDirectoryIfMissing True dst+ content <- getDirectoryContents src+ let paths = filter (`notElem` [".", "..",".git",".gitignore"]) content+ forM_ paths $ \name -> do+ let srcPath = src </> name+ let dstPath = dst </> name+ isDirectory <- doesDirectoryExist srcPath+ (if isDirectory then copyDir' else copyFile) srcPath dstPath++git :: [String] -> ErrorT String IO String+git = run "git"++run :: String -> [String] -> ErrorT String IO String+run command args =+ do result <- liftIO runCommand+ case result of+ Right out -> return out+ Left err -> throwError $+ "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++ readFrom handle label = do+ msg <- hGetContents handle+ length msg `seq` return (label msg)++out :: String -> ErrorT String IO ()+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
@@ -0,0 +1,67 @@+{-# 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 Data.Aeson as Json+import Data.Monoid ((<>))+import qualified Data.List as List+import qualified Data.Vector as Vector+import qualified Data.ByteString.Char8 as BSC+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 domain request =+ do result <- liftIO $ E.catch (Right `fmap` mkRequest) handler+ either throwError return result+ where+ mkRequest = withSocketsDo $ withManager request++ handler exception =+ case exception of+ sce@(StatusCodeException (Status code err) headers _) ->+ let details = case List.lookup "X-Response-Body-Start" headers of+ Just msg | not (BSC.null msg) -> msg+ _ -> err+ in return . Left $ BSC.unpack details++ _ -> return . Left $+ "probably unable to connect to <" ++ domain ++ "> (" +++ show exception ++ ")"++githubTags :: N.Name -> ErrorT String IO Tags+githubTags name =+ do response <- send "https://api.github.com" $ \manager -> do+ request <- parseUrl url+ httpLbs (request {requestHeaders = headers}) manager+ case Json.eitherDecode $ responseBody response of+ Left err -> throwError err+ Right tags -> return tags+ where+ url = "https://api.github.com/repos/" ++ N.user name +++ "/" ++ N.project name ++ "/tags"++ headers = [("User-Agent", "elm-get")] <>+ [("Accept", "application/json")]+++data Tags = Tags [String]+ deriving Show++instance FromJSON Tags where+ parseJSON (Array arr) = Tags `fmap` mapM toTag list+ where+ list = Vector.toList arr++ toTag (Object obj) = obj .: "name"+ toTag _ = fail "expecting an object"++ parseJSON _ = fail "expecting an array"
+ src/Utils/Paths.hs view
@@ -0,0 +1,31 @@+module Utils.Paths where++import System.FilePath+import qualified Elm.Internal.Name as N+import qualified Elm.Internal.Version as V++internals = "_internals"++libDir = "public" </> "catalog"++json = "docs.json"+index = "index.elm"+listing = "public" </> "libraries.json"+listingBits = "listing.bits"++library name = libDir </> N.toFilePath name++libraryVersion :: N.Name -> V.Version -> FilePath+libraryVersion name version = library name </> show version++moduleToElmFile :: String -> FilePath+moduleToElmFile moduleName = swapDots moduleName ++ ".elm"++moduleToJsonFile :: String -> FilePath+moduleToJsonFile moduleName = "docs" </> swapDots moduleName ++ ".json"++swapDots :: String -> String+swapDots = map (\c -> if c == '.' then '/' else c)++combinedJson :: FilePath+combinedJson = "docs" </> "docs.json"
+ src/Utils/PrettyJson.hs view
@@ -0,0 +1,29 @@++module Utils.PrettyJson where++import Text.JSON+import Text.JSON.Pretty+import Data.Ratio+import Text.PrettyPrint++value value =+ case value 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 [] = lbrack <> rbrack+array vs =+ (if length vs < 2 then sep else vcat) (entries ++ [rbrack])+ where+ entries = zipWith (<+>) (lbrack : repeat comma) (map value vs)++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