{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : Network.Gopher
Stability   : experimental
Portability : POSIX

= Overview

This is the main module of the spacecookie library.
It allows to write gopher applications by taking care of
handling gopher requests while leaving the application
logic to a user-supplied function.

For a small tutorial an example of a trivial pure gopher application:

@
{-# LANGUAGE OverloadedStrings #-}
import "Network.Gopher"
import "Network.Gopher.Util"

cfg :: 'GopherConfig'
cfg = 'defaultConfig'
  { cServerName = "localhost"
  , cServerPort = 7000
  }

handler :: 'GopherRequest' -> 'GopherResponse'
handler request =
  case 'requestSelector' request of
    "hello" -> 'FileResponse' "Hello, stranger!"
    "" -> rootMenu
    "/" -> rootMenu
    _ -> 'ErrorResponse' "Not found"
  where rootMenu = 'MenuResponse'
          [ 'Item' 'File' "greeting" "hello" Nothing Nothing ]

main :: IO ()
main = 'runGopherPure' cfg handler
@

There are three possibilities for a 'GopherResponse':

* 'FileResponse': file type agnostic file response, takes a
  'ByteString' to support both text and binary files.
* 'MenuResponse': a gopher menu (“directory listing”) consisting of a
  list of 'GopherMenuItem's
* 'ErrorResponse': gopher way to show an error (e. g. if a file is not found).
  An 'ErrorResponse' results in a menu response with a single entry.

If you use 'runGopher', it is the same story like in the example above, but
you can do 'IO' effects. To see a more elaborate example, have a look at the
server code in this package.
-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.Gopher (
  -- * Main API
  -- $runGopherVariants
    runGopher
  , runGopherPure
  , runGopherManual
  , GopherConfig (..)
  , defaultConfig
  -- ** Requests
  , GopherRequest (..)
  -- ** Responses
  , GopherResponse (..)
  , GopherMenuItem (..)
  , GopherFileType (..)
  -- * Helper Functions
  -- ** Logging
  -- $loggingDoc
  , GopherLogHandler
  , module Network.Gopher.Log
  -- ** Networking
  , setupGopherSocket
  -- ** Gophermaps
  -- $gophermapDoc
  , gophermapToDirectoryResponse
  , Gophermap
  , GophermapEntry (..)
  ) where

import Prelude hiding (log)

import Network.Gopher.Log
import Network.Gopher.Types
import Network.Gopher.Util
import Network.Gopher.Util.Gophermap
import Network.Gopher.Util.Socket

import Control.Concurrent (forkIO, ThreadId (), threadDelay)
import Control.Concurrent.Async (race)
import Control.Exception (bracket, catch, throw, SomeException (), Exception ())
import Control.Monad (forever, when, void)
import Control.Monad.IO.Class (liftIO, MonadIO (..))
import Control.Monad.Reader (ask, runReaderT, MonadReader (..), ReaderT (..))
import Data.Bifunctor (second)
import Data.ByteString (ByteString ())
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import Data.Maybe (fromMaybe)
import Data.Word (Word16 ())
import System.Socket hiding (Error (..))
import System.Socket.Family.Inet6
import System.Socket.Type.Stream (Stream, sendAllBuilder)
import System.Socket.Protocol.TCP

-- | Necessary information to handle gopher requests
data GopherConfig
  = GopherConfig
  { GopherConfig -> ByteString
cServerName    :: ByteString
  -- ^ Public name of the server (either ip address or dns name).
  --   Gopher clients will use this name to fetch any resources
  --   listed in gopher menus located on the same server.
  , GopherConfig -> Maybe ByteString
cListenAddr    :: Maybe ByteString
  -- ^ Address or hostname to listen on (resolved by @getaddrinfo@).
  --   If 'Nothing', listen on all addresses.
  , GopherConfig -> Integer
cServerPort    :: Integer
  -- ^ Port to listen on
  , GopherConfig -> Maybe GopherLogHandler
cLogHandler    :: Maybe GopherLogHandler
  -- ^ 'IO' action spacecookie will call to output its log messages.
  --   If it is 'Nothing', logging is disabled. See [the logging section](#logging)
  --   for an overview on how to implement a log handler.
  }

-- | Default 'GopherConfig' describing a server on @localhost:70@ with
--   no registered log handler.
defaultConfig :: GopherConfig
defaultConfig :: GopherConfig
defaultConfig = ByteString
-> Maybe ByteString
-> Integer
-> Maybe GopherLogHandler
-> GopherConfig
GopherConfig ByteString
"localhost" Maybe ByteString
forall a. Maybe a
Nothing Integer
70 Maybe GopherLogHandler
forall a. Maybe a
Nothing

-- | Type for an user defined 'IO' action which handles logging a
--   given 'GopherLogStr' of a given 'GopherLogLevel'. It may
--   process the string and format in any way desired, but it must
--   be thread safe and should not block (too long) since it
--   is called syncronously.
type GopherLogHandler = GopherLogLevel -> GopherLogStr -> IO ()

-- $loggingDoc
-- #logging#
-- Logging may be enabled by providing 'GopherConfig' with an optional
-- 'GopherLogHandler' which implements processing, formatting and
-- outputting of log messages. While this requires extra work for the
-- library user it also allows the maximum freedom in used logging
-- mechanisms.
--
-- A trivial log handler could look like this:
--
-- @
-- logHandler :: 'GopherLogHandler'
-- logHandler level str = do
--   putStr $ show level ++ \": \"
--   putStrLn $ 'fromGopherLogStr' str
-- @
--
-- If you only want to log errors you can use the 'Ord' instance of
-- 'GopherLogLevel':
--
-- @
-- logHandler' :: 'GopherLogHandler'
-- logHandler' level str = when (level <= 'GopherLogLevelError')
--   $ logHandler level str
-- @
--
-- The library marks parts of 'GopherLogStr' which contain user
-- related data like IP addresses as sensitive using 'makeSensitive'.
-- If you don't want to e. g. write personal information to disk in
-- plain text, you can use 'hideSensitive' to transparently remove
-- that information. Here's a quick example in GHCi:
--
-- >>> hideSensitive $ "Look at my " <> makeSensitive "secret"
-- "Look at my [redacted]"

-- $gophermapDoc
-- Helper functions for converting 'Gophermap's into 'MenuResponse's.
-- For parsing gophermap files, refer to "Network.Gopher.Util.Gophermap".

data GopherRequest
  = GopherRequest
  { GopherRequest -> ByteString
requestRawSelector  :: ByteString
  -- ^ raw selector sent by the client (without the terminating @\\r\\n@
  , GopherRequest -> ByteString
requestSelector     :: ByteString
  -- ^ only the request selector minus the search expression if present
  , GopherRequest -> Maybe ByteString
requestSearchString :: Maybe ByteString
  -- ^ raw search string if the clients sends a search transaction
  , GopherRequest
-> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
requestClientAddr   :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
  -- ^ IPv6 address of the client which sent the request. IPv4 addresses are
  --   <https://en.wikipedia.org/wiki/IPv6#IPv4-mapped_IPv6_addresses mapped>
  --   to an IPv6 address.
  } deriving (Int -> GopherRequest -> ShowS
[GopherRequest] -> ShowS
GopherRequest -> String
(Int -> GopherRequest -> ShowS)
-> (GopherRequest -> String)
-> ([GopherRequest] -> ShowS)
-> Show GopherRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GopherRequest] -> ShowS
$cshowList :: [GopherRequest] -> ShowS
show :: GopherRequest -> String
$cshow :: GopherRequest -> String
showsPrec :: Int -> GopherRequest -> ShowS
$cshowsPrec :: Int -> GopherRequest -> ShowS
Show, GopherRequest -> GopherRequest -> Bool
(GopherRequest -> GopherRequest -> Bool)
-> (GopherRequest -> GopherRequest -> Bool) -> Eq GopherRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GopherRequest -> GopherRequest -> Bool
$c/= :: GopherRequest -> GopherRequest -> Bool
== :: GopherRequest -> GopherRequest -> Bool
$c== :: GopherRequest -> GopherRequest -> Bool
Eq)

data Env
  = Env
  { Env -> GopherConfig
serverConfig :: GopherConfig
  , Env -> GopherRequest -> IO GopherResponse
serverFun    :: GopherRequest -> IO GopherResponse
  }

newtype GopherM a = GopherM { GopherM a -> ReaderT Env IO a
runGopherM :: ReaderT Env IO a }
  deriving (a -> GopherM b -> GopherM a
(a -> b) -> GopherM a -> GopherM b
(forall a b. (a -> b) -> GopherM a -> GopherM b)
-> (forall a b. a -> GopherM b -> GopherM a) -> Functor GopherM
forall a b. a -> GopherM b -> GopherM a
forall a b. (a -> b) -> GopherM a -> GopherM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> GopherM b -> GopherM a
$c<$ :: forall a b. a -> GopherM b -> GopherM a
fmap :: (a -> b) -> GopherM a -> GopherM b
$cfmap :: forall a b. (a -> b) -> GopherM a -> GopherM b
Functor, Functor GopherM
a -> GopherM a
Functor GopherM
-> (forall a. a -> GopherM a)
-> (forall a b. GopherM (a -> b) -> GopherM a -> GopherM b)
-> (forall a b c.
    (a -> b -> c) -> GopherM a -> GopherM b -> GopherM c)
-> (forall a b. GopherM a -> GopherM b -> GopherM b)
-> (forall a b. GopherM a -> GopherM b -> GopherM a)
-> Applicative GopherM
GopherM a -> GopherM b -> GopherM b
GopherM a -> GopherM b -> GopherM a
GopherM (a -> b) -> GopherM a -> GopherM b
(a -> b -> c) -> GopherM a -> GopherM b -> GopherM c
forall a. a -> GopherM a
forall a b. GopherM a -> GopherM b -> GopherM a
forall a b. GopherM a -> GopherM b -> GopherM b
forall a b. GopherM (a -> b) -> GopherM a -> GopherM b
forall a b c. (a -> b -> c) -> GopherM a -> GopherM b -> GopherM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: GopherM a -> GopherM b -> GopherM a
$c<* :: forall a b. GopherM a -> GopherM b -> GopherM a
*> :: GopherM a -> GopherM b -> GopherM b
$c*> :: forall a b. GopherM a -> GopherM b -> GopherM b
liftA2 :: (a -> b -> c) -> GopherM a -> GopherM b -> GopherM c
$cliftA2 :: forall a b c. (a -> b -> c) -> GopherM a -> GopherM b -> GopherM c
<*> :: GopherM (a -> b) -> GopherM a -> GopherM b
$c<*> :: forall a b. GopherM (a -> b) -> GopherM a -> GopherM b
pure :: a -> GopherM a
$cpure :: forall a. a -> GopherM a
$cp1Applicative :: Functor GopherM
Applicative, Applicative GopherM
a -> GopherM a
Applicative GopherM
-> (forall a b. GopherM a -> (a -> GopherM b) -> GopherM b)
-> (forall a b. GopherM a -> GopherM b -> GopherM b)
-> (forall a. a -> GopherM a)
-> Monad GopherM
GopherM a -> (a -> GopherM b) -> GopherM b
GopherM a -> GopherM b -> GopherM b
forall a. a -> GopherM a
forall a b. GopherM a -> GopherM b -> GopherM b
forall a b. GopherM a -> (a -> GopherM b) -> GopherM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> GopherM a
$creturn :: forall a. a -> GopherM a
>> :: GopherM a -> GopherM b -> GopherM b
$c>> :: forall a b. GopherM a -> GopherM b -> GopherM b
>>= :: GopherM a -> (a -> GopherM b) -> GopherM b
$c>>= :: forall a b. GopherM a -> (a -> GopherM b) -> GopherM b
$cp1Monad :: Applicative GopherM
Monad, Monad GopherM
Monad GopherM -> (forall a. IO a -> GopherM a) -> MonadIO GopherM
IO a -> GopherM a
forall a. IO a -> GopherM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> GopherM a
$cliftIO :: forall a. IO a -> GopherM a
$cp1MonadIO :: Monad GopherM
MonadIO, MonadReader Env)

gopherM :: Env -> GopherM a -> IO a
gopherM :: Env -> GopherM a -> IO a
gopherM Env
env GopherM a
action = (ReaderT Env IO a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT Env IO a -> Env -> IO a)
-> (GopherM a -> ReaderT Env IO a) -> GopherM a -> Env -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GopherM a -> ReaderT Env IO a
forall a. GopherM a -> ReaderT Env IO a
runGopherM) GopherM a
action Env
env

-- call given log handler if it is Just
logIO :: Maybe GopherLogHandler -> GopherLogLevel -> GopherLogStr -> IO ()
logIO :: Maybe GopherLogHandler -> GopherLogHandler
logIO Maybe GopherLogHandler
h GopherLogLevel
l = (GopherLogStr -> IO ())
-> Maybe (GopherLogStr -> IO ()) -> GopherLogStr -> IO ()
forall a. a -> Maybe a -> a
fromMaybe (IO () -> GopherLogStr -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) (Maybe (GopherLogStr -> IO ()) -> GopherLogStr -> IO ())
-> Maybe (GopherLogStr -> IO ()) -> GopherLogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ (GopherLogHandler -> GopherLogHandler
forall a b. (a -> b) -> a -> b
$ GopherLogLevel
l) (GopherLogHandler -> GopherLogStr -> IO ())
-> Maybe GopherLogHandler -> Maybe (GopherLogStr -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GopherLogHandler
h

logInfo :: GopherLogStr -> GopherM ()
logInfo :: GopherLogStr -> GopherM ()
logInfo = GopherLogLevel -> GopherLogStr -> GopherM ()
log GopherLogLevel
GopherLogLevelInfo

logError :: GopherLogStr -> GopherM ()
logError :: GopherLogStr -> GopherM ()
logError = GopherLogLevel -> GopherLogStr -> GopherM ()
log GopherLogLevel
GopherLogLevelError

log :: GopherLogLevel -> GopherLogStr -> GopherM ()
log :: GopherLogLevel -> GopherLogStr -> GopherM ()
log GopherLogLevel
l GopherLogStr
m = do
  Maybe GopherLogHandler
h <- GopherConfig -> Maybe GopherLogHandler
cLogHandler (GopherConfig -> Maybe GopherLogHandler)
-> (Env -> GopherConfig) -> Env -> Maybe GopherLogHandler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> GopherConfig
serverConfig (Env -> Maybe GopherLogHandler)
-> GopherM Env -> GopherM (Maybe GopherLogHandler)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GopherM Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> GopherM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GopherM ()) -> IO () -> GopherM ()
forall a b. (a -> b) -> a -> b
$ Maybe GopherLogHandler -> GopherLogHandler
logIO Maybe GopherLogHandler
h GopherLogLevel
l GopherLogStr
m

logException :: Exception e => Maybe GopherLogHandler -> GopherLogStr -> e -> IO ()
logException :: Maybe GopherLogHandler -> GopherLogStr -> e -> IO ()
logException Maybe GopherLogHandler
logger GopherLogStr
msg e
e =
  Maybe GopherLogHandler -> GopherLogHandler
logIO Maybe GopherLogHandler
logger GopherLogLevel
GopherLogLevelError (GopherLogStr -> IO ()) -> GopherLogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ GopherLogStr
msg GopherLogStr -> GopherLogStr -> GopherLogStr
forall a. Semigroup a => a -> a -> a
<> String -> GopherLogStr
forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr (e -> String
forall a. Show a => a -> String
show e
e)

-- | Read request from a client socket.
--   The complexity of this function is caused by the
--   following design features:
--
--   * Requests may be terminated by either "\n\r" or "\n"
--   * After the terminating newline no extra data is accepted
--   * Give up on waiting on a request from the client after
--     a certain amount of time (request timeout)
--   * Don't accept selectors bigger than a certain size to
--     avoid DoS attacks filling up our memory.
receiveRequest :: Socket Inet6 Stream TCP -> IO (Either ByteString ByteString)
receiveRequest :: Socket Inet6 Stream TCP -> IO (Either ByteString ByteString)
receiveRequest Socket Inet6 Stream TCP
sock = (Either
   (Either ByteString ByteString) (Either ByteString ByteString)
 -> Either ByteString ByteString)
-> IO
     (Either
        (Either ByteString ByteString) (Either ByteString ByteString))
-> IO (Either ByteString ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either ByteString ByteString -> Either ByteString ByteString)
-> (Either ByteString ByteString -> Either ByteString ByteString)
-> Either
     (Either ByteString ByteString) (Either ByteString ByteString)
-> Either ByteString ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Either ByteString ByteString -> Either ByteString ByteString
forall a. a -> a
id Either ByteString ByteString -> Either ByteString ByteString
forall a. a -> a
id)
  (IO
   (Either
      (Either ByteString ByteString) (Either ByteString ByteString))
 -> IO (Either ByteString ByteString))
-> IO
     (Either
        (Either ByteString ByteString) (Either ByteString ByteString))
-> IO (Either ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ IO (Either ByteString ByteString)
-> IO (Either ByteString ByteString)
-> IO
     (Either
        (Either ByteString ByteString) (Either ByteString ByteString))
forall a b. IO a -> IO b -> IO (Either a b)
race (Int -> IO ()
threadDelay Int
reqTimeout IO ()
-> IO (Either ByteString ByteString)
-> IO (Either ByteString ByteString)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either ByteString ByteString -> IO (Either ByteString ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left ByteString
"Request Timeout")) (IO (Either ByteString ByteString)
 -> IO
      (Either
         (Either ByteString ByteString) (Either ByteString ByteString)))
-> IO (Either ByteString ByteString)
-> IO
     (Either
        (Either ByteString ByteString) (Either ByteString ByteString))
forall a b. (a -> b) -> a -> b
$ do
    ByteString
req <- ByteString -> Int -> IO ByteString
loop ByteString
forall a. Monoid a => a
mempty Int
0
    Either ByteString ByteString -> IO (Either ByteString ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ByteString ByteString -> IO (Either ByteString ByteString))
-> Either ByteString ByteString
-> IO (Either ByteString ByteString)
forall a b. (a -> b) -> a -> b
$
      case (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
B.break Word8 -> Bool
newline ByteString
req of
        (ByteString
r, ByteString
"\r\n") -> ByteString -> Either ByteString ByteString
forall a b. b -> Either a b
Right ByteString
r
        (ByteString
r, ByteString
"\n")   -> ByteString -> Either ByteString ByteString
forall a b. b -> Either a b
Right ByteString
r
        (ByteString
_, ByteString
"")     -> ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left ByteString
"Request too big or unterminated"
        (ByteString, ByteString)
_           -> ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left ByteString
"Unexpected data after newline"
  where newline :: Word8 -> Bool
newline = Bool -> Bool -> Bool
(||)
          (Bool -> Bool -> Bool) -> (Word8 -> Bool) -> Word8 -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
asciiOrd Char
'\n')
          (Word8 -> Bool -> Bool) -> (Word8 -> Bool) -> Word8 -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
asciiOrd Char
'\r')
        reqTimeout :: Int
reqTimeout = Int
10000000 -- 10s
        maxSize :: Int
maxSize = Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
        loop :: ByteString -> Int -> IO ByteString
loop ByteString
bs Int
size = do
          ByteString
part <- Socket Inet6 Stream TCP -> Int -> MessageFlags -> IO ByteString
forall f t p. Socket f t p -> Int -> MessageFlags -> IO ByteString
receive Socket Inet6 Stream TCP
sock Int
maxSize MessageFlags
msgNoSignal
          let newSize :: Int
newSize = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
part
          if Int
newSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxSize Bool -> Bool -> Bool
|| ByteString
part ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. Monoid a => a
mempty Bool -> Bool -> Bool
|| Word8 -> ByteString -> Bool
B.elem (Char -> Word8
asciiOrd Char
'\n') ByteString
part
            then ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
`mappend` ByteString
part
            else ByteString -> Int -> IO ByteString
loop (ByteString
bs ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
`mappend` ByteString
part) Int
newSize

-- | Auxiliary function that sets up the listening socket for
--   'runGopherManual' correctly and starts to listen.
--
--   May throw a 'SocketException' if an error occurs while
--   setting up the socket.
setupGopherSocket :: GopherConfig -> IO (Socket Inet6 Stream TCP)
setupGopherSocket :: GopherConfig -> IO (Socket Inet6 Stream TCP)
setupGopherSocket GopherConfig
cfg = do
  Socket Inet6 Stream TCP
sock <- (IO (Socket Inet6 Stream TCP)
forall f t p. (Family f, Type t, Protocol p) => IO (Socket f t p)
socket :: IO (Socket Inet6 Stream TCP))
  Socket Inet6 Stream TCP -> ReuseAddress -> IO ()
forall o f t p. SocketOption o => Socket f t p -> o -> IO ()
setSocketOption Socket Inet6 Stream TCP
sock (Bool -> ReuseAddress
ReuseAddress Bool
True)
  Socket Inet6 Stream TCP -> V6Only -> IO ()
forall o f t p. SocketOption o => Socket f t p -> o -> IO ()
setSocketOption Socket Inet6 Stream TCP
sock (Bool -> V6Only
V6Only Bool
False)
  SocketAddress Inet6
addr <-
    case GopherConfig -> Maybe ByteString
cListenAddr GopherConfig
cfg of
      Maybe ByteString
Nothing -> SocketAddress Inet6 -> IO (SocketAddress Inet6)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (SocketAddress Inet6 -> IO (SocketAddress Inet6))
-> SocketAddress Inet6 -> IO (SocketAddress Inet6)
forall a b. (a -> b) -> a -> b
$ Inet6Address
-> Inet6Port
-> Inet6FlowInfo
-> Inet6ScopeId
-> SocketAddress Inet6
SocketAddressInet6 Inet6Address
inet6Any (Integer -> Inet6Port
forall a. Num a => Integer -> a
fromInteger (GopherConfig -> Integer
cServerPort GopherConfig
cfg)) Inet6FlowInfo
0 Inet6ScopeId
0
      Just ByteString
a -> do
        let port :: ByteString
port = String -> ByteString
uEncode (String -> ByteString)
-> (Integer -> String) -> Integer -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> ByteString) -> Integer -> ByteString
forall a b. (a -> b) -> a -> b
$ GopherConfig -> Integer
cServerPort GopherConfig
cfg
        let flags :: AddressInfoFlags
