{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Cardano.Chain.Update.SystemTag (
  SystemTag (..),
  SystemTagError (..),
  checkSystemTag,
  systemTagMaxLength,
  osHelper,
  archHelper,
)
where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  Decoder,
  DecoderError (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  decodeListLen,
  decodeWord8,
  encodeListLen,
  fromByronCBOR,
  matchSize,
  toByronCBOR,
 )
import Cardano.Prelude hiding (cborError)
import Data.Aeson (ToJSON, ToJSONKey)
import Data.Data (Data)
import qualified Data.Text as T
import Distribution.System (Arch (..), OS (..))
import Distribution.Text (display)
import Formatting (bprint, int, stext)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))

-- | Tag of system for which update data is purposed, e.g. win64, mac32
newtype SystemTag = SystemTag
  { SystemTag -> Text
getSystemTag :: Text
  }
  deriving (SystemTag -> SystemTag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SystemTag -> SystemTag -> Bool
$c/= :: SystemTag -> SystemTag -> Bool
== :: SystemTag -> SystemTag -> Bool
$c== :: SystemTag -> SystemTag -> Bool
Eq, Eq SystemTag
SystemTag -> SystemTag -> Bool
SystemTag -> SystemTag -> Ordering
SystemTag -> SystemTag -> SystemTag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SystemTag -> SystemTag -> SystemTag
$cmin :: SystemTag -> SystemTag -> SystemTag
max :: SystemTag -> SystemTag -> SystemTag
$cmax :: SystemTag -> SystemTag -> SystemTag
>= :: SystemTag -> SystemTag -> Bool
$c>= :: SystemTag -> SystemTag -> Bool
> :: SystemTag -> SystemTag -> Bool
$c> :: SystemTag -> SystemTag -> Bool
<= :: SystemTag -> SystemTag -> Bool
$c<= :: SystemTag -> SystemTag -> Bool
< :: SystemTag -> SystemTag -> Bool
$c< :: SystemTag -> SystemTag -> Bool
compare :: SystemTag -> SystemTag -> Ordering
$ccompare :: SystemTag -> SystemTag -> Ordering
Ord, Int -> SystemTag -> ShowS
[SystemTag] -> ShowS
SystemTag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SystemTag] -> ShowS
$cshowList :: [SystemTag] -> ShowS
show :: SystemTag -> String
$cshow :: SystemTag -> String
showsPrec :: Int -> SystemTag -> ShowS
$cshowsPrec :: Int -> SystemTag -> ShowS
Show, forall x. Rep SystemTag x -> SystemTag
forall x. SystemTag -> Rep SystemTag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SystemTag x -> SystemTag
$cfrom :: forall x. SystemTag -> Rep SystemTag x
Generic)
  deriving newtype (SystemTag -> Builder
forall p. (p -> Builder) -> Buildable p
build :: SystemTag -> Builder
$cbuild :: SystemTag -> Builder
B.Buildable)
  deriving anyclass (SystemTag -> ()
forall a. (a -> ()) -> NFData a
rnf :: SystemTag -> ()
$crnf :: SystemTag -> ()
NFData, Context -> SystemTag -> IO (Maybe ThunkInfo)
Proxy SystemTag -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy SystemTag -> String
$cshowTypeOf :: Proxy SystemTag -> String
wNoThunks :: Context -> SystemTag -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SystemTag -> IO (Maybe ThunkInfo)
noThunks :: Context -> SystemTag -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> SystemTag -> IO (Maybe ThunkInfo)
NoThunks)

-- Used for debugging purposes only
instance ToJSON SystemTag

-- Used for debugging purposes only
instance ToJSONKey SystemTag

instance ToCBOR SystemTag where
  toCBOR :: SystemTag -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR SystemTag where
  fromCBOR :: forall s. Decoder s SystemTag
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR SystemTag where
  encCBOR :: SystemTag -> Encoding
encCBOR = forall a. EncCBOR a => a -> Encoding
encCBOR forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SystemTag -> Text
getSystemTag

instance DecCBOR SystemTag where
  decCBOR :: forall s. Decoder s SystemTag
decCBOR = Text -> SystemTag
SystemTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

systemTagMaxLength :: Integral i => i
systemTagMaxLength :: forall i. Integral i => i
systemTagMaxLength = i
10

