Utils.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-} -- for VP.Reifies instances
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Hjugement.CLI.Utils where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Arrow (left)
import Control.Monad (Monad(..), forM_, when)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Except (runExceptT)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable)
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Prelude (min, max, (-))
import Symantic.CLI as CLI
import System.IO (IO)
import Text.Show (Show(..))
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Text as Text
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Builder as TLB
import qualified Lens.Family as Lens
import qualified Pipes as Pip
import qualified Pipes.Aeson as PipJSON (DecodingError(..))
import qualified Pipes.Aeson.Unchecked as PipJSON
import qualified Pipes.ByteString as PipBS
import qualified Pipes.Safe as Pip
import qualified Pipes.Safe.Prelude as Pip
import qualified Symantic.Document as Doc
import qualified System.Console.Terminal.Size as Console
import qualified System.Directory as IO
import qualified System.FilePath as FP
import qualified System.IO as IO
import qualified System.Posix as Posix
import qualified Voting.Protocol as VP

ref = Doc.underline
con = Doc.between "\"" "\""
fileRef = ref
helps = help . Doc.justify
infixr 0 `helps`

-- * Type 'Doc'
type Doc = Doc.Plain TLB.Builder

api_param_crypto =
	"Take cryptographic parameters from file "<>fileRef "FILE"<>"."
	`help`
	requiredTag "crypto" (var "FILE")
api_param_version =
	"Set the protocol version to use.\n"<>
	"Defaults to the \"stable\" version.\n"<>
	Doc.ul
	 [ "stable       == "<>Doc.from (show VP.stableVersion)
	 , "experimental == "<>Doc.from (show VP.experimentalVersion)
	 ]
	`help`
	defaultTag "version" VP.stableVersion (
		constant "stable" VP.stableVersion `alt`
		constant "experimental" VP.experimentalVersion `alt`
		var "VERSION"
	 )
instance CLI.IOType VP.Version
instance CLI.FromSegment VP.Version where
	fromSegment = return . maybe (Left "invalid version string") Right . VP.readVersion
instance CLI.IOType VP.FFC
instance CLI.FromSegment VP.FFC where
	fromSegment = JSON.eitherDecodeFileStrict'
instance VP.Reifies c VP.FFC => CLI.FromSegment (VP.E VP.FFC c) where
	fromSegment = JSON.eitherDecodeFileStrict'
api_param_uuid =
	"UUID of the election."
	`help`
	requiredTag "uuid" (var "UUID")
instance CLI.IOType VP.UUID
instance CLI.FromSegment VP.UUID where
	fromSegment = return . left show . VP.readUUID . Text.pack
instance CLI.IOType VP.Credential
instance CLI.FromSegment VP.Credential where
	fromSegment = return . left show . VP.readCredential . Text.pack
instance IOType (VP.DecryptionShare VP.FFC () ())
instance Outputable (VP.DecryptionShare VP.FFC () ()) where
	output decShare = output $ JSON.encode decShare<>"\n"

api_help full =
	if full
	then
		api_compact <.> response @Doc <!>
		api_full    <.> response @Doc
	else
		(api_compact <!> api_full) <.> response @Doc
	where
	api_compact =
		(if full
		then help "Print an uncommented grammar tree to help using this program."
		else id) $
		tag "h" (just False)
	api_full =
		(if full then help
		 "Print a grammar tree to help using this program,\
     \ along with explanations."
		else id) $
		tag "help" (just True)

run_help lay = route :!: route
	where
	route helpInh_full = do
		width <- Just . maybe 80 (min 80 . max 0 . (\x -> x - 2) . Console.width)
		 <$> Console.size
		return $
			Doc.setWidth width $
				runLayout helpInh_full lay

-- * Type 'Global_Params'
data Global_Params
 =   Global_Params
 {   global_stderr_prepend_newline  :: Bool
 ,   global_stderr_prepend_carriage :: Bool
 ,   global_stderr_append_newline   :: Bool
 ,   global_dir       :: IO.FilePath
 ,   global_verbosity :: Verbosity
 }

api_options =
	rule "OPTIONS" $
		Global_Params False False True
		 <$> api_param_dir
		 <*> api_param_verbosity
api_param_dir =
	"Use directory "<>ref"DIR"<>" for reading and writing election files.\n"<>
	"Default to "<>con (Doc.from currDir)<>".\n"<>
	"Can also be set via HJUGEMENT_DIR="<>ref "DIR"<>"."
	`help`
	toPermDefault currDir $
		tag "dir" (var "DIR")
		`alt`
		env "HJUGEMENT_DIR"
	where currDir = FP.takeDirectory "file"
