{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternSynonyms #-}
module Podman.Api
(
getVersion,
ContainerName (..),
containerExists,
containerInspect,
containerList,
containerCreate,
WaitCondition (..),
containerWait,
mkSpecGenerator,
containerStart,
containerDelete,
containerKill,
containerMount,
containerPause,
containerUnpause,
containerRename,
containerRestart,
containerSendFiles,
containerGetFiles,
containerAttach,
containerChanges,
containerInitialize,
containerExport,
containerLogs,
LogStream (..),
ContainerConnection (..),
ContainerOutput (..),
ExecId (..),
execCreate,
execInspect,
execStart,
generateKubeYAML,
generateSystemd,
ImageName (..),
imageExists,
imageList,
imageTree,
imagePull,
imagePullRaw,
NetworkName (..),
networkExists,
networkList,
VolumeName (..),
volumeExists,
volumeList,
SecretName (..),
secretList,
secretCreate,
secretInspect,
pattern API_VERSION ,
)
where
import qualified Codec.Archive.Tar as Tar
import Control.Monad ((>=>))
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.Binary.Get as B
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Podman.Client
import Podman.Internal
import Podman.Types
import Text.Read (readMaybe)
pattern API_VERSION :: (Eq a, IsString a) => a
pattern API_VERSION = "v2.0.0"
api_base :: Text
api_base = API_VERSION <> "/libpod"
getVersion :: MonadIO m => PodmanClient -> m (Result Version)
getVersion client = withResult <$> podmanGet client (Path $ api_base <> "/version") mempty
newtype ContainerName = ContainerName Text
deriving stock (Show, Eq)
notFoundToFalse :: Maybe Error -> Result Bool
notFoundToFalse Nothing = pure True
notFoundToFalse (Just err@Error {..})
| _errorresponse == 404 = pure False
| otherwise = Left err
containerExists ::
MonadIO m =>
PodmanClient ->
ContainerName ->
m (Result Bool)
containerExists client (ContainerName name) = do
notFoundToFalse . withoutResult <$> podmanGet client (Path (api_base <> "/containers/" <> name <> "/exists")) mempty
containerInspect ::
MonadIO m =>
PodmanClient ->
ContainerName ->
Bool ->
m (Result InspectContainerResponse)
containerInspect client (ContainerName name) size =
withResult <$> podmanGet client (Path (api_base <> "/containers/" <> name <> "/json")) [("size", Just (QBool size))]
containerList ::
MonadIO m =>
PodmanClient ->
ContainerListQuery ->
m (Result [ListContainer])
containerList client ContainerListQuery {..} = do
withResult <$> podmanGet client (Path $ api_base <> "/containers/json") qs
where
qs =
[ ("all", QBool <$> _containerListQueryall),
("size", QBool <$> _containerListQuerysize),
("limit", QInt <$> _containerListQuerylimit),
("sync", QBool <$> _containerListQuerysync),
("filters", QText <$> _containerListQueryfilters)
]
containerCreate :: MonadIO m => PodmanClient -> SpecGenerator -> m (Result ContainerCreateResponse)
containerCreate client spec = withResult <$> podmanPost client (Json spec) (Path $ api_base <> "/containers/create") mempty
containerPath :: ContainerName -> Text -> Path
containerPath (ContainerName name) action = Path (api_base <> "/containers/" <> name <> "/" <> action)
data WaitCondition
= Configured
| Created
| Running
| Stopped
| Paused
| Exited
| Removing
| Stopping
deriving stock (Eq, Show)
containerWait :: MonadIO m => PodmanClient -> ContainerName -> WaitCondition -> m (Either Error Int)
containerWait client name wc = fmap toRc . withRaw <$> podmanPost client emptyBody (containerPath name "wait") qs
where
toRc = fromMaybe (error "couldn't read response") . readMaybe . BS.unpack
qs =
[ ( "condition",
Just $
QText $ case wc of
Configured -> "configured"
Created -> "created"
Running -> "running"
Stopped -> "stopped"
Paused -> "paused"
Exited -> "exited"
Removing -> "removing"
Stopping -> "stopping"
)
]
containerStart ::
MonadIO m =>
PodmanClient ->
ContainerName ->
Maybe Text ->
m (Maybe Error)
containerStart client (ContainerName name) escapeSeq =
withoutResult <$> podmanPost client emptyBody (Path $ api_base <> "/containers/" <> name <> "/start") qs
where
qs = [("detachKeys", QText <$> escapeSeq)]
containerSendFiles ::
MonadIO m =>
PodmanClient ->
ContainerName ->
[Tar.Entry] ->
Text ->
Maybe Bool ->
m (Maybe Error)
containerSendFiles client (ContainerName name) entries path pause =
withoutResult <$> podmanPut client (lazyRaw tar) (Path (api_base <> "/containers/" <> name <> "/archive")) qs
where
qs = [("path", Just $ QText path), ("pause", QBool <$> pause)]
tar = Tar.write entries
containerGetFiles ::
MonadIO m =>
PodmanClient ->
ContainerName ->
Text ->
m (Result (Tar.Entries Tar.FormatError))
containerGetFiles client (ContainerName name) path = do
res <- withRaw <$> podmanGet client (Path (api_base <> "/containers/" <> name <> "/archive")) qs
pure $ case res of
Left err -> Left err
Right bs -> Right (Tar.read $ LBS.fromStrict bs)
where
qs = [("path", Just $ QText path)]
containerKill ::
MonadIO m =>
PodmanClient ->
ContainerName ->
Maybe Text ->
m (Maybe Error)
containerKill client (ContainerName name) signal =
withoutResult <$> podmanPost client emptyBody (Path (api_base <> "/containers/" <> name <> "/kill")) qs
where
qs = [("signal", QText <$> signal)]
containerMount ::
MonadIO m =>
PodmanClient ->
ContainerName ->
m (Either Error FilePath)
containerMount client (ContainerName name) =
toFilePath . withRaw <$> podmanPost client emptyBody (Path $ api_base <> "/containers/" <> name <> "/mount") mempty
where
toFilePath = fmap (T.unpack . T.init . T.decodeUtf8)
containerPost_ :: MonadIO m => Text -> QueryArgs -> PodmanClient -> ContainerName -> m (Maybe Error)
containerPost_ path qs client (ContainerName name) =
withoutResult <$> podmanPost client emptyBody (Path $ api_base <> "/containers/" <> name <> "/" <> path) qs
containerPause ::
MonadIO m =>
PodmanClient ->
ContainerName ->
m (Maybe Error)
containerPause = containerPost_ "pause" mempty
containerUnpause ::
MonadIO m =>
PodmanClient ->
ContainerName ->
m (Maybe Error)
containerUnpause = containerPost_ "unpause" mempty
containerRename ::
MonadIO m =>
PodmanClient ->
ContainerName ->
ContainerName ->
m (Maybe Error)
containerRename client name (ContainerName new) = containerPost_ "rename" [("name", Just $ QText new)] client name
containerRestart ::
MonadIO m =>
PodmanClient ->
ContainerName ->
Maybe Word ->
m (Maybe Error)
containerRestart client name timeout =
containerPost_ "restart" [("timeout", QInt . fromIntegral <$> timeout)] client name
containerDelete ::
MonadIO m =>
PodmanClient ->
ContainerName ->
Maybe Bool ->
Maybe Bool ->
m (Maybe Error)
containerDelete client (ContainerName name) force volume =
withoutResult <$> podmanDelete client (Path $ api_base <> "/containers/" <> name) qs
where
qs = [("force", QBool <$> force), ("v", QBool <$> volume)]
data ContainerOutput = EOF | Stdout ByteString | Stderr ByteString
deriving stock (Eq, Show)
getContainerOutput :: B.Get ContainerOutput
getContainerOutput = do
t <- B.getWord32le
sz <- B.getWord32be
msg <- B.getByteString (fromIntegral sz)
pure $ case t of
1 -> Stdout msg
2 -> Stderr msg
_ -> error ("Unknown output type: " <> show t)
getContainerOutputs :: B.Get [ContainerOutput]
getContainerOutputs = do
empty <- B.isEmpty
if empty
then return []
else do
x <- getContainerOutput
xs <- getContainerOutputs
pure (x : xs)
data ContainerConnection = ContainerConnection
{ containerRecv :: IO ContainerOutput,
containerSend :: ByteString -> IO ()
}
containerAttach ::
MonadIO m =>
PodmanClient ->
ContainerName ->
AttachQuery ->
(ContainerConnection -> IO a) ->
m (Result a)
containerAttach client (ContainerName name) AttachQuery {..} cb = do
podmanConn client "POST" (Path $ api_base <> "/containers/" <> name <> "/attach") qs (cc >=> cb)
where
cc :: Connection -> IO ContainerConnection
cc conn = do
acc <- newIORef ""
pure $ ContainerConnection (cr acc conn) (connectionWrite conn)
cr :: IORef LBS.ByteString -> Connection -> IO ContainerOutput
cr acc conn = do
before <- readIORef acc
buf <- mappend before . LBS.fromStrict <$> connectionRead conn
case buf of
"" -> pure EOF
_ -> do
case B.runGetOrFail getContainerOutput buf of
Left (_, _, _) -> do
writeIORef acc buf
cr acc conn
Right (rest, _, log') -> do
writeIORef acc rest
pure log'
qs =
[ ("detachKeys", QText <$> _attachQuerydetachKeys),
("logs", QBool <$> _attachQuerylogs),
("stream", QBool <$> _attachQuerystream),
("stdout", QBool <$> _attachQuerystdout),
("stderr", QBool <$> _attachQuerystderr),
("stdin", QBool <$> _attachQuerystdin)
]
containerChanges ::
MonadIO m =>
PodmanClient ->
ContainerName ->
m (Result [ContainerChange])
containerChanges client (ContainerName name) =
withResult <$> podmanGet client (Path $ api_base <> "/containers/" <> name <> "/changes") mempty
containerExport ::
MonadIO m =>
PodmanClient ->
ContainerName ->
m (Result (Tar.Entries Tar.FormatError))
containerExport client (ContainerName name) = do
res <- withRaw <$> podmanGet client (Path $ api_base <> "/containers/" <> name <> "/export") mempty
pure $ case res of
Left err -> Left err
Right bs -> Right (Tar.read $ LBS.fromStrict bs)
data LogStream = LogStdout | LogStderr | LogBoth deriving stock (Show, Eq)
containerLogs ::
MonadIO m =>
PodmanClient ->
ContainerName ->
LogStream ->
LogsQuery ->
(ContainerOutput -> IO ()) ->
m (Maybe Error)
containerLogs client (ContainerName name) streams LogsQuery {..} cb = do
x <- podmanStream client "GET" (Path $ api_base <> "/containers/" <> name <> "/logs") qs (cc "")
pure $ case x of
Left err -> Just err
Right _ -> Nothing
where
cc :: LBS.ByteString -> IO ByteString -> IO ()
cc acc conn = do
buf <- mappend acc . LBS.fromStrict <$> conn
case buf of
"" -> pure ()
_ -> do
rest <- case B.runGetOrFail getContainerOutput buf of
Left (_, _, _) -> pure buf
Right (rest', _, log') -> cb log' >> pure rest'
cc rest conn
(stdout, stderr) = case streams of
LogStdout -> (Just True, Just False)
LogStderr -> (Just False, Just True)
LogBoth -> (Just True, Just True)
qs =
[ ("since", qdate <$> _logsQuerysince),
("until", qdate <$> _logsQueryuntil),
("stderr", QBool <$> stderr),
("stdout", QBool <$> stdout),
("timestamps", QBool <$> _logsQuerytimestamps),
("tail", QInt . fromIntegral <$> _logsQuerytail),
("follow", QBool <$> _logsQueryfollow)
]
containerInitialize ::
MonadIO m =>
PodmanClient ->
ContainerName ->
m (Maybe Error)
containerInitialize client (ContainerName name) =
withoutResult <$> podmanPost client emptyBody (Path $ api_base <> "/containers/" <> name <> "/init") mempty
generateKubeYAML ::
MonadIO m =>
PodmanClient ->
[ContainerName] ->
Bool ->
m (Result Text)
generateKubeYAML client names service =
withText <$> podmanGet client (Path $ api_base <> "/generate/kube") qs
where
qs =
map (\(ContainerName name) -> ("names", Just (QText name))) names
<> [("service", Just (QBool True)) | service]
generateSystemd ::
MonadIO m =>
PodmanClient ->
ContainerName ->
GenerateSystemdQuery ->
m (Result (Map Text Text))
generateSystemd client (ContainerName name) GenerateSystemdQuery {..} =
withResult <$> podmanGet client (Path $ api_base <> "/generate/" <> name <> "/systemd") qs
where
qs =
[ ("useName", QBool <$> _generateSystemdQueryuseName),
("new", QBool <$> _generateSystemdQuerynew),
("noHeader", QBool <$> _generateSystemdQuerynoHeader),
("time", QInt <$> _generateSystemdQuerytime),
("restartPolicy", QText . T.pack . show <$> _generateSystemdQueryrestartPolicy),
("containerPrefix", QText <$> _generateSystemdQuerycontainerPrefix),
("podPrefix", QText <$> _generateSystemdQuerypodPrefix),
("separator", QText <$> _generateSystemdQueryseparator)
]
newtype ImageName = ImageName Text
deriving stock (Show, Eq)
imageList ::
MonadIO m =>
PodmanClient ->
ImageListQuery ->
m (Result [ImageSummary])
imageList client ImageListQuery {..} =
withResult <$> podmanGet client (Path $ api_base <> "/images/json") qs
where
qs = [("all", QBool <$> _imageListQueryall), ("filters", QText <$> _imageListQueryfilters)]
imageExists ::
MonadIO m =>
PodmanClient ->
ImageName ->
m (Result Bool)
imageExists client (ImageName name) = do
notFoundToFalse . withoutResult <$> podmanGet client (Path $ api_base <> "/images/" <> name <> "/exists") mempty
imageTree ::
MonadIO m =>
PodmanClient ->
ImageName ->
Maybe Bool ->
m (Result ImageTreeResponse)
imageTree client (ImageName name) whatrequires =
withResult <$> podmanGet client (Path $ api_base <> "/images/" <> name <> "/tree") qs
where
qs = [("whatrequires", QBool <$> whatrequires)]
imagePull ::
MonadIO m =>
PodmanClient ->
ImagePullQuery ->
m (Result [ImageName])
imagePull = (fmap . fmap $ getImageNames) . imagePullRaw
where
getImageNames (Right x@ImagesPullResponse {..}) = case _imagesPullResponseimages of
Just ids -> Right $ map ImageName ids
Nothing -> Left $ Error "pull failed" (T.pack $ show x) 404
getImageNames (Left x) = Left x
imagePullRaw ::
MonadIO m =>
PodmanClient ->
ImagePullQuery ->
m (Result ImagesPullResponse)
imagePullRaw client ImagePullQuery {..} = do
r <- withRaw <$> podmanPost client emptyBody (Path $ api_base <> "/images/pull") qs
pure $ case r of
Right bs -> case decodeImagePullResponse bs of
Left x -> error x
Right x -> Right x
Left x -> Left x
where
qs =
[ ("reference", Just $ QText _imagePullQueryreference),
("credentials", QText <$> _imagePullQuerycredentials),
("Arch", QText <$> _imagePullQueryArch),
("OS", QText <$> _imagePullQueryOS),
("Variant", QText <$> _imagePullQueryVariant),
("tlsVerify", QBool <$> _imagePullQuerytlsVerify),
("allTags", QBool <$> _imagePullQueryallTags)
]
newtype NetworkName = NetworkName Text
deriving stock (Show, Eq)
networkList ::
MonadIO m =>
PodmanClient ->
Maybe Text ->
m (Result [NetworkListReport])
networkList client filters =
withResult <$> podmanGet client (Path $ api_base <> "/networks/json") qs
where
qs = [("filters", QText <$> filters)]
networkExists ::
MonadIO m =>
PodmanClient ->
NetworkName ->
m (Maybe Error)
networkExists client (NetworkName name) =
withoutResult <$> podmanGet client (Path $ api_base <> "/networks/" <> name <> "/exists") mempty
newtype VolumeName = VolumeName Text
deriving stock (Show, Eq)
volumeList ::
MonadIO m =>
PodmanClient ->
Maybe Text ->
m (Result [Volume])
volumeList client filters =
withResult <$> podmanGet client (Path $ api_base <> "/volumes/json") qs
where
qs = [("filters", QText <$> filters)]
volumeExists ::
MonadIO m =>
PodmanClient ->
VolumeName ->
m (Maybe Error)
volumeExists client (VolumeName name) =
withoutResult <$> podmanGet client (Path $ api_base <> "/volumes/" <> name <> "/exists") mempty
execCreate ::
MonadIO m =>
PodmanClient ->
ContainerName ->
ExecConfig ->
m (Result ExecId)
execCreate client (ContainerName name) config =
(fmap . fmap $ getId) withResult
<$> podmanPost client (Json config) (Path $ api_base <> "/containers/" <> name <> "/exec") mempty
where
getId (ExecResponse id') = ExecId id'
newtype ExecId = ExecId Text
deriving stock (Show, Eq)
execInspect ::
MonadIO m =>
PodmanClient ->
ExecId ->
m (Result ExecInspectResponse)
execInspect client (ExecId name) =
withResult <$> podmanGet client (Path $ api_base <> "/exec/" <> name <> "/json") mempty
execStart ::
MonadIO m =>
PodmanClient ->
ExecId ->
m (Result [ContainerOutput])
execStart client (ExecId name) = do
fmap toOutput . withRaw <$> podmanPost client emptyObject (Path $ api_base <> "/exec/" <> name <> "/start") mempty
where
toOutput = B.runGet getContainerOutputs . LBS.fromStrict
newtype SecretName = SecretName Text
deriving stock (Show, Eq)
secretList ::
MonadIO m =>
PodmanClient ->
m (Result [SecretInfoReport])
secretList client =
withResult <$> podmanGet client (Path $ api_base <> "/secrets/json") mempty
secretCreate ::
MonadIO m =>
PodmanClient ->
SecretName ->
ByteString ->
m (Result SecretCreateResponse)
secretCreate client (SecretName name) dat =
withResult <$> podmanPost client (raw dat) (Path $ api_base <> "/secrets/create") qs
where
qs = [("name", Just (QText name))]
secretInspect ::
MonadIO m =>
PodmanClient ->
SecretName ->
m (Result SecretInfoReport)
secretInspect client (SecretName name) =
withResult <$> podmanGet client (Path $ api_base <> "/secrets/" <> name <> "/json") mempty