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