api_param_url =
	"Download election files from "<>ref"URL"<>"."
	`helps`
	toPermutation $ tag "url" (var "URL")

-- * Type 'Verbosity'
data Verbosity
 =   Verbosity_Error
 |   Verbosity_Warning
 |   Verbosity_Info
 |   Verbosity_Debug
 deriving (Eq,Ord)

instance IOType Verbosity
instance FromSegment Verbosity where
	fromSegment = \case
	 "error"   -> return $ Right Verbosity_Error
	 "warning" -> return $ Right Verbosity_Warning
	 "info"    -> return $ Right Verbosity_Info
	 "debug"   -> return $ Right Verbosity_Debug
	 _ -> return $ Left "invalid verbosity"

api_param_verbosity =
 "Verbosity level.\
 \\nDefault to "<>con "info"<>"."
	`help`
	toPermDefault Verbosity_Info $
		tag "verbosity" (
			constant "error"   Verbosity_Error   `alt`
			constant "warning" Verbosity_Warning `alt`
			constant "info"    Verbosity_Info    `alt`
			constant "debug"   Verbosity_Debug
		 ) `alt`
		env "HJUGEMENT_VERBOSITY"

-- * Pipes utilities
runPipe ::
 Pip.MonadIO m =>
 Pip.Effect (Pip.SafeT IO) a -> m a
runPipe = Pip.liftIO . Pip.runSafeT . Pip.runEffect

runPipeWithError ::
 Pip.MonadIO m =>
 Global_Params ->
 Pip.Effect (Pip.SafeT IO) (a, Either Doc ()) -> MaybeT m a
runPipeWithError glob p = do
	(a, r) <- runPipe p
	case r of
	 Left err -> outputError glob err
	 Right () -> return a

writeFileLn ::
 Pip.MonadSafe m =>
 Foldable f =>
 Global_Params ->
 Posix.FileMode ->
 IO.FilePath ->
 Pip.Consumer (f Text) m r
writeFileLn glob fileMode filePath = do
	Pip.liftIO $ outputDebug glob $ "writing " <> Doc.from filePath
	Pip.bracket open close $ \h ->
		Pip.for Pip.cat $ \xs ->
			Pip.liftIO $ do
				forM_ xs $ BS8.hPutStr h . T.encodeUtf8
				BS8.hPutStrLn h ""
	where
	open = Pip.liftIO $ do
		IO.createDirectoryIfMissing True $ FP.takeDirectory filePath
		IO.openFile filePath IO.WriteMode
	close h = Pip.liftIO $ do
		fd <- Posix.handleToFd h
		Posix.setFdMode fd fileMode
		IO.hClose h

writeJSON ::
 Pip.MonadSafe m =>
 JSON.ToJSON a =>
 Global_Params ->
 Posix.FileMode ->
 IO.FilePath ->
 Pip.Consumer a m r
writeJSON glob fileMode filePath = do
	Pip.liftIO $ outputDebug glob $ "writing " <> Doc.from filePath
	Pip.bracket open close $ \h ->
		Pip.for Pip.cat $ \a ->
			Pip.liftIO $ do
				BSL8.hPutStrLn h $ JSON.encode a
	where
	open = Pip.liftIO $ do
		IO.createDirectoryIfMissing True $ FP.takeDirectory filePath
		IO.openFile filePath IO.WriteMode
	close h = Pip.liftIO $ do
		fd <- Posix.handleToFd h
		Posix.setFdMode fd fileMode
		IO.hClose h

readJSON ::
 Pip.MonadSafe m =>
 JSON.FromJSON a =>
 JSON.ToJSON a =>
 Global_Params ->
 IO.FilePath ->
 Pip.Producer a m (Either Doc ())
readJSON glob filePath = do
	Pip.liftIO $ outputDebug glob $ "reading " <> Doc.from filePath
	let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle
	left handleError <$> Lens.view PipJSON.decoded bytes
	where
	handleError (err, _rest) =
		case err of
		 PipJSON.AttoparsecError parsingErr ->
			Doc.from filePath <> ": "<>
			Doc.redder "parsing error"<>": "<>
			Doc.from (show parsingErr) <> "\n"
		 PipJSON.FromJSONError decodingErr ->
			Doc.from filePath <> ": "<>
			Doc.redder "decoding error"<>": "<>
			Doc.from decodingErr <> "\n"

saveJSON ::
 JSON.ToJSON a =>
 Pip.MonadIO m =>
 Global_Params ->
 IO.FilePath -> a -> m ()
saveJSON glob filePath a =
	-- FIXME: abort or demand confirmation if the file exists
	Pip.liftIO $ do
		outputDebug glob $ "saving " <> Doc.from filePath
		JSON.encodeFile filePath a

