module Web.Rails.Session (
decode
, decodeEither
, decrypt
, csrfToken
, sessionId
, lookupString
, lookupFixnum
, Cookie
, mkCookie
, Salt
, mkSalt
, SecretKeyBase
, mkSecretKeyBase
, DecryptedData
, unwrapDecryptedData
) where
import Control.Applicative ((<$>))
import "cryptonite" Crypto.Cipher.AES (AES256)
import "cryptonite" Crypto.Cipher.Types (cbcDecrypt, cipherInit, makeIV)
import "cryptonite" Crypto.Error (CryptoFailable(CryptoFailed, CryptoPassed))
import Crypto.PBKDF.ByteString (sha1PBKDF2)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.Either (Either(..), either)
import Data.Function.Compat ((&))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid ((<>))
import Data.Ruby.Marshal (RubyObject(..), RubyStringEncoding(..))
import qualified Data.Ruby.Marshal as Ruby
import Data.String.Conv (toS)
import qualified Data.Vector as Vec
import Network.HTTP.Types (urlDecode)
import Prelude (Bool(..), Eq, Int, Ord, Show, String, ($!), (.)
, (==), const, error, fst, show, snd)
newtype DecryptedData =
DecryptedData ByteString
deriving (Show, Ord, Eq)
newtype EncryptedData =
EncryptedData ByteString
deriving (Show, Ord, Eq)
newtype InitVector =
InitVector ByteString
deriving (Show, Ord, Eq)
newtype Cookie =
Cookie ByteString
deriving (Show, Ord, Eq)
newtype Salt =
Salt ByteString
deriving (Show, Ord, Eq)
newtype SecretKey =
SecretKey ByteString
deriving (Show, Ord, Eq)
newtype SecretKeyBase =
SecretKeyBase ByteString
deriving (Show, Ord, Eq)
mkCookie :: ByteString -> Cookie
mkCookie = Cookie
mkSalt :: ByteString -> Salt
mkSalt = Salt
mkSecretKeyBase :: ByteString -> SecretKeyBase
mkSecretKeyBase = SecretKeyBase
unwrapDecryptedData :: DecryptedData -> ByteString
unwrapDecryptedData (DecryptedData deData) =
deData
decode :: Maybe Salt
-> SecretKeyBase
-> Cookie
-> Maybe RubyObject
decode mbSalt secretKeyBase cookie =
either (const Nothing) Just (decodeEither mbSalt secretKeyBase cookie)
decodeEither :: Maybe Salt
-> SecretKeyBase
-> Cookie
-> Either String RubyObject
decodeEither mbSalt secretKeyBase cookie = do
case decrypt mbSalt secretKeyBase cookie of
Left errorMessage ->
Left errorMessage
Right (DecryptedData deData) ->
Ruby.decodeEither deData
decrypt :: Maybe Salt
-> SecretKeyBase
-> Cookie
-> Either String DecryptedData
decrypt mbSalt secretKeyBase cookie =
let salt = fromMaybe defaultSalt mbSalt
(SecretKey secret) = generateSecret salt secretKeyBase
(EncryptedData encData, InitVector initVec) = prepare cookie
in case makeIV initVec of
Nothing ->
Left $! "Failed to build init. vector for: " <> show initVec
Just initVec' -> do
let key = BS.take 32 secret
case (cipherInit key :: CryptoFailable AES256) of
CryptoFailed errorMessage ->
Left (show errorMessage)
CryptoPassed cipher ->
Right . DecryptedData $! cbcDecrypt cipher initVec' encData
where
defaultSalt :: Salt
defaultSalt = Salt "encrypted cookie"
csrfToken :: RubyObject -> Maybe ByteString
csrfToken = lookupString "_csrf_token" US_ASCII
sessionId :: RubyObject -> Maybe ByteString
sessionId = lookupString "session_id" UTF_8
lookupFixnum :: ByteString -> RubyStringEncoding -> RubyObject -> Maybe Int
lookupFixnum key enc rubyObject =
case lookup (RIVar (RString key, enc)) rubyObject of
Just (RFixnum val) ->
Just val
_ ->
Nothing
lookupString :: ByteString
-> RubyStringEncoding
-> RubyObject
-> Maybe ByteString
lookupString key enc rubyObject =
case lookup (RIVar (RString key, enc)) rubyObject of
Just (RIVar (RString val, _)) ->
Just val
_ ->
Nothing
generateSecret :: Salt -> SecretKeyBase -> SecretKey
generateSecret (Salt salt) (SecretKeyBase secret) =
SecretKey $! sha1PBKDF2 secret salt 1000 64
prepare :: Cookie -> (EncryptedData, InitVector)
prepare (Cookie cookie) =
urlDecode True cookie
& (fst . split)
& base64decode
& split
& (\(x, y) -> (EncryptedData (base64decode x), InitVector (base64decode y)))
where
base64decode :: ByteString -> ByteString
base64decode = B64.decodeLenient
separator :: ByteString
separator = "--"
split :: ByteString -> (ByteString, ByteString)
split = BS.breakSubstring separator
lookup :: RubyObject -> RubyObject -> Maybe RubyObject
lookup key (RHash vec) = snd <$> Vec.find (\element -> fst element == key) vec
lookup _ _ = Nothing