diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Web/ZeroBin.hs | 77 | ||||
| -rw-r--r-- | src/Web/ZeroBin/SJCL.hs | 93 | ||||
| -rw-r--r-- | src/Web/ZeroBin/Utils.hs | 20 |
3 files changed, 99 insertions, 91 deletions
diff --git a/src/Web/ZeroBin.hs b/src/Web/ZeroBin.hs index f6ba051..0f32a50 100644 --- a/src/Web/ZeroBin.hs +++ b/src/Web/ZeroBin.hs @@ -8,40 +8,42 @@ High-level functions for posting to 0bin services like "http://0bin.net/paste/ZH6VyKXjDHAiPT8J#C6LLidGyHO7xt3xuDtsNHjZ77luualukEuJ25S6w/K1m" -} - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Web.ZeroBin ( - Expiration(..), - ZeroBinError(..), - share -) where +module Web.ZeroBin + ( Expiration(..) + , ZeroBinError(..) + , share + ) where import Control.Exception (Exception) import Control.Exception.Base (throwIO) +import qualified Data.Aeson as JSON import Data.ByteString (ByteString) import Data.ByteString.Base64 (encode) +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L import Data.Maybe (fromJust) import Data.Typeable (Typeable) 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 +import Web.ZeroBin.SJCL (Content, encrypt) +import Web.ZeroBin.Utils (makePassword) -data Response = Response { - status :: String +data Response = Response + { status :: String , message :: Maybe String - , paste :: Maybe String + , paste :: Maybe String } deriving (Generic, Show) + instance JSON.FromJSON Response -- | 0bin error message -data ZeroBinError = ZeroBinError String +data ZeroBinError = + ZeroBinError String deriving (Show, Typeable) + instance Exception ZeroBinError -- | Expiration of a paste. @@ -50,44 +52,45 @@ instance Exception ZeroBinError -- You can verify your paste before sharing the link. -- Original <http://0bin.net> does not support 'Week'. data Expiration - = Once -- ^ burn after reading - | Day -- ^ keep for 24 hours - | Week -- ^ for 7 days - | Month -- ^ for 30 days - | Never -- ^ for 100 years + = Once -- ^ burn after reading + | Day -- ^ keep for 24 hours + | Week -- ^ for 7 days + | Month -- ^ for 30 days + | Never -- ^ for 100 years form :: Expiration -> String -form Once = "burn_after_reading" -form Day = "1_day" -form Week = "1_week" +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 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' + 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 $ bin ++ "/paste/" ++ (fromJust . paste) resp - _ -> throwIO . ZeroBinError $ (fromJust . message) resp - + _ -> throwIO . ZeroBinError $ (fromJust . message) resp -- | Encrypts the plain data with a random password, -- post to 0bin and return the URI of a new paste. -- Can throw 'ZeroBinError' or 'Network.HTTP.Conduit.HttpException'. -share :: String -- ^ the address of 0bin, e. g. <http://0bin.net> or <https://paste.ec> - -> Expiration - -> ByteString -- ^ the plain data to encrypt and paste - -> IO String -- ^ the URI of paste +share :: + String -- ^ the address of 0bin, e. g. <http://0bin.net> or <https://paste.ec> + -> Expiration + -> ByteString -- ^ the plain data to encrypt and paste + -> IO String -- ^ the URI of paste share bin ex txt = do - pwd <- makePassword 33 - cnt <- encrypt pwd (encode txt) - uri <- post bin ex cnt + pwd <- makePassword 33 + cnt <- encrypt pwd (encode txt) + uri <- post bin ex cnt return $ uri ++ "#" ++ pwd - diff --git a/src/Web/ZeroBin/SJCL.hs b/src/Web/ZeroBin/SJCL.hs index a27ecb7..c4bc86e 100644 --- a/src/Web/ZeroBin/SJCL.hs +++ b/src/Web/ZeroBin/SJCL.hs @@ -6,37 +6,37 @@ Encryption compatible with <https://crypto.stanford.edu/sjcl/ SJCL> >>> encrypt "secret-word" (pack "hello") Content {iv = "VxyuJRVtKJqhG2iR/sPjAQ", salt = "AhnDuP1CkTCBlQTHgw", ct = "cqr7/pMRXrcROmcgwA"} -} - {-# LANGUAGE DeriveGeneric #-} -module Web.ZeroBin.SJCL ( - Content(..), - encrypt -) where +module Web.ZeroBin.SJCL + ( Content(..) + , encrypt + ) where import Crypto.Cipher.AES (AES128) -import Crypto.Cipher.Types (ivAdd, blockSize, cipherInit, ecbEncrypt, ctrCombine, makeIV) +import Crypto.Cipher.Types + (blockSize, cipherInit, ctrCombine, ecbEncrypt, ivAdd, makeIV) import Crypto.Error (throwCryptoErrorIO) import Crypto.Hash.Algorithms (SHA256(..)) import Crypto.KDF.PBKDF2 (prfHMAC) +import qualified Crypto.KDF.PBKDF2 as PBKDF2 import Crypto.Number.Serialize (i2ospOf_) import Crypto.Random.Entropy (getEntropy) +import qualified Data.Aeson as JSON +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C 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 -- | Encrypted content. Each field is a 'toWeb'-encoded byte-string -data Content = Content { - iv :: String -- ^ random initialization vector (IV) +data Content = Content + { iv :: String -- ^ random initialization vector (IV) , salt :: String -- ^ random salt - , ct :: String -- ^ encrypted data + , ct :: String -- ^ encrypted data } deriving (Generic, Show) -- FIXME: http://stackoverflow.com/questions/33045350/unexpected-haskell-aeson-warning-no-explicit-implementation-for-tojson @@ -49,16 +49,21 @@ makeCipher = throwCryptoErrorIO . cipherInit -- 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 = PBKDF2.generate (prfHMAC SHA256) - PBKDF2.Parameters {PBKDF2.iterCounts = 1000, PBKDF2.outputLength = 16} +makeKey = + PBKDF2.generate + (prfHMAC SHA256) + PBKDF2.Parameters {PBKDF2.iterCounts = 1000, PBKDF2.outputLength = 16} 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) + 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 @@ -67,34 +72,34 @@ lengthOf = ceiling . (logBase 256 :: Float -> Float) . fromIntegral -- Follows <https://tools.ietf.org/html/rfc3610 RFC3610> with a 8-bytes tag. -- Uses 16-bytes cipher key generated from the password and a random 'salt' -- by PBKDF2-HMAC-SHA256 with 1000 iterations. -encrypt :: String -- ^ the password - -> ByteString -- ^ the plain data to encrypt - -> IO Content +encrypt :: + String -- ^ the password + -> ByteString -- ^ the plain data to encrypt + -> IO Content encrypt password plaintext = do - ivd <- getEntropy 16 -- XXX it is truncated to get the nonce below - slt <- getEntropy 13 -- arbitrary length + 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) + 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 - ] + 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 } - + 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 index 559d9ec..70068aa 100644 --- a/src/Web/ZeroBin/Utils.hs +++ b/src/Web/ZeroBin/Utils.hs @@ -1,11 +1,10 @@ {-| Various utility functions -} - -module Web.ZeroBin.Utils ( - toWeb -, makePassword -) where +module Web.ZeroBin.Utils + ( toWeb + , makePassword + ) where import Crypto.Random.Entropy (getEntropy) import Data.ByteString (ByteString) @@ -13,12 +12,13 @@ import Data.ByteString.Base64 (encode) import Data.ByteString.Char8 (unpack) -- | Encodes to base64 and drops padding '='. -toWeb :: ByteString -- ^ the data to encode - -> String -- ^ base64 string without padding +toWeb :: + ByteString -- ^ the data to encode + -> String -- ^ base64 string without padding toWeb = takeWhile (/= '=') . unpack . encode -- | Makes a random password -makePassword :: Int -- ^ the number of bytes of entropy - -> IO String -- ^ random byte-string encoded by 'toWeb' +makePassword :: + Int -- ^ the number of bytes of entropy + -> IO String -- ^ random byte-string encoded by 'toWeb' makePassword n = toWeb `fmap` getEntropy n - |