Allow for custom mirror hosts for downloading registered packages

src/CommandLine/Arguments.hs

@@ -93,22 +93,31 @@ installInfo =
     Opt.info args infoModifier
   where
     args =
-        installWith <$> optional package <*> optional version <*> yes
+        installWith
+          <$> optional package
+          <*> optional version
+          <*> optional packageHost
+          <*> yes
 
-    installWith maybeName maybeVersion autoYes =
+    installWith maybeName maybeVersion maybeHost autoYes =
         case (maybeName, maybeVersion) of
           (Nothing, Nothing) ->
-              Install.install autoYes Install.Everything
+              Install.install host autoYes Install.Everything
 
           (Just name, Nothing) ->
-              Install.install autoYes (Install.Latest name)
+              Install.install host autoYes (Install.Latest name)
 
           (Just name, Just version) ->
-              Install.install autoYes (Install.Exactly name version)
+              Install.install host autoYes (Install.Exactly name version)
 
           (Nothing, Just version) ->
               throwError $ Error.BadInstall version
 
+        where
+          host = case maybeHost of
+            Nothing -> Path.defaultHostUrl
+            Just v -> v
+
     infoModifier =
         mconcat
           [ Opt.fullDesc
@@ -155,6 +164,17 @@ yes =
         ]
 
 
+packageHost :: Opt.Parser String
+packageHost =
+    Opt.strOption $
+        mconcat
+        [ Opt.long "host"
+        , Opt.metavar "HOST"
+        , Opt.help "Use HOST instead of https://github.com for grabbing packages"
+        , Opt.value "https://github.com"
+        ]
+
+
 customReader :: String -> (String -> Either String a) -> Opt.ReadM a
 customReader argType fromString =
   let reader arg =

src/Elm/Package/Initialize.hs

@@ -13,9 +13,9 @@ import qualified Reporting.Error as Error
 
 
 
-solution :: (MonadIO m) => Bool -> ExceptT String m S.Solution
-solution autoYes =
-  do  result <- liftIO $ Manager.run $ installEverythingAndGetSolution autoYes
+solution :: (MonadIO m) => String -> Bool -> ExceptT String m S.Solution
+solution host autoYes =
+  do  result <- liftIO $ Manager.run $ installEverythingAndGetSolution host autoYes
       case result of
         Right solution ->
           return solution
@@ -24,9 +24,9 @@ solution autoYes =
           throwError $ Error.toString err
 
 
-installEverythingAndGetSolution :: Bool -> Manager.Manager S.Solution
-installEverythingAndGetSolution autoYes =
-  do  () <- Install.install autoYes Install.Everything
+installEverythingAndGetSolution :: String -> Bool -> Manager.Manager S.Solution
+installEverythingAndGetSolution host autoYes =
+  do  () <- Install.install host autoYes Install.Everything
       exists <- liftIO (doesFileExist Path.solvedDependencies)
       if exists
         then S.read Error.CorruptSolution Path.solvedDependencies

src/Elm/Package/Paths.hs

@@ -45,3 +45,8 @@ packagesDirectory =
 package :: Package.Name -> Package.Version -> FilePath
 package name version =
     packagesDirectory </> Package.toFilePath name </> Package.versionToString version
+
+{-| Default url for downloading zips from -}
+defaultHostUrl :: String
+defaultHostUrl =
+  "https://github.com"

src/Install.hs

@@ -28,8 +28,8 @@ data Args
     | Exactly Package.Name Package.Version
 
 
-install :: Bool -> Args -> Manager.Manager ()
-install autoYes args =
+install :: String -> Bool -> Args -> Manager.Manager ()
+install host autoYes args =
   do  exists <- liftIO (doesFileExist Path.description)
 
       description <-
@@ -40,24 +40,24 @@ install autoYes args =
 
       case args of
         Everything ->
-            upgrade autoYes description
+            upgrade host autoYes description
 
         Latest name ->
             do  version <- latestVersion name
                 newDescription <- addConstraint autoYes name version description
-                upgrade autoYes newDescription
+                upgrade host autoYes newDescription
 
         Exactly name version ->
             do  newDescription <- addConstraint autoYes name version description
-                upgrade autoYes newDescription
+                upgrade host autoYes newDescription
 
 
 
 -- INSTALL EVERYTHING
 
 
