aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorIgor Pashev <pashev.igor@gmail.com>2015-11-01 09:56:07 +0300
committerIgor Pashev <pashev.igor@gmail.com>2015-11-01 09:56:07 +0300
commitaf7c57b627c6b83e3d342d9e6c4f95b6041612d8 (patch)
treef3244b1b213a1bba586e0991a5194ff4673c22b3 /src
downloadzerobin-af7c57b627c6b83e3d342d9e6c4f95b6041612d8.tar.gz
Initial commit1.0.0
Diffstat (limited to 'src')
-rw-r--r--src/ZeroBin.hs65
-rw-r--r--src/ZeroBin/SJCL.hs91
-rw-r--r--src/ZeroBin/Utils.hs19
3 files changed, 175 insertions, 0 deletions
diff --git a/src/ZeroBin.hs b/src/ZeroBin.hs
new file mode 100644
index 0000000..d7bfc5c
--- /dev/null
+++ b/src/ZeroBin.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module ZeroBin (
+ Expiration(..),
+ pasteEc,
+ 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
+
+pasteEc :: String
+pasteEc = "https://paste.ec"
+
+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
+
+instance Show Expiration where
+ show Once = "burn_after_reading"
+ show Day = "1_day"
+ show Week = "1_week"
+ show Month = "1_month"
+ show Never = "never"
+
+post :: Expiration -> Content -> IO Response
+post ex ct = do
+ req' <- HTTP.parseUrl $ pasteEc ++ "/paste/create"
+ let req = HTTP.urlEncodedBody
+ [ (C.pack "expiration" , C.pack $ show ex)
+ , (C.pack "content" , L.toStrict $ JSON.encode ct)
+ ] (req' { HTTP.secure = True })
+ manager <- HTTP.newManager HTTP.tlsManagerSettings
+ response <- HTTP.httpLbs req manager
+ return . fromJust . JSON.decode $ HTTP.responseBody response
+
+share :: Expiration -> ByteString -> IO (Either String String)
+share ex txt = do
+ pwd <- makePassword 33
+ c <- encrypt pwd (encode txt)
+ resp <- post ex c
+ case status resp of
+ "ok" -> return . Right $
+ pasteEc ++ "/paste/" ++ (fromJust . paste) resp ++ "#" ++ pwd
+ _ -> return . Left $
+ (fromJust . message) resp
+
diff --git a/src/ZeroBin/SJCL.hs b/src/ZeroBin/SJCL.hs
new file mode 100644
index 0000000..b121546
--- /dev/null
+++ b/src/ZeroBin/SJCL.hs
@@ -0,0 +1,91 @@
+{-# 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 = C.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
new file mode 100644
index 0000000..34871d2
--- /dev/null
+++ b/src/ZeroBin/Utils.hs
@@ -0,0 +1,19 @@
+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
+