{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

#if !defined(mingw32_HOST_OS)
#define UNIX
#endif

-- | TextEnvelope Serialisation
--
module Cardano.Api.SerialiseTextEnvelope
  ( HasTextEnvelope(..)
  , TextEnvelope(..)
  , TextEnvelopeType(..)
  , TextEnvelopeDescr(..)
  , textEnvelopeRawCBOR
  , TextEnvelopeError(..)
  , serialiseToTextEnvelope
  , deserialiseFromTextEnvelope
  , readFileTextEnvelope
  , writeFileTextEnvelope
  , writeFileTextEnvelopeWithOwnerPermissions
  , readTextEnvelopeFromFile
  , readTextEnvelopeOfTypeFromFile
  , textEnvelopeToJSON

    -- * Reading one of several key types
  , FromSomeType(..)
  , deserialiseFromTextEnvelopeAnyOf
  , readFileTextEnvelopeAnyOf

    -- * Data family instances
  , AsType(..)
  ) where

import           Data.Bifunctor (first)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List as List
import           Data.Maybe (fromMaybe)
import           Data.String (IsString)
import           Data.Text (Text)
import qualified Data.Text.Encoding as Text

import           Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))
import qualified Data.Aeson as Aeson
import           Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', keyOrder)

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


import           Cardano.Binary (DecoderError)

import           Cardano.Api.Error
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.SerialiseCBOR
import           Cardano.Api.Utils (readFileBlocking)

#ifdef UNIX
import           Control.Exception (IOException, bracket, bracketOnError, try)
import           System.Directory ()
import           System.IO (hClose)
import           System.Posix.Files (ownerModes, setFdOwnerAndGroup)
import           System.Posix.IO (OpenMode (..), closeFd, defaultFileFlags, fdToHandle, openFd)
import           System.Posix.User (getRealUserID)
#else
import           Control.Exception (bracketOnError)
import           System.Directory (removeFile, renameFile)
import           System.FilePath (splitFileName, (<.>))
import           System.IO (hClose, openTempFile)
#endif


-- ----------------------------------------------------------------------------
-- Text envelopes
--

newtype TextEnvelopeType = TextEnvelopeType String
  deriving (TextEnvelopeType -> TextEnvelopeType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextEnvelopeType -> TextEnvelopeType -> Bool
$c/= :: TextEnvelopeType -> TextEnvelopeType -> Bool
== :: TextEnvelopeType -> TextEnvelopeType -> Bool
$c== :: TextEnvelopeType -> TextEnvelopeType -> Bool
Eq, Int -> TextEnvelopeType -> ShowS
[TextEnvelopeType] -> ShowS
TextEnvelopeType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextEnvelopeType] -> ShowS
$cshowList :: [TextEnvelopeType] -> ShowS
show :: TextEnvelopeType -> String
$cshow :: TextEnvelopeType -> String
showsPrec :: Int -> TextEnvelopeType -> ShowS
$cshowsPrec :: Int -> TextEnvelopeType -> ShowS
Show)
  deriving newtype (String -> TextEnvelopeType
forall a. (String -> a) -> IsString a
fromString :: String -> TextEnvelopeType
$cfromString :: String -> TextEnvelopeType
IsString, NonEmpty TextEnvelopeType -> TextEnvelopeType
TextEnvelopeType -> TextEnvelopeType -> TextEnvelopeType
forall b. Integral b => b -> TextEnvelopeType -> TextEnvelopeType
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> TextEnvelopeType -> TextEnvelopeType
$cstimes :: forall b. Integral b => b -> TextEnvelopeType -> TextEnvelopeType
sconcat :: NonEmpty TextEnvelopeType -> TextEnvelopeType
$csconcat :: NonEmpty TextEnvelopeType -> TextEnvelopeType
<> :: TextEnvelopeType -> TextEnvelopeType -> TextEnvelopeType
$c<> :: TextEnvelopeType -> TextEnvelopeType -> TextEnvelopeType
Semigroup, [TextEnvelopeType] -> Value
[TextEnvelopeType] -> Encoding
TextEnvelopeType -> Value
TextEnvelopeType -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TextEnvelopeType] -> Encoding
$ctoEncodingList :: [TextEnvelopeType] -> Encoding
toJSONList :: [TextEnvelopeType] -> Value
$ctoJSONList :: [TextEnvelopeType] -> Value
toEncoding :: TextEnvelopeType -> Encoding
$ctoEncoding :: TextEnvelopeType -> Encoding
toJSON :: TextEnvelopeType -> Value
$ctoJSON :: TextEnvelopeType -> Value
ToJSON, Value -> Parser [TextEnvelopeType]
Value -> Parser TextEnvelopeType
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TextEnvelopeType]
$cparseJSONList :: Value -> Parser [TextEnvelopeType]
parseJSON :: Value -> Parser TextEnvelopeType
$cparseJSON :: Value -> Parser TextEnvelopeType
FromJSON)

