{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}

-- | Utilities for reading @cabal@'s @plan.json@ file
--
-- @plan.json@ are generated when using @cabal@
-- <http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html Nix-style Local Builds>.
module Cabal.Plan
    (
      PlanJson(..)
    , Unit(..)
    , CompName(..)
    , dispCompName
    , CompInfo(..)
    , UnitType(..)

    -- * Basic types
    , Ver(..)
    , dispVer
    , PkgName(..)
    , PkgId(..)
    , dispPkgId
    , UnitId(..)
    , Sha256(..)
    , dispSha256

    -- * Utilities
    , planJsonIdGraph
    , planJsonIdRoots

    -- * Convenience functions
    , findAndDecodePlanJson
    , decodePlanJson
    ) where

import           Control.Applicative          as App
import           Control.Monad
import           Data.Aeson
import           Data.Aeson.Types
import qualified Data.ByteString              as B
import qualified Data.ByteString.Base16       as B16
import           Data.List
import           Data.Map                     (Map)
import qualified Data.Map                     as M
import           Data.Monoid
import           Data.Set                     (Set)
import qualified Data.Set                     as S
import           Data.Text                    (Text)
import qualified Data.Text                    as T
import qualified Data.Text.Encoding           as T
import qualified Data.Version                 as DV
import           System.Directory
import           System.FilePath
import           Text.ParserCombinators.ReadP

----------------------------------------------------------------------------

-- | Equivalent to @Cabal@'s "Distribution.Package.Version"
newtype Ver = Ver [Int]
            deriving (Show,Eq,Ord)

-- | Equivalent to @Cabal@'s "Distribution.Package.UnitId"
newtype UnitId = UnitId Text
               deriving (Show,Eq,Ord,FromJSON,ToJSON)

-- | Equivalent to @Cabal@'s "Distribution.Package.PackageName"
newtype PkgName = PkgName Text
                deriving (Show,Eq,Ord,FromJSON,ToJSON)

-- | Equivalent to @Cabal@'s "Distribution.Package.PackageIdentifier"
data PkgId = PkgId !PkgName !Ver
           deriving (Show,Eq,Ord)

-- | SHA-256 hash
--
-- As an invariant, the wrapped 'B.ByteString' is exactly 32 bytes long.
newtype Sha256 = Sha256 B.ByteString
               deriving (Eq,Ord)

-- | Represents the information contained in cabal's @plan.json@ file.
--
-- This comprises basic information describing the environment as well
-- as the install/build plan computed by @cabal@.
data PlanJson = PlanJson
     { pjCabalVersion    :: !Ver                     -- ^ Version of @cabal@ frontend
     , pjCabalLibVersion :: !Ver                     -- ^ Version of Cabal library
     , pjCompilerId      :: !PkgId                   -- ^ Name and version of Haskell compiler
     , pjArch            :: !Text                    -- ^ Architecture name
     , pjOs              :: !Text                    -- ^ Operating system name
     , pjUnits           :: !(M.Map UnitId Unit) -- ^ install/build plan
     } deriving Show

-- | Describes kind of build unit and its provenance
data UnitType = UnitTypeBuiltin -- ^ Lives in global (non-nix-style) package db
              | UnitTypeGlobal  -- ^ Lives in Nix-store cache
              | UnitTypeLocal   -- ^ Local package
              | UnitTypeInplace -- ^ Local in-place package
              deriving (Show,Eq)

-- | Represents a build-plan unit uniquely identified by its 'UnitId'
data Unit = Unit
     { uId     :: !UnitId      -- ^ Unit ID uniquely identifying a 'Unit' in install plan
     , uPId    :: !PkgId       -- ^ Package name and version (not necessarily unique within plan)
     , uType   :: !UnitType      -- ^ Describes type of build item, see 'UnitType'
     , uSha256 :: !(Maybe Sha256) -- ^ SHA256 source tarball checksum (as used by e.g. @hackage-security@)
     , uComps  :: !(Map CompName CompInfo) -- ^ Components identified by 'UnitId'
       --
       -- When @cabal@ needs to fall back to legacy-mode (currently for
       -- @custom@ build-types or obsolete @cabal-version@ values), 'uComps'
       -- may contain more than one element.
     , uFlags  :: !(Map Text Bool) -- ^ cabal flag settings (not available for 'UnitTypeBuiltin')
     } deriving Show

-- | Component name inside a build-plan unit
--
-- A similiar type exists in @Cabal@ codebase, see
-- "Distribution.Simple.LocalBuildInfo.ComponentName"
data CompName =
    CompNameLib
  | CompNameSubLib !Text
  | CompNameExe    !Text
  | CompNameTest   !Text
  | CompNameBench  !Text
  | CompNameSetup
  deriving (Show, Eq, Ord)

