Add attr discovery

Main.hs

@@ -9,11 +9,15 @@
 -- TODO: format code
 
 import Control.Monad
+import Control.Monad.State
 import Data.Aeson
 import Data.Bifunctor
 import Data.Char (toUpper)
 import Data.Hashable (Hashable)
+import Data.Maybe (mapMaybe)
 import Data.Semigroup ((<>))
+import Data.String
+import GHC.Exts (toList)
 import Options.Applicative
 import System.Directory
 import System.FilePath
@@ -22,6 +26,8 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.HashMap.Strict as HMap
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
+import qualified GitHub as GH
+import qualified GitHub.Data.Name as GH
 
 fileFetchNix :: FilePath
 fileFetchNix = "nix" </> "fetch.nix"
@@ -62,7 +68,6 @@ getVersionsSpec = do
       Just _ -> error "foo"
       Nothing -> error "Cannot decode versions"
 
-
 newtype PackageName = PackageName { unPackageName :: String }
   deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show)
 
@@ -106,10 +111,62 @@ parsePackageSpec =
 parsePackage :: Parser (PackageName, PackageSpec)
 parsePackage = (,) <$> parsePackageName <*> parsePackageSpec
 
--- FOOs
+-------------------------------------------------------------------------------
+-- PackageSpec State helpers
+-------------------------------------------------------------------------------
 
