{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.Gopher (
runGopher
, runGopherPure
, runGopherManual
, GopherConfig (..)
, defaultConfig
, gophermapToDirectoryResponse
, setupGopherSocket
, 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
}
defaultConfig :: GopherConfig
defaultConfig = GopherConfig "localhost" 70 Nothing
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")
prettyAddr :: SocketAddress Inet6 -> String
prettyAddr (SocketAddressInet6 addr port _ _) = drop 13 (show addr) <> ":" <> show (fromIntegral port)
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 Bool
dropPrivileges username = do
uid <- getRealUserID
if (uid /= 0)
then return False
else do
user <- getUserEntryForName username
setGroupID $ userGroupID user
setUserID $ userID user
return True
setupGopherSocket :: GopherConfig -> IO (Socket Inet6 Stream TCP)
setupGopherSocket cfg = do
sock <- (socket :: IO (Socket Inet6 Stream TCP))
setSocketOption sock (ReuseAddress True)
setSocketOption sock (V6Only False)
bind sock (SocketAddressInet6 inet6Any (fromInteger (cServerPort cfg)) 0 0)
listen sock 5
pure sock
runGopher :: GopherConfig -> (String -> IO GopherResponse) -> IO ()
runGopher cfg f = runGopherManual (setupGopherSocket cfg) (pure ()) close cfg f
runGopherManual :: IO (Socket Inet6 Stream TCP) -> IO () -> (Socket Inet6 Stream TCP -> IO ())
-> GopherConfig -> (String -> IO GopherResponse) -> IO ()
runGopherManual sock ready term cfg f = bracket
sock
term
(\sock -> do
env <- initEnv sock (cServerName cfg) (fromInteger (cServerPort cfg)) f
gopherM env $ do
addr <- liftIO $ getAddress sock
log . LogInfo $ "Now listening on " ++ prettyAddr addr
when (isJust (cRunUserName cfg)) $ do
success <- liftIO (dropPrivileges (fromJust (cRunUserName cfg)))
if success
then log . LogInfo $ "Changed to user " ++ fromJust (cRunUserName cfg)
else log . LogError $ "Could not change UID: not started as root!"
liftIO $ ready
(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 -> SocketAddress Inet6 -> GopherM ()
handleIncoming clientSock addr = do
req <- liftIO $ uDecode . stripNewline <$> receiveRequest clientSock
log . LogInfo $ "Got request '" ++ req ++ "' from " ++ prettyAddr addr
fun <- serverFun <$> ask
res <- liftIO (fun req) >>= response
liftIO $ sendAll clientSock res msgNoSignal
liftIO $ close clientSock
log . LogInfo $ "Closed connection succesfully to " ++ prettyAddr addr
acceptAndHandle :: Socket Inet6 Stream TCP -> GopherM ()
acceptAndHandle sock = do
(clientSock, addr) <- liftIO $ accept sock
log . LogInfo $ "Accepted Connection from " ++ prettyAddr addr
forkGopherM $ handleIncoming clientSock addr `catchError` (\e -> do
liftIO (close clientSock)
log . LogError $ "Closed connection to " ++ prettyAddr 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"]