{-|
Module : Yarn.Lock.File
Description : Convert AST to semantic data structures
Maintainer : Profpatsch
Stability : experimental

After parsing yarn.lock files in 'Yarn.Lock.Parse',
you want to convert the AST to something with more information
and ultimately get a 'T.Lockfile'.

@yarn.lock@ files don’t follow a structured approach
(like for example sum types), so information like e.g.
the remote type have to be inferred frome AST values.
-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, ApplicativeDo, RecordWildCards, NamedFieldPuns #-}
module Yarn.Lock.File
( fromPackages
, astToPackage
-- * Errors
, ConversionError(..)
) where

import Protolude hiding (hash, getField)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import qualified Data.Text as Text
import qualified Data.Either.Validation as V

import qualified Yarn.Lock.Parse as Parse
import qualified Yarn.Lock.Types as T
import qualified Data.MultiKeyedMap as MKM

-- | Press a list of packages into the lockfile structure.
--
-- It’s a dumb conversion, you should probably apply
-- the 'Yarn.Lock.Helpers.decycle' function afterwards.
fromPackages :: [T.Keyed T.Package] -> T.Lockfile
fromPackages :: [Keyed Package] -> Lockfile
fromPackages = Proxy Int -> [(NonEmpty PackageKey, Package)] -> Lockfile
forall ik k v.
(Ord k, Ord ik, Enum ik, Bounded ik) =>
Proxy ik -> [(NonEmpty k, v)] -> MKMap k v
MKM.fromList Proxy Int
T.lockfileIkProxy
             ([(NonEmpty PackageKey, Package)] -> Lockfile)
-> ([Keyed Package] -> [(NonEmpty PackageKey, Package)])
-> [Keyed Package]
-> Lockfile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Keyed Package -> (NonEmpty PackageKey, Package))
-> [Keyed Package] -> [(NonEmpty PackageKey, Package)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(T.Keyed NonEmpty PackageKey
ks Package
p) -> (NonEmpty PackageKey
ks, Package
p))

-- | Possible errors when converting from AST.
data ConversionError
  = MissingField Text
  -- ^ field is missing
  | WrongType { ConversionError -> Text
fieldName :: Text, ConversionError -> Text
fieldType :: Text }
  -- ^ this field has the wrong type
  | UnknownRemoteType
  -- ^ the remote (e.g. git, tar archive) could not be determined
  deriving (Int -> ConversionError -> ShowS
[ConversionError] -> ShowS
ConversionError -> String
(Int -> ConversionError -> ShowS)
-> (ConversionError -> String)
-> ([ConversionError] -> ShowS)
-> Show ConversionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConversionError] -> ShowS
$cshowList :: [ConversionError] -> ShowS
show :: ConversionError -> String
$cshow :: ConversionError -> String
showsPrec :: Int -> ConversionError -> ShowS
$cshowsPrec :: Int -> ConversionError -> ShowS
Show, ConversionError -> ConversionError -> Bool
(ConversionError -> ConversionError -> Bool)
-> (ConversionError -> ConversionError -> Bool)
-> Eq ConversionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConversionError -> ConversionError -> Bool
$c/= :: ConversionError -> ConversionError -> Bool
== :: ConversionError -> ConversionError -> Bool
$c== :: ConversionError -> ConversionError -> Bool
Eq)

-- | Something that can parse the value of a field into type @a@.
data FieldParser a = FieldParser
  { FieldParser a -> Either Text PackageFields -> Maybe a
parseField :: Either Text Parse.PackageFields -> Maybe a
    -- ^ the parsing function (Left is a simple field, Right a nested one)
  , FieldParser a -> Text
parserName :: Text
    -- ^ name of this parser (for type errors)
  }

type Val = V.Validation (NE.NonEmpty ConversionError)

-- | Parse an AST 'PackageFields' to a 'T.Package', which has
-- the needed fields resolved.
astToPackage :: Parse.PackageFields
             -> Either (NE.NonEmpty ConversionError) T.Package
