Allow install via tag, commit, or branch

executable/Subcommands.hs

@@ -25,6 +25,8 @@ import Morloc.Data.Doc
 import Text.Megaparsec.Error (errorBundlePretty)
 import qualified Data.Map as Map
 import Morloc.CodeGenerator.Generate (generatePools)
+import System.Exit (exitFailure)
+import System.IO (hPutStrLn, stderr)
 
 
 runMorloc :: CliCommand -> IO ()
@@ -66,16 +68,24 @@ readScript _ filename = do
   return (Just filename, Code code)
 
 
--- | install a module
+-- | Install a module
 cmdInstall :: InstallCommand -> Int -> Config.Config -> IO ()
-cmdInstall args verbosity conf =
-  MM.runMorlocMonad Nothing verbosity conf cmdInstall' >>= MM.writeMorlocReturn
+cmdInstall args verbosity conf = MM.runMorlocMonad Nothing verbosity conf cmdInstall' >>= MM.writeMorlocReturn
   where
-    cmdInstall' = do
-      let name' = installModuleName args
-      if installGithub args
-        then Mod.installModule (Mod.GithubRepo name') Nothing
-        else Mod.installModule (Mod.CoreGithubRepo name') (Just $ configPlane conf)
+    modName = installModuleName args
+    selector = installSelector args
+
+    cmdInstall'
+      | modName == "." = Mod.installModule (LocalModule Nothing) Nothing
+      | (head modName) `elem` ['.', '/'] = Mod.installModule (LocalModule (Just modName)) Nothing
+      | installGithub args = installGithubModule modName selector
+      | otherwise = Mod.installModule (GithubRepo (configPlane conf) modName selector) (Just $ configPlane conf)
+
+    installGithubModule :: String -> GithubSnapshotSelector -> MorlocMonad ()
+    installGithubModule fullName selector = case break (== '/') fullName of
+      (username, '/':repo) -> Mod.installModule (GithubRepo username repo selector) Nothing
+      _ -> do
+        MM.throwError . ModuleInstallError $ "Error: Expected \"<username>/<repo>\" format for GitHub module name"
 
 -- | build a Morloc program, generating the nexus and pool files
 cmdMake :: MakeCommand -> Int -> Config.Config -> IO ()

executable/UI.hs

@@ -9,6 +9,7 @@ module UI (
 ) where
 
 import Options.Applicative
+import Morloc.Namespace
 import qualified Options.Applicative.Extra as OAE
 
 version :: String
@@ -84,6 +85,7 @@ data InstallCommand = InstallCommand
   , installGithub :: Bool
   , installVanilla :: Bool
   , installModuleName :: String
+  , installSelector :: GithubSnapshotSelector
   }
 
 makeInstallParser :: Parser InstallCommand
@@ -93,6 +95,25 @@ makeInstallParser = InstallCommand
   <*> optGithub
   <*> optVanilla
   <*> optModuleName
+  <*> optSelector
+
+optSelector :: Parser GithubSnapshotSelector
+optSelector = branchOption <|> commitOption <|> tagOption <|> pure LatestDefaultBranch
+  where
+    branchOption = LatestOnBranch <$> strOption
+      (  long "branch"
+      <> metavar "BRANCH"
+      <> help "Retrieve snapshot from a specific branch" )
+
+    commitOption = CommitHash <$> strOption
+      (  long "commit"
+      <> metavar "HASH"
+      <> help "Retrieve snapshot from a specific commit hash" )
+
+    tagOption = ReleaseTag <$> strOption
+      (  long "tag"
+      <> metavar "TAG"
+      <> help "Retrieve snapshot from a specific tag" )
 
 installSubcommand :: Mod CommandFields CliCommand
 installSubcommand = command "install" (info (CmdInstall <$> makeInstallParser) (progDesc "install a morloc module"))

library/Morloc/Module.hs

@@ -16,8 +16,7 @@ All information about morloc module structure should be defined here.
  * installation of modules from github
 -}
 module Morloc.Module
