{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UndecidableInstances #-}
module Voting.Protocol.Election where
import Control.Applicative (Applicative(..), Alternative(..))
import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT(..), runExcept, throwE, withExceptT)
import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))
import Data.Bool
import Data.Either (either)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldMap, and)
import Data.Function (($), (.), id, const)
import Data.Functor (Functor, (<$>), (<$))
import Data.Functor.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe, listToMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..), reify)
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst, snd)
import GHC.Generics (Generic)
import GHC.Natural (minusNaturalMaybe)
import Numeric.Natural (Natural)
import Prelude (fromIntegral)
import System.IO (IO, FilePath)
import System.Random (RandomGen)
import Text.Show (Show(..), showChar, showString)
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Encoding as JSON
import qualified Data.Aeson.Internal as JSON
import qualified Data.Aeson.Parser.Internal as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Text.ParserCombinators.ReadP as Read
import qualified Text.Read as Read
import Voting.Protocol.Utils
import Voting.Protocol.Arith
import Voting.Protocol.Credential
data Encryption crypto v c = Encryption
{ encryption_nonce :: !(G crypto c)
, encryption_vault :: !(G crypto c)
} deriving (Generic)
deriving instance Eq (G crypto c) => Eq (Encryption crypto v c)
deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption crypto v c)
deriving instance NFData (G crypto c) => NFData (Encryption crypto v c)
instance
( Reifies v Version
, GroupParams crypto c
) => ToJSON (Encryption crypto v c) where
toJSON Encryption{..} =
JSON.object
[ "alpha" .= encryption_nonce
, "beta" .= encryption_vault
]
toEncoding Encryption{..} =
JSON.pairs
( "alpha" .= encryption_nonce
<> "beta" .= encryption_vault
)
instance
( Reifies v Version
, GroupParams crypto c
) => FromJSON (Encryption crypto v c) where
parseJSON = JSON.withObject "Encryption" $ \o -> do
encryption_nonce <- o .: "alpha"
encryption_vault <- o .: "beta"
return Encryption{..}
instance GroupParams crypto c => Additive (Encryption crypto v c) where
zero = Encryption one one
x+y = Encryption
(encryption_nonce x * encryption_nonce y)
(encryption_vault x * encryption_vault y)
type EncryptionNonce = E
encrypt ::
Reifies v Version =>
GroupParams crypto c =>
Monad m => RandomGen r =>
PublicKey crypto c -> E crypto c ->
S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c)
encrypt pubKey clear = do
encNonce <- random
return $ (encNonce,)
Encryption
{ encryption_nonce = groupGen^encNonce
, encryption_vault = pubKey ^encNonce * groupGen^clear
}
data Proof crypto v c = Proof
{ proof_challenge :: !(Challenge crypto c)
, proof_response :: !(E crypto c)
} deriving (Eq,Show,NFData,Generic)
instance ToJSON (Proof crypto v c) where
toJSON Proof{..} =
JSON.object
[ "challenge" .= proof_challenge
, "response" .= proof_response
]
toEncoding Proof{..} =
JSON.pairs
( "challenge" .= proof_challenge
<> "response" .= proof_response
)
instance GroupParams crypto c => FromJSON (Proof crypto v c) where
parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do
proof_challenge <- o .: "challenge"
proof_response <- o .: "response"
return Proof{..}
newtype ZKP = ZKP BS.ByteString
type Challenge = E
type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c
prove ::
forall crypto v c list m r.
Reifies v Version =>
GroupParams crypto c =>
Monad m => RandomGen r => Functor list =>
E crypto c ->
list (G crypto c) ->
Oracle list crypto c ->
S.StateT r m (Proof crypto v c)
prove sec commitmentBases oracle = do
nonce <- random
let commitments = (^ nonce) <$> commitmentBases
let proof_challenge = oracle commitments
return Proof
{ proof_challenge
, proof_response = nonce `op` (sec*proof_challenge)
}
where
op =
if reflect (Proxy @v) `hasVersionTag` versionTagQuicker
then (-)
else (+)
proveQuicker ::
Reifies v Version =>
GroupParams crypto c =>
Monad m => RandomGen r => Functor list =>
E crypto c ->
list (G crypto c) ->
Oracle list crypto c ->
S.StateT r m (Proof crypto v c)
proveQuicker sec commitmentBases oracle = do
nonce <- random
let commitments = (^ nonce) <$> commitmentBases
let proof_challenge = oracle commitments
return Proof
{ proof_challenge
, proof_response = nonce - sec*proof_challenge
}
fakeProof ::
GroupParams crypto c =>
Monad m => RandomGen r =>
S.StateT r m (Proof crypto v c)
fakeProof = do
proof_challenge <- random
proof_response <- random
return Proof{..}
type Commitment = G
commit ::
forall crypto v c.
Reifies v Version =>
GroupParams crypto c =>
Proof crypto v c ->
G crypto c ->
G crypto c ->
Commitment crypto c
commit Proof{..} base basePowSec =
(base^proof_response) `op`
(basePowSec^proof_challenge)
where
op =
if reflect (Proxy @v) `hasVersionTag` versionTagQuicker
then (*)
else (/)
{-# INLINE commit #-}
commitQuicker ::
GroupParams crypto c =>
Proof crypto v c ->
G crypto c ->
G crypto c ->
Commitment crypto c
commitQuicker Proof{..} base basePowSec =
base^proof_response *
basePowSec^proof_challenge
type Disjunction = G
booleanDisjunctions ::
forall crypto c.
GroupParams crypto c =>
[Disjunction crypto c]
booleanDisjunctions = List.take 2 $ groupGenInverses @crypto
intervalDisjunctions ::
forall crypto c.
GroupParams crypto c =>
Natural -> Natural -> [Disjunction crypto c]
intervalDisjunctions mini maxi =
List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $
List.genericDrop (nat mini) $
groupGenInverses @crypto
type Opinion = E
newtype DisjProof crypto v c = DisjProof [Proof crypto v c]
deriving (Eq,Show,Generic)
deriving newtype (NFData,ToJSON,FromJSON)
proveEncryption ::
Reifies v Version =>
GroupParams crypto c =>
Monad m => RandomGen r =>
PublicKey crypto c -> ZKP ->
([Disjunction crypto c],[Disjunction crypto c]) ->
(EncryptionNonce crypto c, Encryption crypto v c) ->
S.StateT r m (DisjProof crypto v c)
proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do
prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof
nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof
let fakeChallengeSum =
sum (proof_challenge <$> prevFakeProofs) +
sum (proof_challenge <$> nextFakeProofs)
let statement = encryptionStatement voterZKP enc
genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->
let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in
let prevCommitments = validCommitments prevDisjs prevFakeProofs in
let nextCommitments = validCommitments nextDisjs nextFakeProofs in
let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in
let challenge = hash statement commitments in
let genuineChallenge = challenge - fakeChallengeSum in
genuineChallenge
let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
return (DisjProof proofs)
verifyEncryption ::
Reifies v Version =>
GroupParams crypto c =>
Monad m =>
PublicKey crypto c -> ZKP ->
[Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) ->
ExceptT ErrorVerifyEncryption m Bool
verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =
case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of
Nothing ->
throwE $ ErrorVerifyEncryption_InvalidProofLength
(fromIntegral $ List.length proofs)
(fromIntegral $ List.length disjs)
Just commitments ->
return $ challengeSum ==
hash (encryptionStatement voterZKP enc) (join commitments)
where
challengeSum = sum (proof_challenge <$> proofs)
encryptionStatement ::
GroupParams crypto c =>
ZKP -> Encryption crypto v c -> BS.ByteString
encryptionStatement (ZKP voterZKP) Encryption{..} =
"prove|"<>voterZKP<>"|"
<> bytesNat encryption_nonce<>","
<> bytesNat encryption_vault<>"|"
encryptionCommitments ::
Reifies v Version =>
GroupParams crypto c =>
PublicKey crypto c -> Encryption crypto v c ->
Disjunction crypto c -> Proof crypto v c -> [G crypto c]
encryptionCommitments elecPubKey Encryption{..} disj proof =
[ commit proof groupGen encryption_nonce
, commit proof elecPubKey (encryption_vault*disj)
]
data ErrorVerifyEncryption
= ErrorVerifyEncryption_InvalidProofLength Natural Natural
deriving (Eq,Show)
data Question v = Question
{ question_text :: !Text
, question_choices :: ![Text]
, question_mini :: !Natural
, question_maxi :: !Natural
} deriving (Eq,Show,Generic,NFData)
instance Reifies v Version => ToJSON (Question v) where
toJSON Question{..} =
JSON.object
[ "question" .= question_text
, "answers" .= question_choices
, "min" .= question_mini
, "max" .= question_maxi
]
toEncoding Question{..} =
JSON.pairs
( "question" .= question_text
<> "answers" .= question_choices
<> "min" .= question_mini
<> "max" .= question_maxi
)
instance Reifies v Version => FromJSON (Question v) where
parseJSON = JSON.withObject "Question" $ \o -> do
question_text <- o .: "question"
question_choices <- o .: "answers"
question_mini <- o .: "min"
question_maxi <- o .: "max"
return Question{..}
data Answer crypto v c = Answer
{ answer_opinions :: ![(Encryption crypto v c, DisjProof crypto v c)]
, answer_sumProof :: !(DisjProof crypto v c)
} deriving (Generic)
deriving instance Eq (G crypto c) => Eq (Answer crypto v c)
deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Answer crypto v c)
deriving instance NFData (G crypto c) => NFData (Answer crypto v c)
instance
( Reifies v Version
, GroupParams crypto c
) => ToJSON (Answer crypto v c) where
toJSON Answer{..} =
let (answer_choices, answer_individual_proofs) =
List.unzip answer_opinions in
JSON.object
[ "choices" .= answer_choices
, "individual_proofs" .= answer_individual_proofs
, "overall_proof" .= answer_sumProof
]
toEncoding Answer{..} =
let (answer_choices, answer_individual_proofs) =
List.unzip answer_opinions in
JSON.pairs
( "choices" .= answer_choices
<> "individual_proofs" .= answer_individual_proofs
<> "overall_proof" .= answer_sumProof
)
instance
( Reifies v Version
, GroupParams crypto c
) => FromJSON (Answer crypto v c) where
parseJSON = JSON.withObject "Answer" $ \o -> do
answer_choices <- o .: "choices"
answer_individual_proofs <- o .: "individual_proofs"
let answer_opinions = List.zip answer_choices answer_individual_proofs
answer_sumProof <- o .: "overall_proof"
return Answer{..}
encryptAnswer ::
Reifies v Version =>
GroupParams crypto c =>
Monad m => RandomGen r =>
PublicKey crypto c -> ZKP ->
Question v -> [Bool] ->
S.StateT r (ExceptT ErrorAnswer m) (Answer crypto v c)
encryptAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} opinionByChoice
| not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
lift $ throwE $
ErrorAnswer_WrongSumOfOpinions opinionsSum question_mini question_maxi
| List.length opinions /= List.length question_choices =
lift $ throwE $
ErrorAnswer_WrongNumberOfOpinions
(fromIntegral $ List.length opinions)
(fromIntegral $ List.length question_choices)
| otherwise = do
encryptions <- encrypt elecPubKey `mapM` opinions
individualProofs <- zipWithM
(\opinion -> proveEncryption elecPubKey zkp $
if opinion
then (List.init booleanDisjunctions,[])
else ([],List.tail booleanDisjunctions))
opinionByChoice encryptions
sumProof <- proveEncryption elecPubKey zkp
(List.tail <$> List.genericSplitAt
(fromJust $ opinionsSum`minusNaturalMaybe`question_mini)
(intervalDisjunctions question_mini question_maxi))
( sum (fst <$> encryptions)
, sum (snd <$> encryptions)
)
return $ Answer
{ answer_opinions = List.zip
(snd <$> encryptions)
individualProofs
, answer_sumProof = sumProof
}
where
opinionsSum = sum $ nat <$> opinions
opinions = (\o -> if o then one else zero) <$> opinionByChoice
verifyAnswer ::
Reifies v Version =>
GroupParams crypto c =>
PublicKey crypto c -> ZKP ->
Question v -> Answer crypto v c -> Bool
verifyAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} Answer{..}
| List.length question_choices /= List.length answer_opinions = False
| otherwise = do
either (const False) id $ runExcept $ do
validOpinions <-
verifyEncryption elecPubKey zkp booleanDisjunctions
`traverse` answer_opinions
validSum <- verifyEncryption elecPubKey zkp
(intervalDisjunctions question_mini question_maxi)
( sum (fst <$> answer_opinions)
, answer_sumProof )
return (and validOpinions && validSum)
data ErrorAnswer
= ErrorAnswer_WrongNumberOfOpinions Natural Natural
| ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
deriving (Eq,Show,Generic,NFData)
data Election crypto v c = Election
{ election_name :: !Text
, election_description :: !Text
, election_questions :: ![Question v]
, election_uuid :: !UUID
, election_hash :: Base64SHA256
, election_crypto :: !crypto
, election_version :: !(Maybe Version)
, election_public_key :: !(PublicKey crypto c)
} deriving (Generic)
deriving instance (Eq crypto, Eq (G crypto c)) => Eq (Election crypto v c)
deriving instance (Show crypto, Show (G crypto c)) => Show (Election crypto v c)
deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Election crypto v c)
instance
( Reifies v Version
, GroupParams crypto c
, ToJSON crypto
) => ToJSON (Election crypto v c) where
toJSON Election{..} =
JSON.object $
[ "name" .= election_name
, "description" .= election_description
, ("public_key", JSON.object
[ "group" .= election_crypto
, "y" .= election_public_key
])
, "questions" .= election_questions
, "uuid" .= election_uuid
] <>
maybe [] (\version -> [ "version" .= version ]) election_version
toEncoding Election{..} =
JSON.pairs $
( "name" .= election_name
<> "description" .= election_description
<> JSON.pair "public_key" (JSON.pairs $
"group" .= election_crypto
<> "y" .= election_public_key
)
<> "questions" .= election_questions
<> "uuid" .= election_uuid
) <>
maybe mempty ("version" .=) election_version
hashElection ::
Reifies v Version =>
GroupParams crypto c =>
ToJSON crypto =>
Election crypto v c -> Base64SHA256
hashElection = base64SHA256 . BSL.toStrict . JSON.encode
readElection ::
forall crypto r.
FromJSON crypto =>
ReifyCrypto crypto =>
FilePath ->
(forall v c.
Reifies v Version =>
GroupParams crypto c =>
Election crypto v c -> r) ->
ExceptT String IO r
readElection filePath k = do
fileData <- lift $ BS.readFile filePath
ExceptT $ return $
jsonEitherFormatError $
JSON.eitherDecodeStrictWith JSON.jsonEOF
(JSON.iparse (parseElection fileData))
fileData
where
parseElection fileData = JSON.withObject "Election" $ \o -> do
election_version <- o .:? "version"
reify (fromMaybe stableVersion election_version) $ \(_v::Proxy v) -> do
(election_crypto, elecPubKey) <-
JSON.explicitParseField
(JSON.withObject "public_key" $ \obj -> do
crypto <- obj .: "group"
pubKey :: JSON.Value <- obj .: "y"
return (crypto, pubKey)
) o "public_key"
reifyCrypto election_crypto $ \(_c::Proxy c) -> do
election_name <- o .: "name"
election_description <- o .: "description"
election_questions <- o .: "questions" :: JSON.Parser [Question v]
election_uuid <- o .: "uuid"
election_public_key :: PublicKey crypto c <- parseJSON elecPubKey
return $ k $ Election
{ election_questions = election_questions
, election_public_key = election_public_key
, election_hash = base64SHA256 fileData
, ..
}
data Ballot crypto v c = Ballot
{ ballot_answers :: ![Answer crypto v c]
, ballot_signature :: !(Maybe (Signature crypto v c))
, ballot_election_uuid :: !UUID
, ballot_election_hash :: !Base64SHA256
} deriving (Generic)
deriving instance (NFData (G crypto c), NFData crypto) => NFData (Ballot crypto v c)
instance
( Reifies v Version
, GroupParams crypto c
, ToJSON (G crypto c)
) => ToJSON (Ballot crypto v c) where
toJSON Ballot{..} =
JSON.object $
[ "answers" .= ballot_answers
, "election_uuid" .= ballot_election_uuid
, "election_hash" .= ballot_election_hash
] <>
maybe [] (\sig -> [ "signature" .= sig ]) ballot_signature
toEncoding Ballot{..} =
JSON.pairs $
( "answers" .= ballot_answers
<> "election_uuid" .= ballot_election_uuid
<> "election_hash" .= ballot_election_hash
) <>
maybe mempty ("signature" .=) ballot_signature
instance
( Reifies v Version
, GroupParams crypto c
) => FromJSON (Ballot crypto v c) where
parseJSON = JSON.withObject "Ballot" $ \o -> do
ballot_answers <- o .: "answers"
ballot_signature <- o .:? "signature"
ballot_election_uuid <- o .: "election_uuid"
ballot_election_hash <- o .: "election_hash"
return Ballot{..}
encryptBallot ::
Reifies v Version =>
GroupParams crypto c => Key crypto =>
Monad m => RandomGen r =>
Election crypto v c ->
Maybe (SecretKey crypto c) -> [[Bool]] ->
S.StateT r (ExceptT ErrorBallot m) (Ballot crypto v c)
encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQuest
| List.length election_questions /= List.length opinionsByQuest =
lift $ throwE $
ErrorBallot_WrongNumberOfAnswers
(fromIntegral $ List.length opinionsByQuest)
(fromIntegral $ List.length election_questions)
| otherwise = do
let (voterKeys, voterZKP) =
case ballotSecKeyMay of
Nothing -> (Nothing, ZKP "")
Just ballotSecKey ->
( Just (ballotSecKey, ballotPubKey)
, ZKP (bytesNat ballotPubKey) )
where ballotPubKey = publicKey ballotSecKey
ballot_answers <-
S.mapStateT (withExceptT ErrorBallot_Answer) $
zipWithM (encryptAnswer election_public_key voterZKP)
election_questions opinionsByQuest
ballot_signature <- case voterKeys of
Nothing -> return Nothing
Just (ballotSecKey, signature_publicKey) -> do
signature_proof <-
proveQuicker ballotSecKey (Identity groupGen) $
\(Identity commitment) ->
hash @crypto
(signatureCommitments @crypto voterZKP commitment)
(signatureStatement @crypto ballot_answers)
return $ Just Signature{..}
return Ballot
{ ballot_answers
, ballot_election_hash = election_hash
, ballot_election_uuid = election_uuid
, ballot_signature
}
verifyBallot ::
Reifies v Version =>
GroupParams crypto c =>
Election crypto v c ->
Ballot crypto v c -> Bool
verifyBallot (Election{..}::Election crypto v c) Ballot{..} =
ballot_election_uuid == election_uuid &&
ballot_election_hash == election_hash &&
List.length election_questions == List.length ballot_answers &&
let (isValidSign, zkpSign) =
case ballot_signature of
Nothing -> (True, ZKP "")
Just Signature{..} ->
let zkp = ZKP (bytesNat signature_publicKey) in
(, zkp) $
proof_challenge signature_proof == hash
(signatureCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey))
(signatureStatement @crypto ballot_answers)
in
and $ isValidSign :
List.zipWith (verifyAnswer election_public_key zkpSign)
election_questions ballot_answers
data Signature crypto v c = Signature
{ signature_publicKey :: !(PublicKey crypto c)
, signature_proof :: !(Proof crypto v c)
} deriving (Generic)
deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c)
instance
( Reifies v Version
, GroupParams crypto c
) => ToJSON (Signature crypto v c) where
toJSON (Signature pubKey Proof{..}) =
JSON.object
[ "public_key" .= pubKey
, "challenge" .= proof_challenge
, "response" .= proof_response
]
toEncoding (Signature pubKey Proof{..}) =
JSON.pairs
( "public_key" .= pubKey
<> "challenge" .= proof_challenge
<> "response" .= proof_response
)
instance
( Reifies v Version
, GroupParams crypto c
) => FromJSON (Signature crypto v c) where
parseJSON = JSON.withObject "Signature" $ \o -> do
signature_publicKey <- o .: "public_key"
proof_challenge <- o .: "challenge"
proof_response <- o .: "response"
let signature_proof = Proof{..}
return Signature{..}
signatureStatement :: GroupParams crypto c => Foldable f => f (Answer crypto v c) -> [G crypto c]
signatureStatement =
foldMap $ \Answer{..} ->
(`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
[encryption_nonce, encryption_vault]
signatureCommitments ::
GroupParams crypto c =>
ToNatural (G crypto c) =>
ZKP -> Commitment crypto c -> BS.ByteString
signatureCommitments (ZKP voterZKP) commitment =
"sig|"<>voterZKP<>"|"
<> bytesNat commitment<>"|"
data ErrorBallot
= ErrorBallot_WrongNumberOfAnswers Natural Natural
| ErrorBallot_Answer ErrorAnswer
| ErrorBallot_Wrong
deriving (Eq,Show,Generic,NFData)
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 '.') $
showsPrec 0 <$> version_branch) .
List.foldr (.) id
((\(t,n) -> showChar '-' . showString (Text.unpack t) .
if n > 0 then showsPrec 0 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)
experimentalVersion :: Version
experimentalVersion = stableVersion
{version_tags = [(versionTagQuicker,0)]}
stableVersion :: Version
stableVersion = "1.6"
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{..}
parseReadP :: Read.ReadP a -> String -> Maybe a
parseReadP p s =
let p' = Read.readP_to_S p in
listToMaybe $ do
(x, "") <- p' s
return x