diff --git a/hjugement-cli.cabal b/hjugement-cli.cabal --- a/hjugement-cli.cabal +++ b/hjugement-cli.cabal @@ -2,14 +2,14 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.20190714 +version: 0.0.0.20190721 category: Politic synopsis: Majority Judgment and Helios-C command line tool description: Work in progress command line interface for: . * - * . + * . Run with --help parameter to read the manual. extra-doc-files: @@ -22,7 +22,7 @@ -- homepage: build-type: Simple -cabal-version: 1.24 +cabal-version: 2.0 tested-with: GHC==8.6.4 extra-source-files: stack.yaml @@ -32,16 +32,18 @@ location: git://git.autogeree.net/hjugement type: git -Executable hjugement-cli +Executable hjugement hs-source-dirs: src main-is: Main.hs other-modules: Hjugement.CLI - Hjugement.CLI.MkElection + Hjugement.CLI.Administrator Hjugement.CLI.Registrar Hjugement.CLI.Trustee Hjugement.CLI.Utils Paths_hjugement_cli + autogen-modules: + Paths_hjugement_cli default-language: Haskell2010 default-extensions: AllowAmbiguousTypes @@ -94,7 +96,7 @@ , pipes-text >= 0.0.2.5 , random >= 1.1 , reflection >= 2.1 - , symantic-cli >= 2.3.2 + , symantic-cli >= 2.4 , symantic-document >= 1.5 , terminal-size >= 0.3 , text >= 1.2 diff --git a/src/Hjugement/CLI.hs b/src/Hjugement/CLI.hs --- a/src/Hjugement/CLI.hs +++ b/src/Hjugement/CLI.hs @@ -3,9 +3,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} module Hjugement.CLI where import Control.Applicative (Applicative(..), Alternative(..)) @@ -36,43 +34,43 @@ import qualified System.IO as IO import Hjugement.CLI.Utils +import Hjugement.CLI.Administrator import Hjugement.CLI.Registrar import Hjugement.CLI.Trustee -import Hjugement.CLI.MkElection progname :: Text progname = "hjugement" -version :: Text -version = - progname <> "-" <> - Text.pack (Version.showVersion Hjugement.version) api = program "hjugement" $ - (api_options api_command) + (api_options api_agent) api_help True api_version +run = + run_agent :!: + run_help api :!: + run_version -api_command = - rule "COMMAND" $ - api_registrar +api_agent = + rule "AGENT" $ + api_administrator api_trustee - api_mkelection -run_command opts = - run_registrar opts :!: - run_trustee opts :!: - (run_mkelection :!: run_help api_mkelection) + api_registrar +run_agent params = + run_administrator params :!: + run_trustee params :!: + run_registrar params api_version = "Print the version." `helps` - tagged (TagLong "version") nothing + tag (TagLong "version") nothing <.> response @Doc +run_version = + return (Doc.from version <> Doc.newline) +version :: Text +version = + progname <> "-" <> + Text.pack (Version.showVersion Hjugement.version) -parseAPI = parser @Void @Doc api $ - run_command :!: - run_help api :!: - run_version - where - run_version = - return (Doc.from version <> Doc.newline) +parseAPI = parser @Void @Doc api run diff --git a/src/Hjugement/CLI/Administrator.hs b/src/Hjugement/CLI/Administrator.hs new file mode 100644 --- /dev/null +++ b/src/Hjugement/CLI/Administrator.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +module Hjugement.CLI.Administrator where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad (Monad(..), forM, forM_, join, unless, void) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.State.Strict (runState, runStateT) +import Data.Bits (setBit) +import Data.Bool +import Data.ByteString (ByteString) +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable, foldMap, length, null) +import Data.Function (($), (.), id, flip) +import Data.Functor ((<$>), (<$)) +import Data.Int (Int) +import Data.Maybe (Maybe(..), maybe, fromMaybe, fromJust) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Proxy (Proxy(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String) +import Data.Text (Text) +import GHC.Natural (minusNatural, minusNaturalMaybe) +import GHC.Prim (coerce) +import Numeric.Natural (Natural) +import Pipes ((>->)) +import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double) +import Symantic.CLI as CLI +import System.IO (IO, FilePath) +import Text.Show (Show(..)) +import qualified Crypto.Hash as Crypto +import qualified Data.Aeson as JSON +import qualified Data.ByteArray as ByteArray +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +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 Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Lazy.IO as TL +import qualified Data.Time as Time +import qualified Lens.Family as Lens +import qualified Lens.Family.State.Strict as Lens +import qualified Pipes as Pip +import qualified Pipes.ByteString as PipBS +import qualified Pipes.Group as Pip +import qualified Pipes.Prelude as Pip +import qualified Pipes.Aeson as PipJSON (DecodingError(..)) +import qualified Pipes.Aeson.Unchecked as PipJSON +import qualified Pipes.Safe as Pip +import qualified Pipes.Safe.Prelude as Pip +import qualified Pipes.Text as PipText +import qualified Pipes.Text.Encoding as PipText +import qualified Pipes.Text.IO as PipText +import qualified Symantic.Document as Doc +import qualified System.FilePath as FP +import qualified System.IO as IO +import qualified System.Posix as Posix +import qualified System.Random as Rand +import qualified Voting.Protocol as VP + +import Hjugement.CLI.Utils + +-- * administrator +data Administrator_Params = Administrator_Params + { + } deriving (Show) + +api_administrator = + "Commands for an administrator." + `helps` + command "administrator" $ + api_administrator_election + api_help False +run_administrator globParams = + run_administrator_election globParams + :!: run_help api_administrator + +-- ** election +data AdministratorElection_Params = AdministratorElection_Params + { administratorElection_crypto :: VP.FFC + , administratorElection_name :: Text + , administratorElection_description :: Text + , administratorElection_uuid :: Maybe Text + , administratorElection_grades :: [Text] + , administratorElection_defaultGrade :: Maybe Text + } deriving (Show) + +api_administrator_election = + "This command reads and checks the trustees' public keys in "<>fileRef"public_keys.jsons"<>".\ + \ From which it computes the global election public key\ + \ put it into an "<>fileRef"election.json"<>" file \ + \ with the infos of the vote given here." + `helps` + command "election" $ + rule "PARAMS" + (AdministratorElection_Params + <$> api_param_crypto + <*> api_param_name + <*> api_param_description + <*> api_option_uuid + <*> api_param_grades + <*> api_param_defaultGrade + ) + api_quests + <.> response @(Maybe ()) + where + api_param_name = + "Name of the election." + `help` + defaultTag "name" "" (var "STRING") + api_param_description = + "Description of the election." + `help` + defaultTag "description" "" (var "STRING") + api_option_uuid = + "UUID of the election." + `help` + optionalTag "uuid" $ + var "UUID" + api_quests = + "Some questions." + `help` + many1 (var @Text "STRING") + api_param_grades = + "The grades to evaluate the choices, from the lowest to the highest." + `helps` + many1Tag (TagLong "grade") $ + var @Text "STRING" + api_param_defaultGrade = + "The grade used when no grade is given by a voter.\n"<> + "Defaults to the lowest grade." + `helps` + optionalTag (TagLong "default-grade") $ + var @Text "STRING" + +run_administrator_election + Global_Params{..} + o@AdministratorElection_Params{..} + quests = + VP.reify administratorElection_crypto $ \(crypto::Proxy c) -> runMaybeT $ do + election_uuid <- + case administratorElection_uuid of + Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID + Just u -> + case VP.readUUID u of + Left err -> outputError $ Doc.from (show err) + Right uuid -> return uuid + let trusteeKeysPath = global_dir FP. "public_keys.jsons" + trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError $ + Pip.toListM' $ readJSON trusteeKeysPath + let grades = List.nub administratorElection_grades + unless (List.length grades > 1) $ + outputError $ "at least two distinct grades are needed" + unless (List.length grades == List.length administratorElection_grades) $ + outputError $ "indistinct grades: " <> + Doc.from (Text.intercalate ", " $ List.nub $ + administratorElection_grades List.\\ grades) + let defaultGrade = fromMaybe (grades List.!!0) administratorElection_defaultGrade + -- FIXME: put defaultGrade into election.json + saveJSON (global_dir FP. "election.json") $ + VP.hashElection VP.Election + { VP.election_name = administratorElection_name + , VP.election_description = administratorElection_description + , VP.election_crypto = VP.ElectionCrypto_FFC + { electionCrypto_FFC_params = administratorElection_crypto + , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys + } + , VP.election_questions = (<$> quests) $ \quest -> VP.Question + { question_text = quest + , question_choices = grades + , question_mini = 1 + , question_maxi = 1 + } + , VP.election_uuid + , VP.election_hash = VP.hashJSON JSON.Null + } + outputInfo $ "Created election with "<>Doc.from (show election_uuid) diff --git a/src/Hjugement/CLI/MkElection.hs b/src/Hjugement/CLI/MkElection.hs deleted file mode 100644 --- a/src/Hjugement/CLI/MkElection.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} -module Hjugement.CLI.MkElection where - -import Control.Applicative (Applicative(..)) -import Control.Monad (Monad(..)) -import Data.Bool -import Data.Maybe (Maybe(..)) -import Data.Function (($)) -import Data.Functor ((<$>)) -import Data.Semigroup (Semigroup(..)) -import Data.String (String) -import Symantic.CLI as CLI -import System.IO (FilePath) -import Text.Show (Show) -import qualified Symantic.Document as Doc -import qualified Voting.Protocol as VP - -import Hjugement.CLI.Utils - -data MkElection_Options = MkElection_Options - { mkelection_crypto :: VP.FFC - , mkelection_template :: FilePath - , mkelection_uuid :: VP.UUID - } deriving (Show) - -api_mkelection = - "This command reads and checks "<>fileRef"public_keys.jsons"<>"\ - \ (or "<>fileRef"threshold.json"<>" if it exists).\ - \ It then computes the global election public key\ - \ and generates an "<>fileRef"election.json"<>" file." - `helps` - command "mkelection" $ - rule "OPTIONS" - (MkElection_Options - <$> option_crypto - <*> option_template - <*> option_uuid) - response @Doc - api_help False - -run_mkelection MkElection_Options{..} = - return "" diff --git a/src/Hjugement/CLI/Registrar.hs b/src/Hjugement/CLI/Registrar.hs --- a/src/Hjugement/CLI/Registrar.hs +++ b/src/Hjugement/CLI/Registrar.hs @@ -4,9 +4,11 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Registrar where +import Control.Arrow (left) import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), forM, forM_, join, void) import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.State.Strict (runState, runStateT) import Data.Bool import Data.ByteString (ByteString) @@ -57,8 +59,8 @@ import Hjugement.CLI.Utils --- ** Type 'Registrar_Options' -data Registrar_Options = Registrar_Options +-- ** Type 'Registrar_Params' +data Registrar_Params = Registrar_Params { registrar_election_crypto :: VP.FFC , registrar_election_uuid :: VP.UUID } deriving (Show) @@ -68,20 +70,20 @@ `helps` command "registrar" $ rule "PARAMS" - (Registrar_Options - <$> option_crypto - <*> option_uuid + (Registrar_Params + <$> api_param_crypto + <*> api_param_uuid ) ( api_registrar_credentials api_registrar_pubkey ) api_help False -run_registrar globOpts = - (\opts -> - run_registrar_credentials globOpts opts :!: - run_registrar_pubkey globOpts opts - ) :!: +run_registrar globParams = + (\params -> + run_registrar_credentials globParams params :!: + run_registrar_pubkey globParams params + ) :!: run_help api_registrar api_registrar_pubkey = @@ -90,7 +92,7 @@ command "pubkey" $ var "PRIVATE_CRED" <.> response @Natural -run_registrar_pubkey Global_Options{..} o@Registrar_Options{..} cred = +run_registrar_pubkey Global_Params{..} o@Registrar_Params{..} cred = return $ VP.reify registrar_election_crypto $ \(_::Proxy c) -> VP.nat $ VP.publicKey $ @@ -120,10 +122,10 @@ command "credentials" $ (var @Natural "COUNT" var @IO.FilePath "FILE") - <.> response @Doc + <.> response @(Maybe ()) run_registrar_credentials - Global_Options{..} - o@Registrar_Options{..} = + Global_Params{..} + o@Registrar_Params{..} = run_count :!: run_file where @@ -140,14 +142,14 @@ Lens.view PipText.lines $ Lens.view (PipText.utf8 . PipText.eof) bytes in Pip.concats idents - run_credentials identsProd = do - now <- Time.getCurrentTime - let timestamp = Time.formatTime Time.defaultTimeLocale "%s" now - let baseFile = global_dir FP. timestamp - VP.reify registrar_election_crypto $ \(crypto::Proxy c) -> - Pip.runSafeT $ Pip.runEffect $ do - -- TODO: match err to check utf8 decoding went well - (pubKeys, err) <- Pip.toListM' $ + run_credentials identsProd = + VP.reify registrar_election_crypto $ \(crypto::Proxy c) -> runMaybeT $ do + now <- Pip.liftIO $ Time.getCurrentTime + let timestamp = Time.formatTime Time.defaultTimeLocale "%s" now + let baseFile = global_dir FP. timestamp + pubKeys <- runPipeWithError $ + ((left (\_p -> "UTF-8 decoding failed") <$>) <$>) $ + Pip.toListM' $ identsProd >-> Pip.mapM (\ident -> do cred <- Pip.liftIO $ @@ -170,6 +172,7 @@ >-> writeFileLn 0o444 (baseFile FP.<.>"hashcreds") ) >-> Pip.map (\(_ident, pubKey) -> pubKey) + runPipe $ Pip.each (List.sort pubKeys) -- NOTE: numerical sort on Natural (not lexicographic on String) -- which forgets in this file the relationship between @@ -177,7 +180,7 @@ -- Unfortunately this requires to accumulates all the pubKey in memory. >-> Pip.map (\pubKey -> [T.pack (show (VP.nat pubKey))]) >-> writeFileLn 0o444 (baseFile FP.<.>"pubcreds") - return "" + return () -- | @('firstIdentity' numIdentities)@ returns @(10'^'i0)@ such that -- @(10'^'i0 '+' numIdentities '<=' 10'^'(i0'+'1))@, diff --git a/src/Hjugement/CLI/Trustee.hs b/src/Hjugement/CLI/Trustee.hs --- a/src/Hjugement/CLI/Trustee.hs +++ b/src/Hjugement/CLI/Trustee.hs @@ -4,9 +4,13 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Trustee where +-- :main --dir /tmp/elec trust --crypto demo/groups/default.json gen +-- cat /tmp/elec/*.pubkey >/tmp/elec/public_keys.jsons + import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), forM, forM_, join, void) import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.State.Strict (runState, runStateT) import Data.Bits (setBit) import Data.Bool @@ -70,26 +74,27 @@ import Hjugement.CLI.Utils -- * trustee -data Trustee_Options = Trustee_Options - { trustee_election_crypto :: VP.FFC +data Trustee_Params = Trustee_Params + { trustee_crypto :: VP.FFC } deriving (Show) api_trustee = "Commands for a trustee." `helps` command "trustee" $ - rule "TrusteeOptions" - (Trustee_Options - <$> option_crypto + rule "TrusteeParams" + (Trustee_Params + <$> api_param_crypto ) ( api_trustee_generate api_trustee_decrypt ) api_help False -run_trustee globOpts = - (\opts -> - run_trustee_generate globOpts opts :!: - run_trustee_decrypt globOpts opts + +run_trustee globParams = + (\params -> + run_trustee_generate globParams params :!: + run_trustee_decrypt globParams params ) :!: run_help api_trustee @@ -107,9 +112,9 @@ command "generate" $ response @() run_trustee_generate - Global_Options{..} - o@Trustee_Options{..} = - VP.reify trustee_election_crypto $ \(crypto::Proxy c) -> do + Global_Params{..} + o@Trustee_Params{..} = + VP.reify trustee_crypto $ \(crypto::Proxy c) -> do keys@(secKey, pubKey) <- Pip.liftIO $ Rand.getStdRandom $ runState $ do secKey <- VP.randomSecretKey @c pubKey <- VP.proveIndispensableTrusteePublicKey secKey @@ -118,7 +123,7 @@ T.unpack $ T.toUpper $ T.take 8 $ VP.hexHash $ VP.bytesNat $ VP.trustee_PublicKey pubKey - Pip.runSafeT $ Pip.runEffect $ do + runPipe $ do Pip.each [pubIdent] >-> pipeInfo (\ident -> "Generated trustee keypair "<>ident<> " in "<>(global_dir FP. ident)<>".{privkey,pubkey}" @@ -128,7 +133,7 @@ return () -- ** decrypt -data TrusteeDecrypt_Options = TrusteeDecrypt_Options +data TrusteeDecrypt_Params = TrusteeDecrypt_Params { trusteeDecrypt_privkey :: FilePath , trusteeDecrypt_url :: FilePath } deriving (Show) @@ -137,70 +142,60 @@ "This command is run by each trustee to perform a partial decryption." `helps` command "decrypt" $ - rule "TrusteeDecryptOptions" - (TrusteeDecrypt_Options - <$> option_privkey - <*> option_url - ) + rule "TrusteeDecryptParams" + (TrusteeDecrypt_Params + <$> api_param_privkey + <*> api_param_url) response @(Maybe (VP.DecryptionShare ())) where - option_privkey = + api_param_privkey = "Read private key from file "<>ref"FILE"<>"." `helps` - long "privkey" (var "FILE") - option_url = + requiredTag "privkey" (var "FILE") + api_param_url = "Download election files from "<>ref"URL"<>"."<> "\nDefaults to "<>fileRef "."<>"." `helps` - longOpt "url" "." (var "URL") + defaultTag "url" "." (var "URL") run_trustee_decrypt - Global_Options{..} - o@Trustee_Options{..} - TrusteeDecrypt_Options{..} = do - VP.reify trustee_election_crypto $ \(crypto::Proxy c) -> do - JSON.eitherDecodeFileStrict' trusteeDecrypt_privkey >>= \case - Left err -> do - outputError $ - Doc.from trusteeDecrypt_privkey<>": "<> - Doc.from err<>"\n" - Right (secKey::VP.E c) -> do - let pubKey = VP.publicKey secKey - let trusteeKeysPath = trusteeDecrypt_url FP. "public_keys.jsons" - -- Check that the public key is amongst the public keys of the election - (keys, ret) <- Pip.runSafeT $ Pip.runEffect $ - Pip.toListM' $ + Global_Params{..} + o@Trustee_Params{..} + TrusteeDecrypt_Params{..} = + VP.reify trustee_crypto $ \(crypto::Proxy c) -> runMaybeT $ do + (secKey::VP.E c) <- loadJSON trusteeDecrypt_privkey + let pubKey = VP.publicKey secKey + let trusteeKeysPath = trusteeDecrypt_url FP. "public_keys.jsons" + -- Check that the public key is amongst the public keys of the election + keys <- runPipeWithError $ + Pip.toListM' $ readJSON trusteeKeysPath >-> Pip.filter ((pubKey ==) . VP.trustee_PublicKey) - case ret of - Left err -> outputError err - Right () | null keys -> outputError $ - "the public key associated with the given secret key "<> - "is not within the list of public trustee keys of the election.\n"<> - Doc.ul - [ "List of trustees' public keys: "<>Doc.from trusteeKeysPath - , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey)) - ]<>"\n" - Right () | List.length keys > 1 -> outputError $ - "the public key associated with the given secret key "<> - "appears more than one time in the list of public trustee keys of the election.\n"<> - Doc.ul - [ "List of trustees' public keys: "<>Doc.from trusteeKeysPath - , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey)) - ]<>"\n" - Right () -> do - -- Tally the encrypted ballots - -- FIXME: actually support fetching through an URL - let ballotsPath = trusteeDecrypt_url FP. "ballots.jsons" - ((encTally, numBallots), ret) <- Pip.runSafeT $ Pip.runEffect $ do - Pip.fold' - (flip VP.insertEncryptedTally) - VP.emptyEncryptedTally id $ - readJSON ballotsPath - case ret of - Left err -> outputError err - Right () -> do - decShare <- - Rand.getStdRandom $ runState $ - VP.proveDecryptionShare encTally secKey - return $ Just (coerce decShare :: VP.DecryptionShare ()) + case () of + () | null keys -> outputError $ + "the public key associated with the given secret key "<> + "is not within the list of public trustee keys of the election.\n"<> + Doc.ul + [ "List of trustees' public keys: "<>Doc.from trusteeKeysPath + , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey)) + ]<>"\n" + () | List.length keys > 1 -> outputError $ + "the public key associated with the given secret key "<> + "appears more than one time in the list of public trustee keys of the election.\n"<> + Doc.ul + [ "List of trustees' public keys: "<>Doc.from trusteeKeysPath + , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey)) + ]<>"\n" + () -> do + -- Tally the encrypted ballots + -- FIXME: actually support fetching through an URL + let ballotsPath = trusteeDecrypt_url FP. "ballots.jsons" + (encTally, numBallots) <- runPipeWithError $ + Pip.fold' + (flip VP.insertEncryptedTally) + VP.emptyEncryptedTally id $ + readJSON ballotsPath + decShare <- Pip.liftIO $ + Rand.getStdRandom $ runState $ + VP.proveDecryptionShare encTally secKey + return (coerce decShare :: VP.DecryptionShare ()) diff --git a/src/Hjugement/CLI/Utils.hs b/src/Hjugement/CLI/Utils.hs --- a/src/Hjugement/CLI/Utils.hs +++ b/src/Hjugement/CLI/Utils.hs @@ -9,6 +9,7 @@ import Control.Arrow (left) import Control.Applicative (Alternative(..)) import Control.Monad (Monad(..), forM_) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) import Data.Bits (setBit) import Data.Bool @@ -19,9 +20,10 @@ import Data.Functor ((<$>)) import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) -import Prelude (max, (-)) +import Prelude (min, max, (-)) import Symantic.CLI as CLI import System.IO (IO) import Text.Show (Show(..)) @@ -63,23 +65,19 @@ -- * Type 'Doc' type Doc = Doc.Plain TLB.Builder -option_template = - "Read election template from file "<>ref"FILE"<>"." - `help` - longOpt "template" "" (var "FILE") -option_crypto = +api_param_crypto = "Take cryptographic parameters from file "<>fileRef "FILE"<>"." `help` - long "crypto" (var "FILE") + requiredTag "crypto" (var "FILE") instance CLI.IOType VP.FFC instance CLI.FromSegment VP.FFC where fromSegment = JSON.eitherDecodeFileStrict' instance VP.Reifies c VP.FFC => CLI.FromSegment (VP.E c) where fromSegment = JSON.eitherDecodeFileStrict' -option_uuid = +api_param_uuid = "UUID of the election." `help` - long "uuid" (var "UUID") + requiredTag "uuid" (var "UUID") instance CLI.IOType VP.UUID instance CLI.FromSegment VP.UUID where fromSegment = return . left show . VP.readUUID . Text.pack @@ -102,38 +100,58 @@ (if full then help "Print an uncommented grammar tree to help using this program." else id) $ - tagged (TagShort 'h') (just False) + tag "h" (just False) api_full = (if full then help "Print a grammar tree to help using this program,\ \ along with explanations." else id) $ - tagged (TagLong "help") (just True) + tag "help" (just True) run_help lay = route :!: route where route helpInh_full = do - width <- Just . maybe 80 (max 0 . (\x -> x - 2) . Console.width) <$> Console.size + width <- Just . maybe 80 (min 80 . max 0 . (\x -> x - 2) . Console.width) + <$> Console.size return $ Doc.setWidth width $ runLayout helpInh_full lay --- * Type 'Global_Options' -data Global_Options = Global_Options +-- * Type 'Global_Params' +data Global_Params = Global_Params { global_dir :: IO.FilePath } api_options = rule "OPTIONS" $ - Global_Options - <$> option_dir -option_dir = - "Use directory "<>ref"DIR"<>" for reading and writing election files." + Global_Params + <$> api_param_dir +api_param_dir = + "Use directory "<>ref"DIR"<>" for reading and writing election files.\n"<> + "Default to "<>fileRef (Doc.from currDir)<>".\n"<> + "Can also be set via HJUGEMENT_DIR="<>ref "DIR"<>"." `help` - toPermDefault (FP.takeDirectory "file") - ( tagged (TagLong "dir") (var "DIR") `alt` - env "HJUGEMENT_DIR" ) + toPermDefault currDir $ + tag "dir" (var "DIR") + `alt` + env "HJUGEMENT_DIR" + where currDir = FP.takeDirectory "file" +-- * Pipes utilities +runPipe :: + Pip.MonadIO m => + Pip.Effect (Pip.SafeT IO) a -> m a +runPipe = Pip.liftIO . Pip.runSafeT . Pip.runEffect + +runPipeWithError :: + Pip.MonadIO m => + Pip.Effect (Pip.SafeT IO) (a, Either Doc ()) -> MaybeT m a +runPipeWithError p = do + (a, r) <- runPipe p + case r of + Left err -> outputError err + Right () -> return a + writeFileLn :: Pip.MonadSafe m => Foldable f => @@ -198,6 +216,25 @@ Doc.redder "decoding error"<>": "<> Doc.from decodingErr <> "\n" +saveJSON :: + JSON.ToJSON a => + Pip.MonadIO m => + IO.FilePath -> a -> m () +saveJSON filePath a = + -- FIXME: abort or demand confirmation if the file exists + Pip.liftIO $ JSON.encodeFile filePath a + +loadJSON :: + JSON.FromJSON a => + Pip.MonadIO m => + IO.FilePath -> MaybeT m a +loadJSON filePath = + Pip.liftIO (JSON.eitherDecodeFileStrict' filePath) >>= \case + Left err -> outputError $ + Doc.from filePath<>": "<> + Doc.from err<>"\n" + Right a -> return a + {- readJSON' :: Pip.MonadSafe m => @@ -250,7 +287,15 @@ output $ OnHandle IO.stderr '\n' Pip.yield s -outputError :: Doc -> IO (Maybe a) +outputInfo :: Pip.MonadIO m => Doc -> m () +outputInfo msg = do + Pip.liftIO $ output $ OnHandle @Doc IO.stderr $ + Doc.green "INFO"<>": "<>msg<>"\n" + +outputError :: + Pip.MonadIO m => + Doc -> MaybeT m a outputError msg = do - output $ OnHandle @Doc IO.stderr $ Doc.redder "ERROR"<>": "<>msg - return Nothing + Pip.liftIO $ output $ OnHandle @Doc IO.stderr $ + Doc.redder "ERROR"<>": "<>msg<>"\n" + empty