{-# LANGUAGE ForeignFunctionInterface #-}
module Happstack.Server.Internal.LazyLiner
    (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks
    ) where

import Control.Concurrent.MVar
import System.IO
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L

newtype Lazy = Lazy (MVar L.ByteString)

newLinerHandle :: Handle -> IO Lazy
newLinerHandle :: Handle -> IO Lazy
newLinerHandle Handle
h = (MVar ByteString -> Lazy) -> IO (MVar ByteString) -> IO Lazy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVar ByteString -> Lazy
Lazy (ByteString -> IO (MVar ByteString)
forall a. a -> IO (MVar a)
newMVar (ByteString -> IO (MVar ByteString))
-> IO ByteString -> IO (MVar ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO ByteString
L.hGetContents Handle
h)

headerLines :: Lazy -> IO [P.ByteString]
headerLines :: Lazy -> IO [ByteString]
headerLines (Lazy MVar ByteString
mv) = MVar ByteString
-> (ByteString -> IO (ByteString, [ByteString])) -> IO [ByteString]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ByteString
mv ((ByteString -> IO (ByteString, [ByteString])) -> IO [ByteString])
-> (ByteString -> IO (ByteString, [ByteString])) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \ByteString
l -> do
  let loop :: [ByteString] -> ByteString -> (ByteString, [ByteString])
loop [ByteString]
acc ByteString
r0 = let (ByteString
h,ByteString
r) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
L.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
ch) ByteString
r0
                        ph :: ByteString
ph    = ByteString -> ByteString
toStrict ByteString
h
                        phl :: Int
phl   = ByteString -> Int
P.length ByteString
ph
                        ph2 :: ByteString
ph2   = if Int
phl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| ByteString -> Char
P.last ByteString
ph Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\x0D' then ByteString
ph else ByteString -> ByteString
P.init ByteString
ph
                        ch :: Char
ch    = Char
'\x0A'
                        r' :: ByteString
r'    = if ByteString -> Bool
L.null ByteString
r then ByteString
r else ByteString -> ByteString
L.tail ByteString
r
                    in if ByteString -> Int
P.length ByteString
ph2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then (ByteString
r', [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
acc) else [ByteString] -> ByteString -> (ByteString, [ByteString])
loop (ByteString
ph2ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
acc) ByteString
r'
  (ByteString, [ByteString]) -> IO (ByteString, [ByteString])
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, [ByteString]) -> IO (ByteString, [ByteString]))
-> (ByteString, [ByteString]) -> IO (ByteString, [ByteString])
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString -> (ByteString, [ByteString])
loop [] ByteString
l

getBytesStrict :: Lazy -> Int -> IO P.ByteString
getBytesStrict :: Lazy -> Int -> IO ByteString
getBytesStrict (Lazy MVar ByteString
mv) Int
len = MVar ByteString
-> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ByteString
mv ((ByteString -> IO (ByteString, ByteString)) -> IO ByteString)
-> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
l -> do
  let (ByteString
h,ByteString
p) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) ByteString
l
  (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
p, ByteString -> ByteString
toStrict ByteString
h)

getBytes :: Lazy -> Int -> IO L.ByteString
getBytes :: Lazy -> Int -> IO ByteString
getBytes (Lazy MVar ByteString
mv) Int
len = MVar ByteString
-> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ByteString
mv ((ByteString -> IO (ByteString, ByteString)) -> IO ByteString)
-> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
l -> do
  let (ByteString
h,ByteString
p) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) ByteString
l
  (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
p, ByteString
h)

getRest :: Lazy -> IO L.ByteString
getRest :: Lazy -> IO ByteString
getRest (Lazy MVar ByteString
mv) = MVar ByteString
-> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ByteString
mv ((ByteString -> IO (ByteString, ByteString)) -> IO ByteString)
-> (ByteString -> IO (ByteString, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ByteString
l -> (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
L.empty, ByteString
l)

toStrict :: L.ByteString -> P.ByteString
toStrict :: ByteString -> ByteString
toStrict = [ByteString] -> ByteString
P.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks