{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ViewPatterns      #-}

-- | This module contains the implementation of the @dhall freeze@ subcommand

module Dhall.Freeze
    ( -- * Freeze
      freeze
    , freezeImport
    , freezeRemoteImport

      -- * Types
    , Scope(..)
    , Intent(..)
    ) where

import Data.Bifunctor (first)
import Data.Monoid ((<>))
import Data.Text
import Dhall.Parser (Src)
import Dhall.Pretty (CharacterSet)
import Dhall.Syntax (Expr(..), Import(..), ImportHashed(..), ImportType(..))
import Dhall.Util
    ( Censor
    , CheckFailed(..)
    , Header(..)
    , Input(..)
    , OutputMode(..)
    )
import System.Console.ANSI (hSupportsANSI)

import qualified Control.Exception                         as Exception
import qualified Control.Monad.Trans.State.Strict          as State
import qualified Data.Text.IO                              as Text.IO
import qualified Data.Text.Prettyprint.Doc                 as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text     as Pretty.Text
import qualified Dhall.Core                                as Core
import qualified Dhall.Import
import qualified Dhall.Optics
import qualified Dhall.Parser                              as Parser
import qualified Dhall.Pretty
import qualified Dhall.TypeCheck
import qualified Dhall.Util                                as Util
import qualified System.AtomicWrite.Writer.LazyText        as AtomicWrite.LazyText
import qualified System.FilePath
import qualified System.IO

-- | Retrieve an `Import` and update the hash to match the latest contents
freezeImport
    :: FilePath
    -- ^ Current working directory
    -> Import
    -> IO Import
freezeImport :: FilePath -> Import -> IO Import
freezeImport directory :: FilePath
directory import_ :: Import
import_ = do
    let unprotectedImport :: Import
unprotectedImport =
            Import
import_
                { importHashed :: ImportHashed
importHashed =
                    (Import -> ImportHashed
importHashed Import
import_)
                        { hash :: Maybe SHA256Digest
hash = Maybe SHA256Digest
forall a. Maybe a
Nothing
                        }
                }

    let status :: Status
status = FilePath -> Status
Dhall.Import.emptyStatus FilePath
directory

    Expr Src Void
expression <- StateT Status IO (Expr Src Void) -> Status -> IO (Expr Src Void)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT (Expr Src Import -> StateT Status IO (Expr Src Void)
Dhall.Import.loadWith (Import -> Expr Src Import
forall s a. a -> Expr s a
Embed Import
unprotectedImport)) Status
status

    case Expr Src Void -> Either (TypeError Src Void) (Expr Src Void)
forall s. Expr s Void -> Either (TypeError s Void) (Expr s Void)
Dhall.TypeCheck.typeOf Expr Src Void
expression of
        Left  exception :: TypeError Src Void
exception -> TypeError Src Void -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO TypeError Src Void
exception
        Right _         -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    let normalizedExpression :: Expr s Void
normalizedExpression = Expr s Void -> Expr s Void
forall s a. Expr s a -> Expr s a
Core.alphaNormalize (Expr Src Void -> Expr s Void
forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize Expr Src Void
expression)

    -- make sure the frozen import is present in the semantic cache
    Expr Void Void -> IO ()
Dhall.Import.writeExpressionToSemanticCache (Expr Src Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Core.denote Expr Src Void
expression)

    let expressionHash :: SHA256Digest
expressionHash = Expr Void Void -> SHA256Digest
Dhall.Import.hashExpression Expr Void Void
forall s. Expr s Void
normalizedExpression

    let newImportHashed :: ImportHashed
newImportHashed = (Import -> ImportHashed
importHashed Import
import_) { hash :: Maybe SHA256Digest
hash = SHA256Digest -> Maybe SHA256Digest
forall a. a -> Maybe a
Just SHA256Digest
expressionHash }

    let newImport :: Import
newImport = Import
import_ { importHashed :: ImportHashed
importHashed = ImportHashed
newImportHashed }

    Import -> IO Import
forall (m :: * -> *) a. Monad m => a -> m a
return Import
newImport

-- | Freeze an import only if the import is a `Remote` import
freezeRemoteImport
    :: FilePath
    -- ^ Current working directory
    -> Import
    -> IO Import
freezeRemoteImport :: FilePath -> Import -> IO Import
freezeRemoteImport directory :: FilePath
directory import_ :: Import
import_ = do
    case ImportHashed -> ImportType
importType (Import -> ImportHashed
importHashed Import
import_) of
        Remote {} -> FilePath -> Import -> IO Import
freezeImport FilePath
directory Import
import_
        _         -> Import -> IO Import
forall (m :: * -> *) a. Monad m => a -> m a
return Import
import_

writeExpr :: Input -> (Text, Expr Src Import) -> CharacterSet -> IO ()
writeExpr :: Input -> (Text, Expr Src Import) -> CharacterSet -> IO ()
writeExpr input :: Input
input (header :: Text
header, expr :: Expr Src Import
expr) characterSet :: CharacterSet
characterSet = do
    let doc :: Doc Ann
doc =  Text -> Doc Ann
forall a ann. Pretty a => a -> Doc ann
Pretty.pretty Text
header
            Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> CharacterSet -> Expr Src Import -> Doc Ann
forall a. Pretty a => CharacterSet -> Expr Src a -> Doc Ann
Dhall.Pretty.prettyCharacterSet CharacterSet
characterSet Expr Src Import
expr
            Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> "\n"

    let stream :: SimpleDocStream Ann
stream = Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout Doc Ann
doc

    let unAnnotated :: SimpleDocStream xxx
unAnnotated = SimpleDocStream Ann -> SimpleDocStream xxx
forall ann xxx. SimpleDocStream ann -> SimpleDocStream xxx
Pretty.unAnnotateS SimpleDocStream Ann
stream

    case Input
input of
        InputFile file :: FilePath
file ->
            FilePath -> Text -> IO ()
AtomicWrite.LazyText.atomicWriteFile
                FilePath
file
                (SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.Text.renderLazy SimpleDocStream Any
forall xxx. SimpleDocStream xxx
unAnnotated)

        StandardInput -> do
            Bool
supportsANSI <- Handle -> IO Bool
System.Console.ANSI.hSupportsANSI Handle
System.IO.stdout
            if Bool
supportsANSI
               then
                 Handle -> SimpleDocStream AnsiStyle -> IO ()
Pretty.renderIO Handle
System.IO.stdout (Ann -> AnsiStyle
Dhall.Pretty.annToAnsiStyle (Ann -> AnsiStyle)
-> SimpleDocStream Ann -> SimpleDocStream AnsiStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleDocStream Ann
stream)
               else
                 Handle -> SimpleDocStream AnsiStyle -> IO ()
Pretty.renderIO Handle
System.IO.stdout SimpleDocStream AnsiStyle
forall xxx. SimpleDocStream xxx
unAnnotated

-- | Specifies which imports to freeze
data Scope
    = OnlyRemoteImports
    -- ^ Freeze only remote imports (i.e. URLs)
    | AllImports
    -- ^ Freeze all imports (including paths and environment variables)

-- | Specifies why we are adding semantic integrity checks
data Intent
    = Secure
    -- ^ Protect imports with an integrity check without a fallback so that
    --   import resolution fails if the import changes
    | Cache
    -- ^ Protect imports with an integrity check and also add a fallback import
    --   import without an integrity check.  This is useful if you only want to
    --   cache imports when possible but still gracefully degrade to resolving
    --   them if the semantic integrity check has changed.

-- | Implementation of the @dhall freeze@ subcommand
freeze
    :: OutputMode
    -> Input
    -> Scope
    -> Intent
    -> CharacterSet
    -> Censor
    -> IO ()
freeze :: OutputMode
-> Input -> Scope -> Intent -> CharacterSet -> Censor -> IO ()
freeze outputMode :: OutputMode
outputMode input :: Input
input scope :: Scope
scope intent :: Intent
intent characterSet :: CharacterSet
characterSet censor :: Censor
censor = do
    let directory :: FilePath
directory = case Input
input of
            StandardInput  -> "."
            InputFile file :: FilePath
file -> FilePath -> FilePath
System.FilePath.takeDirectory FilePath
file

    let freezeScope :: FilePath -> Import -> IO Import
freezeScope =
            case Scope
scope of
                AllImports        -> FilePath -> Import -> IO Import
freezeImport
                OnlyRemoteImports -> FilePath -> Import -> IO Import
freezeRemoteImport

    let freezeFunction :: Import -> IO Import
freezeFunction = FilePath -> Import -> IO Import
freezeScope FilePath
directory

    let cache :: Expr s Import -> IO (Expr s Import)
cache
            (ImportAlt
                (Expr s Import -> Expr s Import
forall s a. Expr s a -> Expr s a
Core.shallowDenote -> Embed
                    (Import { importHashed :: Import -> ImportHashed
importHashed = ImportHashed { hash :: ImportHashed -> Maybe SHA256Digest
hash = Just _expectedHash :: SHA256Digest
_expectedHash } })
                )
                import_ :: Expr s Import
import_@(Expr s Import -> Expr s Import
forall s a. Expr s a -> Expr s a
Core.shallowDenote -> ImportAlt
                    (Embed
                        (Import { importHashed :: Import -> ImportHashed
importHashed = ImportHashed { hash :: ImportHashed -> Maybe SHA256Digest
hash = Just _actualHash :: SHA256Digest
_actualHash } })
                    )
                    _
                )
            ) = do
                {- Here we could actually compare the `_expectedHash` and
                   `_actualHash` to see if they differ, but we choose not to do
                   so and instead automatically accept the `_actualHash`.  This
                   is done for the same reason that the `freeze*` functions
                   ignore hash mismatches: the user intention when using `dhall
                   freeze` is to update the hash, which they expect to possibly
                   change.
                -}
                Expr s Import -> IO (Expr s Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr s Import
import_
        cache
            (Embed import_ :: Import
import_@(Import { importHashed :: Import -> ImportHashed
importHashed = ImportHashed { hash :: ImportHashed -> Maybe SHA256Digest
hash = Maybe SHA256Digest
Nothing } })) = do
                Import
frozenImport <- Import -> IO Import
freezeFunction Import
import_

                {- The two imports can be the same if the import is local and
                   `freezeFunction` only freezes remote imports
                -}
                if Import
frozenImport Import -> Import -> Bool
forall a. Eq a => a -> a -> Bool
/= Import
import_
                    then Expr s Import -> IO (Expr s Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr s Import -> Expr s Import -> Expr s Import
forall s a. Expr s a -> Expr s a -> Expr s a
ImportAlt (Import -> Expr s Import
forall s a. a -> Expr s a
Embed Import
frozenImport) (Import -> Expr s Import
forall s a. a -> Expr s a
Embed Import
import_))
                    else Expr s Import -> IO (Expr s Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> Expr s Import
forall s a. a -> Expr s a
Embed Import
import_)
        cache expression :: Expr s Import
expression = do
            Expr s Import -> IO (Expr s Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr s Import
expression

    let rewrite :: Expr s Import -> IO (Expr s Import)
rewrite expression :: Expr s Import
expression =
            case Intent
intent of
                Secure ->
                    (Import -> IO Import) -> Expr s Import -> IO (Expr s Import)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Import -> IO Import
freezeFunction Expr s Import
expression
                Cache  ->
                    LensLike
  (WrappedMonad IO)
  (Expr s Import)
  (Expr s Import)
  (Expr s Import)
  (Expr s Import)
-> (Expr s Import -> IO (Expr s Import))
-> Expr s Import
-> IO (Expr s Import)
forall (m :: * -> *) a b.
Monad m =>
LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b
Dhall.Optics.transformMOf
                        LensLike
  (WrappedMonad IO)
  (Expr s Import)
  (Expr s Import)
  (Expr s Import)
  (Expr s Import)
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
Core.subExpressions
                        Expr s Import -> IO (Expr s Import)
forall s. Expr s Import -> IO (Expr s Import)
cache
                        Expr s Import
expression

    case OutputMode
outputMode of
        Write -> do
            (Header header :: Text
header, parsedExpression :: Expr Src Import
parsedExpression) <- do
                Censor -> Input -> IO (Header, Expr Src Import)
Util.getExpressionAndHeader Censor
censor Input
input

            Expr Src Import
frozenExpression <- Expr Src Import -> IO (Expr Src Import)
forall s. Expr s Import -> IO (Expr s Import)
rewrite Expr Src Import
parsedExpression

            Input -> (Text, Expr Src Import) -> CharacterSet -> IO ()
writeExpr Input
input (Text
header, Expr Src Import
frozenExpression) CharacterSet
characterSet

        Check -> do
            Text
originalText <- case Input
input of
                InputFile file :: FilePath
file -> FilePath -> IO Text
Text.IO.readFile FilePath
file
                StandardInput  -> IO Text
Text.IO.getContents

            let name :: FilePath
name = case Input
input of
                    InputFile file :: FilePath
file -> FilePath
file
                    StandardInput  -> "(stdin)"

            (Header header :: Text
header, parsedExpression :: Expr Src Import
parsedExpression) <- do
                Either ParseError (Header, Expr Src Import)
-> IO (Header, Expr Src Import)
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws ((ParseError -> ParseError)
-> Either ParseError (Header, Expr Src Import)
-> Either ParseError (Header, Expr Src Import)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseError -> ParseError
Parser.censor (FilePath -> Text -> Either ParseError (Header, Expr Src Import)
Parser.exprAndHeaderFromText FilePath
name Text
originalText))

            Expr Src Import
frozenExpression <- Expr Src Import -> IO (Expr Src Import)
forall s. Expr s Import -> IO (Expr s Import)
rewrite Expr Src Import
parsedExpression

            let doc :: Doc Ann
doc =  Text -> Doc Ann
forall a ann. Pretty a => a -> Doc ann
Pretty.pretty Text
header
                    Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> CharacterSet -> Expr Src Import -> Doc Ann
forall a. Pretty a => CharacterSet -> Expr Src a -> Doc Ann
Dhall.Pretty.prettyCharacterSet CharacterSet
characterSet Expr Src Import
frozenExpression
                    Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> "\n"

            let stream :: SimpleDocStream Ann
stream = Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout Doc Ann
doc

            let modifiedText :: Text
modifiedText = SimpleDocStream Ann -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.Text.renderStrict SimpleDocStream Ann
stream

            if Text
originalText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
modifiedText
                then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                else do
                    let command :: Text
command = "freeze"

                    let modified :: Text
modified = "frozen"

                    CheckFailed -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO CheckFailed :: Text -> Text -> CheckFailed
CheckFailed{..}