{-# LANGUAGE LambdaCase #-}
module Network.Gemini.Capsule.Internal (
runConnection,
readURL,
strFromConn,
readMax,
stripCRLF
) where
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder, byteString, toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.Connection (Connection, send, source)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8')
import Data.X509 (Certificate)
import qualified System.IO.Streams as S
import Network.Gemini.Capsule.Encoding
import Network.Gemini.Capsule.Types
inBufSize :: Int
inBufSize :: Int
inBufSize = Int
1026
runConnection
:: Connection a
-> GemHandler
-> Maybe Certificate
-> IO ()
runConnection :: forall a. Connection a -> GemHandler -> Maybe Certificate -> IO ()
runConnection Connection a
conn GemHandler
handler Maybe Certificate
mCert =
( forall a. Connection a -> IO (Maybe GemURL)
readURL Connection a
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe GemURL
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GemResponse
newGemResponse
{ respStatus :: Word8
respStatus = Word8
59
, respMeta :: String
respMeta = String
"bad request"
}
Just GemURL
url -> GemHandler
handler (GemURL -> GemRequest
newGemRequest GemURL
url) { reqCert :: Maybe Certificate
reqCert = Maybe Certificate
mCert }
) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Connection a -> GemResponse -> IO ()
sendResponse Connection a
conn
readURL
:: Connection a
-> IO (Maybe GemURL)
readURL :: forall a. Connection a -> IO (Maybe GemURL)
readURL Connection a
conn =
forall a. Int -> Connection a -> IO (Maybe String)
strFromConn Int
inBufSize Connection a
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> \case
Maybe String
Nothing -> forall a. Maybe a
Nothing
Just String
str -> String -> Maybe GemURL
decodeGemURL String
str
strFromConn
:: Int
-> Connection a
-> IO (Maybe String)
strFromConn :: forall a. Int -> Connection a -> IO (Maybe String)
strFromConn Int
maxLen Connection a
conn = do
Maybe ByteString
mbs <- forall a. Int -> Connection a -> IO (Maybe ByteString)
readMax Int
maxLen Connection a
conn
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
ByteString
bs <- Maybe ByteString
mbs
Text
txt <- case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bs of
Left UnicodeException
_ -> forall a. Maybe a
Nothing
Right Text
s -> forall a. a -> Maybe a
Just Text
s
String -> Maybe String
stripCRLF forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
txt
readMax
:: Int
-> Connection a
-> IO (Maybe BS.ByteString)
readMax :: forall a. Int -> Connection a -> IO (Maybe ByteString)
readMax Int
maxLen Connection a
conn = do
let src :: InputStream ByteString
src = forall a. Connection a -> InputStream ByteString
source Connection a
conn
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$
[Word8] -> ByteString
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BSL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> InputStream ByteString -> MaybeT IO Builder
readLoop Int
maxLen InputStream ByteString
src
stripCRLF :: String -> Maybe String
stripCRLF :: String -> Maybe String
stripCRLF = \case
String
"" -> forall a. Maybe a
Nothing
String
"\r\n" -> forall a. a -> Maybe a
Just String
""
Char
c:String
str -> (Char
cforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String
stripCRLF String
str
readLoop :: Int -> S.InputStream BS.ByteString -> MaybeT IO Builder
readLoop :: Int -> InputStream ByteString -> MaybeT IO Builder
readLoop Int
maxLen InputStream ByteString
src = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. InputStream a -> IO (Maybe a)
S.read InputStream ByteString
src) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
Just ByteString
bs -> do
let
len :: Int
len = ByteString -> Int
BS.length ByteString
bs
b :: Builder
b = ByteString -> Builder
byteString ByteString
bs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len forall a. Ord a => a -> a -> Bool
> Int
maxLen) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"maximum length exceeded"
if (Word8 -> Bool) -> ByteString -> Bool
BS.any (forall a. Eq a => a -> a -> Bool
== Word8
0xa) ByteString
bs
then forall (m :: * -> *) a. Monad m => a -> m a
return Builder
b
else (Builder
b forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> InputStream ByteString -> MaybeT IO Builder
readLoop (Int
maxLen forall a. Num a => a -> a -> a
- Int
len) InputStream ByteString
src
sendResponse
:: Connection a
-> GemResponse
-> IO ()
sendResponse :: forall a. Connection a -> GemResponse -> IO ()
sendResponse Connection a
conn GemResponse
resp = forall a. Connection a -> ByteString -> IO ()
send Connection a
conn forall a b. (a -> b) -> a -> b
$ GemResponse -> ByteString
encodeGemResponse GemResponse
resp