-
Notifications
You must be signed in to change notification settings - Fork 1
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
7 changed files
with
199 additions
and
131 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,8 +1,13 @@ | ||
module Main (main) where | ||
|
||
import qualified Audiocate (start) | ||
import Audiocate (run, Command(..), CommandReturnCode (..)) | ||
|
||
main :: IO () | ||
main = do | ||
Audiocate.start | ||
rc <- run (Encode "hello123" 5 "test/corpus/sample1.wav" "test/output/sample1_cmd.wav") | ||
if rc == CmdSuccess then do | ||
rc2 <- run (Decode "hello123" 5 "test/output/sample1_cmd.wav") | ||
print rc2 | ||
else | ||
print rc | ||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,130 +1,10 @@ | ||
module Audiocate (start) where | ||
module Audiocate ( | ||
run, | ||
Command(..), | ||
CommandReturnCode(..), | ||
) where | ||
|
||
import Control.Concurrent (forkIO) | ||
import Control.Concurrent.STM (atomically, newEmptyTMVarIO, putTMVar, readTChan, takeTMVar) | ||
import Control.Monad (void) | ||
import Control.Monad.Except (runExceptT) | ||
import Data.Audio.Wave (WaveAudio (..), waveAudioFromFile, waveAudioToFile, Frames) | ||
import Data.Text qualified as T | ||
import Data.Text.Encoding (encodeUtf8) | ||
import Data.Time.Clock (getCurrentTime, diffUTCTime) | ||
import Stego.Common (EncodingType (LsbEncoding), StegoParams (StegoParams)) | ||
import Stego.Decode.Decoder qualified as DC | ||
import Stego.Encode.Encoder (EncoderResult (..), enqueueFrame, getResultChannel, newEncoder, stopEncoder) | ||
import Data.List (sort) | ||
import Stego.Decode.Decoder (DecoderResultList) | ||
import Command.Cmd (interpretCmd, Command(..), CommandReturnCode(..)) | ||
|
||
doEncodeFrames :: StegoParams -> Frames -> IO DecoderResultList | ||
doEncodeFrames stegoParams frames = do | ||
encoder <- newEncoder stegoParams | ||
resC <- getResultChannel encoder | ||
printChan <- getResultChannel encoder | ||
decoder <- DC.newDecoder stegoParams | ||
void $ DC.mapDecoderOpQToResultChan decoder resC | ||
resD <- DC.getResultChannel decoder | ||
x <- newEmptyTMVarIO | ||
void $ forkIO $ loopDc resD [] (length frames) x | ||
void $ forkIO $ printLoop printChan 0 (length frames) | ||
|
||
mapM_ (enqueueFrame encoder) frames | ||
t <- stopEncoder encoder | ||
void $ atomically $ takeTMVar t | ||
atomically $ takeTMVar x | ||
where | ||
loopDc resD fs total t = do | ||
res <- atomically $ readTChan resD | ||
case res of | ||
DC.StoppingDecoder -> do | ||
void $ atomically $ putTMVar t fs | ||
f -> do | ||
loopDc resD (f : fs) total t | ||
printLoop c fs totalFs = do | ||
res <- atomically $ readTChan c | ||
case res of | ||
StoppingEncoder -> do | ||
pure () | ||
_ -> do | ||
printLoop c (fs + 1) totalFs | ||
|
||
doDecodeWaveAudio :: StegoParams -> WaveAudio -> IO DC.DecoderResultList | ||
doDecodeWaveAudio stegoParams waveAudio = do | ||
decoder <- DC.newDecoder stegoParams | ||
resD <- DC.getResultChannel decoder | ||
m <- newEmptyTMVarIO | ||
void $ forkIO $ decodeLoop resD [] m | ||
let frames = audioFrames waveAudio | ||
mapM_ (DC.enqueueFrame decoder) frames | ||
_ <- DC.stopDecoder decoder | ||
atomically $ takeTMVar m | ||
where | ||
decodeLoop channel fs resultVar = do | ||
res <- atomically $ readTChan channel | ||
case res of | ||
DC.StoppingDecoder -> do | ||
atomically $ putTMVar resultVar (sort fs) | ||
pure () | ||
f -> do | ||
decodeLoop channel (f : fs) resultVar | ||
|
||
start :: IO () | ||
start = do | ||
let inputFile = "test/corpus/sample2.wav" | ||
let outputFile = "test/output/sample2_out.wav" | ||
let secret = encodeUtf8 (T.pack "Sef7Kp%IU{T&In-=t'up/V2NwiY7,4Ds") | ||
let stegoParams = StegoParams secret 5 6 LsbEncoding 123 | ||
doEncodeFile stegoParams inputFile outputFile | ||
doDecodeFile stegoParams outputFile | ||
|
||
doDecodeFile :: StegoParams -> FilePath -> IO () | ||
doDecodeFile stegoParams inputFile = do | ||
startTime <- getCurrentTime | ||
putStrLn $ "Reading audio file " ++ inputFile ++ "..." | ||
audio <- runExceptT (waveAudioFromFile inputFile) | ||
case audio of | ||
Left err -> putStrLn err | ||
Right wa -> do | ||
readTime <- getCurrentTime | ||
putStrLn $ "Read file in " <> show (diffUTCTime readTime startTime) | ||
putStrLn "" | ||
print wa | ||
result <- doDecodeWaveAudio stegoParams wa | ||
putStrLn "\nDecode Result " | ||
print $ DC.getResultStats result | ||
endTime <- getCurrentTime | ||
putStrLn $ "Completed decode in " <> show (diffUTCTime endTime startTime) | ||
|
||
doEncodeFile :: StegoParams -> FilePath -> FilePath -> IO () | ||
doEncodeFile stegoParams inputFile outputFile = do | ||
startTime <- getCurrentTime | ||
putStrLn $ "Reading audio file " ++ inputFile ++ "..." | ||
audio <- runExceptT (waveAudioFromFile inputFile) | ||
case audio of | ||
Left err -> putStrLn err | ||
Right wa -> do | ||
readTime <- getCurrentTime | ||
putStrLn $ "Read file in " <> show (diffUTCTime readTime startTime) | ||
putStrLn "" | ||
print wa | ||
let frames = audioFrames wa | ||
result <- doEncodeFrames stegoParams (take (length frames `div` 2) frames) | ||
result2 <- doEncodeFrames stegoParams (drop (length frames `div` 2) frames) | ||
putStrLn "\nEncode Result " | ||
putStrLn $ "\nTotal Frames in file: " ++ show (length $ audioFrames wa) | ||
let combined = result ++ result2 | ||
print $ DC.getResultStats combined | ||
putStrLn $ "Writing encoded file " ++ outputFile ++ "..." | ||
let wa' = | ||
WaveAudio | ||
{ srcFile = outputFile | ||
, bitSize = 16 | ||
, rate = rate wa | ||
, channels = channels wa | ||
, audioFrames = [] | ||
, samples = concatMap snd (sort $ DC.getResultFrames combined) | ||
} | ||
write <- runExceptT (waveAudioToFile outputFile wa') | ||
case write of | ||
Left err -> putStrLn err | ||
Right _ -> do | ||
endTime <- getCurrentTime | ||
putStrLn $ "Completed encode in " <> show (diffUTCTime endTime startTime) | ||
run :: Command -> IO CommandReturnCode | ||
run = interpretCmd |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,44 @@ | ||
module Command.Cmd ( | ||
Command (..), | ||
CommandReturnCode (..), | ||
interpretCmd, | ||
) where | ||
|
||
import Command.EncodeCmd (runEncodeCmd) | ||
import qualified Data.Text as T | ||
import Data.Text.Encoding (encodeUtf8) | ||
import Stego.Common (StegoParams(..), EncodingType (LsbEncoding)) | ||
import Data.Word (Word64) | ||
import Command.DecodeCmd (runDecodeCmd) | ||
|
||
data Command | ||
= Help | ||
| Encode String Word64 FilePath FilePath | ||
| Decode String Word64 FilePath | ||
deriving (Show) | ||
|
||
data CommandReturnCode | ||
= CmdSuccess | ||
| CmdFail | ||
| CmdUnknown | ||
deriving (Show, Eq) | ||
|
||
|
||
interpretCmd :: Command -> IO CommandReturnCode | ||
interpretCmd cmd = | ||
case cmd of | ||
Help -> do | ||
putStrLn "run Help" | ||
pure CmdSuccess | ||
(Encode secret timeRange inputFile outputFile) -> do | ||
let s = encodeUtf8 (T.pack secret) | ||
let stegoParams = StegoParams s timeRange 6 LsbEncoding 123 | ||
runEncodeCmd stegoParams inputFile outputFile | ||
pure CmdSuccess | ||
(Decode secret timeRange inputFile) -> do | ||
let s = encodeUtf8 (T.pack secret) | ||
let stegoParams = StegoParams s timeRange 6 LsbEncoding 123 | ||
runDecodeCmd stegoParams inputFile | ||
pure CmdSuccess | ||
|
||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,52 @@ | ||
module Command.DecodeCmd ( | ||
runDecodeCmd, | ||
) where | ||
|
||
import Stego.Common (StegoParams(..)) | ||
import Data.Audio.Wave (WaveAudio (..), waveAudioFromFile) | ||
import Stego.Decode.Decoder (DecoderResultList, DecoderResult (StoppingDecoder), getResultStats, newDecoder, getResultChannel, enqueueFrame, stopDecoder) | ||
import Data.Time (getCurrentTime, diffUTCTime) | ||
import Control.Monad.Except (runExceptT) | ||
import Control.Concurrent.STM (newEmptyTMVarIO, atomically, takeTMVar, readTChan, putTMVar) | ||
import Control.Monad ( void ) | ||
import Data.List (sort) | ||
import Control.Concurrent (forkIO) | ||
|
||
runDecodeCmd :: StegoParams -> FilePath -> IO () | ||
runDecodeCmd stegoParams inputFile = do | ||
startTime <- getCurrentTime | ||
putStrLn $ "Reading audio file " ++ inputFile ++ "..." | ||
audio <- runExceptT (waveAudioFromFile inputFile) | ||
case audio of | ||
Left err -> putStrLn err | ||
Right wa -> do | ||
readTime <- getCurrentTime | ||
putStrLn $ "Read file in " <> show (diffUTCTime readTime startTime) | ||
putStrLn "" | ||
print wa | ||
result <- doDecodeWaveAudio stegoParams wa | ||
putStrLn "\nDecode Result " | ||
print $ getResultStats result | ||
endTime <- getCurrentTime | ||
putStrLn $ "Completed decode in " <> show (diffUTCTime endTime startTime) | ||
|
||
doDecodeWaveAudio :: StegoParams -> WaveAudio -> IO DecoderResultList | ||
doDecodeWaveAudio stegoParams waveAudio = do | ||
decoder <- newDecoder stegoParams | ||
resD <- getResultChannel decoder | ||
m <- newEmptyTMVarIO | ||
void $ forkIO $ decodeLoop resD [] m | ||
let frames = audioFrames waveAudio | ||
mapM_ (enqueueFrame decoder) frames | ||
_ <- stopDecoder decoder | ||
atomically $ takeTMVar m | ||
where | ||
decodeLoop channel fs resultVar = do | ||
res <- atomically $ readTChan channel | ||
case res of | ||
StoppingDecoder -> do | ||
atomically $ putTMVar resultVar (sort fs) | ||
pure () | ||
f -> do | ||
decodeLoop channel (f : fs) resultVar | ||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,84 @@ | ||
module Command.EncodeCmd ( | ||
runEncodeCmd | ||
) where | ||
|
||
import Stego.Common | ||
import qualified Stego.Decode.Decoder as DC | ||
import Data.Audio.Wave (WaveAudio(..), Frames, waveAudioToFile, waveAudioFromFile) | ||
import Stego.Encode.Encoder (EncoderResult(..), newEncoder, getResultChannel, enqueueFrame, stopEncoder) | ||
import Control.Monad (void) | ||
import Control.Concurrent.STM (newEmptyTMVarIO, takeTMVar, readTChan, putTMVar) | ||
import Control.Concurrent (forkIO) | ||
import Control.Monad.STM (atomically) | ||
import Data.Time (getCurrentTime, diffUTCTime) | ||
import Control.Monad.Except (runExceptT) | ||
import Data.List (sort) | ||
|
||
|
||
runEncodeCmd :: StegoParams -> FilePath -> FilePath -> IO () | ||
runEncodeCmd stegoParams inputFile outputFile = do | ||
startTime <- getCurrentTime | ||
putStrLn $ "Reading audio file " ++ inputFile ++ "..." | ||
audio <- runExceptT (waveAudioFromFile inputFile) | ||
case audio of | ||
Left err -> putStrLn err | ||
Right wa -> do | ||
readTime <- getCurrentTime | ||
putStrLn $ "Read file in " <> show (diffUTCTime readTime startTime) | ||
putStrLn "" | ||
print wa | ||
let frames = audioFrames wa | ||
result <- doEncodeFrames stegoParams (take (length frames `div` 2) frames) | ||
result2 <- doEncodeFrames stegoParams (drop (length frames `div` 2) frames) | ||
putStrLn "\nEncode Result " | ||
putStrLn $ "\nTotal Frames in file: " ++ show (length $ audioFrames wa) | ||
let combined = result ++ result2 | ||
print $ DC.getResultStats combined | ||
putStrLn $ "Writing encoded file " ++ outputFile ++ "..." | ||
let wa' = | ||
WaveAudio | ||
{ srcFile = outputFile | ||
, bitSize = bitSize wa | ||
, rate = rate wa | ||
, channels = channels wa | ||
, audioFrames = [] | ||
, samples = concatMap snd (sort $ DC.getResultFrames combined) | ||
} | ||
write <- runExceptT (waveAudioToFile outputFile wa') | ||
case write of | ||
Left err -> putStrLn err | ||
Right _ -> do | ||
endTime <- getCurrentTime | ||
putStrLn $ "Completed encode in " <> show (diffUTCTime endTime startTime) | ||
|
||
doEncodeFrames :: StegoParams -> Frames -> IO DC.DecoderResultList | ||
doEncodeFrames stegoParams frames = do | ||
encoder <- newEncoder stegoParams | ||
resC <- getResultChannel encoder | ||
printChan <- getResultChannel encoder | ||
decoder <- DC.newDecoder stegoParams | ||
void $ DC.mapDecoderOpQToResultChan decoder resC | ||
resD <- DC.getResultChannel decoder | ||
x <- newEmptyTMVarIO | ||
void $ forkIO $ decoderResultLoop resD [] (length frames) x | ||
void $ forkIO $ printLoop printChan (0 :: Int) (length frames) | ||
|
||
mapM_ (enqueueFrame encoder) frames | ||
t <- stopEncoder encoder | ||
void $ atomically $ takeTMVar t | ||
atomically $ takeTMVar x | ||
where | ||
decoderResultLoop resD fs total t = do | ||
res <- atomically $ readTChan resD | ||
case res of | ||
DC.StoppingDecoder -> do | ||
void $ atomically $ putTMVar t fs | ||
f -> do | ||
decoderResultLoop resD (f : fs) total t | ||
printLoop c fs totalFs = do | ||
res <- atomically $ readTChan c | ||
case res of | ||
StoppingEncoder -> do | ||
pure () | ||
_ -> do | ||
printLoop c (fs + 1) totalFs |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters