Version.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances
module Voting.Protocol.Version where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), join, replicateM)
import Control.Monad.Trans.Except (ExceptT(..), throwE)
import Data.Aeson (ToJSON(..), FromJSON(..), (.:), (.=))
import Data.Bits
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.Functor (Functor, (<$>), (<$))
import Data.Maybe (Maybe(..), fromJust, listToMaybe)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import GHC.Natural (minusNaturalMaybe)
import GHC.TypeLits (Nat, Symbol, natVal, symbolVal, KnownNat, KnownSymbol)
import Numeric.Natural (Natural)
import Prelude (Bounded(..), fromIntegral)
import System.Random (RandomGen)
import Text.Show (Show(..), showChar, showString, shows)
import qualified Control.Monad.Trans.State.Strict as S
import qualified Crypto.Hash as Crypto
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS64
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLB
import qualified System.Random as Random
import qualified Text.ParserCombinators.ReadP as Read
import qualified Text.Read as Read

import Voting.Protocol.Utils
import Voting.Protocol.Arithmetic

-- * Type 'Version'
-- | Version of the Helios-C protocol.
data Version = Version
 { version_branch :: [Natural]
 , version_tags   :: [(Text, Natural)]
 } deriving (Eq,Ord,Generic,NFData)
instance IsString Version where
	fromString = fromJust . readVersion
instance Show Version where
	showsPrec _p Version{..} =
		List.foldr (.) id
		 (List.intersperse (showChar '.') $
			shows <$> version_branch) .
		List.foldr (.) id
		 ((\(t,n) -> showChar '-' . showString (Text.unpack t) .
			if n > 0 then shows n else id)
		 <$> version_tags)
instance ToJSON Version where
	toJSON     = toJSON     . show
	toEncoding = toEncoding . show
instance FromJSON Version where
	parseJSON (JSON.String s)
	 | Just v <- readVersion (Text.unpack s)
	 = return v
	parseJSON json = JSON.typeMismatch "Version" json

hasVersionTag :: Version -> Text -> Bool
hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v)

-- ** Type 'ExperimentalVersion'
type ExperimentalVersion = V [1,6] '[ '(VersionTagQuicker,0)]
experimentalVersion :: Version
experimentalVersion = stableVersion{version_tags = [(versionTagQuicker,0)]}

-- ** Type 'StableVersion'
type StableVersion = V [1,6] '[]
stableVersion :: Version
stableVersion = "1.6"

-- ** Type 'VersionTagQuicker'
type VersionTagQuicker = "quicker"
versionTagQuicker :: Text
versionTagQuicker = "quicker"

readVersion :: String -> Maybe Version
readVersion = parseReadP $ do
	version_branch <- Read.sepBy1
	 (Read.read <$> Read.munch1 Char.isDigit)
	 (Read.char '.')
	version_tags <- Read.many $ (,)
		 <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)
		 <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)
	return Version{..}

-- ** Type 'V'
-- | Type-level representation of a specific 'Version'.
data V (branch::[Nat]) (tags::[(Symbol,Nat)])
-- | Like a normal 'reflect' but this one takes
-- its 'Version' from a type-level 'V'ersion
-- instead of a term-level 'Version'.
instance (VersionBranchVal branch, VersionTagsVal tags) => Reifies (V branch tags) Version where
	reflect _ = Version
	 { version_branch = versionBranchVal (Proxy @branch)
	 , version_tags   = versionTagsVal (Proxy @tags)
	 }

-- *** Class 'VersionBranchVal'
class VersionBranchVal a where
	versionBranchVal :: proxy a -> [Natural]
instance KnownNat h => VersionBranchVal '[h] where
	versionBranchVal _ = [fromIntegral (natVal (Proxy @h))]
instance
 ( KnownNat h
 , KnownNat hh
 , VersionBranchVal (hh ':t)
 ) => VersionBranchVal (h ': hh ': t) where
	versionBranchVal _ =
		fromIntegral (natVal (Proxy @h)) :
		versionBranchVal (Proxy @(hh ':t))

-- *** Class 'VersionTagsVal'
class VersionTagsVal a where
	versionTagsVal :: proxy a -> [(Text,Natural)]
instance VersionTagsVal '[] where
	versionTagsVal _ = []
instance
 ( KnownSymbol s
 , KnownNat n
 , VersionTagsVal t
 ) => VersionTagsVal ('(s,n) ': t) where
	versionTagsVal _ =
		( Text.pack (symbolVal (Proxy @s))
		, fromIntegral (natVal (Proxy @n))
		) : versionTagsVal (Proxy :: Proxy t)