{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Hocker.Lib -- Copyright : (C) 2016 Awake Networks -- License : Apache-2.0 -- Maintainer : Awake Networks -- Stability : stable ---------------------------------------------------------------------------- module Hocker.Lib where import Control.Exception (throwIO) import Control.Lens import qualified Control.Monad.Except as Except import Control.Monad.IO.Class (MonadIO (..)) import qualified Crypto.Hash as Hash import qualified Data.Aeson import qualified Data.Aeson.Encode.Pretty as AP import Data.Aeson.Lens import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Lazy.Char8 as C8L import Data.Coerce import Data.Monoid import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) import qualified Network.Wreq as Wreq import Nix.Expr (NExpr) import Nix.Pretty import System.Directory (findExecutable) import System.Environment (getProgName) import System.Exit as Exit import System.FilePath.Posix as File import Text.PrettyPrint.ANSI.Leijen as Text.PrettyPrint (SimpleDoc, displayS, renderPretty) import URI.ByteString import Data.Docker.Image.Types import Hocker.Types import Hocker.Types.Exceptions import Hocker.Types.ImageName import Hocker.Types.ImageTag -- | Throw a 'userError', exiting the program with the supplied -- message. die :: MonadIO io => Text -> io a die = liftIO . throwIO . userError . Text.unpack -- | Print an error message to stderr and return a non-zero exit code, -- the message is prefixed with the name of the program. exitProgFail :: String -> IO a exitProgFail msg = do name <- getProgName Exit.die $ name ++ ": " ++ msg -- | Print the bytestring to stdout if the first argument is -- @Nothing@, otherwise write the bytestring to the provided -- filesystem path and print the path to stdout. writeOrPrint :: Maybe FilePath -> C8L.ByteString -> IO () writeOrPrint filepath content = maybe (C8L.putStrLn content) writeContent filepath where writeContent p = C8L.writeFile p content >> Prelude.putStrLn p -- | Combine an image name and a base path producing an output path. mkOutImage :: ImageName -- ^ Docker image name -> FilePath -- ^ Base path to write to -> FilePath mkOutImage n o = o (takeBaseName $ coerce n) -- | Combine an image name, an image tag, and a base path producing an -- output path with a @-config.json@ suffix. mkOutConfig :: ImageName -- ^ Docker image name -> ImageTag -- ^ Docker image tag -> FilePath -- ^ Base path to write to -> FilePath mkOutConfig n t o = o Prelude.concat [ (takeBaseName $ coerce n) , "_", coerce t , "-config.json" ] -- | Combine an image name, an image tag, and a base path producing an -- output path with a @-manifest.json@ suffix. mkOutManifest :: ImageName -- ^ Docker image name -> ImageTag -- ^ Docker image tag -> FilePath -- ^ Base path to write to -> FilePath mkOutManifest n t o = o Prelude.concat [ (takeBaseName $ coerce n) , "_", coerce t , "-manifest.json" ] -- | Join a list of strings and the path part of a 'RegistryURI' to -- produce a new 'RegistryURI' with a path root of @/v2@. joinURIPath :: [String] -- ^ Extra path segments to add -> RegistryURI -- ^ Base URI to add path segments to -> RegistryURI joinURIPath pts uri@URI{..} = uri { uriPath = joinedParts } where joinedParts = C8.pack $ File.joinPath ("/":"v2":(C8.unpack uriPath):pts) -- | Given a 'Wreq.Auth' produce a 'Wreq.Options'. opts :: Maybe Wreq.Auth -> Wreq.Options opts bAuth = Wreq.defaults & Wreq.auth .~ bAuth -- | Hash a 'Data.ByteString.Lazy.Char8' using the 'Hash.SHA256' -- algorithm. sha256 :: C8L.ByteString -> Hash.Digest Hash.SHA256 sha256 = Hash.hashlazy -- | Strip the @sha256:@ identifier prefix from a hash digest. stripHashId :: Text -> Text stripHashId = snd . Text.breakOnEnd ":" -- | Encode, following Docker's canonical JSON rules, any 'ToJSON' -- data type. -- -- The canonicalization rules enable consistent hashing of encoded -- JSON, a process relied upon heavily by docker for content -- addressability and unique identification of resources within a -- docker registry. Notably, an image's config JSON file and layers. -- -- NB: -- intentionally *does not* follow the 's -- Canonical JSON format even though it was inspired by it. encodeCanonical :: Data.Aeson.ToJSON a => a -> C8L.ByteString encodeCanonical = AP.encodePretty' conf where conf = AP.defConfig { AP.confIndent = AP.Spaces 0, AP.confCompare = compare } -- | Throw an error if the first argument is @Nothing@, otherwise -- return the @FilePath@ unwrapped. requirePath :: (Except.MonadError HockerException m) => Maybe FilePath -> m (FilePath) requirePath = maybe pathError pure where pathError = Except.throwError (hockerException "To fetch and assemble a docker image, '--out=' must be supplied") -- | Pluck out the digest value for the config JSON given a docker -- registry image manifest. Attempting to parse and return the digest -- value as a 'Hash.SHA256', otherwise throw an error. getConfigDigest :: (Except.MonadError HockerException m) => C8L.ByteString -> m (Hash.Digest Hash.SHA256) getConfigDigest (view (key "config" . key "digest" . _String) -> digest) = maybe badDigest return parsedDigest where parsedDigest = toDigest $ encodeUtf8 digest badDigest = Except.throwError $ hockerException "Failed parsing the config hash digest" -- | Split a docker image's name on the forward slash separator so we -- get the distinct repo name and image name. splitRepository :: ImageName -> (RepoNamePart, ImageNamePart) splitRepository (ImageName (Text.pack -> n)) = over _2 Text.tail $ Text.break (=='/') n -- | Given a nix expression AST, produce a pretty printer document. renderNixExpr :: NExpr -> Text.PrettyPrint.SimpleDoc renderNixExpr = renderPretty 0.4 120 . prettyNix -- | Print a nix expression AST using the 'renderNixExpr' pretty -- printing renderer. pprintNixExpr :: NExpr -> IO () pprintNixExpr expr = Prelude.putStrLn (displayS (renderNixExpr expr) "") -- | Given an executable's name, try to find it in the PATH. findExec :: (MonadIO m, Except.MonadError HockerException m) => String -> m Prelude.FilePath findExec execname = (liftIO $ findExecutable execname) >>= \case Just v -> return v Nothing -> Except.throwError $ HockerException ("cannot find executable `" <> execname <> "'") Nothing Nothing