module Web.ClientSession
(
Key
, getKey
, defaultKeyFile
, getDefaultKey
, encrypt
, decrypt
) where
import System.Directory
import qualified Data.ByteString as S
import System.Random
import Data.ByteString.Unsafe
import Foreign.C
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable
import System.IO.Unsafe
type Key = S.ByteString
defaultKeyFile :: String
defaultKeyFile = "client_session_key.aes"
getDefaultKey :: IO Key
getDefaultKey = getKey defaultKeyFile
getKey :: FilePath
-> IO Key
getKey keyFile = do
exists <- doesFileExist keyFile
if exists
then do
key <- S.readFile keyFile
if S.length key < minKeyLength
then newKey
else return key
else newKey
where
newKey = do
key' <- randomKey
S.writeFile keyFile key'
return key'
minKeyLength :: Int
minKeyLength = 16
randomKey :: IO Key
randomKey = do
g <- newStdGen
let (nums, _) =
foldr
(\_ (n, g') -> let (n', g'') = next g' in (n' : n, g''))
([], g)
[1..minKeyLength]
return $ S.pack $ map fromIntegral nums
encrypt :: S.ByteString
-> S.ByteString
-> S.ByteString
encrypt keyBS dataBS = unsafePerformIO $
unsafeUseAsCString keyBS $ \keyPtr ->
unsafeUseAsCStringLen dataBS $ \(dataPtr, dataLen) -> do
let keyPtr' = castPtr keyPtr
dataPtr' = castPtr dataPtr
dataLen' = fromIntegral dataLen
allocaBytes 4 $ \lenp -> do
newPtr <- c_encrypt dataLen' dataPtr' keyPtr' lenp
let newPtr' = castPtr newPtr
len <- peek lenp
let len' = fromIntegral len
unsafePackCStringFinalizer newPtr' len' $ free newPtr'
decrypt :: S.ByteString
-> S.ByteString
-> Maybe S.ByteString
decrypt keyBS dataBS = unsafePerformIO $
unsafeUseAsCString keyBS $ \keyPtr ->
unsafeUseAsCStringLen dataBS $ \(dataPtr, dataLen) -> do
let keyPtr' = castPtr keyPtr
dataPtr' = castPtr dataPtr
dataLen' = fromIntegral dataLen
allocaBytes 4 $ \lenp -> do
newPtr <- c_decrypt dataLen' dataPtr' keyPtr' lenp
if newPtr == nullPtr
then return Nothing
else do
let newPtr' = castPtr newPtr
len <- peek lenp
let len' = fromIntegral len
bs <- unsafePackCStringFinalizer newPtr' len'
$ free newPtr'
return $ Just bs
foreign import ccall unsafe "encrypt"
c_encrypt :: CUInt -> Ptr CUChar -> Ptr CUChar -> Ptr CUInt
-> IO (Ptr CChar)
foreign import ccall unsafe "decrypt"
c_decrypt :: CUInt -> Ptr CChar -> Ptr CUChar -> Ptr CUInt
-> IO (Ptr CUChar)