module Bcc.CLI.Sophie.Script
  ( ScriptDecodeError (..)
  , deserialiseScriptInAnyLang
  , readFileScriptInAnyLang
  ) where

import           Bcc.Prelude (ExceptT)
import           Prelude

import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS

import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither)

import           Bcc.Api



--
-- Handling decoding the variety of script languages and formats
--

data ScriptDecodeError =
       ScriptDecodeTextEnvelopeError TextEnvelopeError
     | ScriptDecodeSimpleScriptError JsonDecodeError
  deriving Int -> ScriptDecodeError -> ShowS
[ScriptDecodeError] -> ShowS
ScriptDecodeError -> String
(Int -> ScriptDecodeError -> ShowS)
-> (ScriptDecodeError -> String)
-> ([ScriptDecodeError] -> ShowS)
-> Show ScriptDecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptDecodeError] -> ShowS
$cshowList :: [ScriptDecodeError] -> ShowS
show :: ScriptDecodeError -> String
$cshow :: ScriptDecodeError -> String
showsPrec :: Int -> ScriptDecodeError -> ShowS
$cshowsPrec :: Int -> ScriptDecodeError -> ShowS
Show

instance Error ScriptDecodeError where
  displayError :: ScriptDecodeError -> String
displayError (ScriptDecodeTextEnvelopeError TextEnvelopeError
err) =
    String
"Error decoding script: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TextEnvelopeError -> String
forall e. Error e => e -> String
displayError TextEnvelopeError
err
  displayError (ScriptDecodeSimpleScriptError JsonDecodeError
err) =
    String
"Syntax error in script: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ JsonDecodeError -> String
forall e. Error e => e -> String
displayError JsonDecodeError
err


-- | Read a script file. The file can either be in the text envelope format
-- wrapping the binary representation of any of the supported script languages,
-- or alternatively it can be a JSON format file for one of the simple script
-- language versions.
--
readFileScriptInAnyLang :: FilePath
                        -> ExceptT (FileError ScriptDecodeError) IO
                                   ScriptInAnyLang
readFileScriptInAnyLang :: String -> ExceptT (FileError ScriptDecodeError) IO ScriptInAnyLang
readFileScriptInAnyLang String
file = do
  ByteString
scriptBytes <- (IOException -> FileError ScriptDecodeError)
-> IO ByteString
-> ExceptT (FileError ScriptDecodeError) IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (String -> IOException -> FileError ScriptDecodeError
forall e. String -> IOException -> FileError e
FileIOError String
file) (IO ByteString
 -> ExceptT (FileError ScriptDecodeError) IO ByteString)
-> IO ByteString
-> ExceptT (FileError ScriptDecodeError) IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
file
  (ScriptDecodeError -> FileError ScriptDecodeError)
-> ExceptT ScriptDecodeError IO ScriptInAnyLang
-> ExceptT (FileError ScriptDecodeError) IO ScriptInAnyLang
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (String -> ScriptDecodeError -> FileError ScriptDecodeError
forall e. String -> e -> FileError e
FileError String
file) (ExceptT ScriptDecodeError IO ScriptInAnyLang
 -> ExceptT (FileError ScriptDecodeError) IO ScriptInAnyLang)
-> ExceptT ScriptDecodeError IO ScriptInAnyLang
-> ExceptT (FileError ScriptDecodeError) IO ScriptInAnyLang
forall a b. (a -> b) -> a -> b
$ Either ScriptDecodeError ScriptInAnyLang
-> ExceptT ScriptDecodeError IO ScriptInAnyLang
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either ScriptDecodeError ScriptInAnyLang
 -> ExceptT ScriptDecodeError IO ScriptInAnyLang)
-> Either ScriptDecodeError ScriptInAnyLang
-> ExceptT ScriptDecodeError IO ScriptInAnyLang
forall a b. (a -> b) -> a -> b
$
    ByteString -> Either ScriptDecodeError ScriptInAnyLang
deserialiseScriptInAnyLang ByteString
scriptBytes


deserialiseScriptInAnyLang :: ByteString
                           -> Either ScriptDecodeError ScriptInAnyLang
deserialiseScriptInAnyLang :: ByteString -> Either ScriptDecodeError ScriptInAnyLang
deserialiseScriptInAnyLang ByteString
bs =
    -- Accept either the text envelope format wrapping the binary serialisation,
    -- or accept the simple script language in its JSON format.
    --
    case AsType TextEnvelope
