{-|

Module      : Network.Gemini.Capsule.Internal
Description : internal functions (do not use)
Copyright   : (C) Jonathan Lamothe
License     : AGPL-3.0-or-later
Maintainer  : jonathan@jlamothe.net
Stability   : experimental
Portability : POSIX

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public
License along with this program.  If not, see
<https://www.gnu.org/licenses/>.

= Important Note

This is an internal module.  It is not intended to be accessed by
outside packages, and should be considered subject to change at any
time.

-}

{-# 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

-- Constants

-- Maximum size to read from a conneciton
inBufSize :: Int
inBufSize :: Int
inBufSize = Int
1026

-- | process a request and return a response over a 'Connection'
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

-- | Reads a 'GemURL' from a 'Connection'
readURL
  :: Connection a
  -- ^ the connection
  -> 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

-- | Reads up to a maxumum number of bytes from a 'Connection', UTF-8
-- decodes it, and returns the resulting string (if possible) without
-- the trailing CR/LF
strFromConn
  :: Int
  -- ^ The maximum number of bytes to read
  -> Connection a
  -- ^ The connection to read from
  -> 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

-- | Reads from a connection up to a maximum number of bytes or a
-- newline character is encountered, returning 'Nothing' if the limit
-- is exceeded
readMax
  :: Int
  -- ^ the maximum number of bytes
  -> Connection a
  -- ^ the 'Connection' to read from
  -> 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

-- | Strips the CR/LF characters from the end of a string, retuning
-- Nothing if they are not present
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
  -- ^ the connection
  -> GemResponse
  -- ^ the response being sent
  -> 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

--jl