{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Stack.Lock
    ( lockCachedWanted
    , LockedLocation(..)
    , Locked(..)
    ) where

import Pantry.Internal.AesonExtended
import Data.ByteString.Builder (byteString)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Yaml as Yaml
import Pantry
import Path (parent)
import Path.Extended (addExtension)
import Path.IO (doesFileExist)
import Stack.Prelude
import Stack.SourceMap
import Stack.Types.Config
import Stack.Types.SourceMap

data LockedLocation a b = LockedLocation
    { llOriginal :: a
    , llCompleted :: b
    } deriving (Eq, Show)

instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where
    toJSON ll =
        object [ "original" .= llOriginal ll, "completed" .= llCompleted ll ]

instance ( FromJSON (WithJSONWarnings (Unresolved a))
         , FromJSON (WithJSONWarnings (Unresolved b))
         ) =>
         FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where
    parseJSON =
        withObjectWarnings "LockedLocation" $ \o -> do
            original <- jsonSubWarnings $ o ..: "original"
            completed <- jsonSubWarnings $ o ..: "completed"
            pure $ LockedLocation <$> original <*> completed

-- Special wrapper extracting only 1 RawPackageLocationImmutable
-- serialization should not produce locations with multiple subdirs
-- so we should be OK using just a head element
newtype SingleRPLI = SingleRPLI { unSingleRPLI :: RawPackageLocationImmutable}

instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where
   parseJSON v =
     do
       WithJSONWarnings unresolvedRPLIs ws <- parseJSON v
       let withWarnings x = WithJSONWarnings x ws
       pure $ withWarnings $ SingleRPLI . NE.head <$> unresolvedRPLIs

data Locked = Locked
    { lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]
    , lckPkgImmutableLocations :: [LockedLocation RawPackageLocationImmutable PackageLocationImmutable]
    } deriving (Eq, Show)

instance ToJSON Locked where
    toJSON Locked {..} =
        object
            [ "snapshots" .= lckSnapshotLocations
            , "packages" .= lckPkgImmutableLocations
            ]

instance FromJSON (WithJSONWarnings (Unresolved Locked)) where
    parseJSON = withObjectWarnings "Locked" $ \o -> do
      snapshots <- jsonSubWarningsT $ o ..: "snapshots"
      packages <- jsonSubWarningsT $ o ..: "packages"
      let unwrap ll = ll { llOriginal = unSingleRPLI (llOriginal ll) }
      pure $ Locked <$> sequenceA snapshots <*> (map unwrap <$> sequenceA packages)

loadYamlThrow
    :: HasLogFunc env
    => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a
loadYamlThrow parser path = do
    val <- liftIO $ Yaml.decodeFileThrow (toFilePath path)
    case Yaml.parseEither parser val of
        Left err -> throwIO $ Yaml.AesonException err
        Right (WithJSONWarnings res warnings) -> do
            logJSONWarnings (toFilePath path) warnings
            return res

lockCachedWanted ::
       (HasPantryConfig env, HasRunner env)
    => Path Abs File
    -> RawSnapshotLocation
    -> (Map RawPackageLocationImmutable PackageLocationImmutable
        -> WantedCompiler
        -> Map PackageName (Bool -> RIO env DepPackage)
        -> RIO env ( SMWanted, [CompletedPLI]))
    -> RIO env SMWanted
lockCachedWanted stackFile resolver fillWanted = do
    lockFile <- liftIO $ addExtension ".lock" stackFile
    let getLockExists = doesFileExist lockFile
    lfb <- view lockFileBehaviorL
    readLockFile <-
      case lfb of
        LFBIgnore -> pure False
        LFBReadWrite -> getLockExists
        LFBReadOnly -> getLockExists
        LFBErrorOnWrite -> getLockExists
    locked <-
        if readLockFile
        then do
            logDebug "Using package location completions from a lock file"
            unresolvedLocked <- loadYamlThrow parseJSON lockFile
            resolvePaths (Just $ parent stackFile) unresolvedLocked
        else do
            logDebug "Not reading lock file"
            pure $ Locked [] []
    let toMap :: Ord a => [LockedLocation a b] -> Map a b
        toMap =  Map.fromList . map (\ll -> (llOriginal ll, llCompleted ll))
        slocCache = toMap $ lckSnapshotLocations locked
        pkgLocCache = toMap $ lckPkgImmutableLocations locked
    (snap, slocCompleted, pliCompleted) <-
        loadAndCompleteSnapshotRaw resolver slocCache pkgLocCache
    let compiler = snapshotCompiler snap
        snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap)
    (wanted, prjCompleted) <- fillWanted pkgLocCache compiler snPkgs
    let lockLocations = map (\(CompletedPLI r c) -> LockedLocation r c)
        differentSnapLocs (CompletedSL raw complete)
          | raw == toRawSL complete = Nothing
          | otherwise = Just $ LockedLocation raw complete
        newLocked = Locked { lckSnapshotLocations = mapMaybe differentSnapLocs slocCompleted
                           , lckPkgImmutableLocations =
                             lockLocations $ pliCompleted <> prjCompleted
                           }
    when (newLocked /= locked) $ do
      case lfb of
        LFBReadWrite ->
          writeBinaryFileAtomic lockFile $
            header <>
            byteString (Yaml.encode newLocked)
        LFBErrorOnWrite -> do
          logError "You indicated that Stack should error out on writing a lock file"
          logError $
            "I just tried to write the following lock file contents to " <>
            fromString (toFilePath lockFile)
          logError $ display $ decodeUtf8With lenientDecode $ Yaml.encode newLocked
          exitFailure
        LFBIgnore -> pure ()
        LFBReadOnly -> pure ()
    pure wanted
  where
    header =
      "# This file was autogenerated by Stack.\n\
      \# You should not edit this file by hand.\n\
      \# For more information, please see the documentation at:\n\
      \#   https://docs.haskellstack.org/en/stable/lock_files\n\n"