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

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