flags = AddressInfoFlags
aiV4Mapped AddressInfoFlags -> AddressInfoFlags -> AddressInfoFlags
forall a. Semigroup a => a -> a -> a
<> AddressInfoFlags
aiNumericService
        [AddressInfo Inet6 Stream TCP]
addrs <- (Maybe ByteString
-> Maybe ByteString
-> AddressInfoFlags
-> IO [AddressInfo Inet6 Stream TCP]
forall f t p.
(HasAddressInfo f, Type t, Protocol p) =>
Maybe ByteString
-> Maybe ByteString -> AddressInfoFlags -> IO [AddressInfo f t p]
getAddressInfo (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
a) (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
port) AddressInfoFlags
flags :: IO [AddressInfo Inet6 Stream TCP])

        -- should be done by getAddressInfo already
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([AddressInfo Inet6 Stream TCP] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AddressInfo Inet6 Stream TCP]
addrs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AddressInfoException -> IO ()
forall a e. Exception e => e -> a
throw AddressInfoException
eaiNoName

        SocketAddress Inet6 -> IO (SocketAddress Inet6)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SocketAddress Inet6 -> IO (SocketAddress Inet6))
-> (AddressInfo Inet6 Stream TCP -> SocketAddress Inet6)
-> AddressInfo Inet6 Stream TCP
-> IO (SocketAddress Inet6)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressInfo Inet6 Stream TCP -> SocketAddress Inet6
forall f t p. AddressInfo f t p -> SocketAddress f
socketAddress (AddressInfo Inet6 Stream TCP -> IO (SocketAddress Inet6))
-> AddressInfo Inet6 Stream TCP -> IO (SocketAddress Inet6)
forall a b. (a -> b) -> a -> b
$ [AddressInfo Inet6 Stream TCP] -> AddressInfo Inet6 Stream TCP
forall a. [a] -> a
head [AddressInfo Inet6 Stream TCP]
addrs
  Socket Inet6 Stream TCP -> SocketAddress Inet6 -> IO ()
