{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.Gopher (
runGopher
, runGopherPure
, runGopherManual
, GopherConfig (..)
, defaultConfig
, GopherRequest (..)
, GopherResponse (..)
, GopherMenuItem (..)
, GopherFileType (..)
, GopherLogHandler
, module Network.Gopher.Log
, setupGopherSocket
, 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
data GopherConfig
= GopherConfig
{ GopherConfig -> ByteString
cServerName :: ByteString
, GopherConfig -> Maybe ByteString
cListenAddr :: Maybe ByteString
, GopherConfig -> Integer
cServerPort :: Integer
, GopherConfig -> Maybe GopherLogHandler
cLogHandler :: Maybe GopherLogHandler
}
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 GopherLogHandler = GopherLogLevel -> GopherLogStr -> IO ()
data GopherRequest
= GopherRequest
{ GopherRequest -> ByteString
requestRawSelector :: ByteString
, GopherRequest -> ByteString
requestSelector :: ByteString
, GopherRequest -> Maybe ByteString
requestSearchString :: Maybe ByteString
, GopherRequest
-> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
requestClientAddr :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
} 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
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)
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
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
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])
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
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
runGopherManual :: IO (Socket Inet6 Stream TCP)
-> IO ()
-> (Socket Inet6 Stream TCP -> IO ())
-> GopherConfig
-> (GopherRequest -> IO GopherResponse)
-> 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
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)
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