Internal.hs

{-|

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 = 1026

-- | process a request and return a response over a 'Connection'
runConnection
  :: Connection a
  -> GemHandler
  -> Maybe Certificate
  -> IO ()
runConnection conn handler mCert =
  ( readURL conn >>= \case
    Nothing -> return $ newGemResponse
      { respStatus = 59
      , respMeta   = "bad request"
      }
    Just url -> handler (newGemRequest url) { reqCert = mCert }
  ) >>= sendResponse conn

-- | Reads a 'GemURL' from a 'Connection'
readURL
  :: Connection a
  -- ^ the connection
  -> IO (Maybe GemURL)
readURL conn =
  strFromConn inBufSize conn >>= return <$> \case
    Nothing  -> Nothing
    Just str -> decodeGemURL 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 maxLen conn = do
  mbs <- readMax maxLen conn
  return $ do
    bs  <- mbs
    txt <- case decodeUtf8' bs of
      Left _  -> Nothing
      Right s -> Just s
    stripCRLF $ T.unpack 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 maxLen conn = do
  let src = source conn
  runMaybeT $
    BS.pack . BSL.unpack . toLazyByteString
    <$> readLoop maxLen src

-- | Strips the CR/LF characters from the end of a string, retuning
-- Nothing if they are not present
stripCRLF :: String -> Maybe String
stripCRLF = \case
  ""     -> Nothing
  "\r\n" -> Just ""
  c:str  -> (c:) <$> stripCRLF str

readLoop :: Int -> S.InputStream BS.ByteString -> MaybeT IO Builder
readLoop maxLen src = lift (S.read src) >>= \case
  Nothing -> return mempty
  Just bs -> do
    let
      len = BS.length bs
      b   = byteString bs
    when (len > maxLen) $
      fail "maximum length exceeded"
    if BS.any (== 0xa) bs
      then return b
      else (b <>) <$> readLoop (maxLen - len) src

sendResponse
  :: Connection a
  -- ^ the connection
  -> GemResponse
  -- ^ the response being sent
  -> IO ()
sendResponse conn resp = send conn $ encodeGemResponse resp

--jl