forall f t p. Family f => Socket f t p -> SocketAddress f -> IO ()
bind Socket Inet6 Stream TCP
sock SocketAddress Inet6
addr
  Socket Inet6 Stream TCP -> Int -> IO ()
forall f t p. Socket f t p -> Int -> IO ()
listen Socket Inet6 Stream TCP
sock Int
5
  Socket Inet6 Stream TCP -> IO (Socket Inet6 Stream TCP)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket Inet6 Stream TCP
sock

-- $runGopherVariants
-- The @runGopher@ function variants will generally not throw exceptions,
-- but handle them somehow (usually by logging that a non-fatal exception
-- occurred) except if the exception occurrs in the setup step of
-- 'runGopherManual'.
--
-- You'll have to handle those exceptions yourself. To see which exceptions
-- can be thrown by 'runGopher' and 'runGopherPure', read the documentation
-- of 'setupGopherSocket'.

-- | Run a gopher application that may cause effects in 'IO'.
--   The application function is given the 'GopherRequest'
--   sent by the client and must produce a GopherResponse.
runGopher :: GopherConfig -> (GopherRequest -> IO GopherResponse) -> IO ()
runGopher :: GopherConfig -> (GopherRequest -> IO GopherResponse) -> IO ()
runGopher GopherConfig
cfg GopherRequest -> IO GopherResponse
f = IO (Socket Inet6 Stream TCP)
-> IO ()
-> (Socket Inet6 Stream TCP -> IO ())
-> GopherConfig
-> (GopherRequest -> IO GopherResponse)
-> IO ()
runGopherManual (GopherConfig -> IO (Socket Inet6 Stream TCP)
setupGopherSocket GopherConfig
cfg) (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Socket Inet6 Stream TCP -> IO ()
forall f t p. Socket f t p -> IO ()
close GopherConfig
cfg GopherRequest -> IO GopherResponse
f

-- | Same as 'runGopher', but allows you to setup the 'Socket' manually
--   and calls an user provided action soon as the server is ready
--   to accept requests. When the server terminates, it calls the given
--   clean up action which must close the socket and may perform other
--   shutdown tasks (like notifying a supervisor it is stopping).
--
--   Spacecookie assumes the 'Socket' is properly set up to listen on the
--   port and host specified in the 'GopherConfig' (i. e. 'bind' and
--   'listen' have been called). This can be achieved using 'setupGopherSocket'.
--   Especially note that spacecookie does /not/ check if the listening
--   address and port of the given socket match 'cListenAddr' and
--   'cServerPort'.
--
--   This is intended for supporting systemd socket activation and storage,
--   but may also be used to support other use cases where more control is
--   necessary. Always use 'runGopher' if possible, as it offers less ways
--   of messing things up.
runGopherManual :: IO (Socket Inet6 Stream TCP)         -- ^ action to set up listening socket
                -> IO ()                                -- ^ ready action called after startup
                -> (Socket Inet6 Stream TCP -> IO ())   -- ^ socket clean up action
                -> GopherConfig                         -- ^ server config
                -> (GopherRequest -> IO GopherResponse) -- ^ request handler
                -> IO ()
runGopherManual :: IO (Socket Inet6 Stream TCP)
-> IO ()
-> (Socket Inet6 Stream TCP -> IO ())
-> GopherConfig
-> (GopherRequest -> IO GopherResponse)
-> IO ()
runGopherManual IO (Socket Inet6 Stream TCP)
sockAction IO ()
ready Socket Inet6 Stream TCP -> IO ()
term GopherConfig
cfg GopherRequest -> IO GopherResponse
f = IO (Socket Inet6 Stream TCP)
-> (Socket Inet6 Stream TCP -> IO ())
-> (Socket Inet6 Stream TCP -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
  IO (Socket Inet6 Stream TCP)
sockAction
  Socket Inet6 Stream TCP -> IO ()
term
  (\Socket Inet6 Stream TCP
sock -> do
    Env -> GopherM () -> IO ()
forall a. Env -> GopherM a -> IO a
gopherM (GopherConfig -> (GopherRequest -> IO GopherResponse) -> Env
Env GopherConfig
cfg GopherRequest -> IO GopherResponse
f) (GopherM () -> IO ()) -> GopherM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      SocketAddress Inet6
addr <- IO (SocketAddress Inet6) -> GopherM (SocketAddress Inet6)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SocketAddress Inet6) -> GopherM (SocketAddress Inet6))
-> IO (SocketAddress Inet6) -> GopherM (SocketAddress Inet6)
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP -> IO (SocketAddress Inet6)
forall f t p. Family f => Socket f t p -> IO (SocketAddress f)
getAddress Socket Inet6 Stream TCP
sock
      GopherLogStr -> GopherM ()
logInfo (GopherLogStr -> GopherM ()) -> GopherLogStr -> GopherM ()
forall a b. (a -> b) -> a -> b
$ GopherLogStr
"Listening on " GopherLogStr -> GopherLogStr -> GopherLogStr
forall a. Semigroup a => a -> a -> a
<> SocketAddress Inet6 -> GopherLogStr
forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr SocketAddress Inet6
addr

      IO () -> GopherM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GopherM ()) -> IO () -> GopherM ()
