{-# LANGUAGE ViewPatterns #-}
module Main (main) where
import Quantum.Random
import Data.Char (isDigit, toLower)
import Control.Monad.Reader (ReaderT (..), liftIO, lift)
import System.Console.Haskeline (InputT, getInputLine, runInputT, defaultSettings)
import System.Environment (getArgs)
---- Structure of commands ----
-- | Represents the settings saved in the settings file. This data type could be
-- extended in the future.
data Setting = MinSize Int
| TargetSize Int
| DefaultStyle DisplayStyle
-- | Represents the supported commands.
data Command = Add Int
| Observe Int (Maybe DisplayStyle)
| Peek Int (Maybe DisplayStyle)
| PeekAll (Maybe DisplayStyle)
| Live Int (Maybe DisplayStyle)
| Fill
| RestoreDefaults
| Reinitialize
| Status
| Save String
| Load String
| Set Setting
| Help
| Quit
helpMsg :: String
helpMsg = unlines
[ ""
, "======= Available commands ======="
, ""
, "add [# bytes] – Request specified number of quantum random bytes from ANU and add them to the store"
, "live [# bytes] – Request specified number of quantum random bytes from ANU and display them directly"
, "observe [# bytes] – Take and display data from store, retrieving more if needed. Those taken from the store are removed"
, "peek [# bytes] – Display up to the specified number of bytes from the store without removing them"
, "peekAll – Display all data from the store without removing them"
, "fill – Fill the store to the target size with live ANU quantum random numbers"
, "restore – Restore default settings"
, "reinitialize – Restore default settings, and refill store to target size"
, "status – Display status of store and settings"
, "save [filepath] – save binary quantum random store file to specified file path"
, "load [filepath] – load binary file and append data to store"
, "set minSize – Set the number of bytes below which the store is refilled"
, "set targetSize – Set the number of bytes to have after refilling"
, "set style [style] – Set the default display style"
, "help/? – Display this text"
, "quit/q – Quit"
, ""
, "======= Display options ======="
, ""
, "Commands that display QR data can take an optional display style modifier: "
, "'spins', 'bits', 'hex', 'colors', 'colorSpins', 'colorBits', 'colorHex' (the default)."
, ""
, "Examples:"
, "\"observe 25 colorspins\""
, "\"live 50 bits\""
]
---- Parsing commands ----
cwords :: String -> [String]
cwords = words . map toLower
readCommand :: String -> Maybe Command
readCommand (cwords -> ["add",n]) = Add <$> readInt n
readCommand (cwords -> ["peekall"]) = Just (PeekAll Nothing)
readCommand (cwords -> ["peekall",s]) = PeekAll <$> readStyle s
readCommand (cwords -> ["peek","all"]) = Just (PeekAll Nothing)
readCommand (cwords -> ["peek","all",s]) = PeekAll <$> readStyle s
readCommand (cwords -> ["observe",n]) = Observe <$> readInt n <*> Just Nothing
readCommand (cwords -> ["observe",n,s]) = Observe <$> readInt n <*> readStyle s
readCommand (cwords -> ["peek",n]) = Peek <$> readInt n <*> Just Nothing
readCommand (cwords -> ["peek",n,s]) = Peek <$> readInt n <*> readStyle s
readCommand (cwords -> ["live",n]) = Live <$> readInt n <*> Just Nothing
readCommand (cwords -> ["live",n,s]) = Live <$> readInt n <*> readStyle s
readCommand (cwords -> ["fill"]) = Just Fill
readCommand (cwords -> ["restore"]) = Just RestoreDefaults
readCommand (cwords -> ["reinitialize"]) = Just Reinitialize
readCommand (cwords -> ["status"]) = Just Status
readCommand (savePattern -> Just path) = Just (Save path)
readCommand (loadPattern -> Just path) = Just (Load path)
readCommand (cwords -> ["help"]) = Just Help
readCommand (cwords -> ["?"]) = Just Help
readCommand (cwords -> ["quit"]) = Just Quit
readCommand (cwords -> ["q"]) = Just Quit
readCommand (cwords -> "set" : ws) = Set <$> readSetting ws
readCommand _ = Nothing
--- Read Integers
readInt :: String -> Maybe Int
readInt = readIntRev . reverse
where readIntRev :: String -> Maybe Int
readIntRev [] = Nothing
readIntRev [c] = readDigit c
readIntRev (c:x:xs) = fmap (+) (readDigit c) <*> fmap (*10) (readIntRev (x:xs))
readDigit :: Char -> Maybe Int
readDigit c = if isDigit c then Just (read [c]) else Nothing
--- Read Settings
readSetting :: [String] -> Maybe Setting
readSetting ["minsize",n] = MinSize <$> readInt n
readSetting ["tarsize",n] = TargetSize <$> readInt n
readSetting ["targetsize",n] = TargetSize <$> readInt n
readSetting ["defaultstyle",s] = DefaultStyle <$> parseStyle s
readSetting ["style",s] = DefaultStyle <$> parseStyle s
readSetting _ = Nothing
--- Read Display Style
readStyle :: String -> Maybe (Maybe DisplayStyle)
readStyle = fmap Just . parseStyle
--- Read save/load commands
--- Used because 'cwords' pattern used elsewhere loses upper/lowercase information
savePattern :: String -> Maybe String
savePattern str =
case cwords str of
[_] -> Nothing
"save" : _ -> return . unwords . tail . words $ str
_ -> Nothing
loadPattern :: String -> Maybe String
loadPattern str =
case cwords str of
[_] -> Nothing
"load" : _ -> return . unwords . tail . words $ str
_ -> Nothing
---- Describing/announcing commands ----
bitsNBytes :: Int -> String
bitsNBytes n = show n ++ bytes ++ show (n*8) ++ " bits)"
where bytes = if n /= 1 then " bytes (" else " byte ("
description :: Command -> String
description (Add n) = "Adding " ++ bitsNBytes n ++ " of quantum random data to store"
description (Live n _) = "Retrieving " ++ bitsNBytes n ++ " of live quantum random data from ANU"
description (Observe n _) = "Observing " ++ bitsNBytes n ++ " of quantum random data from store"
description (Peek n _) = "Viewing up to " ++ bitsNBytes n ++ " of quantum random data from store"
description (PeekAll _) = "Viewing all quantum random data from store"
description Fill = "Filling quantum random data store to specified level"
description RestoreDefaults = "Reverting to default settings"
description Reinitialize = "Reverting to default settings, and refilling store"
description Quit = "Exiting"
description _ = ""
announce :: Command -> IO ()
announce c = let str = description c in if str == "" then pure () else putStrLn str
---- Interpreting commands to actions ----
-- | For a given command, as described by the 'Command' data type, interpret to the corresponding
-- IO action. This is the simple version, whereas 'interpSafe' ensures these actions cannot
-- interfere as they access local files.
interp :: Command -> IO ()
interp (Add n) = addToStore n
interp (Observe n msty) = observe msty n
interp (Peek n msty) = peek msty n
interp (PeekAll msty) = peekAll msty
interp (Live n msty) = fetchQR n >>= display_ msty
interp Fill = fill
interp RestoreDefaults = restoreDefaults
interp Reinitialize = reinitialize
interp Status = status
interp (Save path) = save path
interp (Load path) = load path
interp (Set (MinSize n)) = setMinStoreSize n
interp (Set (TargetSize n)) = setTargetStoreSize n
interp (Set (DefaultStyle s)) = setDefaultStyle s
interp Help = putStrLn helpMsg
interp Quit = pure ()
-- | Perform command, via 'interp', after printing a description to STDOUT.
command :: Command -> IO ()
command c = announce c *> interp c
-- | Given a string, attempt to interpret it as an IO action, and either perform it or report
-- the parse failure.
execCommand :: String -> IO ()
execCommand (readCommand -> Just c) = command c
execCommand _ = errorMsg
errorMsg :: IO ()
errorMsg = do
putStrLn "***** QR Error: Could not parse command."
putStrLn "***** Enter 'help' or '?' to see list of available commands."
---- Interpreting commands in the lifted monadic context ----
type QReader = ReaderT AccessControl IO
-- | Controlled-access variant of 'interp'.
interpSafe :: Command -> QReader ()
interpSafe (Add n) = ReaderT $ \a -> addSafely a n
interpSafe (Observe n s) = ReaderT $ \a -> observeSafely a s n
interpSafe Quit = ReaderT exitSafely
interpSafe c@(Live _ _) = liftIO $ interp c
interpSafe c@Help = liftIO $ interp c
interpSafe c = ReaderT $ \a -> withAccess a (interp c)
-- | Controlled-access, ReaderT-based variant of 'command'. Performs command via 'interpSafe' after
-- printing a description to STDOUT.
commandSafe :: Command -> QReader ()
commandSafe c = do
liftIO $ announce c
interpSafe c
---- Core program code ----
type QR = InputT (ReaderT AccessControl IO)
qrand :: QR ()
qrand = do
str <- getInputLine "quantum-random> "
let jc = readCommand =<< str
case jc of
Just Quit -> lift (commandSafe Quit)
Just c -> lift (commandSafe c) *> qrand
Nothing -> liftIO errorMsg *> qrand
-- | The main function associated with the executable @qrand@, the interactive manager program.
main :: IO ()
main = do
args <- getArgs
case args of
[] -> initAccessControl >>= runReaderT (runInputT defaultSettings qrand)
_ -> execCommand (unwords args)