module Crypto.RLWE.Challenges.Suppress
(suppressMain, getNistCert, writeBeaconXML, suppressChallenge) where
import Crypto.RLWE.Challenges.Beacon
import Crypto.RLWE.Challenges.Common
import Control.Exception (try)
import Control.Monad.Except
import Control.Monad.State
import Crypto.Lol.Types.Proto
import Crypto.Proto.RLWE.Challenges.Challenge
import Data.ByteString.Lazy (writeFile)
import Data.ByteString.Char8 (unpack)
import Data.Maybe (isNothing)
import Data.Time.Clock.POSIX
import Data.Map (Map, empty, insert, lookup)
import Net.Beacon
import Network.HTTP.Client hiding (path)
import Network.HTTP.Conduit (simpleHttp)
import Prelude hiding (lookup, writeFile)
import System.Directory (removeFile)
import System.Exit
suppressMain :: FilePath -> IO ()
suppressMain path = do
challs <- challengeList path
recs <- flip execStateT empty $ mapM_ (suppressChallenge path) challs
mapM_ (writeBeaconXML path) recs
getNistCert path
type RecordState = Map BeaconEpoch Record
suppressChallenge :: (MonadIO m, MonadState RecordState m)
=> FilePath -> String -> m ()
suppressChallenge path name = do
x <- printPassFail ("Deleting secret for challenge " ++ name ++ ":\n") "DONE" $ do
let challFN = challFilePath path name
challProto <- readProtoType challFN
(BA time offset) <- parseBeaconAddr challProto
let numInsts = fromIntegral $ numInstances challProto
rec <- retrieveRecord time
let secID = suppressedSecretID numInsts rec offset
secFile = secretFilePath path name secID
checkFileExists secFile
liftIO $ putStr $ "\tRemoving " ++ secFile ++ "\n\t"
liftIO $ removeFile secFile
when (isNothing x) $ liftIO $ die "To avoid publishing all instance secrets, we are dying early."
return ()
retrieveRecord :: (MonadIO m, MonadError String m, MonadState RecordState m)
=> BeaconEpoch -> m Record
retrieveRecord t = do
mrec <- gets (lookup t)
case mrec of
(Just r) -> return r
Nothing -> do
liftIO $ putStrLn $ "\tDownloading record " ++ show t
trec <- liftIO $ try $ getCurrentRecord $ fromIntegral t
rec <- case trec of
Left e -> catchHttpException t e
Right a -> return a
rec' <- maybeThrowError rec $ "Couldn't parse XML for beacon at time " ++ show t
modify (insert t rec')
return rec'
catchHttpException :: (MonadIO m, MonadError String m)
=> BeaconEpoch -> HttpException -> m a
catchHttpException t (HttpExceptionRequest _ (StatusCodeException _ s)) = do
currTime <- round <$> (liftIO getPOSIXTime)
throwError $ case currTime < t of
True -> "You are requesting a beacon that doesn't exist yet.\n" ++
"Wait another " ++ show (tcurrTime) ++ " seconds and try again."
False -> "The beacon you are requesting should be available, " ++
"but it just isn't there:\n" ++ unpack s
catchHttpException _ (HttpExceptionRequest _ (ConnectionFailure _)) =
throwError "Failed to connect to NIST servers. They might be down for maintenance."
catchHttpException _ _ =
throwError "An unexpected IO error occurred while downloading the beacon."
writeBeaconXML :: (MonadIO m) => FilePath -> Record -> m ()
writeBeaconXML path rec = do
let beacon = toXML rec
filePath = beaconFilePath path $ fromIntegral $ timeStamp rec
liftIO $ writeFile filePath beacon
getNistCert :: (MonadIO m) => FilePath -> m ()
getNistCert path = liftIO $ do
let certPath = certFilePath path
putStrLn $ "Writing NIST certificate to " ++ certPath
bs <- simpleHttp "https://beacon.nist.gov/certificate/beacon.cer"
writeFile certPath bs