{-# LANGUAGE NoImplicitPrelude, DeriveGeneric, OverloadedStrings, RecordWildCards, LambdaCase #-}
module Distribution.Nodejs.Package
(
LoggingPackage(..), decode
, Warning(..), formatWarning
, Package(..)
, Bin(..), Man(..), Dependencies
) where
import Protolude hiding (packageName)
import Control.Monad (fail)
import qualified Control.Monad.Writer.Lazy as WL
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.HashMap.Lazy as HML
import qualified System.FilePath as FP
import Data.Aeson ((.:), (.:?), (.!=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as AT
data Package = Package
{ name :: Text
, version :: Text
, description :: Maybe Text
, homepage :: Maybe Text
, private :: Bool
, scripts :: HML.HashMap Text Text
, bin :: Bin
, man :: Man
, license :: Maybe Text
, dependencies :: Dependencies
, devDependencies :: Dependencies
} deriving (Show, Eq)
newtype LoggingPackage = LoggingPackage
{ unLoggingPackage :: (Package, [Warning]) }
data Warning
= WrongType
{ wrongTypeField :: Text
, wrongTypeDefault :: Maybe Text
}
| PlainWarning Text
data Bin
= BinFiles (HML.HashMap Text FilePath)
| BinFolder FilePath
deriving (Show, Eq)
data Man
= ManFiles (HML.HashMap Text FilePath)
deriving (Show, Eq)
type Dependencies = HML.HashMap Text Text
type Warn = WL.WriterT [Warning] AT.Parser
putWarning :: a -> Warning -> Warn a
putWarning a w = WL.writer (a, [w])
instance A.FromJSON LoggingPackage where
parseJSON = A.withObject "Package" $ \v -> fmap LoggingPackage . WL.runWriterT $ do
let
l :: AT.Parser a -> Warn a
l = WL.WriterT . fmap (\a -> (a, []))
tryWarn :: (AT.FromJSON a, Show a)
=> Text -> a -> Warn a
tryWarn field def =
lift (v .:? field .!= def)
<|> putWarning def (WrongType { wrongTypeField = field
, wrongTypeDefault = Just (show def) })
name <- l $ v .: "name"
version <- l $ v .: "version"
description <- tryWarn "description" Nothing
homepage <- tryWarn "homepage" Nothing
private <- tryWarn "private" False
scripts <- (parseMapText "scripts" =<< (tryWarn "scripts" mempty))
bin <- parseBin name v
man <- l $ parseMan name v
license <- tryWarn "license" Nothing
dependencies <- l $ v .:? "dependencies" .!= mempty
devDependencies <- l $ v .:? "devDependencies" .!= mempty
pure Package{..}
where
parseMapText :: Text -> HML.HashMap Text AT.Value
-> Warn (HML.HashMap Text Text)
parseMapText fieldPath val =
HML.mapMaybe identity <$> HML.traverseWithKey tryParse val
where
tryParse :: Text -> A.Value -> Warn (Maybe Text)
tryParse key el = lift (Just <$> AT.parseJSON el)
<|> putWarning Nothing
(WrongType { wrongTypeField = fieldPath <> "." <> key
, wrongTypeDefault = Nothing })
parseBin :: Text -> AT.Object -> Warn Bin
parseBin packageName v = do
binVal <- lift $ optional $ v .: "bin"
dirBinVal <- lift $ optional $ v .: "directories" >>= (.: "bin")
case (binVal, dirBinVal) of
(Just _ , Just _) ->
putWarning (BinFiles mempty) $ PlainWarning
"`bin` and `directories.bin` must not exist at the same time, skipping."
(Just (A.String path), _) -> pure $ BinFiles
$ HML.singleton packageName (toS path)
(Just (A.Object bins), _) -> lift $ BinFiles
<$> traverse (A.withText "BinPath" (pure.toS)) bins
(Just _ , _) -> fail
$ "`bin` must be a path or a map of names to paths."
(_ , Just (A.String path)) -> pure $ BinFolder $ toS path
(_ , Just _) -> fail
$ "`directories.bin` must be a path."
(Nothing , Nothing) -> pure . BinFiles $ mempty
parseMan name v = do
let getMan f = ManFiles . f <$> v .: "man"
extractName :: FilePath -> (Text, FilePath)
extractName file =
let f = T.pack $ FP.takeFileName file
in if name `T.isPrefixOf` f
then (name, file)
else (name <> "-" <> f, file)
(getMan (HML.fromList . map extractName)
<|> getMan (HML.fromList . (:[]) . extractName)
<|> pure (ManFiles mempty))
decode :: BL.ByteString -> Either Text LoggingPackage
decode = first toS . A.eitherDecode
formatWarning :: Warning -> Text
formatWarning = \case
WrongType{..} ->
"Field \""
<> wrongTypeField
<> "\" has the wrong type. "
<> (case wrongTypeDefault of
Just def -> "Defaulting to " <> def
Nothing -> "Leaving it out")
<> "."
(PlainWarning t) -> t