loadJSON ::
 JSON.FromJSON a =>
 Pip.MonadIO m =>
 Global_Params ->
 IO.FilePath -> MaybeT m a
loadJSON glob filePath =
	Pip.liftIO (do
		outputDebug glob $ "loading " <> Doc.from filePath
		JSON.eitherDecodeFileStrict' filePath
	 ) >>= \case
	 Left err -> outputError glob $
		Doc.from filePath<>": "<>
		Doc.from err<>"\n"
	 Right a -> return a

-- | TODO: abstract over @crypto@ in the continuation.
loadElection ::
 VP.ReifyCrypto crypto =>
 JSON.FromJSON crypto =>
 Pip.MonadIO m =>
 Global_Params ->
 IO.FilePath ->
 (forall v c.
  VP.Reifies v VP.Version =>
  VP.Reifies c crypto =>
  VP.FieldElementConstraints crypto c =>
  VP.Election crypto v c -> MaybeT m r) ->
 MaybeT m r
loadElection glob filePath k =
	Pip.liftIO ( do
		outputDebug glob $ "loading " <> Doc.from filePath
		runExceptT $ VP.readElection filePath k
	 ) >>= \case
	 Left err -> outputError glob $
		Doc.from filePath<>": "<>
		Doc.from err<>"\n"
	 Right r -> r

{-
readJSON' ::
 Pip.MonadSafe m =>
 JSON.FromJSON a =>
 JSON.ToJSON a =>
 IO.FilePath ->
 Pip.Parser a m r -> m r
readJSON' filePath fold =
	let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
	evalStateT (Lens.zoom PipJSON.decoded fold) bytes

readJSON'' ::
 Pip.MonadSafe m =>
 JSON.FromJSON a =>
 IO.FilePath ->
 Pip.FreeT (Pip.Producer (Either PipJSON.DecodingError a) m) m ()
readJSON'' filePath =
	let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
	parseMany (Pip.parsed_ PipJSON.decode) bytes

parseMany ::
 forall m inp a r.
 Monad m =>
 (Pip.Producer inp m r -> Pip.Producer a m (Pip.Producer inp m r)) ->
 Pip.Producer inp m r ->
 Pip.FreeT (Pip.Producer a m) m r
parseMany f = go0
	where
	go0 ::
	 Pip.Producer inp m r ->
	 Pip.FreeT (Pip.Producer a m) m r
	go0 p = Pip.FreeT $ do
		Pip.next p >>= \case
		 Left r -> return $ Pip.Pure r
		 Right (inp, p') -> return $ Pip.Free $ go1 $ Pip.yield inp >> p'
	go1 ::
	 Pip.Producer inp m r ->
	 Pip.Producer a m (Pip.FreeT (Pip.Producer a m) m r)
	go1 p = go0 <$> f p
-}

pipeInfo ::
 Pip.MonadIO m =>
 Global_Params ->
 (a -> Doc) -> Pip.Pipe a a m r
pipeInfo glob d =
	Pip.for Pip.cat $ \s -> do
		Pip.liftIO $ outputInfo glob $ d s
		Pip.yield s

outputMessage :: Pip.MonadIO m => Global_Params -> Doc -> Doc -> m ()
outputMessage Global_Params{..} hdr msg =
	Pip.liftIO $ output $ OnHandle @Doc IO.stderr $
		(if global_stderr_prepend_newline then Doc.newline else mempty) <>
		(if global_stderr_prepend_carriage then "\r" else mempty) <>
		hdr<>": "<>msg<>
		(if global_stderr_append_newline then Doc.newline else mempty)

outputError :: Pip.MonadIO m => Global_Params -> Doc -> MaybeT m a
outputError glob@Global_Params{..} msg = do
	when (Verbosity_Error <= global_verbosity) $ do
		outputMessage glob (Doc.redder "ERROR") msg
	empty

outputWarning :: Pip.MonadIO m => Global_Params -> Doc -> m ()
outputWarning glob@Global_Params{..} msg = do
	when (Verbosity_Warning <= global_verbosity) $ do
		outputMessage glob (Doc.yellower "WARNING") msg

outputInfo :: Pip.MonadIO m => Global_Params -> Doc -> m ()
outputInfo glob@Global_Params{..} msg = do
	when (Verbosity_Info <= global_verbosity) $ do
		outputMessage glob (Doc.greener "info") msg

outputDebug :: Pip.MonadIO m => Global_Params -> Doc -> m ()
outputDebug glob@Global_Params{..} msg = do
	when (Verbosity_Debug <= global_verbosity) $ do
		outputMessage glob (Doc.magentaer "debug") msg