1
1
mirror of https://github.com/nmattia/niv.git synced 2024-11-08 08:26:02 +03:00
niv/Main.hs

300 lines
8.6 KiB
Haskell
Raw Normal View History

2019-01-23 23:55:26 +03:00
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
2019-01-24 23:58:22 +03:00
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
2019-01-23 23:55:26 +03:00
2019-01-18 01:00:48 +03:00
-- TODO: qualified imports
-- TODO: format code
import Control.Monad
2019-01-23 23:55:26 +03:00
import Data.Aeson
import Data.Bifunctor
2019-01-24 23:58:22 +03:00
import Data.Char (toUpper)
2019-01-23 23:55:26 +03:00
import Data.Hashable (Hashable)
2019-01-18 01:00:48 +03:00
import Data.Semigroup ((<>))
2019-01-23 23:55:26 +03:00
import Options.Applicative
2019-01-18 01:00:48 +03:00
import System.Directory
import System.FilePath
2019-01-23 23:55:26 +03:00
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
2019-01-24 23:58:22 +03:00
import qualified Data.HashMap.Strict as HMap
import qualified Data.List.NonEmpty as NE
2019-01-23 23:55:26 +03:00
import qualified Data.Text as T
2019-01-18 01:00:48 +03:00
fileFetchNix :: FilePath
fileFetchNix = "nix" </> "fetch.nix"
2019-01-23 23:55:26 +03:00
-- TODO: file "nix/default.nix"
2019-01-18 01:00:48 +03:00
fileFetchNixContent :: String
fileFetchNixContent = unlines
[
]
fileVersionsJson :: FilePath
fileVersionsJson = "nix" </> "versions.json"
fileVersionsJsonContent :: String
fileVersionsJsonContent = unlines
[
]
2019-01-24 23:58:22 +03:00
newtype VersionsSpec = VersionsSpec
{ unVersionsSpec :: HMap.HashMap PackageName PackageSpec }
deriving newtype (FromJSON, ToJSON)
2019-01-23 23:55:26 +03:00
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 }
2019-01-24 23:58:22 +03:00
deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show)
parsePackageName :: Parser PackageName
parsePackageName = PackageName <$> argument str (metavar "PACKAGE")
2019-01-23 23:55:26 +03:00
newtype PackageSpec = PackageSpec { unPackageSpec :: Object }
2019-01-24 23:58:22 +03:00
deriving newtype (FromJSON, ToJSON, Show)
2019-01-23 23:55:26 +03:00
2019-01-24 23:58:22 +03:00
parsePackageSpec :: Parser PackageSpec
parsePackageSpec =
(PackageSpec . HMap.fromList . fmap fixupAttributes) <$>
many parseAttribute
where
parseAttribute :: Parser (String, String)
parseAttribute = shortcutAttributes <|>
option (maybeReader parseKeyVal)
( long "attribute" <>
short 'a' <>
metavar "KEY=VAL"
)
2019-01-23 23:55:26 +03:00
2019-01-24 23:58:22 +03:00
-- Parse "key=val" into ("key", "val")
parseKeyVal :: String -> Maybe (String, String)
parseKeyVal str = case span (/= '=') str of
(key, '=':val) -> Just (key, val)
_ -> Nothing
-- Shortcuts for common attributes
shortcutAttributes :: Parser (String, String)
shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$>
[ "branch", "name", "owner", "repo" ]
mkShortcutAttribute :: String -> Parser (String, String)
mkShortcutAttribute attr@(c:_) = (attr,) <$> strOption
( long attr <> short c <> metavar (toUpper <$> attr) )
fixupAttributes :: (String, String) -> (T.Text, Value)
fixupAttributes (k, v) = (T.pack k, String (T.pack v))
parsePackage :: Parser (PackageName, PackageSpec)
parsePackage = (,) <$> parsePackageName <*> parsePackageSpec
-- FOOs
2019-01-23 23:55:26 +03:00
preparePackageURL :: PackageSpec -> IO String
preparePackageURL = const $ pure "foo"
-------------------------------------------------------------------------------
-- INIT
-------------------------------------------------------------------------------
parseCmdInit :: ParserInfo (IO ())
parseCmdInit = (info (pure cmdInit <**> helper)) fullDesc
2019-01-18 01:00:48 +03:00
cmdInit :: IO ()
cmdInit = do
putStrLn "Creating directory nix (if it doesn't exist)"
createDirectoryIfMissing True "nix"
putStrLn $ "Creating file " <> fileFetchNix <> " (if it doesn't exist)"
fileFetchNixExists <- doesFileExist fileFetchNix
if fileFetchNixExists
then do
putStrLn $ "Not writing " <> fileFetchNix
putStrLn "(file exists)"
else do
putStrLn $ "Writing " <> fileFetchNix
writeFile fileFetchNix fileFetchNixContent
putStrLn $ "Creating file " <> fileVersionsJson <> " (if it doesn't exist)"
fileVersionsJsonExists <- doesFileExist fileVersionsJson
if fileVersionsJsonExists
then do
putStrLn $ "Not writing " <> fileVersionsJson
putStrLn "(file exists)"
else do
putStrLn $ "Writing " <> fileVersionsJson
writeFile fileVersionsJson fileVersionsJsonContent
2019-01-23 23:55:26 +03:00
-------------------------------------------------------------------------------
-- ADD
-------------------------------------------------------------------------------
2019-01-24 23:58:22 +03:00
parseCmdAdd :: ParserInfo (IO ())
parseCmdAdd = (info ((cmdAdd <$> parsePackages) <**> helper)) fullDesc
where
parsePackages :: Parser [(PackageName, PackageSpec)]
parsePackages = some parsePackage
cmdAdd :: [(PackageName, PackageSpec)] -> IO ()
cmdAdd (package@(packageName, _) : _) = do
2019-01-23 23:55:26 +03:00
putStrLn $ "Adding " <> unPackageName packageName
2019-01-24 23:58:22 +03:00
print package
2019-01-23 23:55:26 +03:00
VersionsSpec versionsSpec <- getVersionsSpec
-- TODO: new package Spec
let fileVersionsValue' = versionsSpec <> HMap.empty
putStrLn $ "Writing new versions file"
encodeFile fileVersionsJson fileVersionsValue'
2019-01-24 23:58:22 +03:00
addCompletePackageSpec
:: (PackageName, PackageSpec)
-> IO (PackageName, PackageSpec)
addCompletePackageSpec x = do
pure x
2019-01-23 23:55:26 +03:00
-------------------------------------------------------------------------------
-- SHOW
-------------------------------------------------------------------------------
2019-01-18 01:00:48 +03:00
2019-01-24 23:58:22 +03:00
parseCmdShow :: ParserInfo (IO ())
parseCmdShow = info (pure cmdShow <**> helper) fullDesc
2019-01-18 01:00:48 +03:00
cmdShow :: IO ()
2019-01-23 23:55:26 +03:00
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
_ -> "<barabajagal>"
putStrLn $ " " <> T.unpack attrName <> ": " <> T.unpack attrValue
-------------------------------------------------------------------------------
-- UPDATE
-------------------------------------------------------------------------------
2019-01-18 01:00:48 +03:00
2019-01-24 23:58:22 +03:00
parseCmdUpdate :: ParserInfo (IO ())
parseCmdUpdate = info (pure cmdUpdate <**> helper) fullDesc
2019-01-18 01:00:48 +03:00
cmdUpdate :: IO ()
2019-01-23 23:55:26 +03:00
cmdUpdate = do
putStrLn $ "Updating versions file"
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'
2019-01-18 01:00:48 +03:00
2019-01-23 23:55:26 +03:00
parseCommand :: Parser (IO ())
parseCommand = subparser (
command "init" parseCmdInit <>
2019-01-24 23:58:22 +03:00
command "add" parseCmdAdd <>
command "show" parseCmdShow <>
command "update" parseCmdUpdate )
2019-01-18 01:00:48 +03:00
main :: IO ()
2019-01-23 23:55:26 +03:00
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