diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,11 @@ +# 1.0.0.2 (2023-01-08) + +Support GHC 9.4 + +# 1.0.0.1 (2021-12-27) + +Support GHC 9.2 + +# 1 (2021-07-07) + +Initial release diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,8 @@ +"Socket activation" is the a feature of systemd. ([documentation]) + +We use it for web servers, to avoid the momentary downtime that otherwise occurs +while restarting processes. Because the socket is manged by systemd, not by our +process, the socket remains even while our process is down. Requests to the +socket are queued until our process comes back up to respond. + + [documentation]: https://www.freedesktop.org/software/systemd/man/sd_listen_fds_with_names.html diff --git a/src/SocketActivation.hs b/src/SocketActivation.hs --- a/src/SocketActivation.hs +++ b/src/SocketActivation.hs @@ -1,29 +1,26 @@ module SocketActivation ( - -- * Actions - getMySocketByName - - -- * Types - , Name (..), VarName (..), Socket, Error (..) - - ) where + {- * Actions -} getMySocketByName, + {- * Types -} Name (..), VarName (..), Socket, Error (..), + ) + where -import Control.Applicative (Applicative ((*>))) -import Control.Monad (Monad (return, (>>=))) -import Data.Either (Either, either) -import System.IO (IO, print) +import Control.Applicative (Applicative ((*>))) +import Control.Monad (Monad (return, (>>=))) +import Data.Either (Either, either) +import System.IO (IO, print) -import qualified Control.Exception as Ex +import qualified Control.Exception as Ex import qualified SocketActivation.CheckRecipient as SA -import qualified SocketActivation.Concepts as SA -import qualified SocketActivation.Env as SA -import qualified SocketActivation.GetByName as SA +import qualified SocketActivation.Env as SA +import qualified SocketActivation.GetByName as SA -import SocketActivation.Concepts as Concepts +import SocketActivation.Concepts + (Socket, Error (..), VarName (..), Name (..)) -getMySocketByName :: SA.Name -> IO SA.Socket +getMySocketByName :: Name -> IO Socket getMySocketByName name = f SA.checkRecipient *> f (SA.getSocketByName name) where - f :: IO (Either SA.Error a) -> IO a + f :: IO (Either Error a) -> IO a f = (>>= either (\e -> (SA.getEnvVars >>= print) *> Ex.throw e) return) diff --git a/src/SocketActivation/CheckRecipient.hs b/src/SocketActivation/CheckRecipient.hs --- a/src/SocketActivation/CheckRecipient.hs +++ b/src/SocketActivation/CheckRecipient.hs @@ -2,18 +2,18 @@ module SocketActivation.CheckRecipient where -import Control.Monad (Monad (return, (>>=))) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Either (Either) -import Data.Eq (Eq ((==))) -import Data.Function ((.)) -import System.IO (IO) +import Control.Monad (Monad (return, (>>=))) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Either (Either) +import Data.Eq (Eq ((==))) +import Data.Function ((.)) +import System.IO (IO) -import qualified System.Posix.Process as Sys +import qualified System.Posix.Process as Sys -import SocketActivation.Concepts -import SocketActivation.Env -import SocketActivation.IO +import SocketActivation.Concepts (Error(WrongProcess), Recipient (recipientPID)) +import SocketActivation.Env (getEnv') +import SocketActivation.IO (IO' (IO', run), throwError) checkRecipient :: IO (Either Error ()) checkRecipient = run (getIt >>= checkIt) @@ -25,4 +25,5 @@ checkRecipient' x = run (getMyPid >>= throwIfDifferent) where getMyPid = liftIO Sys.getProcessID - throwIfDifferent y = if recipientPID x == y then return () else throwError WrongProcess + throwIfDifferent y = + if recipientPID x == y then return () else throwError WrongProcess diff --git a/src/SocketActivation/Concepts.hs b/src/SocketActivation/Concepts.hs --- a/src/SocketActivation/Concepts.hs +++ b/src/SocketActivation/Concepts.hs @@ -1,38 +1,46 @@ module SocketActivation.Concepts - ( Recipient (..) - , ProcessID - , Count (..) - , Name (..) - , Names (..) - , VarName (..) - , Fd (..) - , Socket - , Error (..) - ) where + ( + Recipient (..), + ProcessID, + Count (..), + Name (..), + Names (..), + VarName (..), + Fd (..), + Socket, + Error (..), + ) + where -import Control.Exception (Exception) -import Data.String (IsString) -import Data.Text (Text) -import Numeric.Natural (Natural) -import Prelude (Bounded, Enum, Eq, Ord, Show) +import Control.Exception (Exception) +import Data.String (IsString) +import Data.Text (Text) +import Numeric.Natural (Natural) +import Prelude (Bounded, Enum, Eq, Ord, Show) -import Network.Socket (Socket) -import System.Posix.Types (Fd (..), ProcessID) +import Network.Socket (Socket) +import System.Posix.Types (Fd (..), ProcessID) --- | The ID of the process to whom systemd has given the sockets. A process should not use sockets that are intended for someone else, so we should always check that this matches our own PID before proceeding doing anything with the sockets. +{-| The ID of the process to whom systemd has given the sockets + +A process should not use sockets that are intended for someone else, so we +should always check that this matches our own PID before proceeding doing +anything with the sockets. -} newtype Recipient = RecipientPID { recipientPID :: ProcessID } deriving stock (Eq, Show) --- | The number of sockets that systemd has given the process. +{-| The number of sockets that systemd has given the process -} newtype Count = CountNat { countNat :: Natural } deriving stock (Eq, Show) --- | The name of a socket, corresponding to the socket's FileDescriptorName in the systemd config. +{-| The name of a socket, corresponding to the socket's FileDescriptorName in + the systemd config -} newtype Name = NameText { nameText :: Text } deriving stock (Eq, Ord, Show) deriving newtype IsString --- | The names of the sockets that we have been given, corresponding to the FileDescriptorName of each systemd socket. +{-| The names of the sockets that we have been given, corresponding to the + FileDescriptorName of each systemd socket -} newtype Names = NamesList { namesList :: [Name] } deriving stock (Eq, Show) diff --git a/src/SocketActivation/Env.hs b/src/SocketActivation/Env.hs --- a/src/SocketActivation/Env.hs +++ b/src/SocketActivation/Env.hs @@ -1,22 +1,23 @@ module SocketActivation.Env where -import Control.Monad (Monad (return, (>>=))) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Either (Either, either) -import Data.Function (($), (.)) -import Data.Maybe (Maybe (..), maybe) -import Data.Text (Text) -import Data.Traversable (Traversable (traverse)) -import Prelude (Bounded (maxBound, minBound)) -import System.IO (IO) -import Text.Show (show) +import Control.Monad (Monad (return, (>>=))) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Either (Either, either) +import Data.Function (($), (.)) +import Data.Maybe (Maybe (..), maybe) +import Data.Text (Text) +import Data.Traversable (Traversable (traverse)) +import Prelude (Bounded (maxBound, minBound)) +import System.IO (IO) +import Text.Show (show) -import qualified Data.Text as Text -import qualified System.Environment as Sys +import qualified Data.Text as Text +import qualified System.Environment as Sys -import SocketActivation.Concepts -import SocketActivation.IO -import SocketActivation.Parsing +import SocketActivation.Concepts + (Error (Invalid, Missing), VarName (..), Names, Count, Recipient) +import SocketActivation.IO (IO' (IO', run), throwError) +import SocketActivation.Parsing (readRecipient, readCount, readNames) getVarText :: VarName -> IO (Either Error Text) getVarText name = run (getMaybe >>= throwIfMissing >>= pack) @@ -26,7 +27,11 @@ pack = return . Text.pack getEnvVars :: IO [(VarName, Maybe Text)] -getEnvVars = traverse (\x -> getVarText x >>= \y -> return (x, either (\_ -> Nothing) Just y)) [minBound .. maxBound] +getEnvVars = + traverse + (\x -> getVarText x >>= \y -> + return (x, either (\_ -> Nothing) Just y)) + [minBound .. maxBound] data Env a = Env VarName (Text -> Maybe a) diff --git a/src/SocketActivation/GetByName.hs b/src/SocketActivation/GetByName.hs --- a/src/SocketActivation/GetByName.hs +++ b/src/SocketActivation/GetByName.hs @@ -1,23 +1,23 @@ module SocketActivation.GetByName where -import Control.Applicative (Applicative ((<*>)), - (<$>)) -import Control.Monad (Monad (return, (>>=))) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Either (Either) -import Data.Function ((.)) -import Data.List (zip) -import Data.Map (Map) -import Data.Maybe (maybe) -import System.IO (IO) +import Control.Applicative (Applicative ((<*>)), (<$>)) +import Control.Monad (Monad (return, (>>=))) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Either (Either) +import Data.Function ((.)) +import Data.List (zip) +import Data.Map (Map) +import Data.Maybe (maybe) +import System.IO (IO) -import qualified Data.Map as Map +import qualified Data.Map as Map -import SocketActivation.Concepts -import SocketActivation.Env -import SocketActivation.GetFileDescriptors -import SocketActivation.GetSockets -import SocketActivation.IO +import SocketActivation.Concepts + (Socket, Fd, Error (NoSuchName), Names (namesList), Name) +import SocketActivation.Env (getEnv') +import SocketActivation.GetFileDescriptors (getFileDescriptorList) +import SocketActivation.GetSockets (getSocketList, fdSocket) +import SocketActivation.IO (IO' (IO', run), throwError) getNameList :: IO (Either Error [Name]) getNameList = run (getNames >>= unwrap) diff --git a/src/SocketActivation/GetFileDescriptors.hs b/src/SocketActivation/GetFileDescriptors.hs --- a/src/SocketActivation/GetFileDescriptors.hs +++ b/src/SocketActivation/GetFileDescriptors.hs @@ -1,19 +1,19 @@ module SocketActivation.GetFileDescriptors where -import Control.Monad (Monad (return, (>>=))) -import Data.Either (Either) -import Data.Function ((.)) -import Data.Int (Int) -import Data.List (take) -import Numeric.Natural (Natural) -import Prelude (fromIntegral) -import System.IO (IO) +import Control.Monad (Monad (return, (>>=))) +import Data.Either (Either) +import Data.Function ((.)) +import Data.Int (Int) +import Data.List (take) +import Numeric.Natural (Natural) +import Prelude (fromIntegral) +import System.IO (IO) -import SocketActivation.Concepts -import SocketActivation.Env -import SocketActivation.IO +import SocketActivation.Concepts (Fd (..), Error, Count (countNat)) +import SocketActivation.Env (getEnv') +import SocketActivation.IO (IO' (IO', run)) --- | Get a list of file descriptors for the sockets. +{-| Get a list of file descriptors for the sockets -} getFileDescriptorList :: IO (Either Error [Fd]) getFileDescriptorList = run (getCount >>= enumerateFds) where diff --git a/src/SocketActivation/GetSockets.hs b/src/SocketActivation/GetSockets.hs --- a/src/SocketActivation/GetSockets.hs +++ b/src/SocketActivation/GetSockets.hs @@ -1,17 +1,17 @@ module SocketActivation.GetSockets where -import Control.Monad (Monad ((>>=))) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Either (Either) -import Data.Function ((.)) -import Data.Traversable (Traversable (traverse)) -import System.IO (IO) +import Control.Monad (Monad ((>>=))) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Either (Either) +import Data.Function ((.)) +import Data.Traversable (Traversable (traverse)) +import System.IO (IO) -import qualified Network.Socket as Net +import qualified Network.Socket as Net -import SocketActivation.Concepts -import SocketActivation.GetFileDescriptors -import SocketActivation.IO +import SocketActivation.Concepts (Socket, Fd (..), Error) +import SocketActivation.GetFileDescriptors (getFileDescriptorList) +import SocketActivation.IO (IO' (IO', run)) getSocketList :: IO (Either Error [Socket]) getSocketList = run (getFds >>= convertToSockets) diff --git a/src/SocketActivation/IO.hs b/src/SocketActivation/IO.hs --- a/src/SocketActivation/IO.hs +++ b/src/SocketActivation/IO.hs @@ -1,14 +1,14 @@ module SocketActivation.IO where -import Control.Applicative (Applicative) -import Control.Monad (Functor, Monad (return)) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Except (ExceptT (..)) -import Data.Either (Either (Left)) -import Data.Function ((.)) -import System.IO (IO) +import Control.Applicative (Applicative) +import Control.Monad (Functor, Monad (return)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Except (ExceptT (..)) +import Data.Either (Either (Left)) +import Data.Function ((.)) +import System.IO (IO) -import SocketActivation.Concepts +import SocketActivation.Concepts (Error) newtype IO' a = IO' { run :: IO (Either Error a) } deriving (Functor, Applicative, Monad, MonadIO) via ExceptT Error IO diff --git a/src/SocketActivation/Parsing.hs b/src/SocketActivation/Parsing.hs --- a/src/SocketActivation/Parsing.hs +++ b/src/SocketActivation/Parsing.hs @@ -1,18 +1,17 @@ module SocketActivation.Parsing where -import Control.Monad (Functor (fmap), Monad (return), - (>=>)) -import Data.Bits (toIntegralSized) -import Data.Function ((.)) -import Data.Maybe (Maybe) -import Data.Text (Text) -import Foreign.C.Types (CInt) -import Numeric.Natural (Natural) -import Text.Read (readMaybe) +import Control.Monad (Functor (fmap), Monad (return), (>=>)) +import Data.Bits (toIntegralSized) +import Data.Function ((.)) +import Data.Maybe (Maybe) +import Data.Text (Text) +import Foreign.C.Types (CInt) +import Numeric.Natural (Natural) +import Text.Read (readMaybe) -import qualified Data.Text as Text +import qualified Data.Text as Text -import SocketActivation.Concepts +import SocketActivation.Concepts readRecipient :: Text -> Maybe Recipient readRecipient = read >=> wrap diff --git a/systemd-socket-activation.cabal b/systemd-socket-activation.cabal --- a/systemd-socket-activation.cabal +++ b/systemd-socket-activation.cabal @@ -1,21 +1,15 @@ cabal-version: 3.0 name: systemd-socket-activation -version: 1.0.0.1 +version: 1.0.0.2 category: System, Network synopsis: Let systemd bind the server's socket for you -description: - "Socket activation" is the a feature of systemd. - - https://www.freedesktop.org/software/systemd/man/sd_listen_fds_with_names.html - - We use it for web servers, to avoid the momentary downtime - that otherwise occurs while restarting processes. - Because the socket is manged by systemd, not by our process, - the socket remains even while our process is down. - Requests to the socket are queued until our process comes - back up to respond. +description: "Socket activation" is the a feature of systemd. We use it for web + servers, to avoid the momentary downtime that otherwise occurs while restarting + processes. Because the socket is manged by systemd, not by our process, the + socket remains even while our process is down. Requests to the socket are queued + until our process comes back up to respond. copyright: 2021 Mission Valley Software LLC license: MIT @@ -27,7 +21,7 @@ homepage: https://github.com/typeclasses/systemd-socket-activation bug-reports: https://github.com/typeclasses/systemd-socket-activation/issues -build-type: Simple +extra-source-files: *.md source-repository head type: git @@ -56,9 +50,9 @@ SocketActivation.Parsing build-depends: - base ^>= 4.14 || ^>= 4.15 || ^>= 4.16 - , containers ^>= 0.6 - , network ^>= 3.1 - , text ^>= 1.2.3 + , base ^>= 4.14 || ^>= 4.15 || ^>= 4.16 || ^>= 4.17 + , containers ^>= 0.6.4 + , network ^>= 3.1.2 + , text ^>= 1.2.4 || ^>= 2.0 , transformers ^>= 0.5.6 || ^>= 0.6 , unix ^>= 2.7.2