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