bein-0.3: Bein/SocketHandler.hs

{-# LANGUAGE DeriveDataTypeable #-}
module Bein.SocketHandler (listenWith, Authentication(..),getCommandBlock) where

import Data.Typeable ()
import System.Posix.Types ()
import Control.Monad ( forever )
import Foreign.C.Types ()
import System.Posix.Syslog ()
import Control.Monad ()
import Network.Socket
    ( Socket, accept, getPeerCred, socketToHandle )
import Network ( PortID(UnixSocket), listenOn )
import System.Posix.Files ( fileExist, removeLink )
import Text.Printf ()
import System.Posix.User ( getRealUserID )
import Control.Concurrent ( ThreadId )
import Control.Monad.Reader
    ( MonadReader(ask), MonadIO(..), ReaderT(runReaderT) )
import Control.Monad.Trans ()
import Control.Exception ( finally, throwIO )
import System.IO
    ( BufferMode(LineBuffering),
      IOMode(ReadWriteMode),
      hClose,
      hFlush,
      hSetBuffering,
      hPutStr )
import Bein.Types
    ( AuthenticationFailed(..),
      Authentication(..),
      Configuration(authentication),
      BeinState,
      BeinM,
      configField )
import Bein.Commands ( forkR, getCommandBlock )

listenWith :: BeinState s => (String -> BeinM s String) -> FilePath -> BeinM s ()
listenWith f socketFile = do
  s <- liftIO $ ensureFreeSocket socketFile
  forever $ s `accepts` f

accepts :: BeinState s => Socket -> (String -> BeinM s String) -> BeinM s ThreadId
s `accepts` action = (liftIO.accept) s >>= (forkR . withAuthentication (run action) . fst)
  
ensureFreeSocket :: FilePath -> IO Socket
ensureFreeSocket s = do
  fileExist s >>= \exists -> 
    if exists then removeLink s else return ()
  listenOn (UnixSocket s)

withAuthentication :: BeinState s => (Socket -> BeinM s a) -> Socket -> BeinM s a
withAuthentication f s = do
  authType <- configField authentication
  b <- liftIO $ authenticate authType s
  if b then f s else liftIO $ throwIO AuthenticationFailed

-- authenticateAndRun :: Authentication -> (String -> IO String) -> Socket -> IO ()
-- authenticateAndRun authType f s = do  
--     b <- authenticate authType s
--     if b then communicate f s else closeAndFail s
         
authenticate :: Authentication -> Socket -> IO Bool
authenticate None _ = return True
authenticate SameUser s = liftIO $ do uid <- getRealUserID
                                      (_,otherUid,_) <- getPeerCred s
                                      return $ toInteger uid == toInteger otherUid
authenticate (OnlyUser uid) s = liftIO $ do (_,otherUid,_) <- getPeerCred s
                                            return $ toInteger uid == toInteger otherUid
  
run :: BeinState s => (String -> BeinM s String) -> Socket -> BeinM s ()
run f s = do
   st <- ask
   liftIO $ setup (\str -> runReaderT (f str) st)
     where setup g = do h <- socketToHandle s ReadWriteMode
                        hSetBuffering h LineBuffering
                        (forever $ run' g h) `finally` hClose h
           run' q h = do str <- getCommandBlock h   
                         q str >>= hPutStr h >> hFlush h