newtype TextEnvelopeDescr = TextEnvelopeDescr String
  deriving (TextEnvelopeDescr -> TextEnvelopeDescr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextEnvelopeDescr -> TextEnvelopeDescr -> Bool
$c/= :: TextEnvelopeDescr -> TextEnvelopeDescr -> Bool
== :: TextEnvelopeDescr -> TextEnvelopeDescr -> Bool
$c== :: TextEnvelopeDescr -> TextEnvelopeDescr -> Bool
Eq, Int -> TextEnvelopeDescr -> ShowS
[TextEnvelopeDescr] -> ShowS
TextEnvelopeDescr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextEnvelopeDescr] -> ShowS
$cshowList :: [TextEnvelopeDescr] -> ShowS
show :: TextEnvelopeDescr -> String
$cshow :: TextEnvelopeDescr -> String
showsPrec :: Int -> TextEnvelopeDescr -> ShowS
$cshowsPrec :: Int -> TextEnvelopeDescr -> ShowS
Show)
  deriving newtype (String -> TextEnvelopeDescr
forall a. (String -> a) -> IsString a
fromString :: String -> TextEnvelopeDescr
$cfromString :: String -> TextEnvelopeDescr
IsString, NonEmpty TextEnvelopeDescr -> TextEnvelopeDescr
TextEnvelopeDescr -> TextEnvelopeDescr -> TextEnvelopeDescr
forall b. Integral b => b -> TextEnvelopeDescr -> TextEnvelopeDescr
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> TextEnvelopeDescr -> TextEnvelopeDescr
$cstimes :: forall b. Integral b => b -> TextEnvelopeDescr -> TextEnvelopeDescr
sconcat :: NonEmpty TextEnvelopeDescr -> TextEnvelopeDescr
$csconcat :: NonEmpty TextEnvelopeDescr -> TextEnvelopeDescr
<> :: TextEnvelopeDescr -> TextEnvelopeDescr -> TextEnvelopeDescr
$c<> :: TextEnvelopeDescr -> TextEnvelopeDescr -> TextEnvelopeDescr
Semigroup, [TextEnvelopeDescr] -> Value
[TextEnvelopeDescr] -> Encoding
TextEnvelopeDescr -> Value
TextEnvelopeDescr -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TextEnvelopeDescr] -> Encoding
$ctoEncodingList :: [TextEnvelopeDescr] -> Encoding
toJSONList :: [TextEnvelopeDescr] -> Value
$ctoJSONList :: [TextEnvelopeDescr] -> Value
toEncoding :: TextEnvelopeDescr -> Encoding
$ctoEncoding :: TextEnvelopeDescr -> Encoding
toJSON :: TextEnvelopeDescr -> Value
$ctoJSON :: TextEnvelopeDescr -> Value
ToJSON, Value -> Parser [TextEnvelopeDescr]
Value -> Parser TextEnvelopeDescr
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TextEnvelopeDescr]
$cparseJSONList :: Value -> Parser [TextEnvelopeDescr]
parseJSON :: Value -> Parser TextEnvelopeDescr
$cparseJSON :: Value -> Parser TextEnvelopeDescr
FromJSON)

-- | A 'TextEnvelope' is a structured envelope for serialised binary values
-- with an external format with a semi-readable textual format.
--
-- It contains a \"type\" field, e.g. \"PublicKeyByron\" or \"TxSignedShelley\"
-- to indicate the type of the encoded data. This is used as a sanity check
-- and to help readers.
--
-- It also contains a \"title\" field which is free-form, and could be used
-- to indicate the role or purpose to a reader.
--
data TextEnvelope = TextEnvelope
  { TextEnvelope -> TextEnvelopeType
teType        :: !TextEnvelopeType
  , TextEnvelope -> TextEnvelopeDescr
teDescription :: !TextEnvelopeDescr
  , TextEnvelope -> ByteString
teRawCBOR     :: !ByteString
  } deriving (TextEnvelope -> TextEnvelope -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextEnvelope -> TextEnvelope -> Bool
$c/= :: TextEnvelope -> TextEnvelope -> Bool
== :: TextEnvelope -> TextEnvelope -> Bool
$c== :: TextEnvelope -> TextEnvelope -> Bool
Eq, Int -> TextEnvelope -> ShowS
[TextEnvelope] -> ShowS
TextEnvelope -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextEnvelope] -> ShowS
$cshowList :: [TextEnvelope] -> ShowS
show :: TextEnvelope -> String
$cshow :: TextEnvelope -> String
showsPrec :: Int -> TextEnvelope -> ShowS
$cshowsPrec :: Int -> TextEnvelope -> ShowS
Show)

