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
|