-upgrade :: Bool -> Desc.Description -> Manager.Manager ()
-upgrade autoYes desc =
+upgrade :: String -> Bool -> Desc.Description -> Manager.Manager ()
+upgrade host autoYes desc =
   do  newSolution <- Solver.solve (Desc.elmVersion desc) (Desc.dependencies desc)
 
       exists <- liftIO (doesFileExist Path.solvedDependencies)
@@ -73,7 +73,7 @@ upgrade autoYes desc =
       approve <- liftIO (getApproval autoYes plan)
 
       if approve
-        then runPlan newSolution plan
+        then runPlan host newSolution plan
         else liftIO $ putStrLn "Okay, I did not change anything!"
 
 
@@ -90,8 +90,8 @@ getApproval autoYes plan =
           Cmd.yesOrNo
 
 
-runPlan :: Solution.Solution -> Plan.Plan -> Manager.Manager ()
-runPlan solution plan =
+runPlan :: String -> Solution.Solution -> Plan.Plan -> Manager.Manager ()
+runPlan host solution plan =
   do  let installs =
             Map.toList (Plan.installs plan)
             ++ Map.toList (Map.map snd (Plan.upgrades plan))
@@ -101,7 +101,7 @@ runPlan solution plan =
             ++ Map.toList (Map.map fst (Plan.upgrades plan))
 
       -- fetch new dependencies
-      Fetch.everything installs
+      Fetch.everything host installs
 
       -- try to build new dependencies
       liftIO (Solution.write Path.solvedDependencies solution)

src/Install/Fetch.hs

@@ -29,21 +29,21 @@ import qualified Utils.Http as Http
 -- PARALLEL FETCHING
 
 
-everything :: [(Pkg.Name, Pkg.Version)] -> Manager.Manager ()
-everything packages =
-  if null packages then return () else everythingHelp packages
+everything :: String -> [(Pkg.Name, Pkg.Version)] -> Manager.Manager ()
+everything host packages =
+  if null packages then return () else everythingHelp host packages
 
 
-everythingHelp :: [(Pkg.Name, Pkg.Version)] -> Manager.Manager ()
-everythingHelp packages =
+everythingHelp :: String -> [(Pkg.Name, Pkg.Version)] -> Manager.Manager ()
+everythingHelp host packages =
   Cmd.inDir Path.packagesDirectory $
     do  eithers <- liftIO $ do
           startMessage (length packages)
           isTerminal <- hIsTerminalDevice stdout
           resultChan <- Chan.newChan
           forkIO (printLoop isTerminal resultChan)
           withPool 4 $ \pool ->
-            parallel pool (map (prettyFetch resultChan) packages)
+            parallel pool (map (prettyFetch host $ resultChan) packages)
 
         case sequence eithers of
           Right _ ->
@@ -70,9 +70,9 @@ printLoop isTerminal resultChan =
       printLoop isTerminal resultChan
 
 
-prettyFetch :: Chan.Chan Result -> (Pkg.Name, Pkg.Version) -> IO (Either Error.Error ())
-prettyFetch printChan (name, version) =
-  do  either <- Manager.run $ fetch name version
+prettyFetch :: String -> Chan.Chan Result -> (Pkg.Name, Pkg.Version) -> IO (Either Error.Error ())
+prettyFetch host printChan (name, version) =
+  do  either <- Manager.run $ fetch host name version
       Chan.writeChan printChan (Result name version either)
       return either
 
@@ -110,10 +110,10 @@ toDoc (Result name version either) =
 -- FETCH A PACKAGE
 
 
-fetch :: Pkg.Name -> Pkg.Version -> Manager.Manager ()
-fetch name@(Pkg.Name user project) version =
+fetch :: String -> Pkg.Name -> Pkg.Version -> Manager.Manager ()
+fetch host name@(Pkg.Name user project) version =
   ifNotExists name version $
-    do  Http.send (toZipballUrl name version) extract
+    do  Http.send (toZipballUrl host name version) extract
         files <- liftIO $ getDirectoryContents "."
         case List.find (List.isPrefixOf (user ++ "-" ++ project)) files of
           Nothing ->
@@ -126,9 +126,9 @@ fetch name@(Pkg.Name user project) version =
               renameDirectory dir (home </> Pkg.versionToString version)
 
 
-toZipballUrl :: Pkg.Name -> Pkg.Version -> String
-toZipballUrl name version =
-  "https://github.com/" ++ Pkg.toUrl name
+toZipballUrl :: String -> Pkg.Name -> Pkg.Version -> String
+toZipballUrl host name version =
+  host ++ "/" ++ Pkg.toUrl name
   ++ "/zipball/" ++ Pkg.versionToString version ++ "/"