{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module Web.Rails3.Session
  (
    -- * Tutorial
    -- $tutorial

    -- * Decoding
    decodeEither
  , decode
    -- * Utilities
  , lookupUserIds
    -- * Throw-away data-types
    -- $datatypes
  , Secret(..)
  , Cookie(..)
  )
where

import           Crypto.Hash                  as Hash
import           Crypto.MAC.HMAC              as HMAC
import           Data.ByteString
import           Data.ByteString              as BS
import qualified Data.ByteString.Base16       as B16
import qualified Data.ByteString.Base64       as B64
import qualified Data.Map.Strict              as Map
import           Data.Ruby.Marshal            as Marshal hiding (decode, decodeEither)
import qualified Data.Ruby.Marshal            as Marshal (decodeEither)
import           Data.Ruby.Marshal.RubyObject
import Network.HTTP.Types (urlDecode)
import Data.List.NonEmpty as NE
import Data.List as DL
import Prelude (Either(..), (>>=), (.), (==), ($), Maybe(..), return, Num(..), Int, fromIntegral, Bool(..), fst, String, either, id, const)

-- $tutorial
--
-- Here's how to decode a Rail3 session/auth cookie using 'wai' & 'cookie' package.
--
-- @
-- import Network.Wai (requestHeaders)
-- import Web.Cookie (parseCookies)
-- ...
--
-- case (fmap (lookup "_yourapp_session") $ fmap parseCookies $ lookup "Cookie" $ requestHeaders waiRequest) of
--
-- -- no active Rails session
-- Left _ -> ...
--
-- Right c -> case (decodeEither (Secret "yourSessionSecret") (Cookie c)) of
--
--   -- something went wrong in decoding the cookie. You should log "e" for debugging!
--   Left e -> ...
--
--   Right obj -> case (lookupUserIds obj) of
--
--      -- we have a Rails session-cookie, but the user has not signed-in
--     Nothing -> ...
--
--     -- signed-in user. This /may/ contain muliple userIds depending up on how you have configured Devise\/Warden in your Rails app.
--     Just userIds -> ...
-- @

-- $datatypes
--
-- These data-types exist only as a way to semantically differentiate between
-- various ByteString arguments when they are passed to functions. This is required
-- only because Haskell doesn't have proper keywords-arguments.

newtype Secret = Secret ByteString
newtype Cookie = Cookie ByteString

maybeToEither :: a -> Maybe b -> Either a b
maybeToEither :: a -> Maybe b -> Either a b
maybeToEither a
_ (Just b
b) = b -> Either a b
forall a b. b -> Either a b
Right b
b
maybeToEither a
a Maybe b
Nothing = a -> Either a b
forall a b. a -> Either a b
Left a
a

-- | Decode a cookie encoded by Rails3. Please read the documentation of
-- 'decodeEither' for more details, and consider using 'decodeEither' instead of
-- 'decode'
decode :: Secret -> Cookie -> Maybe RubyObject
decode :: Secret -> Cookie -> Maybe RubyObject
decode Secret
s Cookie
c = (String -> Maybe RubyObject)
-> (RubyObject -> Maybe RubyObject)
-> Either String RubyObject
-> Maybe RubyObject
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe RubyObject -> String -> Maybe RubyObject
forall a b. a -> b -> a
const Maybe RubyObject
forall a. Maybe a
Nothing) RubyObject -> Maybe RubyObject
forall a. a -> Maybe a
Just (Either String RubyObject -> Maybe RubyObject)
-> Either String RubyObject -> Maybe RubyObject
forall a b. (a -> b) -> a -> b
$ Secret -> Cookie -> Either String RubyObject
decodeEither Secret
s Cookie
c

-- | Decode a cookie encoded by Rails3. You can find the @Secret@ in a file
-- called @config\/initializers\/secret_token.rb@ in your Rail3 app.
--
-- __Note:__ `decodeMaybe` has not been added on purpose. When cookie decoding
-- fails, you would really want to know why. Please consider logging `Left`
-- values returned by this function in your log, to save yourself some debugging
-- time later.
decodeEither :: Secret -> Cookie -> Either String RubyObject
decodeEither :: Secret -> Cookie -> Either String RubyObject
decodeEither (Secret ByteString
cookieSecret) (Cookie ByteString
x) =
  Either String (Digest SHA1)
extractChecksum
  Either String (Digest SHA1)
-> (Digest SHA1 -> Either String ByteString)
-> Either String ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Digest SHA1 -> Either String ByteString
compareChecksum
  Either String ByteString
-> (ByteString -> Either String RubyObject)
-> Either String RubyObject
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Either String RubyObject
Marshal.decodeEither
  where
    extractChecksum :: Either String (Digest SHA1)
    extractChecksum :: Either String (Digest SHA1)
extractChecksum = do
      ByteString
decoded <- ByteString -> Either String ByteString
B16.decode ByteString
hexChecksum
      String -> Maybe (Digest SHA1) -> Either String (Digest SHA1)
forall a b. a -> Maybe b -> Either a b
maybeToEither String
"[Rails3 Cookie] Illegal checksum in cookie. Wasn't able to extract a valid HMAC checksum out of it."
                    (ByteString -> Maybe (Digest SHA1)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
Hash.digestFromByteString ByteString
decoded)

    compareChecksum :: Digest SHA1 -> Either String ByteString
    compareChecksum :: Digest SHA1 -> Either String ByteString
