{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TemplateHaskell #-}

module Cloudy.InstanceSetup where

import Cloudy.InstanceSetup.Types ( InstanceSetup(..) )
import Cloudy.Path (getCloudyInstanceSetupsDir)
import Control.DeepSeq (force)
import Control.FromSum (fromEither)
import Data.Bifunctor (Bifunctor(first))
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import Data.FileEmbed (embedDir)
import Data.Functor ((<&>))
import Data.List (sort, find)
import Data.Text (pack, Text)
import Data.Text.Encoding (decodeUtf8')
import Data.Yaml (decodeEither', ParseException (OtherParseException))
import System.Directory (listDirectory)
import System.FilePath (takeBaseName, takeExtension, (</>))
import Control.Exception (SomeException(SomeException))

rawBuiltInInstanceSetups :: [(FilePath, ByteString)]
rawBuiltInInstanceSetups :: [([Char], ByteString)]
rawBuiltInInstanceSetups = $(embedDir "instance-setups/")

builtInInstanceSetups :: [InstanceSetup]
builtInInstanceSetups :: [InstanceSetup]
builtInInstanceSetups =
  -- force is used here because we want to make sure any YAML decoding errors
  -- are surfaced the very first time builtInInstanceSetups is used.  We should
  -- almost never see any errors, since we control the raw instance-setup files
  -- that are used here.
  --
  -- We also have tests that should catch problems with decoding these
  -- instance-setup files.
  [InstanceSetup] -> [InstanceSetup]
forall a. NFData a => a -> a
force ([InstanceSetup] -> [InstanceSetup])
-> [InstanceSetup] -> [InstanceSetup]
forall a b. (a -> b) -> a -> b
$
    [([Char], ByteString)] -> [([Char], ByteString)]
forall a. Ord a => [a] -> [a]
sort [([Char], ByteString)]
rawBuiltInInstanceSetups [([Char], ByteString)]
-> (([Char], ByteString) -> InstanceSetup) -> [InstanceSetup]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \([Char]
fp, ByteString
rawData) ->
      (ParseException -> InstanceSetup)
-> Either ParseException InstanceSetup -> InstanceSetup
forall e a. (e -> a) -> Either e a -> a
fromEither
        (\ParseException
err ->
            [Char] -> InstanceSetup
forall a. HasCallStack => [Char] -> a
error ([Char] -> InstanceSetup) -> [Char] -> InstanceSetup
forall a b. (a -> b) -> a -> b
$
              [Char]
"Failed to decode instance-setup data in " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
fp [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
              [Char]
" as InstanceSetupData: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ParseException -> [Char]
forall a. Show a => a -> [Char]
show ParseException
err
        )
        ([Char] -> ByteString -> Either ParseException InstanceSetup
parseInstanceSetup [Char]
fp ByteString
rawData)

parseInstanceSetup :: FilePath -> ByteString -> Either ParseException InstanceSetup
parseInstanceSetup :: [Char] -> ByteString -> Either ParseException InstanceSetup
parseInstanceSetup [Char]
fp ByteString
rawData = do
  let name :: Text
name = [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
takeBaseName [Char]
fp
  Text
rawDataText <- (UnicodeException -> ParseException)
-> Either UnicodeException Text -> Either ParseException Text
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SomeException -> ParseException
OtherParseException (SomeException -> ParseException)
-> (UnicodeException -> SomeException)
-> UnicodeException
-> ParseException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> SomeException
forall e. Exception e => e -> SomeException
SomeException) (Either UnicodeException Text -> Either ParseException Text)
-> Either UnicodeException Text -> Either ParseException Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
rawData
  InstanceSetupData
instanceSetupData <- ByteString -> Either ParseException InstanceSetupData
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' ByteString
rawData
  InstanceSetup -> Either ParseException InstanceSetup
forall a. a -> Either ParseException a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstanceSetup -> Either ParseException InstanceSetup)
-> InstanceSetup -> Either ParseException InstanceSetup
forall a b. (a -> b) -> a -> b
$ InstanceSetup { Text
name :: Text
$sel:name:InstanceSetup :: Text
name, InstanceSetupData
instanceSetupData :: InstanceSetupData
$sel:instanceSetupData:InstanceSetup :: InstanceSetupData
instanceSetupData, $sel:rawInstanceSetupData:InstanceSetup :: Text
rawInstanceSetupData = Text
rawDataText }


getUserInstanceSetups :: IO [InstanceSetup]
getUserInstanceSetups :: IO [InstanceSetup]
getUserInstanceSetups = do
  [Char]
instanceSetupsDir <- IO [Char]
getCloudyInstanceSetupsDir
  [[Char]]
files <- ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char]
instanceSetupsDir [Char] -> [Char] -> [Char]
</>) ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
listDirectory [Char]
instanceSetupsDir
  let yamlFiles :: [[Char]]
yamlFiles = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
isYamlExt [[Char]]
files
  ([Char] -> IO InstanceSetup) -> [[Char]] -> IO [InstanceSetup]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Char] -> IO InstanceSetup
yamlFileToInstanceSetup [[Char]]
yamlFiles
  where
    isYamlExt :: FilePath -> Bool
    isYamlExt :: [Char] -> Bool
isYamlExt [Char]
fp = [Char] -> [Char]
takeExtension [Char]
fp [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".yaml" Bool -> Bool -> Bool
|| [Char] -> [Char]
takeExtension [Char]
fp [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".yml"

yamlFileToInstanceSetup :: FilePath -> IO InstanceSetup
yamlFileToInstanceSetup :: [Char] -> IO InstanceSetup
yamlFileToInstanceSetup [Char]
rawInstanceSetupFp = do
  ByteString
rawInstanceSetupData <- [Char] -> IO ByteString
ByteString.readFile [Char]
rawInstanceSetupFp
  case [Char] -> ByteString -> Either ParseException InstanceSetup
parseInstanceSetup [Char]
rawInstanceSetupFp ByteString
rawInstanceSetupData of
    Left ParseException
err -> [Char] -> IO InstanceSetup
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO InstanceSetup) -> [Char] -> IO InstanceSetup
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to decode " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
rawInstanceSetupFp [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" as instance-setup: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ParseException -> [Char]
forall a. Show a => a -> [Char]
show ParseException
err
    Right InstanceSetup
instanceSetup -> InstanceSetup -> IO InstanceSetup
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InstanceSetup
instanceSetup

-- | Find an 'InstanceSetup' from within the built-in and user-defined instance
-- setups.
findInstanceSetup ::
  -- | Name of the 'InstanceSetup' to look for.
  Text ->
  IO (Maybe InstanceSetup)
findInstanceSetup :: Text -> IO (Maybe InstanceSetup)
findInstanceSetup Text
nameToFind = do
  [InstanceSetup]
userInstanceSetups <- IO [InstanceSetup]
getUserInstanceSetups
  let allInstanceSetups :: [InstanceSetup]
allInstanceSetups = [InstanceSetup]
userInstanceSetups [InstanceSetup] -> [InstanceSetup] -> [InstanceSetup]
forall a. Semigroup a => a -> a -> a
<> [InstanceSetup]
builtInInstanceSetups
      Maybe InstanceSetup
maybeInstanceSetup :: Maybe InstanceSetup = (InstanceSetup -> Bool) -> [InstanceSetup] -> Maybe InstanceSetup
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\InstanceSetup
instSetup -> InstanceSetup
instSetup.name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nameToFind) [InstanceSetup]
allInstanceSetups
  Maybe InstanceSetup -> IO (Maybe InstanceSetup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InstanceSetup
maybeInstanceSetup