hjugement-cli 0.0.0.20190714 → 0.0.0.20190721
raw patch · 7 files changed
+377/−192 lines, 7 filesdep ~symantic-clinew-component:exe:hjugement
Dependency ranges changed: symantic-cli
Files
- hjugement-cli.cabal +8/−6
- src/Hjugement/CLI.hs +22/−24
- src/Hjugement/CLI/Administrator.hs +187/−0
- src/Hjugement/CLI/MkElection.hs +0/−45
- src/Hjugement/CLI/Registrar.hs +26/−23
- src/Hjugement/CLI/Trustee.hs +65/−70
- src/Hjugement/CLI/Utils.hs +69/−24
hjugement-cli.cabal view
@@ -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: . * <https://hackage.haskell.org/package/hjugement hjugement>- * <https://hackage.haskell.org/package/hjugemen-protocol hjugement-protocol>.+ * <https://hackage.haskell.org/package/hjugemen-protocol hjugement-protocol> . 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
src/Hjugement/CLI.hs view
@@ -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
+ src/Hjugement/CLI/Administrator.hs view
@@ -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)
− src/Hjugement/CLI/MkElection.hs
@@ -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 ""
src/Hjugement/CLI/Registrar.hs view
@@ -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))@,
src/Hjugement/CLI/Trustee.hs view
@@ -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 ())
src/Hjugement/CLI/Utils.hs view
@@ -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