packages feed

systemd-socket-activation (empty) → 1

raw patch · 11 files changed

+365/−0 lines, 11 filesdep +basedep +containersdep +network

Dependencies added: base, containers, network, text, transformers, unix

Files

+ license.txt view
@@ -0,0 +1,18 @@+Copyright 2021 Mission Valley Software LLC++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ src/SocketActivation.hs view
@@ -0,0 +1,29 @@+module SocketActivation+    (+    -- * 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 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           SocketActivation.Concepts       as Concepts++getMySocketByName :: SA.Name -> IO SA.Socket+getMySocketByName name = f SA.checkRecipient *> f (SA.getSocketByName name)+  where+    f :: IO (Either SA.Error a) -> IO a+    f = (>>= either (\e -> (SA.getEnvVars >>= print) *> Ex.throw e) return)
+ src/SocketActivation/CheckRecipient.hs view
@@ -0,0 +1,28 @@+-- | Verification of the socket recipient PID++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 qualified System.Posix.Process      as Sys++import           SocketActivation.Concepts+import           SocketActivation.Env+import           SocketActivation.IO++checkRecipient :: IO (Either Error ())+checkRecipient = run (getIt >>= checkIt)+  where+    getIt = IO' (getEnv' @Recipient)+    checkIt = IO' . checkRecipient'++checkRecipient' :: Recipient -> IO (Either Error ())+checkRecipient' x = run (getMyPid >>= throwIfDifferent)+  where+    getMyPid = liftIO Sys.getProcessID+    throwIfDifferent y = if recipientPID x == y then return () else throwError WrongProcess
+ src/SocketActivation/Concepts.hs view
@@ -0,0 +1,44 @@+module SocketActivation.Concepts+  ( 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           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.+newtype Recipient = RecipientPID { recipientPID :: ProcessID }+    deriving stock (Eq, Show)++-- | 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.+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.+newtype Names = NamesList { namesList :: [Name] }+    deriving stock (Eq, Show)++data VarName = LISTEN_PID | LISTEN_FDS | LISTEN_FDNAMES+    deriving stock (Eq, Show, Enum, Bounded)++data Error = Missing VarName | Invalid VarName | WrongProcess | NoSuchName Name+    deriving stock Show+    deriving anyclass Exception
+ src/SocketActivation/Env.hs view
@@ -0,0 +1,45 @@+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 qualified Data.Text                 as Text+import qualified System.Environment        as Sys++import           SocketActivation.Concepts+import           SocketActivation.IO+import           SocketActivation.Parsing++getVarText :: VarName -> IO (Either Error Text)+getVarText name = run (getMaybe >>= throwIfMissing >>= pack)+  where+    throwIfMissing = maybe (throwError (Missing name)) return+    getMaybe = liftIO $ Sys.lookupEnv $ show @VarName name+    pack = return . Text.pack++getEnvVars :: IO [(VarName, Maybe Text)]+getEnvVars = traverse (\x -> getVarText x >>= \y -> return (x, either (\_ -> Nothing) Just y)) [minBound .. maxBound]++data Env a = Env VarName (Text -> Maybe a)++getEnv :: Env a -> IO (Either Error a)+getEnv (Env name read) = run (getText >>= readOrThrow)+  where+    getText = IO' (getVarText name)+    readOrThrow = maybe (throwError (Invalid name)) return . read++getEnv' :: Env' a => IO (Either Error a)+getEnv' = getEnv env'++class Env' a where env' :: Env a+instance Env' Recipient where env' = Env LISTEN_PID readRecipient+instance Env' Count where env' = Env LISTEN_FDS readCount+instance Env' Names where env' = Env LISTEN_FDNAMES (Just . readNames)
+ src/SocketActivation/GetByName.hs view
@@ -0,0 +1,49 @@+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 qualified Data.Map                            as Map++import           SocketActivation.Concepts+import           SocketActivation.Env+import           SocketActivation.GetFileDescriptors+import           SocketActivation.GetSockets+import           SocketActivation.IO++getNameList :: IO (Either Error [Name])+getNameList = run (getNames >>= unwrap)+  where+    getNames = IO' (getEnv' @Names)+    unwrap = return . namesList++getFileDescriptorMap :: IO (Either Error (Map Name Fd))+getFileDescriptorMap = run (entries >>= toMap)+  where+    entries = zip <$> keys <*> values+    keys = IO' getNameList+    values = IO' getFileDescriptorList+    toMap = return . Map.fromList++getSocketMap :: IO (Either Error (Map Name Socket))+getSocketMap = run (entries >>= toMap)+  where+    entries = zip <$> keys <*> values+    keys = IO' getNameList+    values = IO' getSocketList+    toMap = return . Map.fromList++getSocketByName :: Name -> IO (Either Error Socket)+getSocketByName name = run (getMap >>= findFd >>= convertToSocket)+  where+    getMap = IO' getFileDescriptorMap+    findFd = maybe (throwError (NoSuchName name)) return . Map.lookup name+    convertToSocket = liftIO . fdSocket
+ src/SocketActivation/GetFileDescriptors.hs view
@@ -0,0 +1,27 @@+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           SocketActivation.Concepts+import           SocketActivation.Env+import           SocketActivation.IO++-- | Get a list of file descriptors for the sockets.+getFileDescriptorList :: IO (Either Error [Fd])+getFileDescriptorList = run (getCount >>= enumerateFds)+  where+    getCount = IO' (getEnv' @Count)+    enumerateFds = return . fds++fds :: Count -> [Fd]+fds n = take (convert n) [firstFd ..]+  where+    convert = (fromIntegral :: Natural -> Int) . countNat+    firstFd = Fd 3
+ src/SocketActivation/GetSockets.hs view
@@ -0,0 +1,23 @@+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 qualified Network.Socket                      as Net++import           SocketActivation.Concepts+import           SocketActivation.GetFileDescriptors+import           SocketActivation.IO++getSocketList :: IO (Either Error [Socket])+getSocketList = run (getFds >>= convertToSockets)+  where+    getFds = IO' getFileDescriptorList+    convertToSockets = traverse (liftIO . fdSocket)++fdSocket :: Fd -> IO Socket+fdSocket (Fd i) = Net.mkSocket i
+ src/SocketActivation/IO.hs view
@@ -0,0 +1,17 @@+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           SocketActivation.Concepts++newtype IO' a = IO' { run :: IO (Either Error a) }+    deriving (Functor, Applicative, Monad, MonadIO) via ExceptT Error IO++throwError :: Error -> IO' a+throwError = IO' . return . Left
+ src/SocketActivation/Parsing.hs view
@@ -0,0 +1,31 @@+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 qualified Data.Text                 as Text++import           SocketActivation.Concepts++readRecipient :: Text -> Maybe Recipient+readRecipient = read >=> wrap+  where+    read = readMaybe @ProcessID . Text.unpack+    wrap = return . RecipientPID++readCount :: Text -> Maybe Count+readCount = read >=> convert >=> wrap+  where+    read = readMaybe @CInt . Text.unpack+    convert = toIntegralSized :: CInt -> Maybe Natural+    wrap = return . CountNat++readNames :: Text -> Names+readNames = NamesList . fmap NameText . Text.splitOn ":"
+ systemd-socket-activation.cabal view
@@ -0,0 +1,54 @@+cabal-version: 3.0++name: systemd-socket-activation+version: 1+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.++copyright: 2021 Mission Valley Software LLC+license: MIT+license-file: license.txt++build-type: Simple++library+    default-language: Haskell2010+    ghc-options: -Wall+    hs-source-dirs: src++    default-extensions: DeriveAnyClass DerivingStrategies+        DerivingVia GeneralizedNewtypeDeriving+        NoImplicitPrelude OverloadedStrings TypeApplications++    exposed-modules:+        SocketActivation++    other-modules:+        SocketActivation.CheckRecipient+        SocketActivation.Concepts+        SocketActivation.Env+        SocketActivation.GetByName+        SocketActivation.GetFileDescriptors+        SocketActivation.GetSockets+        SocketActivation.IO+        SocketActivation.Parsing++    build-depends:+        base         ^>= 4.14 || ^>= 4.15+      , containers   ^>= 0.6+      , network      ^>= 3.1+      , text         ^>= 1.2.3+      , transformers ^>= 0.5.6+      , unix         ^>= 2.7.2