diff options
Diffstat (limited to 'src/Web')
| -rw-r--r-- | src/Web/ZeroBin.hs | 64 | ||||
| -rw-r--r-- | src/Web/ZeroBin/SJCL.hs | 91 | ||||
| -rw-r--r-- | src/Web/ZeroBin/Utils.hs | 19 |
3 files changed, 174 insertions, 0 deletions
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 + |