diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/elm-get.cabal b/elm-get.cabal new file mode 100644 --- /dev/null +++ b/elm-get.cabal @@ -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 diff --git a/src/Get/Install.hs b/src/Get/Install.hs new file mode 100644 --- /dev/null +++ b/src/Get/Install.hs @@ -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' diff --git a/src/Get/Main.hs b/src/Get/Main.hs new file mode 100644 --- /dev/null +++ b/src/Get/Main.hs @@ -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 diff --git a/src/Get/Publish.hs b/src/Get/Publish.hs new file mode 100644 --- /dev/null +++ b/src/Get/Publish.hs @@ -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: " + +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 diff --git a/src/Get/Registry.hs b/src/Get/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Get/Registry.hs @@ -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 + ] diff --git a/src/Utils/Commands.hs b/src/Utils/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Commands.hs @@ -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 + diff --git a/src/Utils/Http.hs b/src/Utils/Http.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Http.hs @@ -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" diff --git a/src/Utils/Paths.hs b/src/Utils/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Paths.hs @@ -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" diff --git a/src/Utils/PrettyJson.hs b/src/Utils/PrettyJson.hs new file mode 100644 --- /dev/null +++ b/src/Utils/PrettyJson.hs @@ -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