{-# 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" forall a. Maybe a
Nothing Integer
70 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
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
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 { forall a. GopherM a -> ReaderT Env IO a
runGopherM :: ReaderT Env IO a }
  deriving (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
<$ :: forall a b. a -> GopherM b -> GopherM a
$c<$ :: forall a b. a -> GopherM b -> GopherM a
fmap :: forall a b. (a -> b) -> GopherM a -> GopherM b
$cfmap :: forall a b. (a -> b) -> GopherM a -> GopherM b
Functor, Functor GopherM
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
<* :: forall a b. GopherM a -> GopherM b -> GopherM a
$c<* :: forall a b. GopherM a -> GopherM b -> GopherM a
*> :: forall a b. GopherM a -> GopherM b -> GopherM b
$c*> :: forall a b. GopherM a -> GopherM b -> GopherM b
liftA2 :: forall a b c. (a -> b -> c) -> GopherM a -> GopherM b -> GopherM c
$cliftA2 :: forall a b c. (a -> b -> c) -> GopherM a -> GopherM b -> GopherM c
<*> :: forall a b. GopherM (a -> b) -> GopherM a -> GopherM b
$c<*> :: forall a b. GopherM (a -> b) -> GopherM a -> GopherM b
pure :: forall a. a -> GopherM a
$cpure :: forall a. a -> GopherM a
Applicative, Applicative GopherM
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 :: forall a. a -> GopherM a
$creturn :: forall a. a -> GopherM a
>> :: forall a b. GopherM a -> GopherM b -> GopherM b
$c>> :: forall a b. GopherM a -> GopherM b -> GopherM b
>>= :: forall a b. GopherM a -> (a -> GopherM b) -> GopherM b
$c>>= :: forall a b. GopherM a -> (a -> GopherM b) -> GopherM b
Monad, Monad GopherM
forall a. IO a -> GopherM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> GopherM a
$cliftIO :: forall a. IO a -> GopherM a
MonadIO, MonadReader Env)

gopherM :: Env -> GopherM a -> IO a
gopherM :: forall a. Env -> GopherM a -> IO a
gopherM Env
env GopherM a
action = (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. a -> Maybe a -> a
fromMaybe (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> a -> b
$ GopherLogLevel
l) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> GopherConfig
serverConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 :: forall e.
Exception e =>
Maybe GopherLogHandler -> GopherLogStr -> e -> IO ()
logException Maybe GopherLogHandler
logger GopherLogStr
msg e
e =
  Maybe GopherLogHandler -> GopherLogHandler
logIO Maybe GopherLogHandler
logger GopherLogLevel
GopherLogLevelError forall a b. (a -> b) -> a -> b
$ GopherLogStr
msg forall a. Semigroup a => a -> a -> a
<> forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id)
  forall a b. (a -> b) -> a -> b
$ forall a b. IO a -> IO b -> IO (Either a b)
race (Int -> IO ()
threadDelay Int
reqTimeout forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left ByteString
"Request Timeout")) forall a b. (a -> b) -> a -> b
$ do
    ByteString
req <- ByteString -> Int -> IO ByteString
loop forall a. Monoid a => a
mempty Int
0
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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") -> forall a b. b -> Either a b
Right ByteString
r
        (ByteString
r, ByteString
"\n")   -> forall a b. b -> Either a b
Right ByteString
r
        (ByteString
_, ByteString
"")     -> forall a b. a -> Either a b
Left ByteString
"Request too big or unterminated"
        (ByteString, ByteString)
_           -> forall a b. a -> Either a b
Left ByteString
"Unexpected data after newline"
  where newline :: Word8 -> Bool
newline = Bool -> Bool -> Bool
(||)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Eq a => a -> a -> Bool
== Char -> Word8
asciiOrd Char
'\n')
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Eq a => a -> a -> Bool
== Char -> Word8
asciiOrd Char
'\r')
        reqTimeout :: Int
reqTimeout = Int
10000000 -- 10s
        maxSize :: Int
maxSize = Int
1024 forall a. Num a => a -> a -> a
* Int
1024
        loop :: ByteString -> Int -> IO ByteString
loop ByteString
bs Int
size = do
          ByteString
part <- 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 forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
part
          if Int
newSize forall a. Ord a => a -> a -> Bool
>= Int
maxSize Bool -> Bool -> Bool
|| ByteString
part forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty Bool -> Bool -> Bool
|| Word8 -> ByteString -> Bool
B.elem (Char -> Word8
asciiOrd Char
'\n') ByteString
part
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString
bs forall a. Monoid a => a -> a -> a
`mappend` ByteString
part
            else ByteString -> Int -> IO ByteString
