From 8ceb834aa0c851af5605b09e1d1fcd0c4c728f13 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Wed, 23 Jan 2019 21:55:26 +0100 Subject: [PATCH] Add basic implementation for cmds --- Main.hs | 189 +++++++++++++++++++++++++++++++++++++++++++++++---- README.md | 40 +++++------ package.yaml | 2 + 3 files changed, 199 insertions(+), 32 deletions(-) diff --git a/Main.hs b/Main.hs index 451e2d1..a4316ce 100644 --- a/Main.hs +++ b/Main.hs @@ -1,15 +1,29 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + -- TODO: qualified imports -- TODO: format code -import Options.Applicative import Control.Monad +import Data.Aeson +import Data.Bifunctor +import Data.HashMap.Strict as HMap +import Data.Hashable (Hashable) import Data.Semigroup ((<>)) +import Options.Applicative import System.Directory import System.FilePath +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T fileFetchNix :: FilePath fileFetchNix = "nix" "fetch.nix" +-- TODO: file "nix/default.nix" + fileFetchNixContent :: String fileFetchNixContent = unlines [ @@ -26,6 +40,44 @@ fileVersionsJsonContent = unlines ] +getVersionsSpec :: IO VersionsSpec +getVersionsSpec = do + putStrLn $ "Reading versions file" + decodeFileStrict fileVersionsJson >>= \case + Just (Object v) -> + fmap (VersionsSpec . mconcat) $ + forM (HMap.toList v) $ \(k, v) -> + case v of + Object v' -> + pure $ HMap.singleton (PackageName (T.unpack k)) (PackageSpec v') + _ -> error "baaaaz" + Just _ -> error "foo" + Nothing -> error "Cannot decode versions" + + +newtype PackageName = PackageName { unPackageName :: String } + deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey) + +newtype PackageSpec = PackageSpec { unPackageSpec :: Object } + deriving newtype (FromJSON, ToJSON) + +newtype VersionsSpec = VersionsSpec + { unVersionsSpec :: HMap.HashMap PackageName PackageSpec } + deriving newtype (FromJSON, ToJSON) + +parsePackageName :: Parser PackageName +parsePackageName = undefined + +preparePackageURL :: PackageSpec -> IO String +preparePackageURL = const $ pure "foo" + +------------------------------------------------------------------------------- +-- INIT +------------------------------------------------------------------------------- + +parseCmdInit :: ParserInfo (IO ()) +parseCmdInit = (info (pure cmdInit <**> helper)) fullDesc + cmdInit :: IO () cmdInit = do putStrLn "Creating directory nix (if it doesn't exist)" @@ -53,21 +105,134 @@ cmdInit = do putStrLn $ "Writing " <> fileVersionsJson writeFile fileVersionsJson fileVersionsJsonContent -cmdAdd :: IO () -cmdAdd = putStrLn "add" +------------------------------------------------------------------------------- +-- ADD +------------------------------------------------------------------------------- + +cmdAdd :: PackageName -> IO () +cmdAdd packageName = do + putStrLn $ "Adding " <> unPackageName packageName + + VersionsSpec versionsSpec <- getVersionsSpec + + -- TODO: new package Spec + let fileVersionsValue' = versionsSpec <> HMap.empty + + putStrLn $ "Writing new versions file" + encodeFile fileVersionsJson fileVersionsValue' + +------------------------------------------------------------------------------- +-- SHOW +------------------------------------------------------------------------------- cmdShow :: IO () -cmdShow = putStrLn "show" +cmdShow = do + putStrLn $ "Showing versions file" + + VersionsSpec fileVersionsValue <- getVersionsSpec + + forWithKeyM_ fileVersionsValue $ \key (PackageSpec spec) -> do + putStrLn $ "Package: " <> unPackageName key + forM_ (HMap.toList spec) $ \(attrName, attrValValue) -> do + let attrValue = case attrValValue of + String str -> str + _ -> "" + putStrLn $ " " <> T.unpack attrName <> ": " <> T.unpack attrValue + +------------------------------------------------------------------------------- +-- UPDATE +------------------------------------------------------------------------------- cmdUpdate :: IO () -cmdUpdate = putStrLn "update" +cmdUpdate = do + putStrLn $ "Updating versions file" -opts :: Parser (IO ()) -opts = subparser ( - command "init" (info (pure cmdInit) idm) <> - command "add" (info (pure cmdAdd) idm) <> - command "show" (info (pure cmdAdd) idm) <> - command "update" (info (pure cmdAdd) idm) ) + VersionsSpec fileVersionsValue <- getVersionsSpec + + fileVersionsValue' <- forWithKeyM fileVersionsValue $ \key spec -> do + putStrLn $ "Package: " <> unPackageName key + + packageUrl <- preparePackageURL spec + + putStrLn $ " URL: " <> packageUrl + + sha256 <- nixPrefetchURL packageUrl + + putStrLn $ " SHA256: " <> sha256 + + putStrLn $ "Writing new versions file" + encodeFile fileVersionsJson fileVersionsValue' + +parseCommand :: Parser (IO ()) +parseCommand = subparser ( + command "init" parseCmdInit <> + command "add" (info (cmdAdd <$> parsePackageName) idm) <> + command "show" (info (pure cmdShow) idm) <> + command "update" (info (pure cmdUpdate) idm) ) main :: IO () -main = join $ execParser (info opts idm) +main = join $ execParser opts + where + opts = info (parseCommand <**> helper) + ( fullDesc + <> header "NIV - Nix Version manager" ) + +nixPrefetchURL :: String -> IO String +nixPrefetchURL = pure + +------------------------------------------------------------------------------- +-- Aux +------------------------------------------------------------------------------- + +--- Aeson + +-- | Efficiently deserialize a JSON value from a file. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- The input file's content must consist solely of a JSON document, +-- with no trailing data except for whitespace. +-- +-- This function parses immediately, but defers conversion. See +-- 'json' for details. +decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) +decodeFileStrict = fmap decodeStrict . B.readFile + +-- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file. +encodeFile :: (ToJSON a) => FilePath -> a -> IO () +encodeFile fp = L.writeFile fp . encode + +--- HashMap + +forWithKeyM + :: (Eq k, Hashable k, Monad m) + => HMap.HashMap k v1 + -> (k -> v1 -> m v2) + -> m (HMap.HashMap k v2) +forWithKeyM = flip mapWithKeyM + +forWithKeyM_ + :: (Eq k, Hashable k, Monad m) + => HMap.HashMap k v1 + -> (k -> v1 -> m ()) + -> m () +forWithKeyM_ = flip mapWithKeyM_ + + +mapWithKeyM + :: (Eq k, Hashable k, Monad m) + => (k -> v1 -> m v2) + -> HMap.HashMap k v1 + -> m (HMap.HashMap k v2) +mapWithKeyM f m = do + fmap mconcat $ forM (HMap.toList m) $ \(k, v) -> + HMap.singleton k <$> f k v + +mapWithKeyM_ + :: (Eq k, Hashable k, Monad m) + => (k -> v1 -> m ()) + -> HMap.HashMap k v1 + -> m () +mapWithKeyM_ f m = do + forM_ (HMap.toList m) $ \(k, v) -> + HMap.singleton k <$> f k v diff --git a/README.md b/README.md index 09fab14..70c5b83 100644 --- a/README.md +++ b/README.md @@ -8,9 +8,9 @@ Inside the provided nix shell: ``` bash $ # GHCi: -$ snack ghci -p package.yaml +$ snack ghci $ # actual build: -$ snack build -p package.yaml +$ snack build ``` ## Usage @@ -48,24 +48,6 @@ let pkgs = import fetch.nixpkgs; 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. - -#### update - -* `[p [--commit] [--branch]]` - - `[]`: all packages are updated - - `[p1 p2 ...]`: the specified packages are updated - -* `--commit `: `rev` is set to `` and the package is prefetched -* `--branch `: `branch` is set to ``, `rev` is set to the - latest revision on that branch and the package is prefetched - #### add * ``: adds the following to the versions file where `let = ` @@ -85,6 +67,24 @@ in pkgs.hello * `--gitlab`: use gitlab instead of GitHub * `--attribute `: sets `` to `` +#### update + +* `[p [--commit] [--branch]]` + - `[]`: all packages are updated + - `[p1 p2 ...]`: the specified packages are updated + +* `--commit `: `rev` is set to `` and the package is prefetched +* `--branch `: `branch` is set to ``, `rev` is set to the + latest revision on that branch and the package is prefetched + +#### 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. + **NOTE**: should the URLs be used instead? or more simply, how do we differentiate between Gitlab/GitHub? [Nix]: https://nixos.org/nix/ diff --git a/package.yaml b/package.yaml index c420a62..69dad69 100644 --- a/package.yaml +++ b/package.yaml @@ -4,6 +4,8 @@ executable: source-dirs: . # remove when https://github.com/nmattia/snack/pull/96 is merged main: Main.hs dependencies: + - aeson - directory - filepath - optparse-applicative + - unordered-containers