instance HasTypeProxy TextEnvelope where
    data AsType TextEnvelope = AsTextEnvelope
    proxyToAsType :: Proxy TextEnvelope -> AsType TextEnvelope
proxyToAsType Proxy TextEnvelope
_ = AsType TextEnvelope
AsTextEnvelope

instance ToJSON TextEnvelope where
  toJSON :: TextEnvelope -> Value
toJSON TextEnvelope {TextEnvelopeType
teType :: TextEnvelopeType
teType :: TextEnvelope -> TextEnvelopeType
teType, TextEnvelopeDescr
teDescription :: TextEnvelopeDescr
teDescription :: TextEnvelope -> TextEnvelopeDescr
teDescription, ByteString
teRawCBOR :: ByteString
teRawCBOR :: TextEnvelope -> ByteString
teRawCBOR} =
    [Pair] -> Value
object [ Key
"type"        forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TextEnvelopeType
teType
           , Key
"description" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TextEnvelopeDescr
teDescription
           , Key
"cborHex"     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 (ByteString -> ByteString
Base16.encode ByteString
teRawCBOR)
           ]

instance FromJSON TextEnvelope where
  parseJSON :: Value -> Parser TextEnvelope
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TextEnvelope" forall a b. (a -> b) -> a -> b
$ \Object
v ->
                TextEnvelopeType -> TextEnvelopeDescr -> ByteString -> TextEnvelope
TextEnvelope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type")
                             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"description")
                             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Parser ByteString
parseJSONBase16 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"cborHex")
    where
      parseJSONBase16 :: Value -> Parser ByteString
parseJSONBase16 Value
v =
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base16.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

textEnvelopeJSONConfig :: Config
textEnvelopeJSONConfig :: Config
textEnvelopeJSONConfig = Config
defConfig { confCompare :: Text -> Text -> Ordering
confCompare = Text -> Text -> Ordering
textEnvelopeJSONKeyOrder }

textEnvelopeJSONKeyOrder :: Text -> Text -> Ordering
textEnvelopeJSONKeyOrder :: Text -> Text -> Ordering
textEnvelopeJSONKeyOrder = [Text] -> Text -> Text -> Ordering
keyOrder [Text
"type", Text
"description", Text
"cborHex"]


textEnvelopeRawCBOR :: TextEnvelope -> ByteString
textEnvelopeRawCBOR :: TextEnvelope -> ByteString
textEnvelopeRawCBOR = TextEnvelope -> ByteString
teRawCBOR


-- | The errors that the pure 'TextEnvelope' parsing\/decoding functions can return.
--
data TextEnvelopeError
  = TextEnvelopeTypeError   ![TextEnvelopeType] !TextEnvelopeType -- ^ expected, actual
  | TextEnvelopeDecodeError !DecoderError
  | TextEnvelopeAesonDecodeError !String
  deriving (TextEnvelopeError -> TextEnvelopeError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextEnvelopeError -> TextEnvelopeError -> Bool
$c/= :: TextEnvelopeError -> TextEnvelopeError -> Bool
== :: TextEnvelopeError -> TextEnvelopeError -> Bool
$c== :: TextEnvelopeError -> TextEnvelopeError -> Bool
Eq, Int -> TextEnvelopeError -> ShowS
[TextEnvelopeError] -> ShowS
TextEnvelopeError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextEnvelopeError] -> ShowS
$cshowList :: [TextEnvelopeError] -> ShowS
show :: TextEnvelopeError -> String
$cshow :: TextEnvelopeError -> String
showsPrec :: Int -> TextEnvelopeError -> ShowS
$cshowsPrec :: Int -> TextEnvelopeError -> ShowS
Show)

instance Error TextEnvelopeError where
  displayError :: TextEnvelopeError -> String
displayError TextEnvelopeError
tee =
    case TextEnvelopeError
