{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
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
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 = V [1,6] '[ '(VersionTagQuicker,0)]
experimentalVersion :: Version
experimentalVersion = stableVersion{version_tags = [(versionTagQuicker,0)]}
type StableVersion = V [1,6] '[]
stableVersion :: Version
stableVersion = "1.6"
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{..}
data V (branch::[Nat]) (tags::[(Symbol,Nat)])
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 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 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)