Package.hs

{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, RecordWildCards, LambdaCase, TypeApplications #-}
{-|
Description: Parse and make sense of npm’s @package.json@ project files

They are documented on https://docs.npmjs.com/files/package.json and have a few gotchas. Luckily plain JSON, but the interpretation of certain fields is non-trivial (since they contain a lot of “sugar”).
-}
module Distribution.Nodejs.Package
( -- * Parsing @package.json@
  LoggingPackage(..), decode
, Warning(..), formatWarning
  -- * @package.json@ data
, Package(..)
, Bin(..), Man(..), Dependencies
, parsePackageKeyName
) 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 System.FilePath as FP

import Data.Aeson ((.:), (.:?), (.!=), Key)
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as AT
import qualified Yarn.Lock.Types as YLT
import qualified Data.Aeson.Key as Key
import Data.Aeson.KeyMap (KeyMap)
import qualified Data.Aeson.KeyMap as KeyMap

-- | npm `package.json`. Not complete.
--
-- See https://docs.npmjs.com/files/package.json
data Package = Package
  { name :: Text
  , version :: Text
  , description :: Maybe Text
  , homepage :: Maybe Text
  , private :: Bool
  , scripts :: KeyMap Text
  , bin :: Bin
  , man :: Man
  , license :: Maybe Text
  , dependencies :: Dependencies
  , devDependencies :: Dependencies
  } deriving (Show, Eq)

-- | 'Package' with a potential bunch of parsing warnings.
-- Note the 'A.FromJson' instance.
newtype LoggingPackage = LoggingPackage
  { unLoggingPackage :: (Package, [Warning]) }

-- | Possible warnings from parsing.
data Warning
  = WrongType
  { wrongTypeField :: Text -- ^ the field which has a wrong type
  , wrongTypeDefault :: Maybe Text -- ^ the default value, if used
  }
  | PlainWarning Text

-- | The package’s executable files.
data Bin
  = BinFiles (KeyMap FilePath)
  -- ^ map of files from name to their file path (relative to package path)
  | BinFolder FilePath
  -- ^ a folder containing all executable files of the project (also relative)
  deriving (Show, Eq)

-- | The package’s manual files.
data Man
  = ManFiles (KeyMap FilePath)
  -- ^ map of files from name to their file path (relative to package path)
  deriving (Show, Eq)

-- | Dependencies of a package.
type Dependencies = KeyMap Text

type Warn = WL.WriterT [Warning] AT.Parser
putWarning :: a -> Warning -> Warn a
putWarning a w = WL.writer (a, [w])

-- | See https://github.com/npm/normalize-package-data for
-- normalization steps used by npm itself.
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)
              => AT.Key -> a -> Warn a
      tryWarn field def =
        lift (v .:? field .!= def)
        <|> putWarning def (WrongType { wrongTypeField = field & Key.toText
                                       , 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    <- tryWarn "dependencies" (AT.Object mempty)
                         >>= parseDependencies "dependencies"
    devDependencies <- tryWarn "devDependencies" (AT.Object mempty)
                         >>= parseDependencies "devDependencies"
    pure Package{..}
    where

      parseDependencies ::  Text -> AT.Value -> Warn Dependencies
      parseDependencies field v =
        let
          warn = putWarning mempty
              $ WrongType
              { wrongTypeField   = field
              , wrongTypeDefault = Just (show (mempty :: Dependencies)) }
        in case v of
          AT.Array a ->
            -- we interpret empty arrays as just confused users
            if null a then warn
            -- however if the user uses a non-empty array,
            -- they probably mean something which we don’t know how to deal with.
            else fail
              $ "\"" ++ T.unpack field ++ "\" is a non empty array instead of a JSON object"
          -- if we get an object here, it's malformed
          AT.Object deps -> lift $ traverse (A.parseJSON @Text) deps
          -- everything else defaults to mempty and generates a warning
          _ -> warn

      parseMapText :: Text -> KeyMap AT.Value
                   -> Warn (KeyMap Text)
      parseMapText fieldPath val =
        KeyMap.mapMaybe identity <$> KeyMap.traverseWithKey tryParse val
        where
          tryParse :: A.Key -> A.Value -> Warn (Maybe Text)
          tryParse key el = lift (Just <$> AT.parseJSON el)
            <|> putWarning Nothing
                  (WrongType { wrongTypeField = fieldPath <> "." <> (key & Key.toText)
                             , wrongTypeDefault = Nothing })
      parseBin :: Text -> AT.Object -> Warn Bin
      parseBin packageName v = do
        -- check for existence of these fields
        binVal <- lift $ optional $ v .: "bin"
        dirBinVal <- lift $ optional $ v .: "directories" >>= (.: "bin")
        -- now check for all possible cases of the fields
        -- see npm documentation for more
        case (binVal, dirBinVal) of
          (Just _              , Just _) ->
            putWarning (BinFiles mempty) $ PlainWarning
              "`bin` and `directories.bin` must not exist at the same time, skipping."
          -- either "bin" is a direct path, then it’s linked to the package name
          (Just (A.String path),      _) -> pure $ BinFiles
            $ KeyMap.singleton (parsePackageName packageName & Key.fromText) (toS path)
          -- or it’s a map from names to paths
          (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."
          -- if no executables are given, return an empty set
          (Nothing             , Nothing) -> pure . BinFiles $ mempty

      -- TODO: parsing should be as thorough as with "bin"
      parseMan name v = do
        let getMan f = ManFiles . f <$> v .: "man"
            extractName :: FilePath -> (Key, FilePath)
            extractName file =
              let f = T.pack $ FP.takeFileName file
              in if name `T.isPrefixOf` f
                  then (Key.fromText name, file)
                  else (Key.fromText $ name <> "-" <> f, file)
        -- TODO: handle directories.man
        (getMan (KeyMap.fromList . map extractName)
            <|> getMan (KeyMap.fromList . (:[]) . extractName)
            <|> pure (ManFiles mempty))

-- | Convenience decoding function.
decode :: BL.ByteString -> Either Text LoggingPackage
decode = first toS . A.eitherDecode

-- | Convert a @package.json@ parsing warning to plain text.
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

-- | Parse a package name string into a 'YLT.PackageKeyName'.
parsePackageKeyName :: Text -> YLT.PackageKeyName
parsePackageKeyName k =
  case YLT.parsePackageKeyName k of
    -- we don’t crash on a “wrong” package key to keep this
    -- code pure, but assume it’s a simple key instead.
    Nothing -> (YLT.SimplePackageKey k)
    Just pkn -> pkn

parsePackageName :: Text -> Text
parsePackageName k =
  case parsePackageKeyName k of
     YLT.SimplePackageKey n -> n
     YLT.ScopedPackageKey _ n -> n