{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.Gopher (
runGopher
, runGopherPure
, GopherConfig (..)
, gophermapToDirectoryResponse
, GopherResponse (..)
, GopherMenuItem (..)
, GopherFileType (..)
, GophermapEntry (..)
, Gophermap (..)
) where
import Prelude hiding (log)
import Network.Gopher.Types
import Network.Gopher.Util
import Network.Gopher.Util.Gophermap
import Control.Applicative ((<$>), (<*>), Applicative (..))
import Control.Concurrent (forkIO, ThreadId ())
import Control.Exception (bracket, catch, IOException (..))
import Control.Monad (forever, when)
import Control.Monad.IO.Class (liftIO, MonadIO (..))
import Control.Monad.Reader (ask, runReaderT, MonadReader (..), ReaderT (..))
import Control.Monad.Error.Class (MonadError (..))
import Data.ByteString (ByteString ())
import qualified Data.ByteString as B
import Data.Maybe (isJust, fromJust, fromMaybe)
import Data.Monoid ((<>))
import qualified Data.String.UTF8 as U
import System.IO
import System.Log.FastLogger
import System.Log.FastLogger.Date
import System.Socket hiding (Error (..))
import System.Socket.Family.Inet6
import System.Socket.Type.Stream
import System.Socket.Protocol.TCP
import System.Posix.User
data GopherConfig
= GopherConfig { cServerName :: ByteString
, cServerPort :: Integer
, cRunUserName :: Maybe String
}
data Env
= Env { serverSocket :: Socket Inet6 Stream TCP
, serverName :: ByteString
, serverPort :: Integer
, serverFun :: (String -> IO GopherResponse)
, logger :: (TimedFastLogger, IO ())
}
initEnv :: Socket Inet6 Stream TCP -> ByteString -> Integer -> (String -> IO GopherResponse) -> IO Env
initEnv sock name port fun = do
timeCache <- newTimeCache simpleTimeFormat
logger <- newTimedFastLogger timeCache (LogStderr 128)
pure $ Env sock name port fun logger
newtype GopherM a = GopherM { runGopherM :: ReaderT Env IO a }
deriving ( Functor, Applicative, Monad
, MonadIO, MonadReader Env, MonadError IOException)
gopherM env action = (runReaderT . runGopherM) action env
data LogMessage = LogError String | LogInfo String
instance ToLogStr LogMessage where
toLogStr (LogError s) = "[Error] " <> toLogStr s
toLogStr (LogInfo s) = "[Info] " <> toLogStr s
log :: LogMessage -> GopherM ()
log logMsg = do
(logger, _) <- logger <$> ask
liftIO $ logger (\t -> "[" <> toLogStr t <> "]" <> (toLogStr logMsg) <> "\n")
receiveRequest :: Socket Inet6 Stream TCP -> IO ByteString
receiveRequest sock = receiveRequest' sock mempty
where lengthLimit = 1024
receiveRequest' sock acc = do
bs <- liftIO $ receive sock lengthLimit mempty
case (B.elemIndex (asciiOrd '\n') bs) of
Just i -> return (acc `B.append` (B.take (i + 1) bs))
Nothing -> if B.length bs < lengthLimit
then return (acc `B.append` bs)
else receiveRequest' sock (acc `B.append` bs)
dropPrivileges :: String -> IO ()
dropPrivileges username = do
uid <- getRealUserID
when (uid /= 0) $ return ()
user <- getUserEntryForName username
setGroupID $ userGroupID user
setUserID $ userID user
runGopher :: GopherConfig -> (String -> IO GopherResponse) -> IO ()
runGopher cfg f = bracket
(socket :: IO (Socket Inet6 Stream TCP))
close
(\sock -> do
env <- initEnv sock (cServerName cfg) (fromInteger (cServerPort cfg)) f
gopherM env $ do
liftIO $ setSocketOption sock (ReuseAddress True)
liftIO $ setSocketOption sock (V6Only False)
liftIO $ bind sock (SocketAddressInet6 inet6Any (fromInteger (cServerPort cfg)) 0 0)
liftIO $ listen sock 5
log. LogInfo $ "Now listening [::]:" ++ show (cServerPort cfg)
if isJust (cRunUserName cfg)
then do
liftIO (dropPrivileges (fromJust (cRunUserName cfg)))
log . LogInfo $ "Dropped privileges to " ++ fromJust (cRunUserName cfg)
else log .LogInfo $ "Privileges were not dropped"
(forever (acceptAndHandle sock) `catchError`
(\e -> do
log . LogError $ show e
snd . logger <$> ask >>= liftIO)))
forkGopherM :: GopherM () -> GopherM ThreadId
forkGopherM action = ask >>= liftIO . forkIO . (flip gopherM) action
handleIncoming :: Socket Inet6 Stream TCP -> Inet6Address -> GopherM ()
handleIncoming clientSock addr = do
req <- liftIO $ uDecode . stripNewline <$> receiveRequest clientSock
log . LogInfo $ "Got request '" ++ req ++ "' from " ++ show addr
fun <- serverFun <$> ask
res <- liftIO (fun req) >>= response
liftIO $ sendAll clientSock res msgNoSignal
liftIO $ close clientSock
log . LogInfo $ "Closed connection succesfully to " ++ show addr
acceptAndHandle :: Socket Inet6 Stream TCP -> GopherM ()
acceptAndHandle sock = do
(clientSock, (SocketAddressInet6 addr _ _ _)) <- liftIO $ accept sock
log . LogInfo $ "Accepted Connection from " ++ show addr
forkGopherM $ handleIncoming clientSock addr `catchError` (\e -> do
liftIO (close clientSock)
log . LogError $ "Closed connection to " ++ show addr ++ " after error: " ++ show e)
return ()
runGopherPure :: GopherConfig -> (String -> GopherResponse) -> IO ()
runGopherPure cfg f = runGopher cfg (fmap pure f)
response :: GopherResponse -> GopherM ByteString
response (MenuResponse items) = do
env <- ask
pure $ foldl (\acc (Item fileType title path host port) ->
B.append acc $
fileTypeToChar fileType `B.cons`
B.concat [ title, uEncode "\t", uEncode path, uEncode "\t", fromMaybe (serverName env) host,
uEncode "\t", uEncode . show $ fromMaybe (serverPort env) port, uEncode "\r\n" ])
B.empty items
response (FileResponse str) = pure str
response (ErrorResponse reason) = do
env <- ask
pure $ fileTypeToChar Error `B.cons`
B.concat [uEncode reason, uEncode $ "\tErr\t", serverName env, uEncode "\t", uEncode . show $ serverPort env, uEncode "\r\n"]