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