From ab5802ad6d172adea49fc42edab9742551490be7 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Wed, 4 Nov 2015 11:10:01 +0300 Subject: Use top-level name Web --- src/Web/ZeroBin.hs | 64 ++++++++++++++++++++++++++++++++++ src/Web/ZeroBin/SJCL.hs | 91 ++++++++++++++++++++++++++++++++++++++++++++++++ src/Web/ZeroBin/Utils.hs | 19 ++++++++++ src/ZeroBin.hs | 64 ---------------------------------- src/ZeroBin/SJCL.hs | 91 ------------------------------------------------ src/ZeroBin/Utils.hs | 19 ---------- 6 files changed, 174 insertions(+), 174 deletions(-) create mode 100644 src/Web/ZeroBin.hs create mode 100644 src/Web/ZeroBin/SJCL.hs create mode 100644 src/Web/ZeroBin/Utils.hs delete mode 100644 src/ZeroBin.hs delete mode 100644 src/ZeroBin/SJCL.hs delete mode 100644 src/ZeroBin/Utils.hs (limited to 'src') diff --git a/src/Web/ZeroBin.hs b/src/Web/ZeroBin.hs new file mode 100644 index 0000000..24e7115 --- /dev/null +++ b/src/Web/ZeroBin.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Web.ZeroBin ( + Expiration(..), + share +) where + +import Data.ByteString (ByteString) +import Data.ByteString.Base64 (encode) +import Data.Maybe (fromJust) +import GHC.Generics (Generic) +import Web.ZeroBin.SJCL (encrypt, Content) +import Web.ZeroBin.Utils (makePassword) +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Conduit as HTTP + +data Response = Response { + status :: String + , message :: Maybe String + , paste :: Maybe String + } deriving (Generic, Show) +instance JSON.FromJSON Response + +data Expiration + = Once + | Day + | Week + | Month + | Never + +form :: Expiration -> String +form Once = "burn_after_reading" +form Day = "1_day" +form Week = "1_week" +form Month = "1_month" +form Never = "never" + +post :: String -> Expiration -> Content -> IO (Either String String) +post bin ex ct = do + req' <- HTTP.parseUrl $ bin ++ "/paste/create" + let req = HTTP.urlEncodedBody + [ (C.pack "expiration" , C.pack $ form ex) + , (C.pack "content" , L.toStrict $ JSON.encode ct) + ] req' + manager <- HTTP.newManager HTTP.tlsManagerSettings + response <- HTTP.httpLbs req manager + let resp = fromJust . JSON.decode $ HTTP.responseBody response + case status resp of + "ok" -> return . Right $ + bin ++ "/paste/" ++ (fromJust . paste) resp + _ -> return . Left $ + (fromJust . message) resp + +share :: String -> Expiration -> ByteString -> IO (Either String String) +share bin ex txt = do + pwd <- makePassword 33 + c <- encrypt pwd (encode txt) + append pwd `fmap` post bin ex c + where + append _ (Left e) = Left e + append p (Right u) = Right $ u ++ "#" ++ p + diff --git a/src/Web/ZeroBin/SJCL.hs b/src/Web/ZeroBin/SJCL.hs new file mode 100644 index 0000000..66f8e29 --- /dev/null +++ b/src/Web/ZeroBin/SJCL.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Web.ZeroBin.SJCL ( + Content(..), + encrypt +) where + +import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.Types (ivAdd, blockSize, cipherInit, ecbEncrypt, ctrCombine, makeIV) +import Crypto.Error (throwCryptoErrorIO) +import Crypto.Hash.Algorithms (SHA256(..)) +import Crypto.KDF.PBKDF2 (prfHMAC) +import Crypto.Number.Serialize (i2ospOf_) +import Crypto.Random.Entropy (getEntropy) +import Data.ByteString (ByteString) +import Data.Maybe (fromJust) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Web.ZeroBin.Utils (toWeb) +import qualified Crypto.KDF.PBKDF2 as PBKDF2 +import qualified Data.Aeson as JSON +import qualified Data.ByteArray as BA +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C + +data Content = Content { + iv :: String + , salt :: String + , ct :: String + } deriving (Generic, Show) + +-- FIXME: http://stackoverflow.com/questions/33045350/unexpected-haskell-aeson-warning-no-explicit-implementation-for-tojson +instance JSON.ToJSON Content where + toJSON = JSON.genericToJSON JSON.defaultOptions + +makeCipher :: ByteString -> IO AES256 +makeCipher = throwCryptoErrorIO . cipherInit + +-- SJCL uses PBKDF2-HMAC-SHA256 with 1000 iterations, 32 bytes length, +-- but the output is truncated down to 16 bytes. +-- https://github.com/bitwiseshiftleft/sjcl/blob/master/core/pbkdf2.js +-- TODO: this is default, we can specify it explicitly +-- for forward compatibility +makeKey :: ByteString -> ByteString -> ByteString +makeKey pwd slt = BS.take 16 $ PBKDF2.generate (prfHMAC SHA256) + PBKDF2.Parameters {PBKDF2.iterCounts = 1000, PBKDF2.outputLength = 32} + pwd slt + + +chunks :: Int -> ByteString -> [ByteString] +chunks sz = split + where split b | cl <= sz = [b'] -- padded + | otherwise = b1 : split b2 + where cl = BS.length b + (b1, b2) = BS.splitAt sz b + b' = BS.take sz $ BS.append b (BS.replicate sz 0) + +lengthOf :: Int -> Word8 +lengthOf = ceiling . (logBase 256 :: Float -> Float) . fromIntegral + +-- Ref. https://tools.ietf.org/html/rfc3610 +-- SJCL uses 64-bit tag (8 bytes) +encrypt :: String -> ByteString -> IO Content +encrypt password plaintext = do + ivd <- getEntropy 16 -- XXX it is truncated to get the nonce below + slt <- getEntropy 13 -- arbitrary length + cipher <- makeCipher $ makeKey (C.pack password) slt + let tlen = 8 :: Word8 + l = BS.length plaintext + eL = max 2 (lengthOf l) + nonce = BS.take (15 - fromIntegral eL) ivd + b0 = BS.concat [ + BS.pack [8*((tlen-2) `div` 2) + (eL-1)], + nonce, + i2ospOf_ (fromIntegral eL) (fromIntegral l) + ] + mac = foldl (\ a b -> ecbEncrypt cipher $ BA.xor a b) + (ecbEncrypt cipher b0) + (chunks (blockSize cipher) plaintext) + tag = BS.take (fromIntegral tlen) mac + a0 = BS.concat [ + BS.pack [eL - 1], + nonce, + BS.replicate (fromIntegral eL) 0 + ] + a1iv = ivAdd (fromJust . makeIV $ a0) 1 + ciphtext = BS.append + (ctrCombine cipher a1iv plaintext) + (BA.xor (ecbEncrypt cipher a0) tag) + return Content { iv = toWeb ivd, salt = toWeb slt, ct = toWeb ciphtext } + diff --git a/src/Web/ZeroBin/Utils.hs b/src/Web/ZeroBin/Utils.hs new file mode 100644 index 0000000..915d8ad --- /dev/null +++ b/src/Web/ZeroBin/Utils.hs @@ -0,0 +1,19 @@ +module Web.ZeroBin.Utils ( + toWeb +, makePassword +) where + +import Crypto.Random.Entropy (getEntropy) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 (encode) +import Data.ByteString.Char8 (unpack) +import Data.Char (isAlphaNum) + + +toWeb :: ByteString -> String +toWeb = takeWhile (/= '=') . unpack . encode + +makePassword :: Int -> IO String +makePassword n = (map (\c -> if isAlphaNum c then c else 'X') + . toWeb) `fmap` getEntropy n + diff --git a/src/ZeroBin.hs b/src/ZeroBin.hs deleted file mode 100644 index 5d8abd8..0000000 --- a/src/ZeroBin.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module ZeroBin ( - Expiration(..), - share -) where - -import Data.ByteString (ByteString) -import Data.ByteString.Base64 (encode) -import Data.Maybe (fromJust) -import GHC.Generics (Generic) -import ZeroBin.SJCL (encrypt, Content) -import ZeroBin.Utils (makePassword) -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as L -import qualified Network.HTTP.Conduit as HTTP - -data Response = Response { - status :: String - , message :: Maybe String - , paste :: Maybe String - } deriving (Generic, Show) -instance JSON.FromJSON Response - -data Expiration - = Once - | Day - | Week - | Month - | Never - -form :: Expiration -> String -form Once = "burn_after_reading" -form Day = "1_day" -form Week = "1_week" -form Month = "1_month" -form Never = "never" - -post :: String -> Expiration -> Content -> IO (Either String String) -post bin ex ct = do - req' <- HTTP.parseUrl $ bin ++ "/paste/create" - let req = HTTP.urlEncodedBody - [ (C.pack "expiration" , C.pack $ form ex) - , (C.pack "content" , L.toStrict $ JSON.encode ct) - ] req' - manager <- HTTP.newManager HTTP.tlsManagerSettings - response <- HTTP.httpLbs req manager - let resp = fromJust . JSON.decode $ HTTP.responseBody response - case status resp of - "ok" -> return . Right $ - bin ++ "/paste/" ++ (fromJust . paste) resp - _ -> return . Left $ - (fromJust . message) resp - -share :: String -> Expiration -> ByteString -> IO (Either String String) -share bin ex txt = do - pwd <- makePassword 33 - c <- encrypt pwd (encode txt) - append pwd `fmap` post bin ex c - where - append _ (Left e) = Left e - append p (Right u) = Right $ u ++ "#" ++ p - diff --git a/src/ZeroBin/SJCL.hs b/src/ZeroBin/SJCL.hs deleted file mode 100644 index fc3aa1b..0000000 --- a/src/ZeroBin/SJCL.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module ZeroBin.SJCL ( - Content(..), - encrypt -) where - -import Crypto.Cipher.AES (AES256) -import Crypto.Cipher.Types (ivAdd, blockSize, cipherInit, ecbEncrypt, ctrCombine, makeIV) -import Crypto.Error (throwCryptoErrorIO) -import Crypto.Hash.Algorithms (SHA256(..)) -import Crypto.KDF.PBKDF2 (prfHMAC) -import Crypto.Number.Serialize (i2ospOf_) -import Crypto.Random.Entropy (getEntropy) -import Data.ByteString (ByteString) -import Data.Maybe (fromJust) -import Data.Word (Word8) -import GHC.Generics (Generic) -import ZeroBin.Utils (toWeb) -import qualified Crypto.KDF.PBKDF2 as PBKDF2 -import qualified Data.Aeson as JSON -import qualified Data.ByteArray as BA -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C - -data Content = Content { - iv :: String - , salt :: String - , ct :: String - } deriving (Generic, Show) - --- FIXME: http://stackoverflow.com/questions/33045350/unexpected-haskell-aeson-warning-no-explicit-implementation-for-tojson -instance JSON.ToJSON Content where - toJSON = JSON.genericToJSON JSON.defaultOptions - -makeCipher :: ByteString -> IO AES256 -makeCipher = throwCryptoErrorIO . cipherInit - --- SJCL uses PBKDF2-HMAC-SHA256 with 1000 iterations, 32 bytes length, --- but the output is truncated down to 16 bytes. --- https://github.com/bitwiseshiftleft/sjcl/blob/master/core/pbkdf2.js --- TODO: this is default, we can specify it explicitly --- for forward compatibility -makeKey :: ByteString -> ByteString -> ByteString -makeKey pwd slt = BS.take 16 $ PBKDF2.generate (prfHMAC SHA256) - PBKDF2.Parameters {PBKDF2.iterCounts = 1000, PBKDF2.outputLength = 32} - pwd slt - - -chunks :: Int -> ByteString -> [ByteString] -chunks sz = split - where split b | cl <= sz = [b'] -- padded - | otherwise = b1 : split b2 - where cl = BS.length b - (b1, b2) = BS.splitAt sz b - b' = BS.take sz $ BS.append b (BS.replicate sz 0) - -lengthOf :: Int -> Word8 -lengthOf = ceiling . (logBase 256 :: Float -> Float) . fromIntegral - --- Ref. https://tools.ietf.org/html/rfc3610 --- SJCL uses 64-bit tag (8 bytes) -encrypt :: String -> ByteString -> IO Content -encrypt password plaintext = do - ivd <- getEntropy 16 -- XXX it is truncated to get the nonce below - slt <- getEntropy 13 -- arbitrary length - cipher <- makeCipher $ makeKey (C.pack password) slt - let tlen = 8 :: Word8 - l = BS.length plaintext - eL = max 2 (lengthOf l) - nonce = BS.take (15 - fromIntegral eL) ivd - b0 = BS.concat [ - BS.pack [8*((tlen-2) `div` 2) + (eL-1)], - nonce, - i2ospOf_ (fromIntegral eL) (fromIntegral l) - ] - mac = foldl (\ a b -> ecbEncrypt cipher $ BA.xor a b) - (ecbEncrypt cipher b0) - (chunks (blockSize cipher) plaintext) - tag = BS.take (fromIntegral tlen) mac - a0 = BS.concat [ - BS.pack [eL - 1], - nonce, - BS.replicate (fromIntegral eL) 0 - ] - a1iv = ivAdd (fromJust . makeIV $ a0) 1 - ciphtext = BS.append - (ctrCombine cipher a1iv plaintext) - (BA.xor (ecbEncrypt cipher a0) tag) - return Content { iv = toWeb ivd, salt = toWeb slt, ct = toWeb ciphtext } - diff --git a/src/ZeroBin/Utils.hs b/src/ZeroBin/Utils.hs deleted file mode 100644 index 34871d2..0000000 --- a/src/ZeroBin/Utils.hs +++ /dev/null @@ -1,19 +0,0 @@ -module ZeroBin.Utils ( - toWeb -, makePassword -) where - -import Crypto.Random.Entropy (getEntropy) -import Data.ByteString (ByteString) -import Data.ByteString.Base64 (encode) -import Data.ByteString.Char8 (unpack) -import Data.Char (isAlphaNum) - - -toWeb :: ByteString -> String -toWeb = takeWhile (/= '=') . unpack . encode - -makePassword :: Int -> IO String -makePassword n = (map (\c -> if isAlphaNum c then c else 'X') - . toWeb) `fmap` getEntropy n - -- cgit v1.2.3