forall a b. (a -> b) -> a -> b
$ IO ()
ready

      GopherM () -> GopherM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (GopherM () -> GopherM ()) -> GopherM () -> GopherM ()
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP -> GopherM ()
acceptAndHandle Socket Inet6 Stream TCP
sock)

forkGopherM :: GopherM () -> IO () -> GopherM ThreadId
forkGopherM :: GopherM () -> IO () -> GopherM ThreadId
forkGopherM GopherM ()
action IO ()
cleanup = do
  Env
env <- GopherM Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO ThreadId -> GopherM ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> GopherM ThreadId)
-> IO ThreadId -> GopherM ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Env -> GopherM () -> IO ()
forall a. Env -> GopherM a -> IO a
gopherM Env
env GopherM ()
action IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
      (Maybe GopherLogHandler -> GopherLogStr -> SomeException -> IO ()
forall e.
Exception e =>
Maybe GopherLogHandler -> GopherLogStr -> e -> IO ()
logException
        (GopherConfig -> Maybe GopherLogHandler
cLogHandler (GopherConfig -> Maybe GopherLogHandler)
-> GopherConfig -> Maybe GopherLogHandler
forall a b. (a -> b) -> a -> b
$ Env -> GopherConfig
serverConfig Env
env)
        GopherLogStr
"Thread failed with exception: " :: SomeException -> IO ())
    IO ()