tee of
      TextEnvelopeTypeError [TextEnvelopeType String
expType]
                            (TextEnvelopeType String
actType) ->
          String
"TextEnvelope type error: "
       forall a. Semigroup a => a -> a -> a
<> String
" Expected: " forall a. Semigroup a => a -> a -> a
<> String
expType
       forall a. Semigroup a => a -> a -> a
<> String
" Actual: " forall a. Semigroup a => a -> a -> a
<> String
actType

      TextEnvelopeTypeError [TextEnvelopeType]
expTypes (TextEnvelopeType String
actType) ->
          String
"TextEnvelope type error: "
       forall a. Semigroup a => a -> a -> a
<> String
" Expected one of: "
       forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
List.intercalate String
", "
            [ String
expType | TextEnvelopeType String
expType <- [TextEnvelopeType]
expTypes ]
       forall a. Semigroup a => a -> a -> a
<> String
" Actual: " forall a. Semigroup a => a -> a -> a
<> String
actType
      TextEnvelopeAesonDecodeError String
decErr -> String
"TextEnvelope aeson decode error: " forall a. Semigroup a => a -> a -> a
<> String
decErr
      TextEnvelopeDecodeError DecoderError
decErr -> String
"TextEnvelope decode error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show DecoderError
decErr


-- | Check that the \"type\" of the 'TextEnvelope' is as expected.
--
-- For example, one might check that the type is \"TxSignedShelley\".
--
expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError ()
expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError ()
expectTextEnvelopeOfType TextEnvelopeType
expectedType TextEnvelope { teType :: TextEnvelope -> TextEnvelopeType
teType = TextEnvelopeType
actualType } =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TextEnvelopeType
expectedType forall a. Eq a => a -> a -> Bool
== TextEnvelopeType
actualType) forall a b. (a -> b) -> a -> b
$
      forall a b. a -> Either a b
Left ([TextEnvelopeType] -> TextEnvelopeType -> TextEnvelopeError
TextEnvelopeTypeError [TextEnvelopeType
expectedType] TextEnvelopeType
actualType)


-- ----------------------------------------------------------------------------
-- Serialisation in text envelope format
--

class SerialiseAsCBOR a => HasTextEnvelope a where
    textEnvelopeType :: AsType a -> TextEnvelopeType

    textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr
    textEnvelopeDefaultDescr a
_ = TextEnvelopeDescr
""


serialiseToTextEnvelope :: forall a. HasTextEnvelope a
                        => Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope :: forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope Maybe TextEnvelopeDescr
mbDescr a
a =
    TextEnvelope {
      teType :: TextEnvelopeType
teType    = forall a. HasTextEnvelope a => AsType a -> TextEnvelopeType
textEnvelopeType AsType a
ttoken
    , teDescription :: TextEnvelopeDescr
teDescription   = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasTextEnvelope a => a -> TextEnvelopeDescr
textEnvelopeDefaultDescr a
a) Maybe TextEnvelopeDescr
mbDescr
    , teRawCBOR :: ByteString
teRawCBOR = forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR a
a
    }
  where
    ttoken :: AsType a
    ttoken :: AsType a
ttoken = forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType forall {k} (t :: k). Proxy t
Proxy


deserialiseFromTextEnvelope :: HasTextEnvelope a
                            => AsType a
                            -> TextEnvelope
                            -> Either TextEnvelopeError a
deserialiseFromTextEnvelope :: forall a.
HasTextEnvelope a =>
AsType a -> TextEnvelope -> Either TextEnvelopeError a
deserialiseFromTextEnvelope AsType a
ttoken TextEnvelope
te = do
    TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError ()
expectTextEnvelopeOfType (forall a. HasTextEnvelope a => AsType a -> TextEnvelopeType
textEnvelopeType AsType a
ttoken) TextEnvelope
te
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecoderError -> TextEnvelopeError
TextEnvelopeDecodeError forall a b. (a -> b) -> a -> b
$
      forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR AsType a
ttoken (TextEnvelope -> ByteString
teRawCBOR TextEnvelope
te) --TODO: You have switched from CBOR to JSON


deserialiseFromTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b]
                                 -> TextEnvelope
                                 -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeAnyOf :: forall b.
[FromSomeType HasTextEnvelope b]
-> TextEnvelope -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeAnyOf [FromSomeType HasTextEnvelope b]
types TextEnvelope
te =
    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find FromSomeType HasTextEnvelope b -> Bool