-preparePackageURL :: PackageSpec -> IO String
+whenNotSet
-preparePackageURL = const $ pure "foo"
+  :: T.Text
+  -> StateT (PackageName, PackageSpec) IO ()
+  -> StateT (PackageName, PackageSpec) IO ()
+whenNotSet attrName act = getPackageSpecAttr attrName >>= \case
+  Just _ -> pure ()
+  Nothing -> act
+
+withPackageSpecAttr
+  :: T.Text
+  -> (Value -> StateT (PackageName, PackageSpec) IO ())
+  -> StateT (PackageName, PackageSpec) IO ()
+withPackageSpecAttr attrName act = getPackageSpecAttr attrName >>= \case
+  Just v -> act v
+  Nothing -> pure ()
+
+getPackageSpecAttr
+  :: T.Text
+  -> StateT (PackageName, PackageSpec) IO (Maybe Value)
+getPackageSpecAttr attrName = do
+  (_, PackageSpec obj) <- get
+  pure $ HMap.lookup attrName obj
+
+setPackageSpecAttr
+  :: T.Text -> Value
+  -> StateT (PackageName, PackageSpec) IO ()
+setPackageSpecAttr attrName attrValue = do
+  (packageName, PackageSpec obj) <- get
+  let obj' = HMap.insert attrName attrValue obj
+  put (packageName, PackageSpec obj')
+
+setPackageName
+  :: String -> StateT (PackageName, PackageSpec) IO ()
+setPackageName packageName = do
+  (_, spec) <- get
+  put (PackageName packageName, spec)
+
+hasPackageSpecAttrs
+  :: [String]
+  -> StateT (PackageName, PackageSpec) IO Bool
+hasPackageSpecAttrs attrNames = do
+  (_, PackageSpec obj) <- get
+  pure $ all (\k -> HMap.member (T.pack k) obj) attrNames
+
+
+packageSpecStringValues :: PackageSpec -> [(String, String)]
+packageSpecStringValues (PackageSpec m) = mapMaybe toVal (HMap.toList m)
+  where
+    toVal :: (T.Text, Value) -> Maybe (String, String)
+    toVal = \case
+      (key, String val) -> Just (T.unpack key, T.unpack val)
+      _ -> Nothing
 
 -------------------------------------------------------------------------------
 -- INIT
@@ -150,31 +207,79 @@ cmdInit = do
 -------------------------------------------------------------------------------
 
 parseCmdAdd :: ParserInfo (IO ())
-parseCmdAdd = (info ((cmdAdd <$> parsePackages) <**> helper)) fullDesc
+parseCmdAdd = (info ((cmdAdd <$> parsePackage) <**> helper)) fullDesc
-  where
-    parsePackages :: Parser [(PackageName, PackageSpec)]
-    parsePackages = some parsePackage
 
-cmdAdd :: [(PackageName, PackageSpec)] -> IO ()
+cmdAdd :: (PackageName, PackageSpec) -> IO ()
-cmdAdd (package@(packageName, _) : _) = do
+cmdAdd package = do
-    putStrLn $ "Adding " <> unPackageName packageName
 
-    print package
+    (packageName, packageSpec) <- addCompletePackageSpec package
-    VersionsSpec versionsSpec <- getVersionsSpec
-
-    -- TODO: new package Spec
-    let fileVersionsValue' = versionsSpec <> HMap.empty
 
+    versionsSpec <- HMap.insert packageName packageSpec . unVersionsSpec <$>
+      getVersionsSpec
     putStrLn $ "Writing new versions file"
-    encodeFile fileVersionsJson fileVersionsValue'
+    print versionsSpec
+    -- encodeFile fileVersionsJson fileVersionsValue'
 
 addCompletePackageSpec
   :: (PackageName, PackageSpec)
   -> IO (PackageName, PackageSpec)
-addCompletePackageSpec x = do
+addCompletePackageSpec x@(PackageName str, _) = flip execStateT x $ do
 
+    -- Figures out the owner and repo
+    case span (/= '/') str of
+          (owner@(_:_), '/':repo@(_:_)) -> do
+            whenNotSet "owner" $
+              setPackageSpecAttr "owner" (String $ T.pack owner)
+            whenNotSet "repo" $ do
+                setPackageSpecAttr "repo" (String $ T.pack repo)
+                setPackageName repo
+          _ -> pure ()
 
-    pure x
+    -- In case we have @owner@ and @repo@, pull some data from GitHub
+    (,) <$> getPackageSpecAttr "owner" <*> getPackageSpecAttr "repo" >>= \case
+      (Just (String owner), Just (String repo)) -> do
+          liftIO (GH.executeRequest' $ GH.repositoryR (GH.N owner) (GH.N repo))
+            >>= \case
+              Right ghRepo -> do
+
+                -- Description
+                whenNotSet "description" $ case GH.repoDescription ghRepo of
+                  Just descr -> setPackageSpecAttr "description" (String descr)
+                  Nothing -> pure ()
+
+                -- Branch and rev
+                whenNotSet "branch" $ case GH.repoDefaultBranch ghRepo of
+                  Just branch -> do
+                    setPackageSpecAttr "branch" (String branch)
+                    liftIO (GH.executeRequest' $
+                      GH.commitsWithOptionsForR
+                      (GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
+                      [GH.CommitQuerySha branch]) >>= \case
+                        Right (toList -> (commit:_)) -> do
+                          let GH.N rev = GH.commitSha commit
+                          setPackageSpecAttr "rev" (String rev)
+                        _ -> pure ()
+                  Nothing -> pure ()
+
+    -- Figures out the URL template
+    whenNotSet "url_template" $
+      setPackageSpecAttr "url_template" (String $ T.pack githubURLTemplate)
+
+    -- Figures out the URL from the template
+    withPackageSpecAttr "url_template" (\case
+      String (T.unpack -> template) -> do
+        (_, packageSpec) <- get
+        let stringValues = packageSpecStringValues packageSpec
+        case renderTemplate stringValues template of
+          Just renderedURL ->
+            setPackageSpecAttr "url" (String $ T.pack renderedURL)
+          Nothing -> pure ()
+      _ -> pure ()
+      )
+  where
+    githubURLTemplate :: String
+    githubURLTemplate =
+      "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
 
 -------------------------------------------------------------------------------
 -- SHOW
@@ -202,10 +307,10 @@ cmdShow = do
 -------------------------------------------------------------------------------
 
 parseCmdUpdate :: ParserInfo (IO ())
-parseCmdUpdate = info (pure cmdUpdate <**> helper) fullDesc
+parseCmdUpdate = info ((cmdUpdate <$> parsePackage) <**> helper) fullDesc
 
-cmdUpdate :: IO ()
+cmdUpdate :: (PackageName, PackageSpec) -> IO ()
-cmdUpdate = do
+cmdUpdate pkgs = do
     putStrLn $ "Updating versions file"
 
     VersionsSpec fileVersionsValue <- getVersionsSpec
@@ -213,13 +318,14 @@ cmdUpdate = do
     fileVersionsValue' <- forWithKeyM fileVersionsValue $ \key spec -> do
       putStrLn $ "Package: " <> unPackageName key
 
-      packageUrl <- preparePackageURL spec
+      -- TODO: use StateT
+      -- let packageUrl <- renderTemplate
 
-      putStrLn $ "  URL: " <> packageUrl
+      -- putStrLn $ "  URL: " <> packageUrl
 
-      sha256 <- nixPrefetchURL packageUrl
+      -- sha256 <- nixPrefetchURL packageUrl
 
-      putStrLn $ " SHA256: " <> sha256
+      -- putStrLn $ " SHA256: " <> sha256
 
     putStrLn $ "Writing new versions file"
     encodeFile fileVersionsJson fileVersionsValue'
@@ -297,3 +403,18 @@ mapWithKeyM_
 mapWithKeyM_ f m = do
     forM_ (HMap.toList m) $ \(k, v) ->
       HMap.singleton k <$> f k v
+
+-- | Renders the template. Returns 'Nothing' if some of the attributes are
+-- missing.
+--
+--  renderTemplate [("foo", "bar")] "<foo>" == Just "bar"
+--  renderTemplate [("foo", "bar")] "<baz>" == Nothing
+renderTemplate :: [(String, String)] -> String -> Maybe String
+renderTemplate vals = \case
+    '<':str -> do
+      case span (/= '>') str of
+        (key, '>':rest) ->
+          liftA2 (<>) (lookup key vals) (renderTemplate vals rest)
+
+    c:str -> (c:) <$> renderTemplate vals str
+    [] -> Just []

README.md

@@ -80,6 +80,8 @@ in pkgs.hello
 * `--gitlab`: use gitlab instead of GitHub
 * `--attribute <attribute> <value>`: sets `<attribute>` to `<value>`
 
+If the package already exists, merges with the package (prior to heuristics)
+
 #### update
 
 * `[p [--commit] [--branch]]`
@@ -92,11 +94,13 @@ in pkgs.hello
 
 #### show
 
-`[--branch] [--rev] [--owner] [--repo] [--attribute <attribute>] <p1> <p2>`...
+* Shows all packages
-  if no attribute (br, rev, ...) is given, all attributes are shown for
+
-  `<packages>`.  Otherwise the specified attributes are shown. If no package is
+#### drop
-  specified: `<packages> = <all packages>`, otherwise `<packages>` is set to
+
-  the specified packages.
+`<p1> <p2>`
+
+* Drops the specified packages
 
 **NOTE**: should the URLs be used instead? or more simply, how do we differentiate between Gitlab/GitHub?
 

package.yaml

@@ -7,5 +7,7 @@ executable:
         - aeson
         - directory
         - filepath
+        - github
+        - mtl
         - optparse-applicative
         - unordered-containers