cleanup

-- | Split an selector in the actual search selector and
--   an optional search expression as documented in the
--   RFC1436 appendix.
splitSelector :: ByteString -> (ByteString, Maybe ByteString)
splitSelector :: ByteString -> (ByteString, Maybe ByteString)
splitSelector = (ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> (ByteString, Maybe ByteString)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> Maybe ByteString
checkSearch ((ByteString, ByteString) -> (ByteString, Maybe ByteString))
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> (ByteString, Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
"\t"
  where checkSearch :: ByteString -> Maybe ByteString
checkSearch ByteString
search =
          if ByteString -> Int
B.length ByteString
search Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
            then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.tail ByteString
search
            else Maybe ByteString
forall a. Maybe a
Nothing

handleIncoming :: Socket Inet6 Stream TCP -> SocketAddress Inet6 -> GopherM ()
handleIncoming :: Socket Inet6 Stream TCP -> SocketAddress Inet6 -> GopherM ()
handleIncoming Socket Inet6 Stream TCP
clientSock addr :: SocketAddress Inet6
addr@(SocketAddressInet6 cIpv6 _ _ _) = do
  Either ByteString ByteString
request <- IO (Either ByteString ByteString)
-> GopherM (Either ByteString ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ByteString ByteString)
 -> GopherM (Either ByteString ByteString))
-> IO (Either ByteString ByteString)
-> GopherM (Either ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP -> IO (Either ByteString ByteString)
receiveRequest Socket Inet6 Stream TCP
clientSock
  Maybe GopherLogHandler
logger <- GopherConfig -> Maybe GopherLogHandler
cLogHandler (GopherConfig -> Maybe GopherLogHandler)
-> (Env -> GopherConfig) -> Env -> Maybe GopherLogHandler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> GopherConfig
serverConfig (Env -> Maybe GopherLogHandler)
-> GopherM Env -> GopherM (Maybe GopherLogHandler)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GopherM Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  GopherResponse
intermediateResponse <-
    case Either ByteString ByteString
request of
      Left ByteString
e -> GopherResponse -> GopherM GopherResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GopherResponse -> GopherM GopherResponse)
-> GopherResponse -> GopherM GopherResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> GopherResponse
ErrorResponse ByteString
e
      Right ByteString
rawSelector -> do
        let (ByteString
onlySel, Maybe ByteString
search) = ByteString -> (ByteString, Maybe ByteString)
splitSelector ByteString
rawSelector
            req :: GopherRequest
req = GopherRequest :: ByteString
-> ByteString
-> Maybe ByteString
-> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
-> GopherRequest
GopherRequest
              { requestRawSelector :: ByteString
requestRawSelector = ByteString
rawSelector
              , requestSelector :: ByteString
requestSelector = ByteString
onlySel
              , requestSearchString :: Maybe ByteString
requestSearchString = Maybe ByteString
search
              , requestClientAddr :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
requestClientAddr  = Inet6Address
-> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
inet6AddressToTuple Inet6Address
cIpv6
              }

        GopherLogStr -> GopherM ()
logInfo (GopherLogStr -> GopherM ()) -> GopherLogStr -> GopherM ()
forall a b. (a -> b) -> a -> b
$ GopherLogStr
"New Request \"" GopherLogStr -> GopherLogStr -> GopherLogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> GopherLogStr
forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr ByteString
rawSelector GopherLogStr -> GopherLogStr -> GopherLogStr
forall a. Semigroup a => a -> a -> a
<> GopherLogStr
"\" from "
          GopherLogStr -> GopherLogStr -> GopherLogStr
forall a. Semigroup a => a -> a -> a
<> GopherLogStr -> GopherLogStr
makeSensitive (SocketAddress Inet6 -> GopherLogStr
forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr SocketAddress Inet6
addr)

        GopherRequest -> IO GopherResponse
fun <- Env -> GopherRequest -> IO GopherResponse
serverFun (Env -> GopherRequest -> IO GopherResponse)
-> GopherM Env -> GopherM (GopherRequest -> IO GopherResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GopherM Env
forall r (m :: * -> *). MonadReader r m => m r
ask
        IO GopherResponse -> GopherM GopherResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GopherResponse -> GopherM GopherResponse)
-> IO GopherResponse -> GopherM GopherResponse
forall a b. (a -> b) -> a -> b
$ GopherRequest -> IO GopherResponse
fun GopherRequest
req IO GopherResponse
-> (SomeException -> IO GopherResponse) -> IO GopherResponse
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> do
          let msg :: GopherLogStr
msg = GopherLogStr
"Unhandled exception in handler: "
                GopherLogStr -> GopherLogStr -> GopherLogStr
forall a. Semigroup a => a -> a -> a
<> String -> GopherLogStr
forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException))
          Maybe GopherLogHandler -> GopherLogHandler
