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
 140 -- * Pipes utilities
 141 runPipe ::
 142  Pip.MonadIO m =>
 143  Pip.Effect (Pip.SafeT IO) a -> m a
 144 runPipe = Pip.liftIO . Pip.runSafeT . Pip.runEffect
 145
 146 runPipeWithError ::
 147  Pip.MonadIO m =>
 148  Pip.Effect (Pip.SafeT IO) (a, Either Doc ()) -> MaybeT m a
 149 runPipeWithError p = do
 150         (a, r) <- runPipe p
 151         case r of
 152          Left err -> outputError err
 153          Right () -> return a
 154
 155 writeFileLn ::
 156  Pip.MonadSafe m =>
 157  Foldable f =>
 158  Posix.FileMode ->
 159  IO.FilePath ->
 160  Pip.Consumer (f Text) m r
 161 writeFileLn fileMode filePath =
 162         Pip.bracket open close $ \h ->
 163                 Pip.for Pip.cat $ \xs ->
 164                         Pip.liftIO $ do
 165                                 forM_ xs $ BS8.hPutStr h . T.encodeUtf8
 166                                 BS8.hPutStrLn h ""
 167         where
 168         open = Pip.liftIO $ do
 169                 IO.createDirectoryIfMissing True $ FP.takeDirectory filePath
 170                 h <- IO.openFile filePath IO.WriteMode
 171                 return h
 172         close h = Pip.liftIO $ do
 173                 fd <- Posix.handleToFd h
 174                 Posix.setFdMode fd fileMode
 175                 IO.hClose h
 176
 177 writeJSON ::
 178  Pip.MonadSafe m =>
 179  JSON.ToJSON a =>
 180  Posix.FileMode ->
 181  IO.FilePath ->
 182  Pip.Consumer a m r
 183 writeJSON fileMode filePath =
 184         Pip.bracket open close $ \h ->
 185                 Pip.for Pip.cat $ \a ->
 186                         Pip.liftIO $ do
 187                                 BSL8.hPutStr h $ JSON.encode a
 188         where
 189         open = Pip.liftIO $ do
 190                 IO.createDirectoryIfMissing True $ FP.takeDirectory filePath
 191                 h <- IO.openFile filePath IO.WriteMode
 192                 return h
 193         close h = Pip.liftIO $ do
 194                 fd <- Posix.handleToFd h
 195                 Posix.setFdMode fd fileMode
 196                 IO.hClose h
 197
 198 readJSON ::
 199  Pip.MonadSafe m =>
 200  JSON.FromJSON a =>
 201  JSON.ToJSON a =>
 202  IO.FilePath ->
 203  Pip.Producer a m (Either Doc ())
 204 readJSON filePath =
 205         let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
 206         left handleError <$> Lens.view PipJSON.decoded bytes
 207         where
 208         handleError (err, _rest) =
 209                 case err of
 210                  PipJSON.AttoparsecError parsingErr ->
 211                         Doc.from filePath <> ": "<>
 212                         Doc.redder "parsing error"<>": "<>
 213                         Doc.from (show parsingErr) <> "\n"
 214                  PipJSON.FromJSONError decodingErr ->
 215                         Doc.from filePath <> ": "<>
 216                         Doc.redder "decoding error"<>": "<>
 217                         Doc.from decodingErr <> "\n"
 218
 219 saveJSON ::
 220  JSON.ToJSON a =>
 221  Pip.MonadIO m =>
 222  IO.FilePath -> a -> m ()
 223 saveJSON filePath a =
 224         -- FIXME: abort or demand confirmation if the file exists
 225         Pip.liftIO $ JSON.encodeFile filePath a
 226
 227 loadJSON ::
 228  JSON.FromJSON a =>
 229  Pip.MonadIO m =>
 230  IO.FilePath -> MaybeT m a
 231 loadJSON filePath =
 232         Pip.liftIO (JSON.eitherDecodeFileStrict' filePath) >>= \case
 233          Left err -> outputError $
 234                 Doc.from filePath<>": "<>
 235                 Doc.from err<>"\n"
 236          Right a -> return a
 237
 238 {-
 239 readJSON' ::
 240  Pip.MonadSafe m =>
 241  JSON.FromJSON a =>
 242  JSON.ToJSON a =>
 243  IO.FilePath ->
 244  Pip.Parser a m r -> m r
 245 readJSON' filePath fold =
 246         let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
 247         evalStateT (Lens.zoom PipJSON.decoded fold) bytes
 248
 249 readJSON'' ::
 250  Pip.MonadSafe m =>
 251  JSON.FromJSON a =>
 252  IO.FilePath ->
 253  Pip.FreeT (Pip.Producer (Either PipJSON.DecodingError a) m) m ()
 254 readJSON'' filePath =
 255         let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
 256         parseMany (Pip.parsed_ PipJSON.decode) bytes
 257
 258 parseMany ::
 259  forall m inp a r.
 260  Monad m =>
 261  (Pip.Producer inp m r -> Pip.Producer a m (Pip.Producer inp m r)) ->
 262  Pip.Producer inp m r ->
 263  Pip.FreeT (Pip.Producer a m) m r
 264 parseMany f = go0
 265         where
 266         go0 ::
 267          Pip.Producer inp m r ->
 268          Pip.FreeT (Pip.Producer a m) m r
 269         go0 p = Pip.FreeT $ do
 270                 Pip.next p >>= \case
 271                  Left r -> return $ Pip.Pure r
 272                  Right (inp, p') -> return $ Pip.Free $ go1 $ Pip.yield inp >> p'
 273         go1 ::
 274          Pip.Producer inp m r ->
 275          Pip.Producer a m (Pip.FreeT (Pip.Producer a m) m r)
 276         go1 p = go0 <$> f p
 277 -}
 278
 279 pipeInfo ::
 280  Pip.MonadIO m =>
 281  Outputable (OnHandle d) =>
 282  (a -> d) -> Pip.Pipe a a m r
 283 pipeInfo d =
 284         Pip.for Pip.cat $ \s -> do
 285                 Pip.liftIO $ do
 286                         output $ OnHandle IO.stderr (d s)
 287                         output $ OnHandle IO.stderr '\n'
 288                 Pip.yield s
 289
 290 outputInfo :: Pip.MonadIO m => Doc -> m ()
 291 outputInfo msg = do
 292         Pip.liftIO $ output $ OnHandle @Doc IO.stderr $
 293                 Doc.green "INFO"<>": "<>msg<>"\n"
 294
 295 outputError ::
 296  Pip.MonadIO m =>
 297  Doc -> MaybeT m a
 298 outputError msg = do
 299         Pip.liftIO $ output $ OnHandle @Doc IO.stderr $
 300                 Doc.redder "ERROR"<>": "<>msg<>"\n"
 301         empty