-- | Describes component-specific information inside a 'Unit'
data CompInfo = CompInfo
    { ciLibDeps :: Set UnitId     -- ^ library dependencies
    , ciExeDeps :: Set UnitId     -- ^ executable dependencies
    , ciBinFile :: Maybe FilePath -- ^ path-name of artifact if available
    } deriving Show

----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------

-- JSON instances

instance FromJSON CompName where
    parseJSON = withText "CompName" (maybe (fail "invalid CompName") pure . parseCompName)

instance ToJSON CompName where
    toJSON     = toJSON . dispCompName

instance FromJSONKey CompName where
    fromJSONKey = FromJSONKeyTextParser (maybe (fail "CompName") pure . parseCompName)

instance ToJSONKey   CompName where
    toJSONKey = toJSONKeyText dispCompName

instance FromJSON CompInfo where
    parseJSON = withObject "CompInfo" $ \o ->
        CompInfo <$> o .:?! "depends"
                 <*> o .:?! "exe-depends"
                 <*> o .:? "bin-file"

instance FromJSON PkgId where
    parseJSON = withText "PkgId" (maybe (fail "PkgId") pure . parsePkgId)

instance ToJSON PkgId where
    toJSON = toJSON . dispPkgId

----------------------------------------------------------------------------
-- parser helpers

parseCompName :: Text -> Maybe CompName
parseCompName t0 = case T.splitOn ":" t0 of
                     ["lib"]     -> Just CompNameLib
                     ["lib",n]   -> Just $ CompNameSubLib n
                     ["exe",n]   -> Just $ CompNameExe n
                     ["bench",n] -> Just $ CompNameBench n
                     ["test",n]  -> Just $ CompNameTest n
                     ["setup"]   -> Just CompNameSetup
                     _           -> Nothing

-- | Pretty print 'CompName'
dispCompName :: CompName -> Text
dispCompName cn = case cn of
    CompNameLib      -> "lib"
    CompNameSubLib n -> "lib:" <> n
    CompNameExe n    -> "exe:" <> n
    CompNameBench n  -> "bench:" <> n
    CompNameTest n   -> "test:" <> n
    CompNameSetup    -> "setup"

