Types.hs

{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module    : Aura.Types
-- Copyright : (c) Colin Woodbury, 2012 - 2021
-- License   : GPL3
-- Maintainer: Colin Woodbury <colin@fosskers.ca>
--
-- Core Aura types.

module Aura.Types
  ( -- * Package Types
    Package(..), pname, pprov, pver, dividePkgs
  , Dep(..), parseDep, renderedDep
  , Buildable(..)
  , Prebuilt(..)
  , SimplePkg(..), simplepkg, simplepkg', bToSP, pToSP
    -- * Typeclasses
  , Flagable(..)
    -- * Package Building
  , VersionDemand(..), _VersionDemand
  , InstallType(..)
    -- * Errors
  , DepError(..)
  , Failure(..)
  , FailMsg(..)
    -- * Language
  , Language(..)
    -- * Other Wrappers
  , PkgName(..)
  , PkgGroup(..)
  , Provides(..)
  , PackagePath, packagePath, ppPath
  , Pkgbuild(..)
  , Environment
  , User(..)
  ) where

import           Aura.Utils
import           Data.Aeson (FromJSONKey, ToJSONKey)
import           Data.Versions hiding (Traversal')
import           Prettyprinter hiding (list, space)
import           Prettyprinter.Render.Terminal
import           RIO hiding (try)
import           RIO.FilePath
import qualified RIO.Text as T
import           Text.Megaparsec
import           Text.Megaparsec.Char

---

-- | Types whose members can be converted to CLI flags.
class Flagable a where
  asFlag :: a -> [Text]

instance Flagable Text where
  asFlag t = [t]

instance (Foldable f, Flagable a) => Flagable (f a) where
  asFlag = foldMap asFlag

-- | A package to be installed.
data Package = FromRepo !Prebuilt | FromAUR !Buildable deriving (Eq)

-- | The name of a `Package`.
pname :: Package -> PkgName
pname (FromRepo pb) = pName pb
pname (FromAUR b)   = bName b

-- | Other names which allow this `Package` to be satisfied as a dependency.
pprov :: Package -> Provides
pprov (FromRepo pb) = pProvides pb
pprov (FromAUR b)   = bProvides b

-- | The version of a `Package`.
pver :: Package -> Versioning
pver (FromRepo pb) = pVersion pb
pver (FromAUR b)   = bVersion b

dividePkgs :: NonEmpty Package -> These (NonEmpty Prebuilt) (NonEmpty Buildable)
dividePkgs = partNonEmpty f
  where
    f :: Package -> These Prebuilt Buildable
    f (FromRepo p) = This p
    f (FromAUR b)  = That b

-- TODO Figure out how to do this more generically.
instance Ord Package where
  compare (FromAUR a) (FromAUR b)   = compare a b
  compare (FromRepo a) (FromRepo b) = compare a b
  compare (FromAUR a) (FromRepo b)  = compare (bToSP a) (pToSP b)
  compare (FromRepo a) (FromAUR b)  = compare (pToSP a) (bToSP b)

-- | A `Package` from the AUR that's buildable in some way on the user's machine.
data Buildable = Buildable
  { bName       :: !PkgName
  , bVersion    :: !Versioning
  , bBase       :: !PkgName
  , bProvides   :: !Provides
  , bDeps       :: ![Dep]
  , bPkgbuild   :: !Pkgbuild
  , bIsExplicit :: !Bool }
  deriving (Eq, Ord, Show, Generic)

-- | A prebuilt `Package` from the official Arch repositories.
data Prebuilt = Prebuilt
  { pName     :: !PkgName
  , pVersion  :: !Versioning
  , pBase     :: !PkgName
  , pProvides :: !Provides }
  deriving (Eq, Ord, Show, Generic)

-- | A dependency on another package.
data Dep = Dep
  { dName   :: !PkgName
  , dDemand :: !VersionDemand }
  deriving (Eq, Ord, Show, Generic)

-- | Parse a dependency entry as it would appear in a PKGBUILD:
--
-- @
-- >>> parseDep "pacman>1.2.3"
-- Just (Dep {name = PkgName {name = "pacman"}, demand = >1.2.3})
-- @
parseDep :: Text -> Maybe Dep
parseDep = hush . parse dep "dep"
  where dep = Dep <$> n <*> v
        n   = PkgName <$> takeWhile1P Nothing (\c -> c /= '<' && c /= '>' && c /= '=')
        v   = do
          end <- atEnd
          if end
            then pure Anything
            else choice [ char '<'    *> fmap LessThan versioning'
                        , string ">=" *> fmap AtLeast  versioning'
                        , char '>'    *> fmap MoreThan versioning'
                        , char '='    *> fmap MustBe   versioning'
                        , pure Anything ]

-- | Renders the `Dep` into a form that @pacman -T@ understands. The dual of
-- `parseDep`.
renderedDep :: Dep -> Text
renderedDep (Dep n ver) = pnName n <> asT ver
  where
    asT :: VersionDemand -> Text
    asT (LessThan v) = "<"  <> prettyV v
    asT (AtLeast  v) = ">=" <> prettyV v
    asT (MoreThan v) = ">"  <> prettyV v
    asT (MustBe   v) = "="  <> prettyV v
    asT Anything     = ""

-- | The versioning requirement of some package's dependency.
data VersionDemand = LessThan !Versioning
                   | AtLeast  !Versioning
                   | MoreThan !Versioning
                   | MustBe   !Versioning
                   | Anything
                   deriving (Eq, Ord)

instance Show VersionDemand where
  show (LessThan v) = T.unpack $ "<"  <> prettyV v
  show (AtLeast  v) = T.unpack $ ">=" <> prettyV v
  show (MoreThan v) = T.unpack $ ">"  <> prettyV v
  show (MustBe   v) = T.unpack $ "="  <> prettyV v
  show Anything     = "Anything"

-- | Attempt to zoom into the `Versioning` hiding within a `VersionDemand`.
_VersionDemand :: Traversal' VersionDemand Versioning
_VersionDemand f (LessThan v) = LessThan <$> f v
_VersionDemand f (AtLeast v)  = AtLeast  <$> f v
_VersionDemand f (MoreThan v) = MoreThan <$> f v
_VersionDemand f (MustBe v)   = MustBe   <$> f v
_VersionDemand _ p            = pure p

-- | The installation method.
data InstallType = Pacman !PkgName | Build !Buildable deriving (Eq)

-- | A package name with its version number.
data SimplePkg = SimplePkg
  { spName    :: !PkgName
  , spVersion :: !Versioning }
  deriving (Eq, Ord, Show, Generic)

bToSP :: Buildable -> SimplePkg
bToSP b = SimplePkg (bName b) (bVersion b)

pToSP :: Prebuilt -> SimplePkg
pToSP p = SimplePkg (pName p) (pVersion p)

-- | Attempt to create a `SimplePkg` from filepaths like
--   @\/var\/cache\/pacman\/pkg\/linux-3.2.14-1-x86_64.pkg.tar.zst@
simplepkg :: PackagePath -> Maybe SimplePkg
simplepkg (PackagePath t) = do
  nav <- hush . parse nameAndVer "Name and Version" . T.pack $ takeFileName t
  uncurry SimplePkg <$> bitraverse hush hush (parse n "name" nav, parse ver "version" nav)
  where
    nameAndVer :: Parsec Void Text Text
    nameAndVer = T.pack <$> manyTill anySingle (string "-x86_64" <|> string "-any")

    n :: Parsec Void Text PkgName
    n = PkgName . T.pack <$> manyTill anySingle (try finished)

    -- | Assumes that a version number will never start with a letter,
    -- and that a package name section (i.e. abc-def-ghi) will never start
    -- with a number.
    finished :: Parsec Void Text Char
    finished = char '-' *> lookAhead digitChar

    ver :: Parsec Void Text Versioning
    ver = do
      void $ manyTill anySingle (try finished)
      choice [ try $ fmap Ideal semver'
             , try $ fmap General version'
             , fmap Complex mess' ]

-- | Attempt to create a `SimplePkg` from text like:
--     xchat 2.8.8-19
simplepkg' :: Text -> Maybe SimplePkg
simplepkg' = hush . parse parser "name-and-version"
  where parser = SimplePkg <$> (PkgName <$> takeWhile1P Nothing (/= ' ')) <*> (space *> versioning')

-- | Filepaths like:
--
--   * \/var\/cache\/pacman\/pkg\/linux-3.2.14-1-x86_64.pkg.tar.xz
--   * \/var\/cache\/pacman\/pkg\/wine-1.4rc6-1-x86_64.pkg.tar.xz
--   * \/var\/cache\/pacman\/pkg\/ruby-1.9.3_p125-4-x86_64.pkg.tar.xz
newtype PackagePath = PackagePath { ppPath :: FilePath }
  deriving (Eq, Generic)

-- | If they have the same package names, compare by their versions.
-- Otherwise, do raw comparison of the path string.
instance Ord PackagePath where
  compare a b | nameA /= nameB = compare (ppPath a) (ppPath b)
              | otherwise      = compare verA verB
    where
      (nameA, verA) = f a
      (nameB, verB) = f b

      f :: PackagePath -> (Maybe PkgName, Maybe Versioning)
      f = (fmap spName &&& fmap spVersion) . simplepkg

-- | Smart constructor for `PackagePath`.
packagePath :: FilePath -> Maybe PackagePath
packagePath fp = bool Nothing (Just $ PackagePath fp) $ not (isExtensionOf "sig" fp) && isAbsolute fp

-- | The contents of a PKGBUILD file.
newtype Pkgbuild = Pkgbuild { pkgbuild :: ByteString }
  deriving (Eq, Ord, Show, Generic)

-- | All human languages available for text output.
data Language = English
              | Japanese
              | Polish
              | Croatian
              | Swedish
              | German
              | Spanish
              | Portuguese
              | French
              | Russian
              | Italian
              | Serbian
              | Norwegian
              | Indonesia
              | Chinese
              | Esperanto
              | Dutch
              | Turkish
              | Arabic
              | Ukrainian
              | Romanian
              | Vietnamese
              | Czech
              | Korean
              deriving (Eq, Enum, Bounded, Ord, Show)

-- | The various ways that dependency resolution can fail.
data DepError = NonExistant !PkgName !PkgName
              | VerConflict !(Doc AnsiStyle)
              | Ignored !(Doc AnsiStyle)
              | BrokenProvides !PkgName !Provides !PkgName

-- | Failures that can occur during Aura processing. Could be a message, or a
-- silent failure that should print nothing to the console.
data Failure = Silent | Failure FailMsg
  deriving stock (Show)

instance Exception Failure

-- | Some failure message that when given the current runtime `Language`
-- will produce a human-friendly error.
newtype FailMsg = FailMsg { failure :: Language -> Doc AnsiStyle }

instance Exception FailMsg

instance Show FailMsg where
  show _ = "There was some failure."

-- | Shell environment variables.
type Environment = Map Text Text

-- | The name of a user account on a Linux system.
newtype User = User { user :: Text }
  deriving (Eq, Show, Generic)

-- | The name of an Arch Linux package.
newtype PkgName = PkgName { pnName :: Text }
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (Flagable, ToJSONKey, FromJSONKey, IsString)

-- | A group that a `Package` could belong too, like @base@, @base-devel@, etc.
newtype PkgGroup = PkgGroup { pgGroup :: Text }
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (Flagable)

-- | The dependency which some package provides. May not be the same name
-- as the package itself (e.g. cronie provides cron).
newtype Provides = Provides { provides :: PkgName }
  deriving (Eq, Ord, Show, Generic)