astToPackage :: PackageFields -> Either (NonEmpty ConversionError) Package
astToPackage = Validation (NonEmpty ConversionError) Package
-> Either (NonEmpty ConversionError) Package
forall e a. Validation e a -> Either e a
V.validationToEither (Validation (NonEmpty ConversionError) Package
 -> Either (NonEmpty ConversionError) Package)
-> (PackageFields -> Validation (NonEmpty ConversionError) Package)
-> PackageFields
-> Either (NonEmpty ConversionError) Package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageFields -> Validation (NonEmpty ConversionError) Package
validate
  where
    validate :: Parse.PackageFields -> Val T.Package
    validate :: PackageFields -> Validation (NonEmpty ConversionError) Package
validate PackageFields
fs = do
      Text
version              <- FieldParser Text -> Text -> PackageFields -> Val Text
forall a. FieldParser a -> Text -> PackageFields -> Val a
getField FieldParser Text
text Text
"version" PackageFields
fs
      Remote
remote               <- PackageFields -> Val Remote
checkRemote PackageFields
fs
      [PackageKey]
dependencies         <- FieldParser [PackageKey]
-> Text -> PackageFields -> Val [PackageKey]
forall a.
Monoid a =>
FieldParser a -> Text -> PackageFields -> Val a
getFieldOpt FieldParser [PackageKey]
keylist Text
"dependencies" PackageFields
fs
      [PackageKey]
optionalDependencies <- FieldParser [PackageKey]
-> Text -> PackageFields -> Val [PackageKey]
forall a.
Monoid a =>
FieldParser a -> Text -> PackageFields -> Val a
getFieldOpt FieldParser [PackageKey]
keylist Text
"optionalDependencies" PackageFields
fs
      pure $ Package :: Text -> Remote -> [PackageKey] -> [PackageKey] -> Package
T.Package{[PackageKey]
Text
Remote
optionalDependencies :: [PackageKey]
dependencies :: [PackageKey]
remote :: Remote
version :: Text
optionalDependencies :: [PackageKey]
dependencies :: [PackageKey]
remote :: Remote
version :: Text
..}

    -- | Parse a field from a 'PackageFields'.
    getField :: FieldParser a -> Text -> Parse.PackageFields -> Val a
    getField :: FieldParser a -> Text -> PackageFields -> Val a
getField = Maybe a -> FieldParser a -> Text -> PackageFields -> Val a
forall a.
Maybe a -> FieldParser a -> Text -> PackageFields -> Val a
getFieldImpl Maybe a
forall a. Maybe a
Nothing
    -- | Parse an optional field and insert the empty monoid value
    getFieldOpt :: Monoid a => FieldParser a -> Text -> Parse.PackageFields -> Val a
    getFieldOpt :: FieldParser a -> Text -> PackageFields -> Val a
getFieldOpt = Maybe a -> FieldParser a -> Text -> PackageFields -> Val a
forall a.
Maybe a -> FieldParser a -> Text -> PackageFields -> Val a
getFieldImpl (a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Monoid a => a
mempty)

    getFieldImpl :: Maybe a -> FieldParser a -> Text -> Parse.PackageFields -> Val a
    getFieldImpl :: Maybe a -> FieldParser a -> Text -> PackageFields -> Val a
getFieldImpl Maybe a
mopt FieldParser a
typeParser Text
fieldName (Parse.PackageFields Map Text (Either Text PackageFields)
m)=
      (ConversionError -> NonEmpty ConversionError)
-> Validation ConversionError a -> Val a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ConversionError -> NonEmpty ConversionError
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Validation ConversionError a -> Val a)
-> Validation ConversionError a -> Val a
forall a b. (a -> b) -> a -> b
$ Either ConversionError a -> Validation ConversionError a
forall e a. Either e a -> Validation e a
V.eitherToValidation (Either ConversionError a -> Validation ConversionError a)
-> Either ConversionError a -> Validation ConversionError a
forall a b. (a -> b) -> a -> b
$ do
        case Text
