packages feed

quantum-random (empty) → 0.6.0

raw patch · 16 files changed

+1323/−0 lines, 16 filesdep +QuickCheckdep +aesondep +ansi-terminalsetup-changed

Dependencies added: QuickCheck, aeson, ansi-terminal, ansigraph, base, bytestring, directory, haskeline, hspec, http-conduit, mtl, quantum-random, regex-posix, terminal-size, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for `quantum-random`++## 0.6.0++* First public version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2016 Cliff Harvey++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,121 @@+# quantum-random-numbers++[![Build Status](https://travis-ci.org/BlackBrane/quantum-random.svg?branch=master)](https://travis-ci.org/BlackBrane/quantum-random)+[![Hackage](https://img.shields.io/hackage/v/quantum-random.svg)](http://hackage.haskell.org/package/quantum-random)+[![quantum-random on Stackage Nightly](http://stackage.org/package/quantum-random/badge/nightly)](http://stackage.org/nightly/package/quantum-random)+++Retrieve, store and manage real quantum random data, originating from vacuum fluctuations of the electromagnetic field and served by [Australian National University](http://qrng.anu.edu.au/).++The package is designed to ensure quantum random data is promptly available for your application by keeping a sufficient amount locally. When depleted to a specified level, more data is downloaded concurrently over SSL. It can be configured by specifying the minimum store size (below which more data are retrieved) the target store size (the size of the store after retrieval) and the default display style.++This functionality is provided by:++* An executable program `qrand`+* A Haskell module `Quantum.Random`.++### Command line usage++Call `qrand` without any command line arguments to launch the interactive program, or alternatively+supply the desired command as arguments to only perform the specified operation.++#### Setup++Assuming GHC and Cabal are installed:++```+cabal update+cabal install quantum-random+qrand fill+```++One might also opt to set appropriate store size defaults before filling:++```+$ qrand+quantum-random> set minsize 150+quantum-random> set tarsize 300+quantum-random> fill+```++#### 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              –  Quit+```++Commands are not case-sensitive.++#### Display options++There are a number of available styles for displaying the binary data, including (or combined with) printing a colored block for every 4 bits (every half-byte). The basic display styles are hex, binary, or equivalently arrows (↑/↓) representing quantum mechanical spin states.++So the available display modifiers are:++* `hex`/`hexidecimal`+* `bits`/`binary`+* `spins`+* `colors`+* `colorHex` __(default)__+* `colorBits`/`colorBinary`+* `colorSpins`+++You can enter these modifiers after any display command. For example:++`observe 100 colorspins`++`live 50 binary`++### Usage in Haskell code++All user-facing functionality may be accessed from the `Quantum.Random` module, though a user can+also import the constituent modules when only a subset of the functionality is needed.++The most basic service is to retrieve data directly from ANU, which is provided by functions+from the `Quantum.Random.ANU` module. There are two variants yielding either a list of bytes or a+list of booleans. In both cases the argument specifies the number of bytes.++```haskell+fetchQR :: Int -> IO [Word8]+fetchQRBits :: Int -> IO [Bool]+```++Operations involving the data store are exported by `Quantum.Random.Store`. An important one is++```haskell+extract :: Int -> IO [Word8]+```+This also invokes the machinery to retrieve more data and refill the store as needed.++#### Exceptions++Most of the IO actions in the package use a custom exception type `QRException` to handle the unlikely+parse errors that may be encountered. Namely parse failure of either the JSON response object+of the API, or the settings file (which never needs to be edited directly). See the `Quantum.Random.Exceptions` module for details.++Beyond this, the operations for retrieving from the ANU server use `simpleHttp` from the+`http-conduit` package and therefore may throw an `HttpException`.++### Physical Origin++Detailed information on the physical setup used to produce these random numbers can be+found in these papers:++* [Real time demonstration of high bitrate quantum random number generation with coherent laser light](http://arxiv.org/abs/1107.4438)+* [Maximization of Extractable Randomness in a Quantum Random-Number Generator](http://arxiv.org/abs/1411.4512)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ qr_data/qr_settings.json view
@@ -0,0 +1,1 @@+{"minStoreSize":400,"targetStoreSize":800,"defaultDisplayStyle":"ColorHex"}
+ qr_data/qr_store.bin view
+ quantum-random.cabal view
@@ -0,0 +1,93 @@+name:                quantum-random+version:             0.6.0+synopsis:            Retrieve, store and manage real quantum random data.++description:         Retrieve, store and manage real quantum random data, originating from vacuum+                     fluctuations of the electromagnetic field and served by Australian National+                     University.+                     .++                     The package is designed to ensure quantum random data is promptly available for+                     your application by keeping a sufficient amount locally. When depleted to a+                     specified level, more data is downloaded concurrently over SSL. It can be+                     configured by specifying the minimum store size (below which more data are+                     retrieved) the target store size (the size of the store after retrieval) and+                     the default display style.+                     .++                     For more information on the API service on which this package is based,+                     visit the ANU QRN webpage at <http://qrng.anu.edu.au/>.++homepage:            http://github.com/BlackBrane/quantum-random/+license:             MIT+license-file:        LICENSE+author:              Cliff Harvey+maintainer:          cs.hbar+hs@gmail.com+copyright:           2016+category:            Scientific+build-type:          Simple++cabal-version:       >=1.10++data-files:          qr_data/qr_store.bin,+                     qr_data/qr_settings.json++extra-source-files:  README.md,+                     CHANGELOG.md++source-repository head+  type:     git+  location: git://github.com/BlackBrane/quantum-random.git++library+  hs-source-dirs:      src-lib++  build-depends:       base          >=4.8  && <4.10,+                       ansigraph     >=0.2  && <0.3,+                       aeson         >=0.8  && <0.12,+                       text          >=1.2  && <1.3,+                       regex-posix   >=0.9  && <1.0,+                       bytestring    >=0.10 && <0.11,+                       http-conduit  >=2.1  && <2.2,+                       ansi-terminal >=0.6  && <0.7,+                       terminal-size >=0.3  && <0.4,+                       directory     >=1.2  && <1.3+++  exposed-modules:     Quantum.Random,+                       Quantum.Random.Exceptions,+                       Quantum.Random.ANU,+                       Quantum.Random.Display,+                       Quantum.Random.Store+++  other-modules:       Quantum.Random.Codec,+                       Quantum.Random.Mutex,+                       Paths_quantum_random++  default-language:    Haskell2010++  ghc-options:         -Wall+                       -fno-warn-unused-do-bind++executable qrand+  hs-source-dirs:      src-ex++  main-is:             Main.hs++  build-depends:       base          >=4.8 && <4.10,+                       haskeline     >=0.7 && <0.8,+                       mtl           >=2.2 && <2.3,+                       quantum-random++  default-language:    Haskell2010++test-suite test-quantum-random+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          test-quantum-random.hs+  default-language: Haskell2010+  build-depends:    base == 4.*,+                    quantum-random,+                    hspec == 2.*,+                    QuickCheck == 2.*
+ src-ex/Main.hs view
@@ -0,0 +1,245 @@+{-# 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              –  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 _)      = "Viewing up to " ++ 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)
+ src-lib/Quantum/Random.hs view
@@ -0,0 +1,12 @@+-- | This module reexports all the public modules in the package.+module Quantum.Random (+  module Quantum.Random.ANU,+  module Quantum.Random.Store,+  module Quantum.Random.Display,+  module Quantum.Random.Exceptions+) where++import Quantum.Random.ANU+import Quantum.Random.Store+import Quantum.Random.Display+import Quantum.Random.Exceptions
+ src-lib/Quantum/Random/ANU.hs view
@@ -0,0 +1,49 @@+-- | This module provides functionality for retrieving and parsing the+--   quantum random number data from the Australian National University QRN server.+--+--   This module can be used when one only wants to use live data directly from the server,+--   without using any of the data store functionality.+--+--   In most other cases it should be imported via the "Quantum.Random" module.+module Quantum.Random.ANU (++-- ** QRN data retrieval+  fetchQR,+  fetchQRBits,++) where++import Quantum.Random.Codec+import Quantum.Random.Exceptions++import Data.Word            (Word8)+import Data.Bits            (testBit)+import Data.ByteString.Lazy (ByteString)+import Network.HTTP.Conduit (simpleHttp)+++anuURL :: Int -> String+anuURL n = "https://qrng.anu.edu.au/API/jsonI.php?length=" ++ show n ++ "&type=uint8"++getANU :: Int -> IO ByteString+getANU = simpleHttp . anuURL+++fetchQRResponse :: Int -> IO QRResponse+fetchQRResponse n = throwLeft $ parseResponse <$> getANU n+++-- | Fetch quantum random data from ANU server as a linked list of bytes via HTTPS. Network+--   problems may result in an `HttpException`. An invalid response triggers a 'QRException'.+fetchQR :: Int -> IO [Word8]+fetchQR n = map fromIntegral . qdata <$> fetchQRResponse n++-- | Fetch QRN data from ANU server as a linked list of booleans via HTTPS. Network+--   problems may result in an `HttpException`. An invalid response triggers a 'QRException'.+fetchQRBits :: Int -> IO [Bool]+fetchQRBits n = concat . map w8bools <$> fetchQR n++-- Converts a byte (Word8) to the corresponding list of 8 boolean values.+-- 'Bits' type class indexes bits from least to most significant, thus the reverse+w8bools :: Word8 -> [Bool]+w8bools w = reverse $ testBit w <$> [0..7]
+ src-lib/Quantum/Random/Codec.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveGeneric #-}++-- | Internal module for handling conversion between raw text and structured data.+module Quantum.Random.Codec (++  QRResponse (..),+  QRSettings (..),+  defaults,+  parseResponse,+  parseSettings,+  updateTarSize,+  updateMinSize,+  updateDefaultStyle++) where++import Quantum.Random.Exceptions+import Quantum.Random.Display++import GHC.Generics               (Generic)+import Data.Aeson                 (FromJSON,ToJSON,eitherDecode)+import Data.Text                  (Text)+import Data.ByteString.Lazy       (ByteString)+import Data.ByteString.Lazy.Char8 (pack,unpack)+import Text.Regex.Posix           ((=~))+import Data.Bifunctor             (first)+++-- | Corresponds to the JSON object returned by ANU, minus 'q' prefixes.+--   The 'process' function performs appropriate renamings.+data QRResponse = QRResponse { qtype   :: !Text+                             , qlength :: !Int+                             , qdata   :: ![Int]+                             , success :: !Bool } deriving (Show, Generic)++-- | Corresponds to the JSON object in which settings are stored locally.+data QRSettings = QRSettings { minStoreSize :: Int+                             , targetStoreSize :: Int+                             , defaultDisplayStyle :: DisplayStyle } deriving (Show, Generic)+++instance FromJSON QRResponse+instance ToJSON   QRResponse+instance FromJSON QRSettings+instance ToJSON   QRSettings++-- | Default settings.+defaults :: QRSettings+defaults = QRSettings 400 800 ColorHex++-- | Update the minimum store size field of a settings record.+updateMinSize :: Int -> QRSettings -> QRSettings+updateMinSize n qs = qs { minStoreSize = n }++-- | Update the target store size field of a settings record.+updateTarSize :: Int -> QRSettings -> QRSettings+updateTarSize n qs = qs { targetStoreSize = n }++-- | Update the default 'DisplayStyle' of a settings record.+updateDefaultStyle :: DisplayStyle -> QRSettings -> QRSettings+updateDefaultStyle sty qs = qs { defaultDisplayStyle = sty }++-- | Replace instances of the words "data", "type", "length", with "qdata", "qtype", "qlength"+--   respectively, to avoid clashes between record field names and keywords/Prelude.+process :: ByteString -> ByteString+process = pack . repData . repType . repLength . unpack++repData :: String -> String+repData = replaceWord "data" "qdata"++repType :: String -> String+repType = replaceWord "type" "qtype"++repLength :: String -> String+repLength = replaceWord "length" "qlength"+++replaceWord :: String -> String -> String -> String+replaceWord x y s = let (a,_,c) = s =~ x :: (String, String, String)+                    in  a ++ y ++ c++-- | From a Bytestring, attempt to decode a response from ANU ('QRResponse').+parseResponse :: ByteString -> Either QRException QRResponse+parseResponse = first ParseResponseError . eitherDecode . process++-- | From a Bytestring, attempt to decode a settings record.+parseSettings :: ByteString -> Either QRException QRSettings+parseSettings = first ParseSettingsError . eitherDecode
+ src-lib/Quantum/Random/Display.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE DeriveGeneric,+             ViewPatterns   #-}++-- | Functionality for display of binary data. Seeing a visual representation of quantum random+--   data lets a user visually verify that it is indeed random.+--+--   Usually to be imported via the "Quantum.Random" module.+module Quantum.Random.Display (++  DisplayStyle (..),+  parseStyle,+  display++) where++import GHC.Generics                 (Generic)+import Data.Aeson                   (FromJSON,ToJSON)+import System.Console.ANSI          (Color (..), ColorIntensity (..))+import System.Console.Ansigraph     (AnsiColor (AnsiColor), colorStr, fromFG)+import System.Console.Terminal.Size (size,width)+import Data.Word                    (Word8)+import Data.Bits                    (testBit)+import Data.Char                    (toLower)+import Numeric                      (showHex)+++-- | Represents the supported methods for displaying binary data.+--   All styles show data separated by byte except for 'Hex'.+data DisplayStyle = Colors+                  | Spins+                  | Bits+                  | Hex+                  | ColorSpins+                  | ColorBits+                  | ColorHex deriving (Generic,Show,Eq)++instance FromJSON DisplayStyle+instance ToJSON   DisplayStyle++-- | Parse a string to one of the supported display styles.+parseStyle :: String -> Maybe DisplayStyle+parseStyle (map toLower -> "colors")      = Just Colors+parseStyle (map toLower -> "spins")       = Just Spins+parseStyle (map toLower -> "bits")        = Just Bits+parseStyle (map toLower -> "binary")      = Just Bits+parseStyle (map toLower -> "hex")         = Just Hex+parseStyle (map toLower -> "hexidecimal") = Just Hex+parseStyle (map toLower -> "colorspins")  = Just ColorSpins+parseStyle (map toLower -> "colorbits")   = Just ColorBits+parseStyle (map toLower -> "colorbinary") = Just ColorBits+parseStyle (map toLower -> "colorhex")    = Just ColorHex+parseStyle _                              = Nothing+++---- Interpreting as colors ----++-- 'Bits' type class indexes bits from least to most significant, thus the reverse+w8bools :: Word8 -> [Bool]+w8bools w = reverse $ testBit w <$> [0..7]++type EightBits = (Bool,Bool,Bool,Bool,Bool,Bool,Bool,Bool)+type FourBits  = (Bool,Bool,Bool,Bool)++byteBits :: Word8 -> EightBits+byteBits (w8bools -> [a,b,c,d,e,f,g,h]) = (a,b,c,d,e,f,g,h)+byteBits _ = error "byteBits: Impossible case: w8bools produces length-8 list"++sepByte :: Word8 -> (FourBits, FourBits)+sepByte (byteBits -> (a,b,c,d,e,f,g,h)) = ((a,b,c,d), (e,f,g,h))++color :: FourBits -> AnsiColor+color (False,False,False,False) = AnsiColor Dull Black+color (False,False,False,True)  = AnsiColor Vivid Black+color (False,False,True,False)  = AnsiColor Dull Red+color (False,False,True,True)   = AnsiColor Vivid Red+color (False,True,False,False)  = AnsiColor Dull Green+color (False,True,False,True)   = AnsiColor Vivid Green+color (False,True,True,False)   = AnsiColor Dull Yellow+color (False,True,True,True)    = AnsiColor Vivid Yellow+color (True,False,False,False)  = AnsiColor Dull Blue+color (True,False,False,True)   = AnsiColor Vivid Blue+color (True,False,True,False)   = AnsiColor Dull Magenta+color (True,False,True,True)    = AnsiColor Vivid Magenta+color (True,True,False,False)   = AnsiColor Dull Cyan+color (True,True,False,True)    = AnsiColor Vivid Cyan+color (True,True,True,False)    = AnsiColor Dull White+color (True,True,True,True)     = AnsiColor Vivid White++colorBlock :: AnsiColor -> IO ()+colorBlock c = colorStr (fromFG c) "█"+++---- Interpreting as strings ----++binChar :: Bool -> Char+binChar False = '0'+binChar True  = '1'++spinChar :: Bool -> Char+spinChar False = '↑'+spinChar True  = '↓'++binStr :: FourBits -> String+binStr (a,b,c,d) = [binChar a, binChar b, binChar c, binChar d]++spinStr :: FourBits -> String+spinStr (a,b,c,d) = [spinChar a, spinChar b, spinChar c, spinChar d]++hexStr :: Word8 -> String+hexStr w = let hx = showHex w ""+           in  if length hx < 2 then '0' : hx else hx+++---- Byte display functions ----++binDisplay :: Word8 -> IO ()+binDisplay (sepByte -> (x,y)) = do+  putStr $ (binStr x) ++ " " ++ (binStr y) ++ "  "++spinDisplay :: Word8 -> IO ()+spinDisplay (sepByte -> (x,y)) = do+  putStr $ (spinStr x) ++ " " ++ (spinStr y) ++ "  "++hexDisplay :: Word8 -> IO ()+hexDisplay = putStr . hexStr++binColorDisplay :: Word8 -> IO ()+binColorDisplay (sepByte -> (x,y)) = do+  colorBlock (color x)+  colorBlock (color y)+  putStr $ " " ++ (binStr x) ++ " " ++ (binStr y) ++ " "++spinColorDisplay :: Word8 -> IO ()+spinColorDisplay (sepByte -> (x,y)) = do+  colorBlock (color x)+  colorBlock (color y)+  putStr $ " " ++ (spinStr x) ++ " " ++ (spinStr y) ++ " "++hexColorDisplay :: Word8 -> IO ()+hexColorDisplay w = do+  let (x,y) = sepByte w+  colorBlock (color x)+  colorBlock (color y)+  putStr $ " " ++ hexStr w ++ " "++colorDisplay :: Word8 -> IO ()+colorDisplay (sepByte -> (x,y)) = do+  colorBlock (color x)+  colorBlock (color y)+++---- Interpreting as display IO actions ----++displayByte :: DisplayStyle -> Word8 -> IO ()+displayByte Colors     = colorDisplay+displayByte Spins      = spinDisplay+displayByte Bits       = binDisplay+displayByte ColorSpins = spinColorDisplay+displayByte ColorBits  = binColorDisplay+displayByte Hex        = hexDisplay+displayByte ColorHex   = hexColorDisplay++-- How many characters each display style uses per byte+byteSize :: DisplayStyle -> Int+byteSize ColorHex   = 6+byteSize ColorBits  = 13+byteSize ColorSpins = 13+byteSize Bits       = 11+byteSize Spins      = 11+byteSize Hex        = 2+byteSize Colors     = 1++insertEvery :: Int -> a -> [a] -> [a]+insertEvery n x l = take n l ++ nl+   where nl = if length (drop n l) > 0+              then (x : insertEvery n x (drop n l))+              else []++-- Obtain the character-width of the terminal. On failure assume a conservative default.+termWidth :: IO Int+termWidth = do mw <- fmap width <$> size+               case mw of+                    Just w  -> pure w+                    Nothing -> pure 80++-- Display data, such that no byte is broken by a new line.+displayBytes :: DisplayStyle -> [Word8] -> IO ()+displayBytes sty ws = do+  w <- termWidth+  let bw = w `div` byteSize sty+  sequence_ $ insertEvery bw (putStrLn "") $ displayByte sty <$> ws++-- | Display a given list of bytes with the specified display style.+display :: DisplayStyle -> [Word8] -> IO ()+display Hex l = putStrLn $ concatMap hexStr l+display s   l = displayBytes s l *> putStrLn ""
+ src-lib/Quantum/Random/Exceptions.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Provides a data type describing the parsing errors that are possible, though unlikely,+--   to be encountered.+--+--   Note that since network requests are handled by the @http-conduit@ package,+--   the corresponding 'HttpException' is also one a user may wish to handle.+--+--   Usually to be imported via the "Quantum.Random" module.+module Quantum.Random.Exceptions (++-- * QRN exception data type+  QRException (..),++-- * Throwing+  throwLeft++) where++import Data.Typeable        (Typeable)+import Control.Exception    (Exception, throw)++-- | Represents two possible error conditions that may be encountered: in interpreting+--   data retrived from ANU, or while reading the local settings file.+data QRException = ParseResponseError String+                 | ParseSettingsError String deriving Typeable++instance Show QRException where+  show (ParseResponseError str) = unlines ["Problem parsing response from ANU server:", str]+  show (ParseSettingsError str) = unlines ["Problem interpreting settings file:", str]++instance Exception QRException++-- | Perform an IO computation that might encounter a problem corresponding to a 'Exception'.+--   If so, throw the exception, if not just return the value.+throwLeft :: Exception e => IO (Either e a) -> IO a+throwLeft ioer = do+  mx <- ioer+  case mx of+       Left er -> throw er+       Right x -> pure x
+ src-lib/Quantum/Random/Mutex.hs view
@@ -0,0 +1,49 @@+module Quantum.Random.Mutex where++import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)+import Control.Concurrent      (forkIO, ThreadId)++-- | A data type to coordinate access to the local files, implemented with an `MVar` @()@. When the+--   unit is present, access is available. IO operations that need access to the store or settings+--   file remove it from the `MVar` before doing so, and then replace it when they're done. Then+--   whenever two such operations might otherwise interfere, they will instead wait their turn to+--   obtain the access. This functionality is implemented with 'initAccessControl' and 'withAccess'.+--+--   Secondarily, it also contains another `MVar` @()@ used to prevent premature program exit when+--   a forked thread is running, implemented as 'forkSafely' and 'exitSafely'. The @qrand@+--   executable uses this to ensure that a concurrent operation to add data from ANU can finish.+data AccessControl = AccessControl {+  accessControl :: MVar (),+  exitControl   :: MVar ()+}++-- | Initiate the access control system.+initAccessControl :: IO AccessControl+initAccessControl = AccessControl <$> newMVar () <*> newMVar ()++-- | Perform the supplied IO action only when access is granted.+withAccess :: AccessControl -> IO a -> IO a+withAccess (AccessControl ac _) io = do+  _ <- takeMVar ac+  x <- io+  putMVar ac ()+  pure x++-- | Perform the supplied IO action while preventing premature program exit in conjunction+--   with 'exitSafely'.+holdExitWhile :: AccessControl -> IO a -> IO a+holdExitWhile (AccessControl _ ex) io = do+  _ <- takeMVar ex+  x <- io+  putMVar ex ()+  pure x++-- | Perform the supplied IO action in a new thread while preventing premature program exit+--   in conjunction with 'exitSafely'.+forkSafely :: AccessControl -> IO () -> IO ThreadId+forkSafely acc io = forkIO (holdExitWhile acc io)++-- | Exit with this operation to ensure a thread forked with 'forkSafely' can finish before+--   @main@ returns.+exitSafely :: AccessControl -> IO ()+exitSafely = return . takeMVar =<< exitControl
+ src-lib/Quantum/Random/Store.hs view
@@ -0,0 +1,338 @@+-- | This module provides functionality for quantum random data operations involving+--   the local data store and/or the settings file.+--+--   It also provides a way to coordinate access to these local files.+--   See 'AccessControl' for details. Any IO operation that uses these files can used in a+--   coordinated way by wrapping them in a 'withAccess'.+--+--   Some of these functions already come in special access-controlled variants because they only+--   require access in particular branches or phases of execution.+--   In particular we have 'addSafely', 'extractSafely' and 'observeSafely'.+--+--   Finally, there is functionality to ensure that a forked thread is allowed to finish, in case+--   main would otherwise return too soon. This is primarily needed to provide 'addConcurrently',+--   but it can be re-used by forking a thread with 'forkSafely' and exiting the program with+--   'exitSafely'.+--+--   Usually to be imported via the "Quantum.Random" module.+module Quantum.Random.Store (++-- * Data store operations+-- ** Basic store access++  getStoreFile,+  getStore,+  getStoreBytes,+  storeSize,+  save,+  status,++-- ** Store update++  putStore,+  putStoreBytes,+  appendToStore,+  addToStore,+  addSafely,+  addConcurrently,+  fill,+  refill,+  load,+  clearStore,++-- ** Primary store access++  extract,+  extractSafely,++-- ** Store data display++  observe,+  observeSafely,+  peek,+  peekAll,+  display_,++-- * Settings file operations+-- ** Settings access++  getMinStoreSize,+  getTargetStoreSize,+  getDefaultStyle,++-- ** Settings update++  setMinStoreSize,+  setTargetStoreSize,+  setDefaultStyle,+  restoreDefaults,+  reinitialize,++  -- * Store access control++  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)+++---- Data/Settings file locations ----++-- | Get path of local store file set up by cabal on installation.+getStoreFile :: IO FilePath+getStoreFile = getDataFileName "qr_data/qr_store.bin"++-- | Get path of local settings file set up by cabal on installation.+getSettingsFile :: IO FilePath+getSettingsFile = getDataFileName "qr_data/qr_settings.json"+++---- Settings access and update ----++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++-- | Query the settings file for the minimum store size setting.+getMinStoreSize :: IO Int+getMinStoreSize = minStoreSize <$> getSettings++-- | Query the settings file for the target store size setting.+getTargetStoreSize :: IO Int+getTargetStoreSize = targetStoreSize <$> getSettings++-- | Query the settings file for the default display style.+getDefaultStyle :: IO DisplayStyle+getDefaultStyle = defaultDisplayStyle <$> getSettings++-- | Update the minimum store size setting in the settings file.+setMinStoreSize :: Int -> IO ()+setMinStoreSize n = updateMinSize n <$> getSettings >>= putSettings++-- | Update the target store size setting in the settings file.+setTargetStoreSize :: Int -> IO ()+setTargetStoreSize n = updateTarSize n <$> getSettings >>= putSettings++-- | Update the default 'DisplayStyle' setting in the settings file.+setDefaultStyle :: DisplayStyle -> IO ()+setDefaultStyle sty = updateDefaultStyle sty <$> getSettings >>= putSettings++-- | Restore default settings.+restoreDefaults :: IO ()+restoreDefaults = putSettings defaults++-- | Restore default settings and 'refill' the store.+reinitialize :: IO ()+reinitialize = restoreDefaults *> refill+++---- Basic store access ----++-- | Retrieve quantum random data from local store as a raw bytestring.+getStore :: IO ByteString+getStore = getStoreFile >>= readFile++-- | Insert data into local store as a raw bytestring, overwriting any current contents.+putStore :: ByteString -> IO ()+putStore bs = getStoreFile >>= flip writeFile bs++-- | Retrieve quantum random data from local store as a list of bytes.+getStoreBytes :: IO [Word8]+getStoreBytes = unpack <$> getStore++-- | Insert data into local store as a list of bytes, overwriting any current contents.+putStoreBytes :: [Word8] -> IO ()+putStoreBytes = putStore . pack++-- | Compute the size of the current data store.+storeSize :: IO Int+storeSize = length <$> getStore++-- | Save the data store to another file, specified by the provided path.+--   Asks for overwrite confirmation if the file already exists.+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."++-- | Display status information: Current store size, minimum size setting, target+--   size setting, default display style and data file path.+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 ("+++---- Store update ----++-- | Remove all data from the store.+clearStore :: IO ()+clearStore = putStore mempty++-- | Append the supplied bytestring to the store file.+appendToStore :: ByteString -> IO ()+appendToStore bs = do+  storefile <- getStoreFile+  h <- openBinaryFile storefile AppendMode+  hPut h bs+  hClose h++-- | Retrieve the specified number of QRN bytes and add them to the store.+addToStore :: Int -> IO ()+addToStore n = do+  bs <- pack <$> fetchQR n+  appendToStore bs++-- | Like `addToStore`, but uses 'AccessControl' to ensure that file writing doesn't interfere with+--   other operations.+addSafely :: AccessControl -> Int -> IO ()+addSafely acc n = do+  bs <- pack <$> fetchQR n+  withAccess acc (appendToStore bs)++-- | Fork a thread to add data to the store concurrently.+addConcurrently :: AccessControl -> Int -> IO ThreadId+addConcurrently acc n = forkSafely acc $ addSafely acc n++-- | Load binary data from specified file path, append it to the data store.+load :: String -> IO ()+load path = do+  exists <- doesFileExist path+  case exists of+       False -> putStrLn "Load failed. File does not exist."+       True  -> readFile path >>= appendToStore++-- | Calculate the amount of data needed to reach target store size and retrieve it from ANU.+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 data store to target size, discarding data already present.+refill :: IO ()+refill = getTargetStoreSize >>= fetchQR >>= putStoreBytes+++---- Primary store access, including update/display ----++-- | Get the specified number of QRN bytes, either from the store and/or by+--   obtaining more from ANU as needed. As the name implies, the obtained bytes+--   are removed from the store. If the store is left with fewer than the+--   minimum number of QRN bytes it is filled back to the target size.+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++-- | Access-controlled version of 'extract'.+extractSafely :: AccessControl -> Int -> IO [Word8]+extractSafely acc n = do+  size <- storeSize+  qs <- getStoreBytes+  st <- getSettings+  let delta = size - minStoreSize st         -- "current margin"+  let needed = targetStoreSize st + n - size -- "what you want minus what you have"+  case (compare n delta, compare n size) of+       (GT,GT) -> do anu <- fetchQR needed  -- if n > margin then must req ANU+                     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++-- | Like 'display' only taking a `Maybe` 'DisplayStyle' as the first argument, where `Nothing`+--   signifies using the default display style.+display_ :: Maybe DisplayStyle -> [Word8] -> IO ()+display_ (Just style) ws = display style ws+display_ Nothing      ws = getDefaultStyle >>= flip display ws++-- | Destructively view the specified number of bytes, via 'extract'.+--   The name connotes the irreversibility of quantum measurement.+--   Measuring quantum data (analogously, viewing or using) expends them as a randomness resource.+--   Thus they are discarded. Use 'peek' if instead you wish the data to be kept.+observe :: Maybe DisplayStyle -> Int -> IO ()+observe ms n = extract n >>= display_ ms++-- | Destructively view the specified number of bytes, via 'extractSafely'.+--   Access-controlled version of 'observe'.+observeSafely :: AccessControl -> Maybe DisplayStyle -> Int -> IO ()+observeSafely a ms n = extractSafely a n >>= display_ ms++-- | Non-destructively view the specified number of bytes.+peek :: Maybe DisplayStyle -> Int -> IO ()+peek ms n = take n <$> getStoreBytes >>= display_ ms++-- | Non-destructively view all data in the store.+peekAll :: Maybe DisplayStyle -> IO ()+peekAll ms = getStoreBytes >>= display_ ms
+ test/test-quantum-random.hs view
@@ -0,0 +1,62 @@+module Main where++import Test.Hspec+import Test.QuickCheck+import Quantum.Random+++main :: IO ()+main = hspec $ do++  describe "parseStyle" $ do++    it "returns Nothing for unrecognized strings" $+      parseStyle "notastyle" `shouldBe` Nothing+    it "parses 'colors' to Just Colors" $+      parseStyle "colors" `shouldBe` Just Colors+    it "parses 'COLORS' to Just Colors" $+      parseStyle "COLORS" `shouldBe` Just Colors+    it "parses 'bits' to Just Bits" $+      parseStyle "bits" `shouldBe` Just Bits+    it "parses 'BITS' to Just Bits" $+      parseStyle "BITS" `shouldBe` Just Bits++    it "parses 'hex' to Just Hex" $+      parseStyle "hex" `shouldBe` Just Hex+    it "parses 'HEX' to Just Hex" $+      parseStyle "HEX" `shouldBe` Just Hex+    it "parses 'hexidecimal' to Just Hex" $+      parseStyle "hexidecimal" `shouldBe` Just Hex+    it "parses 'HEXIDECIMAL' to Just Hex" $+      parseStyle "HEXIDECIMAL" `shouldBe` Just Hex++    it "parses 'colorbits' to Just ColorBits" $+      parseStyle "colorbits" `shouldBe` Just ColorBits+    it "parses 'COLORBITS' to Just ColorBits" $+      parseStyle "COLORBITS" `shouldBe` Just ColorBits+    it "parses 'colorhex' to Just ColorHex" $+      parseStyle "colorhex" `shouldBe` Just ColorHex+    it "parses 'COLORHEX' to Just ColorHex" $+      parseStyle "COLORHEX" `shouldBe` Just ColorHex++    it "parses 'colorspins' to Just ColorSpins" $+      parseStyle "colorspins" `shouldBe` Just ColorSpins+    it "parses 'COLORSPINS' to Just ColorSpins" $+      parseStyle "COLORSPINS" `shouldBe` Just ColorSpins+++{-+-- | Parse a string to one of the supported display styles.+parseStyle :: String -> Maybe DisplayStyle+parseStyle (map toLower -> "colors")      = Just Colors+parseStyle (map toLower -> "spins")       = Just Spins+parseStyle (map toLower -> "bits")        = Just Bits+parseStyle (map toLower -> "binary")      = Just Bits+parseStyle (map toLower -> "hex")         = Just Hex+parseStyle (map toLower -> "hexidecimal") = Just Hex+parseStyle (map toLower -> "colorspins")  = Just ColorSpins+parseStyle (map toLower -> "colorbits")   = Just ColorBits+parseStyle (map toLower -> "colorbinary") = Just ColorBits+parseStyle (map toLower -> "colorhex")    = Just ColorHex+parseStyle _                              = Nothing+-}