-  ( ModuleSource(..)
-  , installModule
+  ( installModule
   , findModule
   , loadModuleMetadata
   , handleFlagsAndPaths
@@ -32,14 +31,26 @@ import qualified Morloc.Monad as MM
 import qualified Morloc.System as MS
 import qualified Data.Yaml.Config as YC
 
--- | Specify where a module is located
-data ModuleSource
-  = LocalModule (Maybe String)
-  -- ^ A module in the working directory
-  | GithubRepo String
-  -- ^ A module stored in an arbitrary Github repo: "<username>/<reponame>"
-  | CoreGithubRepo String
-  -- ^ The repo name of a core package, e.g., "math"
+-- needed for github retrieval
+import qualified Data.ByteString.Lazy as BL
+import qualified Codec.Archive.Zip as Zip
+import Network.HTTP.Simple
+import System.Directory
+import System.FilePath
+import Control.Monad
+import Control.Exception
+import Data.Maybe (fromMaybe)
+import Data.Aeson
+import System.IO (hClose)
+
+
+
+data RepoInfo = RepoInfo { defaultBranch :: MT.Text } deriving Show
+
+instance FromJSON RepoInfo where
+    parseJSON = withObject "RepoInfo" $ \v -> RepoInfo
+        <$> v .: "default_branch"
+
 
 -- | Look for a local morloc module.
 findModule :: Maybe (Path, MVar) -> MVar -> MorlocMonad Path
@@ -321,30 +332,67 @@ getFile x = do
       then Just x
       else Nothing
 
--- | Attempt to clone a package from github
-installGithubRepo ::
-     String -- ^ the repo path ("<username>/<reponame>")
-  -> [String] -- ^ directory path (e.g., ["github"], or ["plane", "rbase"] for core)
-  -> String -- ^ the url for github (e.g., "https://github.com/")
-  -> MorlocMonad ()
-installGithubRepo repo dirPath url = do
-  config <- MM.ask
-  let path = foldl MS.combine (Config.configLibrary config) (dirPath <> [repo])
-      cmd = unwords ["git clone", url, path]
-  MM.runCommand "installGithubRepo" (MT.pack cmd)
 
 -- | Install a morloc module
 installModule
     :: ModuleSource
     -> Maybe Path -- plane path
     -> MorlocMonad ()
-installModule (GithubRepo repo) _ =
-  installGithubRepo repo ["github"] ("https://github.com/" <> repo) -- repo has form "user/reponame"
-installModule (CoreGithubRepo name') (Just plane) = do
-  planeDir <- MM.asks configPlane
-  installGithubRepo name' ["plane", plane] ("https://github.com/" <> planeDir <> "/" <> name')
+installModule (GithubRepo user repo selector) _ = do
+  libPath <- MM.asks Config.configLibrary
+  result <- liftIO $ retrieveGitHubSnapshot user repo (libPath </> "github" </> user </> repo) selector
+  maybe (return ()) (MM.throwError . ModuleInstallError . MT.pack) result
+installModule (CoreGithubRepo repo selector) (Just plane) = do
+  libPath <- MM.asks Config.configLibrary
+  planeDir <- MM.asks Config.configPlane
+  result <- liftIO $ retrieveGitHubSnapshot planeDir repo (libPath </> "plane" </> plane) selector
+  maybe (return ()) (MM.throwError . ModuleInstallError . MT.pack) result
 installModule (LocalModule Nothing) _ =
   MM.throwError (NotImplemented "module installation from working directory")
 installModule (LocalModule (Just _)) _ =
   MM.throwError (NotImplemented "module installation from local directory")
 installModule _ _ = undefined
+
+
+retrieveGitHubSnapshot
+  :: String -- github user/org name
+  -> String -- github repo name
+  -> FilePath -- path to installation folder
+  -> GithubSnapshotSelector -- snapshot specifier (latest default branch, commit hash, or tag)
+  -> IO (Maybe String) -- Nothing if all is good, Just error message otherwise
+retrieveGitHubSnapshot username repo finalPath selector = handle handleException $ do
+    pathExists <- doesDirectoryExist finalPath
+    if pathExists
+        then return $ Just $ "Path " ++ finalPath ++ " already exists."
+        else do
+            snapshotIdent <- case selector of
+                LatestDefaultBranch -> getDefaultBranch username repo
+                LatestOnBranch branch -> return branch
+                CommitHash hash -> return hash
+                ReleaseTag tag -> return $ "refs/tags/" ++ tag
+
+            zipContent <- downloadZip username repo snapshotIdent
+            let archive = Zip.toArchive zipContent
+            createDirectoryIfMissing True finalPath
+            Zip.extractFilesFromArchive [Zip.OptDestination finalPath] archive
+
+            return Nothing
+
+  where
+    handleException :: SomeException -> IO (Maybe String)
+    handleException e = return $ Just $ "Error: " ++ show e
+
+    getDefaultBranch :: String -> String -> IO String
+    getDefaultBranch user repo = do
+        let apiUrl = "https://api.github.com/repos/" ++ user ++ "/" ++ repo
+        request <- parseRequest apiUrl
+        response <- httpJSON request
+        let repoInfo = getResponseBody response :: RepoInfo
+        return $ MT.unpack $ defaultBranch repoInfo
+
+    downloadZip :: String -> String -> String -> IO BL.ByteString
+    downloadZip user repo ident = do
+        let url = "https://github.com/" ++ user ++ "/" ++ repo ++ "/archive/" ++ ident ++ ".zip"
+        request <- parseRequest url
+        response <- httpLBS request
+        return $ getResponseBody response

library/Morloc/Namespace.hs

@@ -120,6 +120,9 @@ module Morloc.Namespace
   , NexusSource(..)
   -- sockets
   , Socket(..)
+  -- module installation and github
+  , GithubSnapshotSelector(..)
+  , ModuleSource(..)
   ) where
 
 import Morloc.Language (Lang(..))
@@ -416,6 +419,23 @@ data Socket = Socket
   }
   deriving (Show)
 