-> Map Text (Either Text PackageFields)
-> Maybe (Either Text PackageFields)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
fieldName Map Text (Either Text PackageFields)
m of
          Maybe (Either Text PackageFields)
Nothing -> case Maybe a
mopt of
            Just a
opt -> a -> Either ConversionError a
forall a b. b -> Either a b
Right a
opt
            Maybe a
Nothing  -> ConversionError -> Either ConversionError a
forall a b. a -> Either a b
Left (ConversionError -> Either ConversionError a)
-> ConversionError -> Either ConversionError a
forall a b. (a -> b) -> a -> b
$ Text -> ConversionError
MissingField Text
fieldName
          Just Either Text PackageFields
val -> ConversionError -> Maybe a -> Either ConversionError a
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note
            (WrongType :: Text -> Text -> ConversionError
WrongType { Text
fieldName :: Text
fieldName :: Text
fieldName, fieldType :: Text
fieldType = FieldParser a -> Text
forall a. FieldParser a -> Text
parserName FieldParser a
typeParser })
            (Maybe a -> Either ConversionError a)
-> Maybe a -> Either ConversionError a
forall a b. (a -> b) -> a -> b
$ FieldParser a -> Either Text PackageFields -> Maybe a
forall a. FieldParser a -> Either Text PackageFields -> Maybe a
parseField FieldParser a
typeParser Either Text PackageFields
val

    -- | Parse a simple field to type 'Text'.
    text :: FieldParser Text
    text :: FieldParser Text
text = FieldParser :: forall a.
(Either Text PackageFields -> Maybe a) -> Text -> FieldParser a
FieldParser { parseField :: Either Text PackageFields -> Maybe Text
parseField = (Text -> Maybe Text)
-> (PackageFields -> Maybe Text)
-> Either Text PackageFields
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Maybe Text
forall a. a -> Maybe a
Just (Maybe Text -> PackageFields -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing)
                       , parserName :: Text
parserName = Text
"text" }

    packageKey :: FieldParser T.PackageKeyName
    packageKey :: FieldParser PackageKeyName
packageKey = FieldParser :: forall a.
(Either Text PackageFields -> Maybe a) -> Text -> FieldParser a
FieldParser
      { parseField :: Either Text PackageFields -> Maybe PackageKeyName
parseField = FieldParser Text -> Either Text PackageFields -> Maybe Text
forall a. FieldParser a -> Either Text PackageFields -> Maybe a
parseField FieldParser Text
text (Either Text PackageFields -> Maybe Text)
-> (Text -> Maybe PackageKeyName)
-> Either Text PackageFields
-> Maybe PackageKeyName
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Maybe PackageKeyName
T.parsePackageKeyName
      , parserName :: Text
parserName = Text
"package key" }

    -- | Parse a field nested one level to a list of 'PackageKey's.
    keylist :: FieldParser [T.PackageKey]
    keylist :: FieldParser [PackageKey]
