{-# 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 :: Connection a -> GemHandler -> Maybe Certificate -> IO ()
runConnection Connection a
conn GemHandler
handler Maybe Certificate
mCert =
( Connection a -> IO (Maybe GemURL)
forall a. Connection a -> IO (Maybe GemURL)
readURL Connection a
conn IO (Maybe GemURL)
-> (Maybe GemURL -> IO GemResponse) -> IO GemResponse
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe GemURL
Nothing -> GemResponse -> IO GemResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (GemResponse -> IO GemResponse) -> GemResponse -> IO GemResponse
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 }
) IO GemResponse -> (GemResponse -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection a -> GemResponse -> IO ()
forall a. Connection a -> GemResponse -> IO ()
sendResponse Connection a
conn
readURL
:: Connection a
-> IO (Maybe GemURL)
readURL :: Connection a -> IO (Maybe GemURL)
readURL Connection a
conn =
Int -> Connection a -> IO (Maybe String)
forall a. Int -> Connection a -> IO (Maybe String)
strFromConn Int
inBufSize Connection a
conn IO (Maybe String)
-> (Maybe String -> IO (Maybe GemURL)) -> IO (Maybe GemURL)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe GemURL -> IO (Maybe GemURL)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe GemURL -> IO (Maybe GemURL))
-> (Maybe String -> Maybe GemURL)
-> Maybe String
-> IO (Maybe GemURL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> \case
Maybe String
Nothing -> Maybe GemURL
forall a. Maybe a
Nothing
Just String
str -> String -> Maybe GemURL
decodeGemURL String
str
strFromConn
:: Int
-> Connection a
-> IO (Maybe String)
strFromConn :: Int -> Connection a -> IO (Maybe String)
strFromConn Int
maxLen Connection a
conn = do
Maybe ByteString
mbs <- Int -> Connection a -> IO (Maybe ByteString)
forall a. Int -> Connection a -> IO (Maybe ByteString)
readMax Int
maxLen Connection a
conn
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
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
_ -> Maybe Text
forall a. Maybe a
Nothing
Right Text
s -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
String -> Maybe String
stripCRLF (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
txt
readMax
:: Int
-> Connection a
-> IO (Maybe BS.ByteString)
readMax :: Int -> Connection a -> IO (Maybe ByteString)
readMax Int
maxLen Connection a
conn = do
let src :: InputStream ByteString
src = Connection a -> InputStream ByteString
forall a. Connection a -> InputStream ByteString
source Connection a
conn
MaybeT IO ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO ByteString -> IO (Maybe ByteString))
-> MaybeT IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
[Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> (Builder -> [Word8]) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BSL.unpack (ByteString -> [Word8])
-> (Builder -> ByteString) -> Builder -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
(Builder -> ByteString)
-> MaybeT IO Builder -> MaybeT IO ByteString
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
"" -> Maybe String
forall a. Maybe a
Nothing
String
"\r\n" -> String -> Maybe String
forall a. a -> Maybe a
Just String
""
Char
c:String
str -> (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> Maybe String -> Maybe String
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 = IO (Maybe ByteString) -> MaybeT IO (Maybe ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
S.read InputStream ByteString
src) MaybeT IO (Maybe ByteString)
-> (Maybe ByteString -> MaybeT IO Builder) -> MaybeT IO Builder
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ByteString
Nothing -> Builder -> MaybeT IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
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
Bool -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLen) (MaybeT IO () -> MaybeT IO ()) -> MaybeT IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$
String -> MaybeT IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"maximum length exceeded"
if (Word8 -> Bool) -> ByteString -> Bool
BS.any (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xa) ByteString
bs
then Builder -> MaybeT IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return Builder
b
else (Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder) -> MaybeT IO Builder -> MaybeT IO Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> InputStream ByteString -> MaybeT IO Builder
readLoop (Int
maxLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) InputStream ByteString
src
sendResponse
:: Connection a
-> GemResponse
-> IO ()
sendResponse :: Connection a -> GemResponse -> IO ()
sendResponse Connection a
conn GemResponse
resp = Connection a -> ByteString -> IO ()
forall a. Connection a -> ByteString -> IO ()
send Connection a
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ GemResponse -> ByteString
encodeGemResponse GemResponse
resp