# LANGUAGE NoImplicitPrelude #
{-# LANGUAGE BangPatterns #-}
# LANGUAGE LambdaCase #
{-# LANGUAGE OverloadedStrings #-}
# LANGUAGE ScopedTypeVariables #
# LANGUAGE DeriveGeneric #
module NixFromNpm.Npm.Types where

import qualified ClassyPrelude as CP
import Data.Aeson
import Data.Aeson.Types as Aeson (Parser, typeMismatch, withObject)
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import Data.SemVer (SemVer, SemVerRange)
import Data.SemVer (parseSemVer, parseSemVerRange, anyVersion)

import NixFromNpm.Common
import NixFromNpm.Git.Types (getObject, GithubError)
import NixFromNpm.Npm.Version
import NixFromNpm.Npm.PackageMap

-- | Package information; specifically all of the different versions.
data PackageInfo = PackageInfo {
  piVersions :: HashMap SemVer VersionInfo,
  piTags :: Record SemVer
  } deriving (Show, Eq)

  | Taken from #process_process_platform ,
-- and filtered to those that correspond to nixpkgs platforms.
data NodePlatform
  = Darwin
  | FreeBSD
  | OpenBSD
  | Linux
  | SunOS
  deriving (Show, Eq)

  | Convert a NodePlatform into text
nodePlatformToText :: IsString t => NodePlatform -> t
nodePlatformToText = \case
  Darwin -> "darwin"
  FreeBSD -> "freebsd"
  OpenBSD -> "openbsd"
  Linux -> "linux"
  SunOS -> "solaris"

-- | Parse a node platform from a string.
parseNodePlatform :: Alternative f => Text -> f NodePlatform
parseNodePlatform = \case
  "linux" -> pure Linux
  "darwin" -> pure Darwin
  "freebsd" -> pure FreeBSD
  "openbsd" -> pure OpenBSD
  "sunos" -> pure SunOS
  _ -> empty

-- | Metadata about a package.
data PackageMeta = PackageMeta {
  pmDescription :: Maybe Text,
  pmAuthor :: Maybe Text,
  pmHomepage :: Maybe URI,
  pmKeywords :: Vector Text,
  pmPlatforms :: Vector NodePlatform
  } deriving (Show, Eq)

-- | Default (empty) package metadata.
emptyPackageMeta :: PackageMeta
emptyPackageMeta = PackageMeta Nothing Nothing Nothing mempty mempty

instance FromJSON PackageMeta where
  parseJSON = withObject "PackageMeta" $ \o -> do
    let getString = \case {String s -> Just s; _ -> Nothing}
    description <- o .:? "description"
    author <- o .:? "author" <|> pure Nothing
    maybePlatforms :: Maybe (Vector Text) <- o .:? "os" <|> pure Nothing
    let platforms = maybe mempty (catMaybes . map parseNodePlatform) maybePlatforms
    homepage <- o .:? "homepage" >>= \case
      Nothing -> return Nothing
      Just (String txt) -> return $ parseURIText txt
      Just (Array stuff) -> case toList $ catMaybes (getString <$> stuff) of
        [] -> return Nothing
        (uri:_) -> return $ parseURIText uri
    let
      -- If keywords are a string, split on commas and strip whitespace.
      getKeywords (String s) = fromList $ T.strip <$> T.split (==',') s
      -- If an array, just take the array.
      getKeywords (Array a) = catMaybes $ map getString a
      -- Otherwise, this is an error, but just return an empty array.
      getKeywords _ = mempty
    keywords <- map getKeywords $ o .:? "keywords" .!= Null
    return $ PackageMeta description author homepage keywords platforms


-- | Expresses all of the information that a version of a package needs, in
-- the abstract (e.g. using version ranges instead of explicit versions).
-- This type can be used as an input to the Npm.Resolve stuff to produce a
  ` ResolvedPkg ` .
data VersionInfo = VersionInfo {
  viName :: PackageName,
  viDependencies :: PRecord NpmVersionRange,
  viOptionalDependencies :: PRecord NpmVersionRange,
  viDevDependencies :: PRecord NpmVersionRange,
  viBundledDependencies :: [PackageName],
  viDist :: Maybe DistInfo, -- not present if in a package.json file.
  viMeta :: PackageMeta,
  viVersion :: SemVer
  } deriving (Show, Eq)

  | SHA digest , combining an algorithm type with a digest .
data Shasum = SHA1 Text | SHA256 Text deriving (Show, Eq)

  | Distribution info from NPM . Tells us the URL and hash of a tarball .
data DistInfo = DistInfo {
  diUrl :: Text,
  diShasum :: Shasum
  } deriving (Show, Eq)

-- | Flag for different types of dependencies.
data DependencyType
  = Dependency    -- ^ Required at runtime.
  | OptionalDependency
  | DevDependency -- ^ Only required for development.
  deriving (Show, Eq)

-- | Dependencies might be circular; this type lets us indicate if so.
data PossiblyCircularSemVer
  = NotCircular SemVer
  | Circular CircularSemVer
  deriving (Show, Eq, Ord, Generic)

instance Hashable PossiblyCircularSemVer

-- | Wrapper for SemVers so we can tell when they're circular.
newtype CircularSemVer = CircularSemVer {unCirc :: SemVer}
  deriving (Show, Eq, Ord, Generic)

instance Hashable CircularSemVer

  | Convert a PossiblyCircularSemVer to a SemVer .
unpackPSC :: PossiblyCircularSemVer -> SemVer
unpackPSC (Circular (CircularSemVer sv)) = sv
unpackPSC (NotCircular sv) = sv

  | Separate a list of PossiblyCircularSemVers into two lists .
  The first element contains non - circular dependencies , and the
-- second contains circular ones.
sepCirculars :: [PossiblyCircularSemVer] -> ([SemVer], [CircularSemVer])
sepCirculars [] = ([], [])
sepCirculars (psc:rest) = do
  let (noncirculars, circulars) = sepCirculars rest
  case psc of
    NotCircular nc -> (nc:noncirculars, circulars)
    Circular c -> (noncirculars, c:circulars)

  | Similar to @sepCirculars@ but takes in a HashMap and returns a
-- pair of HashMaps.
sepCircularMap :: (Hashable a, Eq a)
               => HashMap a PossiblyCircularSemVer
               -> (HashMap a SemVer, HashMap a CircularSemVer)
sepCircularMap m = go $ H.toList m where
  go [] = (mempty, mempty)
  go ((key, psc):rest) = do
    let (noncirculars, circulars) = go rest
    case psc of
      NotCircular nc -> (H.insert key nc noncirculars, circulars)
      Circular c -> (noncirculars, H.insert key c circulars)

-- | Reasons why an expression might not have been able to be built.
data BrokenPackageReason
  = NoMatchingPackage PackageName
  | NoMatchingVersion NpmVersionRange
  | InvalidNpmVersionRange Text
  | NoSuchTag Name
  | TagPointsToInvalidVersion Name SemVer
  | InvalidSemVerSyntax Text String
  | InvalidPackageJson Text String
  | NoDistributionInfo
  | Reason String
  | GithubError GithubError
  | NotYetImplemented String
  | UnsatisfiedDependency PackageName -- This should never happen, but in case
  | BrokenDependency PackageName BrokenPackageReason
  deriving (Show, Eq, Typeable)

instance Exception BrokenPackageReason

-- | We might not be able to resolve a dependency, in which case we record
-- it as a broken package.
data ResolvedDependency
  = Resolved PossiblyCircularSemVer -- ^ Package resolved at this version.
  | Broken BrokenPackageReason -- ^ Could not build the dependency.
  deriving (Show, Eq)

instance Semigroup PackageInfo where
  PackageInfo vs ts <> PackageInfo vs' ts' =
    PackageInfo (vs CP.<> vs') (ts CP.<> ts')

instance Monoid PackageInfo where
  mempty = PackageInfo mempty mempty
  mappend = (CP.<>)

instance FromJSON PackageName where
  parseJSON (String name) = case parsePackageName name of
    Left err -> fail $ unpack err
    Right pname -> return pname
  parseJSON v = typeMismatch "Expected a string for a package name" v

  | Gets a hashmap from an object , or otherwise returns an empty hashmap .
getDict :: (FromJSON val, FromJSON key, Hashable key, Eq key)
        => Text -> Object -> Aeson.Parser (HashMap key val)
getDict key obj = case H.lookup key obj of
  Just (Object obj') -> map H.fromList $
    forM (H.toList obj') $ \(k, v) -> do
      key <- parseJSON (String k)
      val <- parseJSON v
      return (key, val)
  -- sometimes it's malformed, like humanize-number
  _ -> return mempty

instance FromJSON VersionInfo where
  parseJSON = withObject "version info" $ \o -> do
    listedDependencies <- getDict "dependencies" o
    devDependencies <- getDict "devDependencies" o
    optionalDependencies <- getDict "optionalDependencies" o
    bundledDependencies <- o .:? "bundledDependencies" .!= []
    -- Loop through the bundled dependencies. If any of them are missing
    -- from the dependencies record, add it here.
    let isMissingDep name = not $ H.member name listedDependencies
        missing = filter isMissingDep bundledDependencies
        missingDependencies = zip missing (repeat $ SemVerRange anyVersion)
        dependencies = listedDependencies <> H.fromList missingDependencies
    dist <- o .:? "dist"
    pkgName <- o .: "name"
    version <- o .: "version"
    packageMeta <- parseJSON (Object o)
    scripts :: Record Value <- getDict "scripts" o <|> fail "couldn't get scripts"
    -- Remove any keys which appear in `optionalDependencies` from
    -- the dependencies and devdependencies sets.
    let rmOptionals = flip H.difference optionalDependencies
    case parseSemVer version of
      Left _ -> throw $ VersionSyntaxError version
      Right semver -> return $ VersionInfo {
        viDependencies = rmOptionals dependencies,
        viDevDependencies = rmOptionals devDependencies,
        viOptionalDependencies = optionalDependencies,
        viBundledDependencies = bundledDependencies,
        viDist = dist,
        viName = pkgName,
        viMeta = packageMeta,
        viVersion = semver
      }

instance FromJSON SemVerRange where
  parseJSON v = case v of
    String s -> case parseSemVerRange s of
      Left err -> do
        let errorMessage = "valid semantic version (got " <> show v <> ")"
        typeMismatch errorMessage v
      Right range -> return range
    _ -> typeMismatch "string" v

instance FromJSON PackageInfo where
  parseJSON = getObject "package info" >=> \o -> do
    vs' :: Record VersionInfo <- getDict "versions" o
    tags' <- getDict "dist-tags" o
    let vs = H.fromList $ map (\vi -> (viVersion vi, vi)) $ H.elems vs'
        convert tags [] = return $ PackageInfo vs (H.fromList tags)
        convert tags ((tName, tVer):ts) = case parseSemVer tVer of
          Left err -> failC ["Tag ", tName, " refers to an invalid ",
                             "semver string ", tVer, ": ", tshow err]
          Right ver -> convert ((tName, ver):tags) ts
    convert [] $ H.toList tags'

instance FromJSON DistInfo where
  parseJSON = getObject "dist info" >=> \o -> do
    tarball <- o .: "tarball"
    shasum <- SHA1 <$> o .: "shasum"
    return $ DistInfo tarball shasum

# LANGUAGE BangPatterns #
# LANGUAGE OverloadedStrings #
 | Package information; specifically all of the different versions.
 and filtered to those that correspond to nixpkgs platforms.
 | Parse a node platform from a string.
 | Metadata about a package.
 | Default (empty) package metadata.
 If keywords are a string, split on commas and strip whitespace.
 If an array, just take the array.
 Otherwise, this is an error, but just return an empty array.
 | Expresses all of the information that a version of a package needs, in
 the abstract (e.g. using version ranges instead of explicit versions).
 This type can be used as an input to the Npm.Resolve stuff to produce a
 not present if in a package.json file.
 | Flag for different types of dependencies.
 ^ Required at runtime.
 ^ Only required for development.
 | Dependencies might be circular; this type lets us indicate if so.
 | Wrapper for SemVers so we can tell when they're circular.
 second contains circular ones.
 pair of HashMaps.
 | Reasons why an expression might not have been able to be built.
 This should never happen, but in case
 | We might not be able to resolve a dependency, in which case we record
 it as a broken package.
 ^ Package resolved at this version.
 ^ Could not build the dependency.
 sometimes it's malformed, like humanize-number
 Loop through the bundled dependencies. If any of them are missing
 from the dependencies record, add it here.
 Remove any keys which appear in `optionalDependencies` from
 the dependencies and devdependencies sets.
# LANGUAGE NoImplicitPrelude #
# LANGUAGE LambdaCase #
# LANGUAGE ScopedTypeVariables #
# LANGUAGE DeriveGeneric #
module NixFromNpm.Npm.Types where

import qualified ClassyPrelude as CP
import Data.Aeson
import Data.Aeson.Types as Aeson (Parser, typeMismatch, withObject)
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import Data.SemVer (SemVer, SemVerRange)
import Data.SemVer (parseSemVer, parseSemVerRange, anyVersion)

import NixFromNpm.Common
import NixFromNpm.Git.Types (getObject, GithubError)
import NixFromNpm.Npm.Version
import NixFromNpm.Npm.PackageMap

data PackageInfo = PackageInfo {
  piVersions :: HashMap SemVer VersionInfo,
  piTags :: Record SemVer
  } deriving (Show, Eq)

  | Taken from #process_process_platform ,
data NodePlatform
  = Darwin
  | FreeBSD
  | OpenBSD
  | Linux
  | SunOS
  deriving (Show, Eq)

  | Convert a NodePlatform into text
nodePlatformToText :: IsString t => NodePlatform -> t
nodePlatformToText = \case
  Darwin -> "darwin"
  FreeBSD -> "freebsd"
  OpenBSD -> "openbsd"
  Linux -> "linux"
  SunOS -> "solaris"

parseNodePlatform :: Alternative f => Text -> f NodePlatform
parseNodePlatform = \case
  "linux" -> pure Linux
  "darwin" -> pure Darwin
  "freebsd" -> pure FreeBSD
  "openbsd" -> pure OpenBSD
  "sunos" -> pure SunOS
  _ -> empty

data PackageMeta = PackageMeta {
  pmDescription :: Maybe Text,
  pmAuthor :: Maybe Text,
  pmHomepage :: Maybe URI,
  pmKeywords :: Vector Text,
  pmPlatforms :: Vector NodePlatform
  } deriving (Show, Eq)

emptyPackageMeta :: PackageMeta
emptyPackageMeta = PackageMeta Nothing Nothing Nothing mempty mempty

instance FromJSON PackageMeta where
  parseJSON = withObject "PackageMeta" $ \o -> do
    let getString = \case {String s -> Just s; _ -> Nothing}
    description <- o .:? "description"
    author <- o .:? "author" <|> pure Nothing
    maybePlatforms :: Maybe (Vector Text) <- o .:? "os" <|> pure Nothing
    let platforms = maybe mempty (catMaybes . map parseNodePlatform) maybePlatforms
    homepage <- o .:? "homepage" >>= \case
      Nothing -> return Nothing
      Just (String txt) -> return $ parseURIText txt
      Just (Array stuff) -> case toList $ catMaybes (getString <$> stuff) of
        [] -> return Nothing
        (uri:_) -> return $ parseURIText uri
    let
      getKeywords (String s) = fromList $ T.strip <$> T.split (==',') s
      getKeywords (Array a) = catMaybes $ map getString a
      getKeywords _ = mempty
    keywords <- map getKeywords $ o .:? "keywords" .!= Null
    return $ PackageMeta description author homepage keywords platforms


  ` ResolvedPkg ` .
data VersionInfo = VersionInfo {
  viName :: PackageName,
  viDependencies :: PRecord NpmVersionRange,
  viOptionalDependencies :: PRecord NpmVersionRange,
  viDevDependencies :: PRecord NpmVersionRange,
  viBundledDependencies :: [PackageName],
  viMeta :: PackageMeta,
  viVersion :: SemVer
  } deriving (Show, Eq)

  | SHA digest , combining an algorithm type with a digest .
data Shasum = SHA1 Text | SHA256 Text deriving (Show, Eq)

  | Distribution info from NPM . Tells us the URL and hash of a tarball .
data DistInfo = DistInfo {
  diUrl :: Text,
  diShasum :: Shasum
  } deriving (Show, Eq)

data DependencyType
  | OptionalDependency
  deriving (Show, Eq)

data PossiblyCircularSemVer
  = NotCircular SemVer
  | Circular CircularSemVer
  deriving (Show, Eq, Ord, Generic)

instance Hashable PossiblyCircularSemVer

newtype CircularSemVer = CircularSemVer {unCirc :: SemVer}
  deriving (Show, Eq, Ord, Generic)

instance Hashable CircularSemVer

  | Convert a PossiblyCircularSemVer to a SemVer .
unpackPSC :: PossiblyCircularSemVer -> SemVer
unpackPSC (Circular (CircularSemVer sv)) = sv
unpackPSC (NotCircular sv) = sv

  | Separate a list of PossiblyCircularSemVers into two lists .
  The first element contains non - circular dependencies , and the
sepCirculars :: [PossiblyCircularSemVer] -> ([SemVer], [CircularSemVer])
sepCirculars [] = ([], [])
sepCirculars (psc:rest) = do
  let (noncirculars, circulars) = sepCirculars rest
  case psc of
    NotCircular nc -> (nc:noncirculars, circulars)
    Circular c -> (noncirculars, c:circulars)

  | Similar to @sepCirculars@ but takes in a HashMap and returns a
sepCircularMap :: (Hashable a, Eq a)
               => HashMap a PossiblyCircularSemVer
               -> (HashMap a SemVer, HashMap a CircularSemVer)
sepCircularMap m = go $ H.toList m where
  go [] = (mempty, mempty)
  go ((key, psc):rest) = do
    let (noncirculars, circulars) = go rest
    case psc of
      NotCircular nc -> (H.insert key nc noncirculars, circulars)
      Circular c -> (noncirculars, H.insert key c circulars)

data BrokenPackageReason
  = NoMatchingPackage PackageName
  | NoMatchingVersion NpmVersionRange
  | InvalidNpmVersionRange Text
  | NoSuchTag Name
  | TagPointsToInvalidVersion Name SemVer
  | InvalidSemVerSyntax Text String
  | InvalidPackageJson Text String
  | NoDistributionInfo
  | Reason String
  | GithubError GithubError
  | NotYetImplemented String
  | BrokenDependency PackageName BrokenPackageReason
  deriving (Show, Eq, Typeable)

instance Exception BrokenPackageReason

data ResolvedDependency
  deriving (Show, Eq)

instance Semigroup PackageInfo where
  PackageInfo vs ts <> PackageInfo vs' ts' =
    PackageInfo (vs CP.<> vs') (ts CP.<> ts')

instance Monoid PackageInfo where
  mempty = PackageInfo mempty mempty
  mappend = (CP.<>)

instance FromJSON PackageName where
  parseJSON (String name) = case parsePackageName name of
    Left err -> fail $ unpack err
    Right pname -> return pname
  parseJSON v = typeMismatch "Expected a string for a package name" v

  | Gets a hashmap from an object , or otherwise returns an empty hashmap .
getDict :: (FromJSON val, FromJSON key, Hashable key, Eq key)
        => Text -> Object -> Aeson.Parser (HashMap key val)
getDict key obj = case H.lookup key obj of
  Just (Object obj') -> map H.fromList $
    forM (H.toList obj') $ \(k, v) -> do
      key <- parseJSON (String k)
      val <- parseJSON v
      return (key, val)
  _ -> return mempty

instance FromJSON VersionInfo where
  parseJSON = withObject "version info" $ \o -> do
    listedDependencies <- getDict "dependencies" o
    devDependencies <- getDict "devDependencies" o
    optionalDependencies <- getDict "optionalDependencies" o
    bundledDependencies <- o .:? "bundledDependencies" .!= []
    let isMissingDep name = not $ H.member name listedDependencies
        missing = filter isMissingDep bundledDependencies
        missingDependencies = zip missing (repeat $ SemVerRange anyVersion)
        dependencies = listedDependencies <> H.fromList missingDependencies
    dist <- o .:? "dist"
    pkgName <- o .: "name"
    version <- o .: "version"
    packageMeta <- parseJSON (Object o)
    scripts :: Record Value <- getDict "scripts" o <|> fail "couldn't get scripts"
    let rmOptionals = flip H.difference optionalDependencies
    case parseSemVer version of
      Left _ -> throw $ VersionSyntaxError version
      Right semver -> return $ VersionInfo {
        viDependencies = rmOptionals dependencies,
        viDevDependencies = rmOptionals devDependencies,
        viOptionalDependencies = optionalDependencies,
        viBundledDependencies = bundledDependencies,
        viDist = dist,
        viName = pkgName,
        viMeta = packageMeta,
        viVersion = semver
      }

instance FromJSON SemVerRange where
  parseJSON v = case v of
    String s -> case parseSemVerRange s of
      Left err -> do
        let errorMessage = "valid semantic version (got " <> show v <> ")"
        typeMismatch errorMessage v
      Right range -> return range
    _ -> typeMismatch "string" v

instance FromJSON PackageInfo where
  parseJSON = getObject "package info" >=> \o -> do
    vs' :: Record VersionInfo <- getDict "versions" o
    tags' <- getDict "dist-tags" o
    let vs = H.fromList $ map (\vi -> (viVersion vi, vi)) $ H.elems vs'
        convert tags [] = return $ PackageInfo vs (H.fromList tags)
        convert tags ((tName, tVer):ts) = case parseSemVer tVer of
          Left err -> failC ["Tag ", tName, " refers to an invalid ",
                             "semver string ", tVer, ": ", tshow err]
          Right ver -> convert ((tName, ver):tags) ts
    convert [] $ H.toList tags'

instance FromJSON DistInfo where
  parseJSON = getObject "dist info" >=> \o -> do
    tarball <- o .: "tarball"
    shasum <- SHA1 <$> o .: "shasum"
    return $ DistInfo tarball shasum