keylist = FieldParser :: forall a.
(Either Text PackageFields -> Maybe a) -> Text -> FieldParser a
FieldParser
      { parserName :: Text
parserName = Text
"list of package keys"
      , parseField :: Either Text PackageFields -> Maybe [PackageKey]
parseField = (Text -> Maybe [PackageKey])
-> (PackageFields -> Maybe [PackageKey])
-> Either Text PackageFields
-> Maybe [PackageKey]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [PackageKey] -> Text -> Maybe [PackageKey]
forall a b. a -> b -> a
const Maybe [PackageKey]
forall a. Maybe a
Nothing)
             (\(Parse.PackageFields Map Text (Either Text PackageFields)
inner) ->
                  [(Text, Either Text PackageFields)]
-> ((Text, Either Text PackageFields) -> Maybe PackageKey)
-> Maybe [PackageKey]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map Text (Either Text PackageFields)
-> [(Text, Either Text PackageFields)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text (Either Text PackageFields)
inner) (((Text, Either Text PackageFields) -> Maybe PackageKey)
 -> Maybe [PackageKey])
-> ((Text, Either Text PackageFields) -> Maybe PackageKey)
-> Maybe [PackageKey]
forall a b. (a -> b) -> a -> b
$ \(Text
k, Either Text PackageFields
v) -> do
                    PackageKeyName
name <- FieldParser PackageKeyName
-> Either Text PackageFields -> Maybe PackageKeyName
forall a. FieldParser a -> Either Text PackageFields -> Maybe a
parseField FieldParser PackageKeyName
packageKey (Text -> Either Text PackageFields
forall a b. a -> Either a b
Left Text
k)
                    Text
npmVersionSpec <- FieldParser Text -> Either Text PackageFields -> Maybe Text
forall a. FieldParser a -> Either Text PackageFields -> Maybe a
parseField FieldParser Text
text Either Text PackageFields
v
                    pure $ PackageKey :: PackageKeyName -> Text -> PackageKey
T.PackageKey { PackageKeyName
name :: PackageKeyName
name :: PackageKeyName
name, Text
npmVersionSpec :: Text
npmVersionSpec :: Text
npmVersionSpec }) }

    -- | Appling heuristics to the field contents to find the
    -- correct remote type.
    checkRemote :: Parse.PackageFields -> Val T.Remote
    checkRemote :: PackageFields -> Val Remote
checkRemote PackageFields
fs =
      -- any error is replaced by the generic remote error
      NonEmpty ConversionError -> Maybe Remote -> Val Remote
forall e a. e -> Maybe a -> Validation e a
mToV (ConversionError -> NonEmpty ConversionError
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConversionError
UnknownRemoteType)
        -- implementing the heuristics of searching for types;
        -- it should of course not lead to false positives
        -- see tests/TestLock.hs
        (Maybe Remote -> Val Remote) -> Maybe Remote -> Val Remote
forall a b. (a -> b) -> a -> b
$ Maybe Remote
checkGit Maybe Remote -> Maybe Remote -> Maybe Remote
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Remote
checkFileLocal Maybe Remote -> Maybe Remote -> Maybe Remote
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Remote
checkFile
      where
        mToV :: e -> Maybe a -> V.Validation e a
        mToV :: e -> Maybe a -> Validation e a
mToV e
err = Either e a -> Validation e a
forall e a. Either e a -> Validation e a
V.eitherToValidation (Either e a -> Validation e a)
-> (Maybe a -> Either e a) -> Maybe a -> Validation e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Maybe a -> Either e a
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note e
err
        vToM :: Val a -> Maybe a
        vToM :: Val a -> Maybe a
vToM = Either (NonEmpty ConversionError) a -> Maybe a
forall (m :: * -> *) e a. Alternative m => Either e a -> m a
hush (Either (NonEmpty ConversionError) a -> Maybe a)
-> (Val a -> Either (NonEmpty ConversionError) a)
-> Val a
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val a -> Either (NonEmpty ConversionError) a
forall e a. Validation e a -> Either e a
V.validationToEither

        -- | "https://blafoo.com/a/b#alonghash"
        --   -> ("https://blafoo.com/a/b", "alonghash")
        -- we assume the # can only occur exactly once
        findUrlHash :: Text -> (Text, Maybe Text)
        findUrlHash :: Text -> (Text, Maybe Text)
findUrlHash Text
url = case Text -> Text -> [Text]
Text.splitOn Text
"#" Text
url of
          [Text
url']       -> (Text
url', Maybe Text
forall a. Maybe a
Nothing)
          [Text
url', Text
""]   -> (Text
url', Maybe Text
forall a. Maybe a
Nothing)
          [Text
url', Text
hash] -> (Text
url', Text -> Maybe Text
forall a. a -> Maybe a
Just Text
hash)
          [Text]
_           -> Text -> (Text, Maybe Text)
forall a. HasCallStack => Text -> a
panic Text
"checkRemote: # should only appear exactly once!"

        checkGit :: Maybe T.Remote
        checkGit :: Maybe Remote
