{-# 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" Maybe ByteString
forall a. Maybe a
Nothing Integer
70 Maybe GopherLogHandler
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
(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
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)
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
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
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])
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
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
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 = 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
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)
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