instance FromJSON PlanJson where
    parseJSON = withObject "PlanJson" $ \o -> do
        pjCabalVersion    <- o .: "cabal-version"

        unless (pjCabalVersion >= Ver [2]) $
            fail ("plan.json version " ++ T.unpack (dispVer pjCabalVersion) ++ " not supported")

        pjCabalLibVersion <- o .: "cabal-lib-version"
        pjCompilerId      <- o .: "compiler-id"
        pjArch            <- o .: "arch"
        pjOs              <- o .: "os"
        pjUnits           <- toMap =<< o .: "install-plan"

        App.pure PlanJson{..}
      where
        toMap pil = do
            let pim = M.fromList [ (uId pi',pi') | pi' <- pil ]
            unless (M.size pim == length pil) $
                fail "install-plan[] has duplicate ids"
            pure pim

(.:?!) :: (FromJSON a, Monoid a) => Object -> Text -> Parser a
o .:?! fld = o .:? fld .!= mempty

planItemAllDeps :: Unit -> Set UnitId
planItemAllDeps Unit{..} = mconcat [ ciLibDeps <> ciExeDeps | CompInfo{..} <- M.elems uComps ]

instance FromJSON Unit where
    parseJSON = withObject "Unit" $ \o -> do
        mcomponents    <- o .:? "components"
        mcomponentname <- o .:? "component-name"
        ty             <- o .:  "type"
        mstyle         <- o .:? "style"

        uId     <- o .: "id"
        uPId    <- PkgId <$> o .: "pkg-name" <*> o .: "pkg-version"
        uType   <- case (ty :: Text, mstyle :: Maybe Text) of
                   ("pre-existing",Nothing)      -> pure UnitTypeBuiltin
                   ("configured",Just "global")  -> pure UnitTypeGlobal
                   ("configured",Just "local")   -> pure UnitTypeLocal
                   ("configured",Just "inplace") -> pure UnitTypeInplace
                   _                             -> fail (show (ty,mstyle))
        uFlags  <- o .:?! "flags"
        uSha256 <- o .:? "pkg-src-sha256"
        uComps  <- case (mcomponents, mcomponentname) of
          (Just comps0, Nothing) ->
              pure comps0
          (Nothing, Just cname) ->
              M.singleton cname <$> parseJSON (Object o)
          (Nothing, Nothing) | uType == UnitTypeBuiltin ->
              M.singleton CompNameLib <$> parseJSON (Object o)
          _ -> fail (show o)

        pure Unit{..}

----------------------------------------------------------------------------
-- Convenience helper

-- | Locates and decodes @plan.json@ for cabal project being in scope
-- for current working directory
--
-- The folder assumed to be the project-root is returned as well.
--
-- Throws 'IO' exceptions on errors.
--
findAndDecodePlanJson :: IO (PlanJson, FilePath)
findAndDecodePlanJson = do
    projbase <- findProjRoot

    let distFolder = projbase </> "dist-newstyle"
    haveDistFolder <- doesDirectoryExist distFolder

    unless haveDistFolder $
        fail ("missing " ++ show distFolder ++ " folder; do you need to run 'cabal new-build'?")

    let planJsonFn = distFolder </> "cache" </> "plan.json"

    havePlanJson <- doesFileExist planJsonFn

    unless havePlanJson $
        fail "missing 'plan.json' file; do you need to run 'cabal new-build'?"

    plan <- decodePlanJson planJsonFn

    pure (plan, projbase)

-- | Decodes @plan.json@ file location provided as 'FilePath'
--
-- This is a trivial convenience function so that the caller doesn't
-- have to depend on @aeson@ directly
--
-- Throws 'IO' exceptions on errors.
--
decodePlanJson :: FilePath -> IO PlanJson
decodePlanJson planJsonFn = do
    jsraw <- B.readFile planJsonFn
    either fail pure $ eitherDecodeStrict' jsraw

-- Find project root, this emulates cabal's current heuristic
--
-- TODO: currently fallsback to CWD if no cabal.project is found; fallback to locating $pkg.cabal files instead
findProjRoot :: IO FilePath
findProjRoot = do
    cwd  <- getCurrentDirectory

    let tst d = do let fn = d </> "cabal.project"
                   ex <- doesFileExist fn
                   if ex then pure (Just fn) else pure Nothing

    md <- walkUpFolders tst cwd

    pure (maybe cwd fst md)


walkUpFolders :: (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe (FilePath,a))
walkUpFolders dtest d0 = do
    home <- getHomeDirectory

    let go d | d == home  = pure Nothing
             | isDrive d  = pure Nothing
             | otherwise  = do
                   t <- dtest d
                   case t of
                     Just a  -> pure $ Just (d, a)
                     Nothing -> go (takeDirectory d)

    go d0


parseVer :: Text -> Maybe Ver
parseVer str = case reverse $ readP_to_S DV.parseVersion (T.unpack str) of
  (ver, "") : _ | not (null (DV.versionBranch ver)), all (>= 0) (DV.versionBranch ver)
      -> Just (Ver $ DV.versionBranch ver)
  _   -> Nothing

-- | Pretty print 'Ver'
dispVer :: Ver -> Text
dispVer (Ver ns) = T.pack $ intercalate "." (map show ns)

instance FromJSON Ver where
    parseJSON = withText "Ver" (maybe (fail "Ver") pure . parseVer)

instance ToJSON Ver where
    toJSON = toJSON . dispVer

parsePkgId :: Text -> Maybe PkgId
parsePkgId t = do
  let (pns_, pvs) = T.breakOnEnd "-" t
  pv <- parseVer pvs

  pn <- T.stripSuffix "-" pns_

  -- TODO: validate pn
  pure (PkgId (PkgName pn) pv)

-- | Pretty print 'PkgId'
dispPkgId :: PkgId -> Text
dispPkgId (PkgId (PkgName pn) pv) = pn <> "-" <> dispVer pv

parseSha256 :: Text -> Maybe Sha256
parseSha256 t
  | B.length s == 32, B.null rest = Just (Sha256 s)
  | otherwise                       = Nothing
  where
    (s, rest) = B16.decode $ T.encodeUtf8 t

-- | Pretty print 'Sha256' as base-16
dispSha256 :: Sha256 -> Text
dispSha256 (Sha256 s) = T.decodeLatin1 (B16.encode s)

instance FromJSON Sha256 where
    parseJSON = withText "Sha256" (maybe (fail "Sha256") pure . parseSha256)

instance ToJSON Sha256 where
    toJSON = toJSON . dispSha256

instance Show Sha256 where
    show = show . dispSha256



----------------------------------------------------------------------------

-- | Extract directed 'UnitId' dependency graph edges from 'pjUnits'
--
-- This graph contains both, library and executable dependencies edges
planJsonIdGraph :: PlanJson -> Map UnitId (Set UnitId)
planJsonIdGraph PlanJson{..} = M.fromList [ (uId unit, planItemAllDeps unit)
                                          | unit <- M.elems pjUnits
                                          ]

-- | Extract 'UnitId' root nodes from dependency graph computed by 'planJsonIdGraph'
planJsonIdRoots :: PlanJson -> Set UnitId
planJsonIdRoots PlanJson{..} = M.keysSet pjUnits `S.difference` nonRoots
  where
    nonRoots :: Set UnitId
    nonRoots = mconcat $ M.elems $ planJsonIdGraph PlanJson{..}