checkGit = do
          Text
resolved <- Val Text -> Maybe Text
forall a. Val a -> Maybe a
vToM (Val Text -> Maybe Text) -> Val Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FieldParser Text -> Text -> PackageFields -> Val Text
forall a. FieldParser a -> Text -> PackageFields -> Val a
getField FieldParser Text
text Text
"resolved" PackageFields
fs
          -- either in uid field or after the hash in the “resolved” URL
          (Text
repo, Text
gitRev) <- do
            let (Text
repo', Maybe Text
mayHash) = Text -> (Text, Maybe Text)
findUrlHash Text
resolved
            Text
hash <- Val Text -> Maybe Text
forall a. Val a -> Maybe a
vToM (FieldParser Text -> Text -> PackageFields -> Val Text
forall a. FieldParser a -> Text -> PackageFields -> Val a
getField FieldParser Text
text Text
"uid" PackageFields
fs)
              Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> if (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`Text.isPrefixOf` Text
resolved) [Text
"git+", Text
"git://"]
                  then Maybe Text
mayHash else Maybe Text
forall a. Maybe a
Nothing
            pure (Text
repo', Text
hash)
          Remote -> Maybe Remote
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Remote -> Maybe Remote) -> Remote -> Maybe Remote
forall a b. (a -> b) -> a -> b
$ GitRemote :: Text -> Text -> Remote
T.GitRemote
            { gitRepoUrl :: Text
T.gitRepoUrl = Text -> Text -> Text
noPrefix Text
"git+" Text
repo , Text
gitRev :: Text
gitRev :: Text
.. }

        -- | resolved fields that are prefixed with @"file:"@
        checkFileLocal :: Maybe T.Remote
        checkFileLocal :: Maybe Remote
checkFileLocal = do
          Text
resolved <- Val Text -> Maybe Text
forall a. Val a -> Maybe a
vToM (Val Text -> Maybe Text) -> Val Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FieldParser Text -> Text -> PackageFields -> Val Text
forall a. FieldParser a -> Text -> PackageFields -> Val a
getField FieldParser Text
text Text
"resolved" PackageFields
fs
          let (Text
file, Maybe Text
mayHash) = Text -> (Text, Maybe Text)
findUrlHash Text
resolved
          Text
fileLocalPath <- if Text
"file:" Text -> Text -> Bool
`Text.isPrefixOf` Text
file
                           then Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
noPrefix Text
"file:" Text
file
                           else Maybe Text
forall a. Maybe a
Nothing
          case Maybe Text
mayHash of
            Just Text
hash -> Remote -> Maybe Remote
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Remote
T.FileLocal Text
fileLocalPath Text
hash)
            Maybe Text
Nothing   -> Remote -> Maybe Remote
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Remote
T.FileLocalNoIntegrity Text
fileLocalPath)

        checkFile :: Maybe T.Remote
        checkFile :: Maybe Remote
checkFile = do
          Text
resolved <- Val Text -> Maybe Text
forall a. Val a -> Maybe a
vToM (FieldParser Text -> Text -> PackageFields -> Val Text
forall a. FieldParser a -> Text -> PackageFields -> Val a
getField FieldParser Text
text Text
"resolved" PackageFields
fs)
          let (Text
fileUrl, Maybe Text
mayHash) = Text -> (Text, Maybe Text)
findUrlHash Text
resolved
          case Maybe Text
mayHash of
            Just Text
hash -> Remote -> Maybe Remote
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Remote
T.FileRemote Text
fileUrl Text
hash)
            Maybe Text
Nothing   -> Remote -> Maybe Remote
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Remote
T.FileRemoteNoIntegrity Text
fileUrl)

        -- | ensure the prefix is removed
        noPrefix :: Text -> Text -> Text
        noPrefix :: Text -> Text -> Text
noPrefix Text
pref Text
hay = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
hay Text -> Text
forall a. a -> a
identity (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
Text.stripPrefix Text
pref Text
hay