+data GithubSnapshotSelector
+  = LatestDefaultBranch
+  | LatestOnBranch String
+  | CommitHash String
+  | ReleaseTag String
+  deriving (Show, Eq, Ord)
+
+-- | Specify where a module is located
+data ModuleSource
+  = LocalModule (Maybe String)
+  -- ^ A module in the working directory
+  | GithubRepo String String GithubSnapshotSelector
+  -- ^ A module stored in an arbitrary users repo, e.g., (GithubRepo "weena" "math")
+  | CoreGithubRepo String GithubSnapshotSelector
+  -- ^ The repo name of a core package, e.g., "math"
+  deriving (Show, Eq, Ord)
+
 type MorlocMonad a = MorlocMonadGen Config MorlocError [Text] MorlocState a
 
 data SysCommand
@@ -700,6 +720,8 @@ data MorlocError
   | UnknownLanguage Text
   -- | Raised when a module cannot be loaded
   | CannotLoadModule Text
+  -- | Raised when a module cannot be installed
+  | ModuleInstallError Text
   -- | System call failed
   | SystemCallError Text Text Text
   -- | Raised when there is an error in the code generators
@@ -1340,6 +1362,7 @@ instance Pretty MorlocError where
   pretty (SyntaxError err') = "SyntaxError: " <> pretty (errorBundlePretty err')
   pretty (SerializationError t) = "SerializationError: " <> pretty t
   pretty (CannotLoadModule t) = "CannotLoadModule: " <> pretty t
+  pretty (ModuleInstallError t) = "ModuleInstallError: " <> pretty t 
   pretty (SystemCallError cmd loc msg) =
     "System call failed at (" <>
     pretty loc <> "):\n" <> " cmd> " <> pretty cmd <> "\n" <> " msg>\n" <> pretty msg

package.yaml

@@ -41,6 +41,7 @@ dependencies:
   - filepath
   - file-embed
   - haskell-src-meta
+  - http-conduit
   - megaparsec
   - mtl
   - parsec
@@ -55,6 +56,7 @@ dependencies:
   - text
   - unordered-containers
   - yaml
+  - zip-archive
 
 ghc-options:
   - -Wall
@@ -83,15 +85,7 @@ executables:
       - -rtsopts
       - -with-rtsopts=-N
       - -O2
-      # The static build requires a static `libgmp.a` file
-      # On arch, this requires libgmp-static from AUR
-      # On debian systems, libgmp-dev should cover it
-      - -static
       - -haddock
-    cc-options:
-      - -static
-    ld-options:
-      - -static
     dependencies:
       - morloc 
       - base