module Network.MiniHTTP.Session
( getSession
, putSession
, addSession
, setSessionSecretKey
) where
import Control.Concurrent.STM
import Control.Monad (forM_)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Binary.Put as P
import qualified Data.Binary.Strict.Get as G
import Data.Bits
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 ()
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Internal (w2c)
import Data.Word (Word32)
import Network.MiniHTTP.Server
import Network.MiniHTTP.Marshal
import System.IO.Unsafe (unsafePerformIO)
import qualified OpenSSL.EVP.Base64 as Base64
import qualified OpenSSL.EVP.Cipher as Cipher
import qualified OpenSSL.EVP.Digest as Digest
import OpenSSL.Random (randBytes)
toString :: B.ByteString -> String
toString = map w2c . B.unpack
secretKey :: TVar B.ByteString
secretKey = unsafePerformIO $ do
rand <- randBytes 16
newTVarIO rand
setSessionSecretKey :: B.ByteString -> STM ()
setSessionSecretKey = writeTVar secretKey
sha256 :: Digest.Digest
Just sha256 = unsafePerformIO $ Digest.getDigestByName "SHA256"
aes128 :: Cipher.Cipher
Just aes128 = unsafePerformIO $ Cipher.getCipherByName "AES128"
parseMap :: G.Get [(B.ByteString, B.ByteString)]
parseMap = do
emptyp <- G.isEmpty
if emptyp
then return []
else do
keylen <- varInt32
key <- G.getByteString keylen
valuelen <- varInt32
value <- G.getByteString valuelen
rest <- parseMap
rest `seq` (return $ (key, value) : rest)
putMap :: [(B.ByteString, B.ByteString)] -> P.Put
putMap vs = do
forM_ vs $ \(key, value) -> do
putVarInt32 $ B.length key
P.putByteString key
putVarInt32 $ B.length value
P.putByteString value
decode :: B.ByteString -> IO (Map.Map B.ByteString B.ByteString)
decode bs = do
secret <- atomically $ readTVar secretKey
let bs' = Base64.decodeBase64BS bs
(mac, bs'') = B.splitAt 32 bs'
if Digest.hmacBS sha256 secret bs'' /= mac
then return Map.empty
else do
let (iv, ciphertext) = B.splitAt 16 bs''
plaintext <- Cipher.cipherBS aes128 (toString secret) (toString iv) Cipher.Decrypt ciphertext
case G.runGet parseMap plaintext of
(Left _, _) -> return Map.empty
(Right m, _) -> return $ Map.fromList m
encode :: Map.Map B.ByteString B.ByteString -> IO B.ByteString
encode map = do
secret <- atomically $ readTVar secretKey
iv <- randBytes 16
let plaintext = B.concat $ BL.toChunks $ P.runPut $ putMap $ Map.toList map
ciphertext <- Cipher.cipherBS aes128 (toString secret) (toString iv) Cipher.Encrypt plaintext
let bs = iv `B.append` ciphertext
mac = Digest.hmacBS sha256 secret bs
return $ Base64.encodeBase64BS $ mac `B.append` bs
getSession :: WebMonad (Map.Map B.ByteString B.ByteString)
getSession = do
req <- getRequest
case filter (\cookie -> cookieName cookie == "nmhs") $ httpCookie $ reqHeaders req of
[] -> return Map.empty
x:_ -> liftIO $ decode $ cookieValue x
putSession :: Map.Map B.ByteString B.ByteString -> WebMonad ()
putSession m = do
v <- liftIO $ encode m
setCookie $ emptyCookie { cookieName = "nmhs"
, cookieValue = v
, cookiePath = Just "/" }
addSession :: B.ByteString -> B.ByteString -> WebMonad ()
addSession key value = do
s <- getSession
putSession $ Map.insert key value s
varInt32 :: (Integral i) => G.Get i
varInt32 = varIntWord32 >>= return . fromIntegral
varIntWord32 :: G.Get Word32
varIntWord32 = do
byte <- G.getWord8
if byte `testBit` 7
then do rest <- varIntWord32
return $ (rest `shiftL` 7) .|. (fromIntegral $ byte .&. 0x7f)
else return $ fromIntegral byte
putVarInt32 :: (Integral i) => i -> P.Put
putVarInt32 = putVarWord32 . fromIntegral
putVarWord32 :: Word32 -> P.Put
putVarWord32 value
| value < 128 = P.putWord8 $ fromIntegral value
| otherwise = do
P.putWord8 $ 0x80 .|. (fromIntegral $ value .&. 0x7f)
putVarWord32 $ value `shiftR` 7