From 7628070e98b237781c33ec7b81144e400fa2408a Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 26 Jan 2019 23:39:38 +0100 Subject: [PATCH] Add attr discovery --- Main.hs | 173 +++++++++++++++++++++++++++++++++++++++++++-------- README.md | 14 +++-- package.yaml | 2 + 3 files changed, 158 insertions(+), 31 deletions(-) diff --git a/Main.hs b/Main.hs index c12e3ea..5a93b48 100644 --- a/Main.hs +++ b/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 -preparePackageURL = const $ pure "foo" +whenNotSet + :: 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 - where - parsePackages :: Parser [(PackageName, PackageSpec)] - parsePackages = some parsePackage +parseCmdAdd = (info ((cmdAdd <$> parsePackage) <**> helper)) fullDesc -cmdAdd :: [(PackageName, PackageSpec)] -> IO () -cmdAdd (package@(packageName, _) : _) = do - putStrLn $ "Adding " <> unPackageName packageName +cmdAdd :: (PackageName, PackageSpec) -> IO () +cmdAdd package = do - print package - VersionsSpec versionsSpec <- getVersionsSpec - - -- TODO: new package Spec - let fileVersionsValue' = versionsSpec <> HMap.empty + (packageName, packageSpec) <- addCompletePackageSpec package + 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///archive/.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 = do +cmdUpdate :: (PackageName, PackageSpec) -> IO () +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")] "" == Just "bar" +-- renderTemplate [("foo", "bar")] "" == 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 [] diff --git a/README.md b/README.md index 0b2e6ff..a02b16f 100644 --- a/README.md +++ b/README.md @@ -80,6 +80,8 @@ in pkgs.hello * `--gitlab`: use gitlab instead of GitHub * `--attribute `: sets `` to `` +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 ] `... - if no attribute (br, rev, ...) is given, all attributes are shown for - ``. Otherwise the specified attributes are shown. If no package is - specified: ` = `, otherwise `` is set to - the specified packages. +* Shows all packages + +#### drop + +` ` + +* Drops the specified packages **NOTE**: should the URLs be used instead? or more simply, how do we differentiate between Gitlab/GitHub? diff --git a/package.yaml b/package.yaml index 69dad69..a90d974 100644 --- a/package.yaml +++ b/package.yaml @@ -7,5 +7,7 @@ executable: - aeson - directory - filepath + - github + - mtl - optparse-applicative - unordered-containers