hjugement-protocol/src/Voting/Protocol/Version.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE PolyKinds #-}
   3 {-# LANGUAGE DeriveAnyClass #-}
   4 {-# LANGUAGE DeriveGeneric #-}
   5 {-# LANGUAGE DerivingStrategies #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances
   8 module Voting.Protocol.Version where
   9
  10 import Control.Applicative (Applicative(..), Alternative(..))
  11 import Control.DeepSeq (NFData)
  12 import Control.Monad (Monad(..), join, replicateM)
  13 import Control.Monad.Trans.Except (ExceptT(..), throwE)
  14 import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=))
  15 import Data.Bits
  16 import Data.Bool
  17 import Data.Eq (Eq(..))
  18 import Data.Function (($), (.), id)
  19 import Data.Functor (Functor, (<$>), (<$))
  20 import Data.Maybe (Maybe(..), fromJust, listToMaybe)
  21 import Data.Ord (Ord(..))
  22 import Data.Proxy (Proxy(..))
  23 import Data.Reflection (Reifies(..))
  24 import Data.Semigroup (Semigroup(..))
  25 import Data.String (String, IsString(..))
  26 import Data.Text (Text)
  27 import GHC.Generics (Generic)
  28 import GHC.Natural (minusNaturalMaybe)
  29 import GHC.TypeLits (Nat, Symbol, natVal, symbolVal, KnownNat, KnownSymbol)
  30 import Numeric.Natural (Natural)
  31 import Prelude (Bounded(..), fromIntegral)
  32 import System.Random (RandomGen)
  33 import Text.Show (Show(..), showChar, showString, shows)
  34 import qualified Control.Monad.Trans.State.Strict as S
  35 import qualified Crypto.Hash as Crypto
  36 import qualified Data.Aeson as JSON
  37 import qualified Data.Aeson.Types as JSON
  38 import qualified Data.ByteArray as ByteArray
  39 import qualified Data.ByteString as BS
  40 import qualified Data.ByteString.Base64 as BS64
  41 import qualified Data.Char as Char
  42 import qualified Data.List as List
  43 import qualified Data.Text as Text
  44 import qualified Data.Text.Encoding as Text
  45 import qualified Data.Text.Lazy as TL
  46 import qualified Data.Text.Lazy.Builder as TLB
  47 import qualified Data.Text.Lazy.Builder.Int as TLB
  48 import qualified System.Random as Random
  49 import qualified Text.ParserCombinators.ReadP as Read
  50 import qualified Text.Read as Read
  51
  52 import Voting.Protocol.Utils
  53 import Voting.Protocol.Arithmetic
  54
  55 -- * Type 'Version'
  56 -- | Version of the Helios-C protocol.
  57 data Version = Version
  58  { version_branch :: [Natural]
  59  , version_tags   :: [(Text, Natural)]
  60  } deriving (Eq,Ord,Generic,NFData)
  61 instance IsString Version where
  62         fromString = fromJust . readVersion
  63 instance Show Version where
  64         showsPrec _p Version{..} =
  65                 List.foldr (.) id
  66                  (List.intersperse (showChar '.') $
  67                         shows <$> version_branch) .
  68                 List.foldr (.) id
  69                  ((\(t,n) -> showChar '-' . showString (Text.unpack t) .
  70                         if n > 0 then shows n else id)
  71                  <$> version_tags)
  72 instance ToJSON Version where
  73         toJSON     = toJSON     . show
  74         toEncoding = toEncoding . show
  75 instance FromJSON Version where
  76         parseJSON (JSON.String s)
  77          | Just v <- readVersion (Text.unpack s)
  78          = return v
  79         parseJSON json = JSON.typeMismatch "Version" json
  80
  81 hasVersionTag :: Version -> Text -> Bool
  82 hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v)
  83
  84 -- ** Type 'ExperimentalVersion'
  85 type ExperimentalVersion = V [1,6] '[ '(VersionTagQuicker,0)]
  86 experimentalVersion :: Version
  87 experimentalVersion = stableVersion{version_tags = [(versionTagQuicker,0)]}
  88
  89 -- ** Type 'StableVersion'
  90 type StableVersion = V [1,6] '[]
  91 stableVersion :: Version
  92 stableVersion = "1.6"
  93
  94 -- ** Type 'VersionTagQuicker'
  95 type VersionTagQuicker = "quicker"
  96 versionTagQuicker :: Text
  97 versionTagQuicker = "quicker"
  98
  99 readVersion :: String -> Maybe Version
 100 readVersion = parseReadP $ do
 101         version_branch <- Read.sepBy1
 102          (Read.read <$> Read.munch1 Char.isDigit)
 103          (Read.char '.')
 104         version_tags <- Read.many $ (,)
 105                  <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)
 106                  <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)
 107         return Version{..}
 108
 109 -- ** Type 'V'
 110 -- | Type-level representation of a specific 'Version'.
 111 data V (branch::[Nat]) (tags::[(Symbol,Nat)])
 112 -- | Like a normal 'reflect' but this one takes
 113 -- its 'Version' from a type-level 'V'ersion
 114 -- instead of a term-level 'Version'.
 115 instance (VersionBranchVal branch, VersionTagsVal tags) => Reifies (V branch tags) Version where
 116         reflect _ = Version
 117          { version_branch = versionBranchVal (Proxy @branch)
 118          , version_tags   = versionTagsVal (Proxy @tags)
 119          }
 120
 121 -- *** Class 'VersionBranchVal'
 122 class VersionBranchVal a where
 123         versionBranchVal :: proxy a -> [Natural]
 124 instance KnownNat h => VersionBranchVal '[h] where
 125         versionBranchVal _ = [fromIntegral (natVal (Proxy @h))]
 126 instance
 127  ( KnownNat h
 128  , KnownNat hh
 129  , VersionBranchVal (hh ':t)
 130  ) => VersionBranchVal (h ': hh ': t) where
 131         versionBranchVal _ =
 132                 fromIntegral (natVal (Proxy @h)) :
 133                 versionBranchVal (Proxy @(hh ':t))
 134
 135 -- *** Class 'VersionTagsVal'
 136 class VersionTagsVal a where
 137         versionTagsVal :: proxy a -> [(Text,Natural)]
 138 instance VersionTagsVal '[] where
 139         versionTagsVal _ = []
 140 instance
 141  ( KnownSymbol s
 142  , KnownNat n
 143  , VersionTagsVal t
 144  ) => VersionTagsVal ('(s,n) ': t) where
 145         versionTagsVal _ =
 146                 ( Text.pack (symbolVal (Proxy @s))
 147                 , fromIntegral (natVal (Proxy @n))
 148                 ) : versionTagsVal (Proxy :: Proxy t)