matching [FromSomeType HasTextEnvelope b]
types of
      Maybe (FromSomeType HasTextEnvelope b)
Nothing ->
        forall a b. a -> Either a b
Left ([TextEnvelopeType] -> TextEnvelopeType -> TextEnvelopeError
TextEnvelopeTypeError [TextEnvelopeType]
expectedTypes TextEnvelopeType
actualType)

      Just (FromSomeType AsType a
ttoken a -> b
f) ->
        forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecoderError -> TextEnvelopeError
TextEnvelopeDecodeError forall a b. (a -> b) -> a -> b
$
          a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR AsType a
ttoken (TextEnvelope -> ByteString
teRawCBOR TextEnvelope
te)
  where
    actualType :: TextEnvelopeType
actualType    = TextEnvelope -> TextEnvelopeType
teType TextEnvelope
te
    expectedTypes :: [TextEnvelopeType]
expectedTypes = [ forall a. HasTextEnvelope a => AsType a -> TextEnvelopeType
textEnvelopeType AsType a
ttoken
                    | FromSomeType AsType a
ttoken a -> b
_f <- [FromSomeType HasTextEnvelope b]
types ]

    matching :: FromSomeType HasTextEnvelope b -> Bool
matching (FromSomeType AsType a
ttoken a -> b
_f) = TextEnvelopeType
actualType forall a. Eq a => a -> a -> Bool
== forall a. HasTextEnvelope a => AsType a -> TextEnvelopeType
textEnvelopeType AsType a
ttoken

writeFileWithOwnerPermissions
  :: FilePath
  -> LBS.ByteString
  -> IO (Either (FileError ()) ())
#ifdef UNIX
-- On a unix based system, we grab a file descriptor and set ourselves as owner.
-- Since we're holding the file descriptor at this point, we can be sure that
-- what we're about to write to is owned by us if an error didn't occur.
writeFileWithOwnerPermissions :: String -> ByteString -> IO (Either (FileError ()) ())
writeFileWithOwnerPermissions String
path ByteString
a = do
    UserID
user <- IO UserID
getRealUserID
    Either IOException Fd
ownedFile <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$
      -- We only close the FD on error here, otherwise we let it leak out, since
      -- it will be immediately turned into a Handle (which will be closed when
      -- the Handle is closed)
      forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (String -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd String
path OpenMode
WriteOnly (forall a. a -> Maybe a
Just FileMode
ownerModes) OpenFileFlags
defaultFileFlags)
        Fd -> IO ()
