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