-> ByteString -> Either JsonDecodeError TextEnvelope
forall a.
FromJSON a =>
AsType a -> ByteString -> Either JsonDecodeError a
deserialiseFromJSON AsType TextEnvelope
AsTextEnvelope ByteString
bs of
      Left JsonDecodeError
_   ->
        -- The SimpleScript language has the property that it is backwards
        -- compatible, so we can parse as the latest version and then downgrade
        -- to the minimum version that has all the features actually used.
        case AsType (SimpleScript SimpleScriptV2)
-> ByteString
-> Either JsonDecodeError (SimpleScript SimpleScriptV2)
forall a.
FromJSON a =>
AsType a -> ByteString -> Either JsonDecodeError a
deserialiseFromJSON (AsType SimpleScriptV2 -> AsType (SimpleScript SimpleScriptV2)
forall lang. AsType lang -> AsType (SimpleScript lang)
AsSimpleScript AsType SimpleScriptV2
AsSimpleScriptV2) ByteString
bs of
          Left  JsonDecodeError
err    -> ScriptDecodeError -> Either ScriptDecodeError ScriptInAnyLang
forall a b. a -> Either a b
Left (JsonDecodeError -> ScriptDecodeError
ScriptDecodeSimpleScriptError JsonDecodeError
err)
          Right SimpleScript SimpleScriptV2
script -> ScriptInAnyLang -> Either ScriptDecodeError ScriptInAnyLang
forall a b. b -> Either a b
Right (SimpleScript SimpleScriptV2 -> ScriptInAnyLang
toMinimumSimpleScriptVersion SimpleScript SimpleScriptV2
script)

      Right TextEnvelope
te ->
        case [FromSomeType HasTextEnvelope ScriptInAnyLang]
-> TextEnvelope -> Either TextEnvelopeError ScriptInAnyLang
forall b.
[FromSomeType HasTextEnvelope b]
-> TextEnvelope -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeAnyOf [FromSomeType HasTextEnvelope ScriptInAnyLang]
textEnvTypes TextEnvelope
te of
          Left  TextEnvelopeError
err    -> ScriptDecodeError -> Either ScriptDecodeError ScriptInAnyLang
forall a b. a -> Either a b
Left (TextEnvelopeError -> ScriptDecodeError
ScriptDecodeTextEnvelopeError TextEnvelopeError
err)
          Right ScriptInAnyLang
script -> ScriptInAnyLang -> Either ScriptDecodeError ScriptInAnyLang
forall a b. b -> Either a b
Right ScriptInAnyLang
script

  where
    textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang]
    textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang]