data SystemTagError
  = SystemTagNotAscii Text
  | SystemTagTooLong Text
  deriving (SystemTagError -> SystemTagError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SystemTagError -> SystemTagError -> Bool
$c/= :: SystemTagError -> SystemTagError -> Bool
== :: SystemTagError -> SystemTagError -> Bool
$c== :: SystemTagError -> SystemTagError -> Bool
Eq, Int -> SystemTagError -> ShowS
[SystemTagError] -> ShowS
SystemTagError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SystemTagError] -> ShowS
$cshowList :: [SystemTagError] -> ShowS
show :: SystemTagError -> String
$cshow :: SystemTagError -> String
showsPrec :: Int -> SystemTagError -> ShowS
$cshowsPrec :: Int -> SystemTagError -> ShowS
Show, Typeable SystemTagError
SystemTagError -> DataType
SystemTagError -> Constr
(forall b. Data b => b -> b) -> SystemTagError -> SystemTagError
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> SystemTagError -> u
forall u. (forall d. Data d => d -> u) -> SystemTagError -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SystemTagError -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SystemTagError -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> SystemTagError -> m SystemTagError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SystemTagError -> m SystemTagError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SystemTagError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SystemTagError -> c SystemTagError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SystemTagError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SystemTagError)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SystemTagError -> m SystemTagError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SystemTagError -> m SystemTagError
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SystemTagError -> m SystemTagError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> SystemTagError -> m SystemTagError
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> SystemTagError -> m SystemTagError
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> SystemTagError -> m SystemTagError
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> SystemTagError -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> SystemTagError -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> SystemTagError -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SystemTagError -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SystemTagError -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SystemTagError -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SystemTagError -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SystemTagError -> r
gmapT :: (forall b. Data b => b -> b) -> SystemTagError -> SystemTagError
$cgmapT :: (forall b. Data b => b -> b) -> SystemTagError -> SystemTagError
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SystemTagError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SystemTagError)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SystemTagError)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SystemTagError)
dataTypeOf :: SystemTagError -> DataType
$cdataTypeOf :: SystemTagError -> DataType
toConstr :: SystemTagError -> Constr
$ctoConstr :: SystemTagError -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SystemTagError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SystemTagError
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SystemTagError -> c SystemTagError
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SystemTagError -> c SystemTagError
Data)

instance ToCBOR SystemTagError where
  toCBOR :: SystemTagError -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR SystemTagError where
  fromCBOR :: forall s. Decoder s SystemTagError
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR SystemTagError where
  encCBOR :: SystemTagError -> Encoding
encCBOR SystemTagError
err = case SystemTagError
err of
    SystemTagNotAscii Text
tag ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
0 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Text
tag
    SystemTagTooLong Text
tag ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
1 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Text
tag

instance DecCBOR SystemTagError where
  decCBOR :: forall s. Decoder s SystemTagError
decCBOR = do
    Int
len <- forall s. Decoder s Int
decodeListLen
    let checkSize :: Int -> Decoder s ()
        checkSize :: forall s. Int -> Decoder s ()
checkSize Int
size = forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"SystemTagError" Int
size Int
len
    Word8
tag <- forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> SystemTagError
SystemTagNotAscii forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
1 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> SystemTagError
SystemTagTooLong forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"SystemTagError" Word8
tag

instance B.Buildable SystemTagError where
  build :: SystemTagError -> Builder
build = \case
    SystemTagNotAscii Text
tag ->
      forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"SystemTag, " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
", contains non-ascii characters") Text
tag
    SystemTagTooLong Text
tag ->
      forall a. Format Builder a -> a
bprint
        (Format (Text -> Int -> Builder) (Text -> Int -> Builder)
"SystemTag, " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Int -> Builder) (Int -> Builder)
", exceeds limit of " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Integral a => Format r (a -> r)
int)
        Text
tag
        (forall i. Integral i => i
systemTagMaxLength :: Int)

checkSystemTag :: MonadError SystemTagError m => SystemTag -> m ()
checkSystemTag :: forall (m :: * -> *).
MonadError SystemTagError m =>
SystemTag -> m ()
checkSystemTag (SystemTag Text
tag)
  | Text -> Int
T.length Text
tag forall a. Ord a => a -> a -> Bool
> forall i. Integral i => i
systemTagMaxLength = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> SystemTagError
SystemTagTooLong Text
tag
  | (Char -> Bool) -> Text -> Bool
T.any (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Bool
isAscii) Text
tag = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> SystemTagError
SystemTagNotAscii Text
tag
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Helper to turn an @OS@ into a @Text@ compatible with the @systemTag@
--   previously used in 'configuration.yaml'
osHelper :: OS -> Text
osHelper :: OS -> Text
osHelper OS
sys = case OS
sys of
  OS
Windows -> Text
"win"
  OS
OSX -> Text
"macos"
  OS
Linux -> Text
"linux"
  OS
_ -> forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
display OS
sys

-- | Helper to turn an @Arch@ into a @Text@ compatible with the @systemTag@
--   previously used in 'configuration.yaml'
archHelper :: Arch -> Text
archHelper :: Arch -> Text
archHelper Arch
archt = case Arch
archt of
  Arch
I386 -> Text
"32"
  Arch
X86_64 -> Text
"64"
  Arch
_ -> forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
display Arch
archt