closeFd
        (\Fd
fd -> Fd -> UserID -> GroupID -> IO ()
setFdOwnerAndGroup Fd
fd UserID
user (-GroupID
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Fd
fd)
    case Either IOException Fd
ownedFile of
      Left (IOException
err :: IOException) -> do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. String -> IOException -> FileError e
FileIOError String
path IOException
err
      Right Fd
fd -> do
        forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
          (Fd -> IO Handle
fdToHandle Fd
fd)
          Handle -> IO ()
hClose
          (\Handle
handle -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (forall e. String -> IOException -> FileError e
FileIOError String
path) forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
LBS.hPut Handle
handle ByteString
a)
#else
-- On something other than unix, we make a _new_ file, and since we created it,
-- we must own it. We then place it at the target location. Unfortunately this
-- won't work correctly with pseudo-files.
writeFileWithOwnerPermissions targetPath a =
    bracketOnError
      (openTempFile targetDir $ targetFile <.> "tmp")
      (\(tmpPath, fHandle) -> do
        hClose fHandle >> removeFile tmpPath
        return . Left $ FileErrorTempFile targetPath tmpPath fHandle)
      (\(tmpPath, fHandle) -> do
          LBS.hPut fHandle a
          hClose fHandle
          renameFile tmpPath targetPath
          return $ Right ())
  where
    (targetDir, targetFile) = splitFileName targetPath
#endif

writeFileTextEnvelope :: HasTextEnvelope a
                      => FilePath
                      -> Maybe TextEnvelopeDescr
                      -> a
                      -> IO (Either (FileError ()) ())
writeFileTextEnvelope :: forall a.
HasTextEnvelope a =>
String
-> Maybe TextEnvelopeDescr -> a -> IO (Either (FileError ()) ())
writeFileTextEnvelope String
path Maybe TextEnvelopeDescr
mbDescr a
a =
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (forall e. String -> IOException -> FileError e
FileIOError String
path) forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
path ByteString
content
  where
    content :: ByteString
content = forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> ByteString
textEnvelopeToJSON Maybe TextEnvelopeDescr
mbDescr a
a


writeFileTextEnvelopeWithOwnerPermissions
  :: HasTextEnvelope a
  => FilePath
  -> Maybe TextEnvelopeDescr
  -> a
  -> IO (Either (FileError ()) ())
writeFileTextEnvelopeWithOwnerPermissions :: forall a.
HasTextEnvelope a =>
String
-> Maybe TextEnvelopeDescr -> a -> IO (Either (FileError ()) ())
writeFileTextEnvelopeWithOwnerPermissions String
targetPath Maybe TextEnvelopeDescr
mbDescr a
a =
  String -> ByteString -> IO (Either (FileError ()) ())
writeFileWithOwnerPermissions String
targetPath ByteString
content
 where
  content :: ByteString
content = forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> ByteString
textEnvelopeToJSON Maybe TextEnvelopeDescr
mbDescr a
a


textEnvelopeToJSON :: HasTextEnvelope a =>  Maybe TextEnvelopeDescr -> a -> LBS.ByteString
textEnvelopeToJSON :: forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> ByteString
textEnvelopeToJSON Maybe TextEnvelopeDescr
mbDescr a
a  =
  forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
textEnvelopeJSONConfig (forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope Maybe TextEnvelopeDescr
mbDescr a
a) forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"

readFileTextEnvelope :: HasTextEnvelope a
                     => AsType a
                     -> FilePath
                     -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope :: forall a.
HasTextEnvelope a =>
AsType a -> String -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope AsType a
ttoken String
path =
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
      ByteString
content <- forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (forall e. String -> IOException -> FileError e
FileIOError String
path) forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
readFileBlocking String
path
      forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (forall e. String -> e -> FileError e
FileError String
path) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither forall a b. (a -> b) -> a -> b
$ do
        TextEnvelope
te <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> TextEnvelopeError
TextEnvelopeAesonDecodeError forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
content
        forall a.
HasTextEnvelope a =>
AsType a -> TextEnvelope -> Either TextEnvelopeError a
deserialiseFromTextEnvelope AsType a
ttoken TextEnvelope
te


readFileTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b]
                          -> FilePath
                          -> IO (Either (FileError TextEnvelopeError) b)
readFileTextEnvelopeAnyOf :: forall b.
[FromSomeType HasTextEnvelope b]
-> String -> IO (Either (FileError TextEnvelopeError) b)
readFileTextEnvelopeAnyOf [FromSomeType HasTextEnvelope b]
types String
path =
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
      ByteString
content <- forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (forall e. String -> IOException -> FileError e
FileIOError String
path) forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
readFileBlocking String
path
      forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (forall e. String -> e -> FileError e
FileError String
path) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither forall a b. (a -> b) -> a -> b
$ do
        TextEnvelope
te <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> TextEnvelopeError
TextEnvelopeAesonDecodeError forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
content
        forall b.
[FromSomeType HasTextEnvelope b]
-> TextEnvelope -> Either TextEnvelopeError b
deserialiseFromTextEnvelopeAnyOf [FromSomeType HasTextEnvelope b]
types TextEnvelope
te


readTextEnvelopeFromFile :: FilePath
                         -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
readTextEnvelopeFromFile :: String -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
readTextEnvelopeFromFile String
path =
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    ByteString
bs <- forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (forall e. String -> IOException -> FileError e
FileIOError String
path) forall a b. (a -> b) -> a -> b
$
            String -> IO ByteString
readFileBlocking String
path
    forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (forall e. String -> e -> FileError e
FileError String
path forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TextEnvelopeError
TextEnvelopeAesonDecodeError)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
bs


readTextEnvelopeOfTypeFromFile
  :: TextEnvelopeType
  -> FilePath
  -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
readTextEnvelopeOfTypeFromFile :: TextEnvelopeType
-> String -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
readTextEnvelopeOfTypeFromFile TextEnvelopeType
expectedType String
path =
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    TextEnvelope
te <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (String -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
readTextEnvelopeFromFile String
path)
    forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (forall e. String -> e -> FileError e
FileError String
path) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither forall a b. (a -> b) -> a -> b
$
      TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError ()
expectTextEnvelopeOfType TextEnvelopeType
expectedType TextEnvelope
te
    forall (m :: * -> *) a. Monad m => a -> m a
return TextEnvelope
te