Utils.hs

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

import Control.Arrow (left)
import Control.Applicative (Alternative(..))
import Control.Monad (Monad(..), forM_)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.State.Strict (StateT(..), evalStateT)
import Data.Bits (setBit)
import Data.Bool
import Data.ByteString (ByteString)
import Data.Either (Either(..))
import Data.Foldable (Foldable)
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.String (IsString(..))
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 Crypto.Hash as Crypto
import qualified Data.Aeson as JSON
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
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 as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLB
import qualified Lens.Family as Lens
import qualified Lens.Family.State.Strict 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.Group as Pip
import qualified Pipes.Parse as Pip
import qualified Pipes.Prelude as Pip
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
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")
instance CLI.IOType VP.FFC
instance CLI.FromSegment VP.FFC where
	fromSegment = JSON.eitherDecodeFileStrict'
instance VP.Reifies c VP.FFC => CLI.FromSegment (VP.E 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 ())
instance Outputable (VP.DecryptionShare ()) 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_dir :: IO.FilePath
 }

api_options =
	rule "OPTIONS" $
		Global_Params
		 <$> api_param_dir
api_param_dir =
	"Use directory "<>ref"DIR"<>" for reading and writing election files.\n"<>
	"Default to "<>fileRef (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"

-- * 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 =>
 Pip.Effect (Pip.SafeT IO) (a, Either Doc ()) -> MaybeT m a
runPipeWithError p = do
	(a, r) <- runPipe p
	case r of
	 Left err -> outputError err
	 Right () -> return a

writeFileLn ::
 Pip.MonadSafe m =>
 Foldable f =>
 Posix.FileMode ->
 IO.FilePath ->
 Pip.Consumer (f Text) m r
writeFileLn fileMode 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
		h <- IO.openFile filePath IO.WriteMode
		return h
	close h = Pip.liftIO $ do
		fd <- Posix.handleToFd h
		Posix.setFdMode fd fileMode
		IO.hClose h

writeJSON ::
 Pip.MonadSafe m =>
 JSON.ToJSON a =>
 Posix.FileMode ->
 IO.FilePath ->
 Pip.Consumer a m r
writeJSON fileMode filePath =
	Pip.bracket open close $ \h ->
		Pip.for Pip.cat $ \a ->
			Pip.liftIO $ do
				BSL8.hPutStr h $ JSON.encode a
	where
	open = Pip.liftIO $ do
		IO.createDirectoryIfMissing True $ FP.takeDirectory filePath
		h <- IO.openFile filePath IO.WriteMode
		return h
	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 =>
 IO.FilePath ->
 Pip.Producer a m (Either Doc ())
readJSON filePath =
	let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in
	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 =>
 IO.FilePath -> a -> m ()
saveJSON filePath a =
	-- FIXME: abort or demand confirmation if the file exists
	Pip.liftIO $ JSON.encodeFile filePath a

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

{-
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 =>
 Outputable (OnHandle d) =>
 (a -> d) -> Pip.Pipe a a m r
pipeInfo d =
	Pip.for Pip.cat $ \s -> do
		Pip.liftIO $ do
			output $ OnHandle IO.stderr (d s)
			output $ OnHandle IO.stderr '\n'
		Pip.yield s

outputInfo :: Pip.MonadIO m => Doc -> m ()
outputInfo msg = do
	Pip.liftIO $ output $ OnHandle @Doc IO.stderr $
		Doc.green "INFO"<>": "<>msg<>"\n"

outputError ::
 Pip.MonadIO m =>
 Doc -> MaybeT m a
outputError msg = do
	Pip.liftIO $ output $ OnHandle @Doc IO.stderr $
		Doc.redder "ERROR"<>": "<>msg<>"\n"
	empty