textEnvTypes =
      [ AsType (Script SimpleScriptV1)
-> (Script SimpleScriptV1 -> ScriptInAnyLang)
-> FromSomeType HasTextEnvelope ScriptInAnyLang
forall (c :: * -> Constraint) a b.
c a =>
AsType a -> (a -> b) -> FromSomeType c b
FromSomeType (AsType SimpleScriptV1 -> AsType (Script SimpleScriptV1)
forall lang. AsType lang -> AsType (Script lang)
AsScript AsType SimpleScriptV1
AsSimpleScriptV1)
                     (ScriptLanguage SimpleScriptV1
-> Script SimpleScriptV1 -> ScriptInAnyLang
forall lang. ScriptLanguage lang -> Script lang -> ScriptInAnyLang
ScriptInAnyLang (SimpleScriptVersion SimpleScriptV1 -> ScriptLanguage SimpleScriptV1
forall lang. SimpleScriptVersion lang -> ScriptLanguage lang
SimpleScriptLanguage SimpleScriptVersion SimpleScriptV1
SimpleScriptV1))

      , AsType (Script SimpleScriptV2)
-> (Script SimpleScriptV2 -> ScriptInAnyLang)
-> FromSomeType HasTextEnvelope ScriptInAnyLang
forall (c :: * -> Constraint) a b.
c a =>
AsType a -> (a -> b) -> FromSomeType c b
FromSomeType (AsType SimpleScriptV2 -> AsType (Script SimpleScriptV2)
forall lang. AsType lang -> AsType (Script lang)
AsScript AsType SimpleScriptV2
AsSimpleScriptV2)
                     (ScriptLanguage SimpleScriptV2
-> Script SimpleScriptV2 -> ScriptInAnyLang
forall lang. ScriptLanguage lang -> Script lang -> ScriptInAnyLang
ScriptInAnyLang (SimpleScriptVersion SimpleScriptV2 -> ScriptLanguage SimpleScriptV2
forall lang. SimpleScriptVersion lang -> ScriptLanguage lang
SimpleScriptLanguage SimpleScriptVersion SimpleScriptV2
SimpleScriptV2))

      , AsType (Script ZerepochScriptV1)
-> (Script ZerepochScriptV1 -> ScriptInAnyLang)
-> FromSomeType HasTextEnvelope ScriptInAnyLang
forall (c :: * -> Constraint) a b.
c a =>
AsType a -> (a -> b) -> FromSomeType c b
FromSomeType (AsType ZerepochScriptV1 -> AsType (Script ZerepochScriptV1)
forall lang. AsType lang -> AsType (Script lang)
AsScript AsType ZerepochScriptV1
AsZerepochScriptV1)
                     (ScriptLanguage ZerepochScriptV1
-> Script ZerepochScriptV1 -> ScriptInAnyLang
forall lang. ScriptLanguage lang -> Script lang -> ScriptInAnyLang
ScriptInAnyLang (ZerepochScriptVersion ZerepochScriptV1
-> ScriptLanguage ZerepochScriptV1
forall lang. ZerepochScriptVersion lang -> ScriptLanguage lang
ZerepochScriptLanguage ZerepochScriptVersion ZerepochScriptV1
ZerepochScriptV1))
      ]

    toMinimumSimpleScriptVersion :: SimpleScript SimpleScriptV2
                                 -> ScriptInAnyLang
    toMinimumSimpleScriptVersion :: SimpleScript SimpleScriptV2 -> ScriptInAnyLang
toMinimumSimpleScriptVersion SimpleScript SimpleScriptV2
s =
      -- TODO aurum: this will need to be adjusted when more versions are added
      -- with appropriate helper functions it can probably be done in an
      -- era-generic style
      case SimpleScriptVersion SimpleScriptV1
-> SimpleScript SimpleScriptV2
-> Maybe (SimpleScript SimpleScriptV1)
forall lang' lang.
SimpleScriptVersion lang'
-> SimpleScript lang -> Maybe (SimpleScript lang')
adjustSimpleScriptVersion SimpleScriptVersion SimpleScriptV1
SimpleScriptV1 SimpleScript SimpleScriptV2
s of
        Maybe (SimpleScript SimpleScriptV1)
Nothing -> ScriptLanguage SimpleScriptV2
-> Script SimpleScriptV2 -> ScriptInAnyLang
forall lang. ScriptLanguage lang -> Script lang -> ScriptInAnyLang
ScriptInAnyLang (SimpleScriptVersion SimpleScriptV2 -> ScriptLanguage SimpleScriptV2
forall lang. SimpleScriptVersion lang -> ScriptLanguage lang
SimpleScriptLanguage SimpleScriptVersion SimpleScriptV2
SimpleScriptV2)
                                   (SimpleScriptVersion SimpleScriptV2
-> SimpleScript SimpleScriptV2 -> Script SimpleScriptV2
forall lang.
SimpleScriptVersion lang -> SimpleScript lang -> Script lang
SimpleScript SimpleScriptVersion SimpleScriptV2
SimpleScriptV2 SimpleScript SimpleScriptV2
s)
        Just SimpleScript SimpleScriptV1
s' -> ScriptLanguage SimpleScriptV1
-> Script SimpleScriptV1 -> ScriptInAnyLang
forall lang. ScriptLanguage lang -> Script lang -> ScriptInAnyLang
ScriptInAnyLang (SimpleScriptVersion SimpleScriptV1 -> ScriptLanguage SimpleScriptV1
forall lang. SimpleScriptVersion lang -> ScriptLanguage lang
SimpleScriptLanguage SimpleScriptVersion SimpleScriptV1
SimpleScriptV1)
                                   (SimpleScriptVersion SimpleScriptV1
-> SimpleScript SimpleScriptV1 -> Script SimpleScriptV1
forall lang.
SimpleScriptVersion lang -> SimpleScript lang -> Script lang
SimpleScript SimpleScriptVersion SimpleScriptV1
SimpleScriptV1 SimpleScript SimpleScriptV1
s')