logIO Maybe GopherLogHandler
logger GopherLogLevel
GopherLogLevelError GopherLogStr
msg
          GopherResponse -> IO GopherResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GopherResponse -> IO GopherResponse)
-> GopherResponse -> IO GopherResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> GopherResponse
ErrorResponse ByteString
"Unknown error occurred"

  Builder
rawResponse <- GopherResponse -> GopherM Builder
response GopherResponse
intermediateResponse

  IO () -> GopherM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GopherM ()) -> IO () -> GopherM ()
forall a b. (a -> b) -> a -> b
$ IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Socket Inet6 Stream TCP
-> Int -> Builder -> MessageFlags -> IO Int64
forall f p.
Socket f Stream p -> Int -> Builder -> MessageFlags -> IO Int64
sendAllBuilder Socket Inet6 Stream TCP
clientSock Int
10240 Builder
rawResponse MessageFlags
msgNoSignal) IO () -> (SocketException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SocketException
e ->
    Maybe GopherLogHandler -> GopherLogStr -> SocketException -> IO ()
forall e.
Exception e =>
Maybe GopherLogHandler -> GopherLogStr -> e -> IO ()
logException Maybe GopherLogHandler
logger GopherLogStr
"Exception while sending response to client: " (SocketException
e :: SocketException)

acceptAndHandle :: Socket Inet6 Stream TCP -> GopherM ()
acceptAndHandle :: Socket Inet6 Stream TCP -> GopherM ()
acceptAndHandle Socket Inet6 Stream TCP
sock = do
  Either
  SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)
