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