loop (ByteString
bs 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 <- (forall f t p. (Family f, Type t, Protocol p) => IO (Socket f t p)
socket :: IO (Socket Inet6 Stream TCP))
  forall o f t p. SocketOption o => Socket f t p -> o -> IO ()
setSocketOption Socket Inet6 Stream TCP
sock (Bool -> ReuseAddress
ReuseAddress Bool
True)
  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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall a b. (a -> b) -> a -> b
$ Inet6Address
-> Inet6Port
-> Inet6FlowInfo
-> Inet6ScopeId
-> SocketAddress Inet6
SocketAddressInet6 Inet6Address
inet6Any (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ GopherConfig -> Integer
cServerPort GopherConfig
cfg
        let flags :: AddressInfoFlags
flags = AddressInfoFlags
aiV4Mapped forall a. Semigroup a => a -> a -> a
<> AddressInfoFlags
aiNumericService
        [AddressInfo Inet6 Stream TCP]
addrs <- (forall f t p.
(HasAddressInfo f, Type t, Protocol p) =>
Maybe ByteString
-> Maybe ByteString -> AddressInfoFlags -> IO [AddressInfo f t p]
getAddressInfo (forall a. a -> Maybe a
Just ByteString
a) (forall a. a -> Maybe a
Just ByteString
port) AddressInfoFlags
flags :: IO [AddressInfo Inet6 Stream TCP])

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

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f t p. AddressInfo f t p -> SocketAddress f
socketAddress forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [AddressInfo Inet6 Stream TCP]
addrs
  forall f t p. Family f => Socket f t p -> SocketAddress f -> IO ()
bind Socket Inet6 Stream TCP
sock SocketAddress Inet6
addr
  forall f t p. Socket f t p -> Int -> IO ()
listen Socket Inet6 Stream TCP
sock Int
5
  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) (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) 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 = 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
    forall a. Env -> GopherM a -> IO a
gopherM (GopherConfig -> (GopherRequest -> IO GopherResponse) -> Env
Env GopherConfig
cfg GopherRequest -> IO GopherResponse
f) forall a b. (a -> b) -> a -> b
$ do
      SocketAddress Inet6
addr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall f t p. Family f => Socket f t p -> IO (SocketAddress f)
getAddress Socket Inet6 Stream TCP
sock
      GopherLogStr -> GopherM ()
logInfo forall a b. (a -> b) -> a -> b
$ GopherLogStr
"Listening on " forall a. Semigroup a => a -> a -> a
<> forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr SocketAddress Inet6
addr

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

      forall (f :: * -> *) a b. Applicative f => f a -> f b
forever 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
    forall a. Env -> GopherM a -> IO a
gopherM Env
env GopherM ()
action forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
      (forall e.
Exception e =>
Maybe GopherLogHandler -> GopherLogStr -> e -> IO ()
logException
        (GopherConfig -> Maybe GopherLogHandler
cLogHandler 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 = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> Maybe ByteString
checkSearch 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 forall a. Ord a => a -> a -> Bool
> Int
1
            then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
B.tail ByteString
search
            else 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 Inet6Address
cIpv6 Inet6Port
_ Inet6FlowInfo
_ Inet6ScopeId
_) = do
  Either ByteString ByteString
request <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> GopherConfig
serverConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  GopherResponse
intermediateResponse <-
    case Either ByteString ByteString
request of
      Left ByteString
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
              { 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 forall a b. (a -> b) -> a -> b
$ GopherLogStr
"New Request \"" forall a. Semigroup a => a -> a -> a
<> forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr ByteString
rawSelector forall a. Semigroup a => a -> a -> a
<> GopherLogStr
"\" from "
          forall a. Semigroup a => a -> a -> a
<> GopherLogStr -> GopherLogStr
makeSensitive (forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr SocketAddress Inet6
addr)

        GopherRequest -> IO GopherResponse
fun <- Env -> GopherRequest -> IO GopherResponse
serverFun forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GopherRequest -> IO GopherResponse
fun GopherRequest
req 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: "
                forall a. Semigroup a => a -> a -> a
<> forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr (forall a. Show a => a -> String
show (SomeException
e :: SomeException))
          Maybe GopherLogHandler -> GopherLogHandler
logIO Maybe GopherLogHandler
logger GopherLogLevel
GopherLogLevelError GopherLogStr
msg
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> GopherResponse
ErrorResponse ByteString
"Unknown error occurred"

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

  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall f p.
Socket f Stream p -> Int -> Builder -> MessageFlags -> IO Int64
sendAllBuilder Socket Inet6 Stream TCP
clientSock Int
10240 Builder
rawResponse MessageFlags
msgNoSignal) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SocketException
e ->
    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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right (forall f t p.
Family f =>
Socket f t p -> IO (Socket f t p, SocketAddress f)
accept Socket Inet6 Stream TCP
sock) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ GopherLogStr
"Failure while accepting connection "
      forall a. Semigroup a => a -> a -> a
<> forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr (forall a. Show a => a -> String
show (SocketException
e :: SocketException))
    Right (Socket Inet6 Stream TCP
clientSock, SocketAddress Inet6
addr) -> do
      GopherLogStr -> GopherM ()
logInfo forall a b. (a -> b) -> a -> b
$ GopherLogStr
"New connection from " forall a. Semigroup a => a -> a -> a
<> GopherLogStr -> GopherLogStr
makeSensitive (forall a. ToGopherLogStr a => a -> GopherLogStr
toGopherLogStr SocketAddress Inet6
addr)
      forall (f :: * -> *) a. Functor f => f a -> f ()
void 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) (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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
BB.byteString ByteString
str
response (ErrorResponse ByteString
reason) = GopherResponse -> GopherM Builder
response forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GopherMenuItem] -> GopherResponse
MenuResponse forall a b. (a -> b) -> a -> b
$
    [ GopherFileType
-> ByteString
-> ByteString
-> Maybe ByteString
-> Maybe Integer
-> GopherMenuItem
Item GopherFileType
Error ByteString
reason ByteString
"Err" forall a. Maybe a
Nothing 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 forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
BB.word8 (GopherFileType -> Word8
fileTypeToChar GopherFileType
fileType) forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (GopherConfig -> Builder -> GopherMenuItem -> Builder
appendItem GopherConfig
cfg) forall a. Monoid a => a
mempty [GopherMenuItem]
items