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.GroupParams crypto c =>
 309   VP.Election crypto v c -> MaybeT m r) ->
 310  MaybeT m r
 311 loadElection glob filePath k =
 312         Pip.liftIO ( do
 313                 outputDebug glob $ "loading " <> Doc.from filePath
 314                 runExceptT $ VP.readElection filePath k
 315          ) >>= \case
 316          Left err -> outputError glob $
 317                 Doc.from filePath<>": "<>
 318                 Doc.from err<>"\n"
 319          Right r -> r
 320
 321 {-
 322 readJSON' ::
 323  Pip.MonadSafe m =>
 324  JSON.FromJSON a =>
 325  JSON.ToJSON a =>
 326  IO.FilePath ->
 327  Pip.Parser a m r -> m r
 328 readJSON' filePath fold =
 329         let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
 330         evalStateT (Lens.zoom PipJSON.decoded fold) bytes
 331
 332 readJSON'' ::
 333  Pip.MonadSafe m =>
 334  JSON.FromJSON a =>
 335  IO.FilePath ->
 336  Pip.FreeT (Pip.Producer (Either PipJSON.DecodingError a) m) m ()
 337 readJSON'' filePath =
 338         let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
 339         parseMany (Pip.parsed_ PipJSON.decode) bytes
 340
 341 parseMany ::
 342  forall m inp a r.
 343  Monad m =>
 344  (Pip.Producer inp m r -> Pip.Producer a m (Pip.Producer inp m r)) ->
 345  Pip.Producer inp m r ->
 346  Pip.FreeT (Pip.Producer a m) m r
 347 parseMany f = go0
 348         where
 349         go0 ::
 350          Pip.Producer inp m r ->
 351          Pip.FreeT (Pip.Producer a m) m r
 352         go0 p = Pip.FreeT $ do
 353                 Pip.next p >>= \case
 354                  Left r -> return $ Pip.Pure r
 355                  Right (inp, p') -> return $ Pip.Free $ go1 $ Pip.yield inp >> p'
 356         go1 ::
 357          Pip.Producer inp m r ->
 358          Pip.Producer a m (Pip.FreeT (Pip.Producer a m) m r)
 359         go1 p = go0 <$> f p
 360 -}
 361
 362 pipeInfo ::
 363  Pip.MonadIO m =>
 364  Global_Params ->
 365  (a -> Doc) -> Pip.Pipe a a m r
 366 pipeInfo glob d =
 367         Pip.for Pip.cat $ \s -> do
 368                 Pip.liftIO $ outputInfo glob $ d s
 369                 Pip.yield s
 370
 371 outputMessage :: Pip.MonadIO m => Global_Params -> Doc -> Doc -> m ()
 372 outputMessage Global_Params{..} hdr msg =
 373         Pip.liftIO $ output $ OnHandle @Doc IO.stderr $
 374                 (if global_stderr_prepend_newline then Doc.newline else mempty) <>
 375                 (if global_stderr_prepend_carriage then "\r" else mempty) <>
 376                 hdr<>": "<>msg<>
 377                 (if global_stderr_append_newline then Doc.newline else mempty)
 378
 379 outputError :: Pip.MonadIO m => Global_Params -> Doc -> MaybeT m a
 380 outputError glob@Global_Params{..} msg = do
 381         when (Verbosity_Error <= global_verbosity) $ do
 382                 outputMessage glob (Doc.redder "ERROR") msg
 383         empty
 384
 385 outputWarning :: Pip.MonadIO m => Global_Params -> Doc -> m ()
 386 outputWarning glob@Global_Params{..} msg = do
 387         when (Verbosity_Warning <= global_verbosity) $ do
 388                 outputMessage glob (Doc.yellower "WARNING") msg
 389
 390 outputInfo :: Pip.MonadIO m => Global_Params -> Doc -> m ()
 391 outputInfo glob@Global_Params{..} msg = do
 392         when (Verbosity_Info <= global_verbosity) $ do
 393                 outputMessage glob (Doc.greener "info") msg
 394
 395 outputDebug :: Pip.MonadIO m => Global_Params -> Doc -> m ()
 396 outputDebug glob@Global_Params{..} msg = do
 397         when (Verbosity_Debug <= global_verbosity) $ do
 398                 outputMessage glob (Doc.magentaer "debug") msg