hjugement-cli/src/Hjugement/CLI/Utils.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE StrictData #-}
   5 {-# LANGUAGE TypeApplications #-}
   6 {-# LANGUAGE UndecidableInstances #-} -- for VP.Reifies instances
   7 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   8 {-# OPTIONS_GHC -Wno-orphans #-}
   9 module Hjugement.CLI.Utils where
  10
  11 import Control.Applicative (Applicative(..), Alternative(..))
  12 import Control.Arrow (left)
  13 import Control.Monad (Monad(..), forM_, when)
  14 import Control.Monad.Trans.Maybe (MaybeT(..))
  15 import Control.Monad.Trans.Except (runExceptT)
  16 import Data.Bool
  17 import Data.Either (Either(..))
  18 import Data.Eq (Eq(..))
  19 import Data.Foldable (Foldable)
  20 import Data.Function (($), (.), id)
  21 import Data.Functor ((<$>))
  22 import Data.Maybe (Maybe(..), maybe)
  23 import Data.Monoid (Monoid(..))
  24 import Data.Ord (Ord(..))
  25 import Data.Semigroup (Semigroup(..))
  26 import Data.Text (Text)
  27 import Prelude (min, max, (-))
  28 import Symantic.CLI as CLI
  29 import System.IO (IO)
  30 import Text.Show (Show(..))
  31 import qualified Data.Aeson as JSON
  32 import qualified Data.ByteString.Char8 as BS8
  33 import qualified Data.ByteString.Lazy.Char8 as BSL8
  34 import qualified Data.Text as Text
  35 import qualified Data.Text.Encoding as T
  36 import qualified Data.Text.Lazy.Builder as TLB
  37 import qualified Lens.Family as Lens
  38 import qualified Pipes as Pip
  39 import qualified Pipes.Aeson as PipJSON (DecodingError(..))
  40 import qualified Pipes.Aeson.Unchecked as PipJSON
  41 import qualified Pipes.ByteString as PipBS
  42 import qualified Pipes.Safe as Pip
  43 import qualified Pipes.Safe.Prelude as Pip
  44 import qualified Symantic.Document as Doc
  45 import qualified System.Console.Terminal.Size as Console
  46 import qualified System.Directory as IO
  47 import qualified System.FilePath as FP
  48 import qualified System.IO as IO
  49 import qualified System.Posix as Posix
  50 import qualified Voting.Protocol as VP
  51
  52 ref = Doc.underline
  53 con = Doc.between "\"" "\""
  54 fileRef = ref
  55 helps = help . Doc.justify
  56 infixr 0 `helps`
  57
  58 -- * Type 'Doc'
  59 type Doc = Doc.Plain TLB.Builder
  60
  61 api_param_crypto =
  62         "Take cryptographic parameters from file "<>fileRef "FILE"<>"."
  63         `help`
  64         requiredTag "crypto" (var "FILE")
  65 api_param_version =
  66         "Set the protocol version to use.\n"<>
  67         "Defaults to the \"stable\" version.\n"<>
  68         Doc.ul
  69          [ "stable       == "<>Doc.from (show VP.stableVersion)
  70          , "experimental == "<>Doc.from (show VP.experimentalVersion)
  71          ]
  72         `help`
  73         defaultTag "version" VP.stableVersion (
  74                 constant "stable" VP.stableVersion `alt`
  75                 constant "experimental" VP.experimentalVersion `alt`
  76                 var "VERSION"
  77          )
  78 instance CLI.IOType VP.Version
  79 instance CLI.FromSegment VP.Version where
  80         fromSegment = return . maybe (Left "invalid version string") Right . VP.readVersion
  81 instance CLI.IOType VP.FFC
  82 instance CLI.FromSegment VP.FFC where
  83         fromSegment = JSON.eitherDecodeFileStrict'
  84 instance VP.Reifies c VP.FFC => CLI.FromSegment (VP.E VP.FFC c) where
  85         fromSegment = JSON.eitherDecodeFileStrict'
  86 api_param_uuid =
  87         "UUID of the election."
  88         `help`
  89         requiredTag "uuid" (var "UUID")
  90 instance CLI.IOType VP.UUID
  91 instance CLI.FromSegment VP.UUID where
  92         fromSegment = return . left show . VP.readUUID . Text.pack
  93 instance CLI.IOType VP.Credential
  94 instance CLI.FromSegment VP.Credential where
  95         fromSegment = return . left show . VP.readCredential . Text.pack
  96 instance IOType (VP.DecryptionShare VP.FFC () ())
  97 instance Outputable (VP.DecryptionShare VP.FFC () ()) where
  98         output decShare = output $ JSON.encode decShare<>"\n"
  99
 100 api_help full =
 101         if full
 102         then
 103                 api_compact <.> response @Doc <!>
 104                 api_full    <.> response @Doc
 105         else
 106                 (api_compact <!> api_full) <.> response @Doc
 107         where
 108         api_compact =
 109                 (if full
 110                 then help "Print an uncommented grammar tree to help using this program."
 111                 else id) $
 112                 tag "h" (just False)
 113         api_full =
 114                 (if full then help
 115                  "Print a grammar tree to help using this program,\
 116      \ along with explanations."
 117                 else id) $
 118                 tag "help" (just True)
 119
 120 run_help lay = route :!: route
 121         where
 122         route helpInh_full = do
 123                 width <- Just . maybe 80 (min 80 . max 0 . (\x -> x - 2) . Console.width)
 124                  <$> Console.size
 125                 return $
 126                         Doc.setWidth width $
 127                                 runLayout helpInh_full lay
 128
 129 -- * Type 'Global_Params'
 130 data Global_Params
 131  =   Global_Params
 132  {   global_stderr_prepend_newline  :: Bool
 133  ,   global_stderr_prepend_carriage :: Bool
 134  ,   global_stderr_append_newline   :: Bool
 135  ,   global_dir       :: IO.FilePath
 136  ,   global_verbosity :: Verbosity
 137  }
 138
 139 api_options =
 140         rule "OPTIONS" $
 141                 Global_Params False False True
 142                  <$> api_param_dir
 143                  <*> api_param_verbosity
 144 api_param_dir =
 145         "Use directory "<>ref"DIR"<>" for reading and writing election files.\n"<>
 146         "Default to "<>con (Doc.from currDir)<>".\n"<>
 147         "Can also be set via HJUGEMENT_DIR="<>ref "DIR"<>"."
 148         `help`
 149         toPermDefault currDir $
 150                 tag "dir" (var "DIR")
 151                 `alt`
 152                 env "HJUGEMENT_DIR"
 153         where currDir = FP.takeDirectory "file"
 154 api_param_url =
 155         "Download election files from "<>ref"URL"<>"."
 156         `helps`
 157         toPermutation $ tag "url" (var "URL")
 158
 159 -- * Type 'Verbosity'
 160 data Verbosity
 161  =   Verbosity_Error
 162  |   Verbosity_Warning
 163  |   Verbosity_Info
 164  |   Verbosity_Debug
 165  deriving (Eq,Ord)
 166
 167 instance IOType Verbosity
 168 instance FromSegment Verbosity where
 169         fromSegment = \case
 170          "error"   -> return $ Right Verbosity_Error
 171          "warning" -> return $ Right Verbosity_Warning
 172          "info"    -> return $ Right Verbosity_Info
 173          "debug"   -> return $ Right Verbosity_Debug
 174          _ -> return $ Left "invalid verbosity"
 175
 176 api_param_verbosity =
 177  "Verbosity level.\
 178  \\nDefault to "<>con "info"<>"."
 179         `help`
 180         toPermDefault Verbosity_Info $
 181                 tag "verbosity" (
 182                         constant "error"   Verbosity_Error   `alt`
 183                         constant "warning" Verbosity_Warning `alt`
 184                         constant "info"    Verbosity_Info    `alt`
 185                         constant "debug"   Verbosity_Debug
 186                  ) `alt`
 187                 env "HJUGEMENT_VERBOSITY"
 188
 189 -- * Pipes utilities
 190 runPipe ::
 191  Pip.MonadIO m =>
 192  Pip.Effect (Pip.SafeT IO) a -> m a
 193 runPipe = Pip.liftIO . Pip.runSafeT . Pip.runEffect
 194
 195 runPipeWithError ::
 196  Pip.MonadIO m =>
 197  Global_Params ->
 198  Pip.Effect (Pip.SafeT IO) (a, Either Doc ()) -> MaybeT m a
 199 runPipeWithError glob p = do
 200         (a, r) <- runPipe p
 201         case r of
 202          Left err -> outputError glob err
 203          Right () -> return a
 204
 205 writeFileLn ::
 206  Pip.MonadSafe m =>
 207  Foldable f =>
 208  Global_Params ->
 209  Posix.FileMode ->
 210  IO.FilePath ->
 211  Pip.Consumer (f Text) m r
 212 writeFileLn glob fileMode filePath = do
 213         Pip.liftIO $ outputDebug glob $ "writing " <> Doc.from filePath
 214         Pip.bracket open close $ \h ->
 215                 Pip.for Pip.cat $ \xs ->
 216                         Pip.liftIO $ do
 217                                 forM_ xs $ BS8.hPutStr h . T.encodeUtf8
 218                                 BS8.hPutStrLn h ""
 219         where
 220         open = Pip.liftIO $ do
 221                 IO.createDirectoryIfMissing True $ FP.takeDirectory filePath
 222                 IO.openFile filePath IO.WriteMode
 223         close h = Pip.liftIO $ do
 224                 fd <- Posix.handleToFd h
 225                 Posix.setFdMode fd fileMode
 226                 IO.hClose h
 227
 228 writeJSON ::
 229  Pip.MonadSafe m =>
 230  JSON.ToJSON a =>
 231  Global_Params ->
 232  Posix.FileMode ->
 233  IO.FilePath ->
 234  Pip.Consumer a m r
 235 writeJSON glob fileMode filePath = do
 236         Pip.liftIO $ outputDebug glob $ "writing " <> Doc.from filePath
 237         Pip.bracket open close $ \h ->
 238                 Pip.for Pip.cat $ \a ->
 239                         Pip.liftIO $ do
 240                                 BSL8.hPutStrLn h $ JSON.encode a
 241         where
 242         open = Pip.liftIO $ do
 243                 IO.createDirectoryIfMissing True $ FP.takeDirectory filePath
 244                 IO.openFile filePath IO.WriteMode
 245         close h = Pip.liftIO $ do
 246                 fd <- Posix.handleToFd h
 247                 Posix.setFdMode fd fileMode
 248                 IO.hClose h
 249
 250 readJSON ::
 251  Pip.MonadSafe m =>
 252  JSON.FromJSON a =>
 253  JSON.ToJSON a =>
 254  Global_Params ->
 255  IO.FilePath ->
 256  Pip.Producer a m (Either Doc ())
 257 readJSON glob filePath = do
 258         Pip.liftIO $ outputDebug glob $ "reading " <> Doc.from filePath
 259         let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle
 260         left handleError <$> Lens.view PipJSON.decoded bytes
 261         where
 262         handleError (err, _rest) =
 263                 case err of
 264                  PipJSON.AttoparsecError parsingErr ->
 265                         Doc.from filePath <> ": "<>
 266                         Doc.redder "parsing error"<>": "<>
 267                         Doc.from (show parsingErr) <> "\n"
 268                  PipJSON.FromJSONError decodingErr ->
 269                         Doc.from filePath <> ": "<>
 270                         Doc.redder "decoding error"<>": "<>
 271                         Doc.from decodingErr <> "\n"
 272
 273 saveJSON ::
 274  JSON.ToJSON a =>
 275  Pip.MonadIO m =>
 276  Global_Params ->
 277  IO.FilePath -> a -> m ()
 278 saveJSON glob filePath a =
 279         -- FIXME: abort or demand confirmation if the file exists
 280         Pip.liftIO $ do
 281                 outputDebug glob $ "saving " <> Doc.from filePath
 282                 JSON.encodeFile filePath a
 283
 284 loadJSON ::
 285  JSON.FromJSON a =>
 286  Pip.MonadIO m =>
 287  Global_Params ->
 288  IO.FilePath -> MaybeT m a
 289 loadJSON glob filePath =
 290         Pip.liftIO (do
 291                 outputDebug glob $ "loading " <> Doc.from filePath
 292                 JSON.eitherDecodeFileStrict' filePath
 293          ) >>= \case
 294          Left err -> outputError glob $
 295                 Doc.from filePath<>": "<>
 296                 Doc.from err<>"\n"
 297          Right a -> return a
 298
 299 -- | TODO: abstract over @crypto@ in the continuation.
 300 loadElection ::
 301  VP.ReifyCrypto crypto =>
 302  JSON.FromJSON crypto =>
 303  Pip.MonadIO m =>
 304  Global_Params ->
 305  IO.FilePath ->
 306  (forall v c.
 307   VP.Reifies v VP.Version =>
 308   VP.Reifies c crypto =>
 309   VP.FieldElementConstraints crypto c =>
 310   VP.Election crypto v c -> MaybeT m r) ->
 311  MaybeT m r
 312 loadElection glob filePath k =
 313         Pip.liftIO ( do
 314                 outputDebug glob $ "loading " <> Doc.from filePath
 315                 runExceptT $ VP.readElection filePath k
 316          ) >>= \case
 317          Left err -> outputError glob $
 318                 Doc.from filePath<>": "<>
 319                 Doc.from err<>"\n"
 320          Right r -> r
 321
 322 {-
 323 readJSON' ::
 324  Pip.MonadSafe m =>
 325  JSON.FromJSON a =>
 326  JSON.ToJSON a =>
 327  IO.FilePath ->
 328  Pip.Parser a m r -> m r
 329 readJSON' filePath fold =
 330         let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
 331         evalStateT (Lens.zoom PipJSON.decoded fold) bytes
 332
 333 readJSON'' ::
 334  Pip.MonadSafe m =>
 335  JSON.FromJSON a =>
 336  IO.FilePath ->
 337  Pip.FreeT (Pip.Producer (Either PipJSON.DecodingError a) m) m ()
 338 readJSON'' filePath =
 339         let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
 340         parseMany (Pip.parsed_ PipJSON.decode) bytes
 341
 342 parseMany ::
 343  forall m inp a r.
 344  Monad m =>
 345  (Pip.Producer inp m r -> Pip.Producer a m (Pip.Producer inp m r)) ->
 346  Pip.Producer inp m r ->
 347  Pip.FreeT (Pip.Producer a m) m r
 348 parseMany f = go0
 349         where
 350         go0 ::
 351          Pip.Producer inp m r ->
 352          Pip.FreeT (Pip.Producer a m) m r
 353         go0 p = Pip.FreeT $ do
 354                 Pip.next p >>= \case
 355                  Left r -> return $ Pip.Pure r
 356                  Right (inp, p') -> return $ Pip.Free $ go1 $ Pip.yield inp >> p'
 357         go1 ::
 358          Pip.Producer inp m r ->
 359          Pip.Producer a m (Pip.FreeT (Pip.Producer a m) m r)
 360         go1 p = go0 <$> f p
 361 -}
 362
 363 pipeInfo ::
 364  Pip.MonadIO m =>
 365  Global_Params ->
 366  (a -> Doc) -> Pip.Pipe a a m r
 367 pipeInfo glob d =
 368         Pip.for Pip.cat $ \s -> do
 369                 Pip.liftIO $ outputInfo glob $ d s
 370                 Pip.yield s
 371
 372 outputMessage :: Pip.MonadIO m => Global_Params -> Doc -> Doc -> m ()
 373 outputMessage Global_Params{..} hdr msg =
 374         Pip.liftIO $ output $ OnHandle @Doc IO.stderr $
 375                 (if global_stderr_prepend_newline then Doc.newline else mempty) <>
 376                 (if global_stderr_prepend_carriage then "\r" else mempty) <>
 377                 hdr<>": "<>msg<>
 378                 (if global_stderr_append_newline then Doc.newline else mempty)
 379
 380 outputError :: Pip.MonadIO m => Global_Params -> Doc -> MaybeT m a
 381 outputError glob@Global_Params{..} msg = do
 382         when (Verbosity_Error <= global_verbosity) $ do
 383                 outputMessage glob (Doc.redder "ERROR") msg
 384         empty
 385
 386 outputWarning :: Pip.MonadIO m => Global_Params -> Doc -> m ()
 387 outputWarning glob@Global_Params{..} msg = do
 388         when (Verbosity_Warning <= global_verbosity) $ do
 389                 outputMessage glob (Doc.yellower "WARNING") msg
 390
 391 outputInfo :: Pip.MonadIO m => Global_Params -> Doc -> m ()
 392 outputInfo glob@Global_Params{..} msg = do
 393         when (Verbosity_Info <= global_verbosity) $ do
 394                 outputMessage glob (Doc.greener "info") msg
 395
 396 outputDebug :: Pip.MonadIO m => Global_Params -> Doc -> m ()
 397 outputDebug glob@Global_Params{..} msg = do
 398         when (Verbosity_Debug <= global_verbosity) $ do
 399                 outputMessage glob (Doc.magentaer "debug") msg