{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, ApplicativeDo, RecordWildCards, NamedFieldPuns #-}
module Yarn.Lock.File
( fromPackages
, astToPackage
, 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
fromPackages :: [T.Keyed T.Package] -> T.Lockfile
fromPackages = MKM.fromList T.lockfileIkProxy
. fmap (\(T.Keyed ks p) -> (ks, p))
data ConversionError
= MissingField Text
| WrongType { fieldName :: Text, fieldType :: Text }
| UnknownRemoteType
deriving (Show, Eq)
data FieldParser a = FieldParser
{ parseField :: Either Text Parse.PackageFields -> Maybe a
, parserName :: Text
}
type Val = V.Validation (NE.NonEmpty ConversionError)
astToPackage :: Parse.PackageFields
-> Either (NE.NonEmpty ConversionError) T.Package
astToPackage = V.validationToEither . validate
where
validate :: Parse.PackageFields -> Val T.Package
validate fs = do
version <- getField text "version" fs
remote <- checkRemote fs
dependencies <- getFieldOpt keylist "dependencies" fs
optionalDependencies <- getFieldOpt keylist "optionalDependencies" fs
pure $ T.Package{..}
getField :: FieldParser a -> Text -> Parse.PackageFields -> Val a
getField = getFieldImpl Nothing
getFieldOpt :: Monoid a => FieldParser a -> Text -> Parse.PackageFields -> Val a
getFieldOpt = getFieldImpl (Just mempty)
getFieldImpl :: Maybe a -> FieldParser a -> Text -> Parse.PackageFields -> Val a
getFieldImpl mopt typeParser fieldName (Parse.PackageFields m)=
first pure $ V.eitherToValidation $ do
case M.lookup fieldName m of
Nothing -> case mopt of
Just opt -> Right opt
Nothing -> Left $ MissingField fieldName
Just val -> note
(WrongType { fieldName, fieldType = parserName typeParser })
$ parseField typeParser val
text :: FieldParser Text
text = FieldParser { parseField = either Just (const Nothing)
, parserName = "text" }
packageKey :: FieldParser T.PackageKeyName
packageKey = FieldParser
{ parseField = parseField text >=> T.parsePackageKeyName
, parserName = "package key" }
keylist :: FieldParser [T.PackageKey]
keylist = FieldParser
{ parserName = "list of package keys"
, parseField = either (const Nothing)
(\(Parse.PackageFields inner) ->
for (M.toList inner) $ \(k, v) -> do
name <- parseField packageKey (Left k)
npmVersionSpec <- parseField text v
pure $ T.PackageKey { name, npmVersionSpec }) }
checkRemote :: Parse.PackageFields -> Val T.Remote
checkRemote fs =
mToV (pure UnknownRemoteType)
$ checkGit <|> checkFile
where
mToV :: e -> Maybe a -> V.Validation e a
mToV err = V.eitherToValidation . note err
vToM :: Val a -> Maybe a
vToM = hush . V.validationToEither
findUrlHash :: Text -> (Text, Maybe Text)
findUrlHash url = case Text.splitOn "#" url of
[url'] -> (url', Nothing)
[url', ""] -> (url', Nothing)
[url', hash] -> (url', Just hash)
_ -> panic "checkRemote: # should only appear exactly once!"
checkGit = do
resolved <- vToM $ getField text "resolved" fs
(repo, gitRev) <- do
let (repo', mayHash) = findUrlHash resolved
hash <- vToM (getField text "uid" fs)
<|> if any (`Text.isPrefixOf` resolved) ["git+", "git://"]
then mayHash else Nothing
pure (repo', hash)
pure $ T.GitRemote
{ T.gitRepoUrl = noPrefix "git+" repo , .. }
noPrefix :: Text -> Text -> Text
noPrefix pref hay = maybe hay identity $ Text.stripPrefix pref hay
checkFile = do
resolved <- vToM (getField text "resolved" fs)
let (fileUrl, mayFileSha1) = findUrlHash resolved
fileSha1 <- mayFileSha1
pure $ T.FileRemote{..}