module Quantum.Random.Store (
getStoreFile,
getStore,
getStoreBytes,
storeSize,
save,
status,
putStore,
putStoreBytes,
appendToStore,
addToStore,
addSafely,
addConcurrently,
fill,
refill,
load,
clearStore,
extract,
extractSafely,
observe,
observeSafely,
peek,
peekAll,
display_,
getMinStoreSize,
getTargetStoreSize,
getDefaultStyle,
setMinStoreSize,
setTargetStoreSize,
setDefaultStyle,
restoreDefaults,
reinitialize,
AccessControl,
initAccessControl,
withAccess,
forkSafely,
exitSafely
) where
import Paths_quantum_random
import Quantum.Random.Codec
import Quantum.Random.ANU
import Quantum.Random.Display
import Quantum.Random.Exceptions
import Quantum.Random.Mutex
import System.IO (openBinaryFile, IOMode (..), hClose)
import System.Directory (doesFileExist)
import Data.Aeson (encode)
import Data.Word (Word8)
import Data.ByteString (ByteString, readFile, writeFile, pack, unpack, hPut, length)
import qualified Data.ByteString.Lazy as Lazy
(fromStrict, toStrict)
import Control.Concurrent (ThreadId)
import Prelude hiding (readFile, writeFile, length)
getStoreFile :: IO FilePath
getStoreFile = getDataFileName "qr_data/qr_store.bin"
getSettingsFile :: IO FilePath
getSettingsFile = getDataFileName "qr_data/qr_settings.json"
getSettings :: IO QRSettings
getSettings = throwLeft . fmap (parseSettings . Lazy.fromStrict) $ readFile =<< getSettingsFile
putSettings :: QRSettings -> IO ()
putSettings qs = do
file <- getSettingsFile
writeFile file . Lazy.toStrict . encode $ qs
getMinStoreSize :: IO Int
getMinStoreSize = minStoreSize <$> getSettings
getTargetStoreSize :: IO Int
getTargetStoreSize = targetStoreSize <$> getSettings
getDefaultStyle :: IO DisplayStyle
getDefaultStyle = defaultDisplayStyle <$> getSettings
setMinStoreSize :: Int -> IO ()
setMinStoreSize n = updateMinSize n <$> getSettings >>= putSettings
setTargetStoreSize :: Int -> IO ()
setTargetStoreSize n = updateTarSize n <$> getSettings >>= putSettings
setDefaultStyle :: DisplayStyle -> IO ()
setDefaultStyle sty = updateDefaultStyle sty <$> getSettings >>= putSettings
restoreDefaults :: IO ()
restoreDefaults = putSettings defaults
reinitialize :: IO ()
reinitialize = restoreDefaults *> refill
getStore :: IO ByteString
getStore = getStoreFile >>= readFile
putStore :: ByteString -> IO ()
putStore bs = getStoreFile >>= flip writeFile bs
getStoreBytes :: IO [Word8]
getStoreBytes = unpack <$> getStore
putStoreBytes :: [Word8] -> IO ()
putStoreBytes = putStore . pack
storeSize :: IO Int
storeSize = length <$> getStore
save :: String -> IO ()
save path = do
exists <- doesFileExist path
qs <- getStore
case exists of
False -> writeFile path qs
True -> do putStrLn "File already exists. Enter 'yes' to overwrite."
i <- getLine
case i of
"yes" -> writeFile path qs *> putStrLn "Data saved."
_ -> putStrLn "Save aborted."
status :: IO ()
status = do
smin <- getMinStoreSize
star <- getTargetStoreSize
sty <- getDefaultStyle
siz <- storeSize
sto <- getStoreFile
mapM_ putStrLn
[ "Store contains " ++ bitsNBytes siz ++ " of quantum random data."
, ""
, "Minimum store size set to " ++ bitsNBytes smin ++ "."
, "Target store size set to " ++ bitsNBytes star ++ "."
, ""
, "Default display style: " ++ show sty ++ "."
, ""
, "Local data store location:"
, sto
, ""
]
bitsNBytes :: Int -> String
bitsNBytes n = show n ++ bytes ++ show (n*8) ++ " bits)"
where bytes = if n /= 1 then " bytes (" else " byte ("
clearStore :: IO ()
clearStore = putStore mempty
appendToStore :: ByteString -> IO ()
appendToStore bs = do
storefile <- getStoreFile
h <- openBinaryFile storefile AppendMode
hPut h bs
hClose h
addToStore :: Int -> IO ()
addToStore n = do
bs <- pack <$> fetchQR n
appendToStore bs
addSafely :: AccessControl -> Int -> IO ()
addSafely acc n = do
bs <- pack <$> fetchQR n
withAccess acc (appendToStore bs)
addConcurrently :: AccessControl -> Int -> IO ThreadId
addConcurrently acc n = forkSafely acc $ addSafely acc n
load :: String -> IO ()
load path = do
exists <- doesFileExist path
case exists of
False -> putStrLn "Load failed. File does not exist."
True -> readFile path >>= appendToStore
fill :: IO ()
fill = do
targ <- targetStoreSize <$> getSettings
qs <- getStoreBytes
size <- storeSize
case (compare size targ) of
LT -> do anu <- fetchQR (targ size)
putStoreBytes $ qs ++ anu
_ -> pure ()
refill :: IO ()
refill = getTargetStoreSize >>= fetchQR >>= putStoreBytes
extract :: Int -> IO [Word8]
extract n = do
size <- storeSize
qs <- getStoreBytes
st <- getSettings
let delta = size minStoreSize st
let needed = targetStoreSize st + n size
case (compare n delta) of
GT -> do anu <- fetchQR needed
let (xs,ys) = splitAt n $ qs ++ anu
putStoreBytes ys
pure xs
_ -> do let (xs,ys) = splitAt n qs
putStoreBytes ys
pure xs
extractSafely :: AccessControl -> Int -> IO [Word8]
extractSafely acc n = do
size <- storeSize
qs <- getStoreBytes
st <- getSettings
let delta = size minStoreSize st
let needed = targetStoreSize st + n size
case (compare n delta, compare n size) of
(GT,GT) -> do anu <- fetchQR needed
let (xs,ys) = splitAt n $ qs ++ anu
withAccess acc $ putStoreBytes ys
pure xs
(GT,_) -> do addConcurrently acc needed
let (xs,ys) = splitAt n qs
withAccess acc $ putStoreBytes ys
pure xs
_ -> do let (xs,ys) = splitAt n qs
withAccess acc $ putStoreBytes ys
pure xs
display_ :: Maybe DisplayStyle -> [Word8] -> IO ()
display_ (Just style) ws = display style ws
display_ Nothing ws = getDefaultStyle >>= flip display ws
observe :: Maybe DisplayStyle -> Int -> IO ()
observe ms n = extract n >>= display_ ms
observeSafely :: AccessControl -> Maybe DisplayStyle -> Int -> IO ()
observeSafely a ms n = extractSafely a n >>= display_ ms
peek :: Maybe DisplayStyle -> Int -> IO ()
peek ms n = take n <$> getStoreBytes >>= display_ ms
peekAll :: Maybe DisplayStyle -> IO ()
peekAll ms = getStoreBytes >>= display_ ms