connection <- IO
  (Either
     SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
-> GopherM
     (Either
        SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either
      SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
 -> GopherM
      (Either
         SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)))
-> IO
     (Either
        SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
-> GopherM
     (Either
        SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
forall a b. (a -> b) -> a -> b
$ ((Socket Inet6 Stream TCP, SocketAddress Inet6)
 -> Either
      SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
-> IO (Socket Inet6 Stream TCP, SocketAddress Inet6)
-> IO
     (Either
        SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Socket Inet6 Stream TCP, SocketAddress Inet6)
-> Either
     SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)
forall a b. b -> Either a b
Right (Socket Inet6 Stream TCP
-> IO (Socket Inet6 Stream TCP, SocketAddress Inet6)
forall f t p.
Family f =>
Socket f t p -> IO (Socket f t p, SocketAddress f)
accept Socket Inet6 Stream TCP
sock) IO
  (Either
     SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
-> (SocketException
    -> IO
         (Either
            SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)))
-> IO
     (Either
        SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Either
  SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)
-> IO
     (Either
        SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)
 -> IO
      (Either
         SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)))
-> (SocketException
    -> Either
         SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
-> SocketException
-> IO
     (Either
        SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SocketException
-> Either
     SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)
forall a b. a -> Either a b
Left)
  case Either
  SocketException (Socket Inet6 Stream TCP, SocketAddress Inet6)