compareChecksum Digest SHA1
checksum = if (Digest SHA1
computedChecksum Digest SHA1 -> Digest SHA1 -> Bool
forall a. Eq a => a -> a -> Bool
== Digest SHA1
checksum) then (ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.decodeLenient ByteString
b64) else (String -> Either String ByteString
forall a b. a -> Either a b
Left String
"[Rails3 Cookie] Checksum doesn't match")

    computedChecksum :: Digest SHA1
    computedChecksum :: Digest SHA1
computedChecksum = HMAC SHA1 -> Digest SHA1
forall a. HMAC a -> Digest a
HMAC.hmacGetDigest (ByteString -> ByteString -> HMAC SHA1
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac ByteString
cookieSecret ByteString
b64 :: HMAC SHA1)

    (ByteString
b64, ByteString
hexChecksum) = let (ByteString
a, ByteString
b) = (ByteString -> ByteString -> (ByteString, ByteString)
breakSubstring ByteString
delimiter (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
urlDecode Bool
False ByteString
x)
                         in (ByteString
a, Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
delimiter) ByteString
b)
    delimiter :: ByteString
delimiter = ByteString
"--"


-- NOTE: Please refer to
-- http://blog.bigbinary.com/2013/03/19/cookies-on-rails.html to understand how
-- a Rails3 cookie is encoded (NOT encyrpted). Encryption of session cookies
-- only began in Rails4. Rails3 marshals a RubyObject and base64 encodes it to
-- store it as a cookie. To ensure that it cannot be tamped with, it also adds
-- an HMAC computed with the help of a secret key/value/token.

safeHead :: [a] -> Maybe a
safeHead :: [a] -> Maybe a
safeHead []    = Maybe a
forall a. Maybe a
Nothing
safeHead (a
x:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

lookupKey :: (Rubyable a) => (BS.ByteString, RubyStringEncoding) -> RubyObject -> Maybe a
lookupKey :: (ByteString, RubyStringEncoding) -> RubyObject -> Maybe a
lookupKey (ByteString, RubyStringEncoding)
key RubyObject
robj = (RubyObject
-> Maybe (Map (ByteString, RubyStringEncoding) RubyObject)
forall a. Rubyable a => RubyObject -> Maybe a
fromRuby RubyObject
robj :: Maybe (Map.Map (BS.ByteString, RubyStringEncoding) RubyObject))
  Maybe (Map (ByteString, RubyStringEncoding) RubyObject)
-> (Map (ByteString, RubyStringEncoding) RubyObject
    -> Maybe RubyObject)
-> Maybe RubyObject
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ByteString, RubyStringEncoding)
-> Map (ByteString, RubyStringEncoding) RubyObject
-> Maybe RubyObject
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString, RubyStringEncoding)
key
  Maybe RubyObject -> (RubyObject -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RubyObject -> Maybe a
forall a. Rubyable a => RubyObject -> Maybe a
fromRuby

-- | Lookup the Warden\/Devise UserIds from a decoded cookie. __Please note,__ a
-- cookie may contain multiple UserIds, because it /seems/ that it is possible
-- to be logged-in as multiple users simultaneously, if you define [multiple
-- user
-- models](https://github.com/plataformatec/devise/wiki/How-to-Setup-Multiple-Devise-User-Models)
-- (the underlying data-structure allows it, as well).
lookupUserIds :: (Num a) => RubyObject -> Maybe (NonEmpty a)
lookupUserIds :: RubyObject -> Maybe (NonEmpty a)
lookupUserIds RubyObject
robj =
  (ByteString, RubyStringEncoding) -> RubyObject -> Maybe RubyObject
forall a.
Rubyable a =>
(ByteString, RubyStringEncoding) -> RubyObject -> Maybe a
lookupKey (ByteString
"warden.user.user.key", RubyStringEncoding
UTF_8) RubyObject
robj
  Maybe RubyObject
-> (RubyObject -> Maybe [RubyObject]) -> Maybe [RubyObject]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\RubyObject
x -> RubyObject -> Maybe [RubyObject]
forall a. Rubyable a => RubyObject -> Maybe a
fromRuby RubyObject
x :: Maybe [RubyObject]) -- [[int, int int], "random string"]
  Maybe [RubyObject]
-> ([RubyObject] -> Maybe RubyObject) -> Maybe RubyObject
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [RubyObject] -> Maybe RubyObject
forall a. [a] -> Maybe a
safeHead
  Maybe RubyObject -> (RubyObject -> Maybe [Int]) -> Maybe [Int]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\RubyObject
x -> RubyObject -> Maybe [Int]
forall a. Rubyable a => RubyObject -> Maybe a
fromRuby RubyObject
x :: Maybe [Int]) -- [int, int, int]
  Maybe [Int] -> ([Int] -> Maybe [a]) -> Maybe [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\[Int]
xs -> [a] -> Maybe [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Maybe [a]) -> [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
DL.map Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
xs)
  Maybe [a] -> ([a] -> Maybe (NonEmpty a)) -> Maybe (NonEmpty a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty