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