connection of
    Left SocketException
e -> GopherLogStr -> GopherM ()
logError (GopherLogStr -> GopherM ()) -> GopherLogStr -> GopherM ()
forall a b. (a -> b) -> a -> b
$ GopherLogStr
"Failure while accepting connection "
      GopherLogStr -> GopherLogStr -> GopherLogStr
forall a. Semigroup a => a -> a -> a
<> String -> GopherLogStr
forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr (SocketException -> String
forall a. Show a => a -> String
show (SocketException
e :: SocketException))
    Right (Socket Inet6 Stream TCP
clientSock, SocketAddress Inet6
addr) -> do
      GopherLogStr -> GopherM ()
logInfo (GopherLogStr -> GopherM ()) -> GopherLogStr -> GopherM ()
forall a b. (a -> b) -> a -> b
$ GopherLogStr
"New connection from " GopherLogStr -> GopherLogStr -> GopherLogStr
forall a. Semigroup a => a -> a -> a
<> GopherLogStr -> GopherLogStr
makeSensitive (SocketAddress Inet6 -> GopherLogStr
forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr SocketAddress Inet6
addr)
      GopherM ThreadId -> GopherM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (GopherM ThreadId -> GopherM ()) -> GopherM ThreadId -> GopherM ()
forall a b. (a -> b) -> a -> b
$ GopherM () -> IO () -> GopherM ThreadId
forkGopherM (Socket Inet6 Stream TCP -> SocketAddress Inet6 -> GopherM ()
handleIncoming Socket Inet6 Stream TCP
clientSock SocketAddress Inet6
addr) (Socket Inet6 Stream TCP -> IO ()
forall f. Family f => Socket f Stream TCP -> IO ()
gracefulClose Socket Inet6 Stream TCP
clientSock)

-- | Like 'runGopher', but may not cause effects in 'IO' (or anywhere else).
runGopherPure :: GopherConfig -> (GopherRequest -> GopherResponse) -> IO ()
runGopherPure :: GopherConfig -> (GopherRequest -> GopherResponse) -> IO ()
runGopherPure GopherConfig
cfg GopherRequest -> GopherResponse
f = GopherConfig -> (GopherRequest -> IO GopherResponse) -> IO ()
runGopher GopherConfig
cfg ((GopherResponse -> IO GopherResponse)
-> (GopherRequest -> GopherResponse)
-> GopherRequest
-> IO GopherResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GopherResponse -> IO GopherResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure GopherRequest -> GopherResponse
f)

response :: GopherResponse -> GopherM BB.Builder
response :: GopherResponse -> GopherM Builder
response (FileResponse ByteString
str) = Builder -> GopherM Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> GopherM Builder) -> Builder -> GopherM Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
BB.byteString ByteString
str
response (ErrorResponse ByteString
reason) = GopherResponse -> GopherM Builder
response (GopherResponse -> GopherM Builder)
-> ([GopherMenuItem] -> GopherResponse)
-> [GopherMenuItem]
-> GopherM Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GopherMenuItem] -> GopherResponse
MenuResponse ([GopherMenuItem] -> GopherM Builder)
-> [GopherMenuItem] -> GopherM Builder
forall a b. (a -> b) -> a -> b
$
    [ GopherFileType
-> ByteString
-> ByteString
-> Maybe ByteString
-> Maybe Integer
-> GopherMenuItem
Item GopherFileType
Error ByteString
reason ByteString
"Err" Maybe ByteString
forall a. Maybe a
Nothing Maybe Integer
forall a. Maybe a
Nothing ]
response (MenuResponse [GopherMenuItem]
items) =
  let appendItem :: GopherConfig -> Builder -> GopherMenuItem -> Builder
appendItem GopherConfig
cfg Builder
acc (Item GopherFileType
fileType ByteString
title ByteString
path Maybe ByteString
host Maybe Integer
port) =
        Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
BB.word8 (GopherFileType -> Word8
fileTypeToChar GopherFileType
fileType) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
          [ ByteString -> Builder
BB.byteString ByteString
title
          , Char -> Builder
BB.charUtf8 Char
'\t'
          , ByteString -> Builder
BB.byteString ByteString
path
          , Char -> Builder
BB.charUtf8 Char
'\t'
          , ByteString -> Builder
BB.byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (GopherConfig -> ByteString
cServerName GopherConfig
cfg) Maybe ByteString
host
          , Char -> Builder
BB.charUtf8 Char
'\t'
          , Int -> Builder
BB.intDec (Int -> Builder) -> (Integer -> Int) -> Integer -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Builder) -> Integer -> Builder
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe (GopherConfig -> Integer
cServerPort GopherConfig
cfg) Maybe Integer
port
          , ByteString -> Builder
BB.byteString ByteString
"\r\n"
          ]
   in do
  GopherConfig
cfg <- Env -> GopherConfig
serverConfig (Env -> GopherConfig) -> GopherM Env -> GopherM GopherConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GopherM Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  Builder -> GopherM Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> GopherM Builder) -> Builder -> GopherM Builder
forall a b. (a -> b) -> a -> b
$ (Builder -> GopherMenuItem -> Builder)
-> Builder -> [GopherMenuItem] -> Builder
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (GopherConfig -> Builder -> GopherMenuItem -> Builder
appendItem GopherConfig
cfg) Builder
forall a. Monoid a => a
mempty [GopherMenuItem]
items