module Cloudy.Cmd.Scaleway.Utils where

import Cloudy.Scaleway (Zone (..), zoneFromText, PageNum (PageNum))
import Data.Foldable (asum, foldl')
import Data.Maybe (fromMaybe)
import Data.Text (Text, unpack)
import Network.HTTP.Client.TLS (newTlsManager)
import Servant.API (AuthProtect, Headers (Headers), Header, HList (..), ResponseHeader (Header))
import Servant.Client (BaseUrl (BaseUrl), Scheme (Https), ClientM, ClientError, mkClientEnv, runClientM)
import Servant.Client.Core (mkAuthenticatedRequest, AuthenticatedRequest, AuthClientData, Request, addHeader)

createAuthReq :: Text -> AuthenticatedRequest (AuthProtect "auth-token")
createAuthReq :: Text -> AuthenticatedRequest (AuthProtect "auth-token")
createAuthReq Text
secretKey = AuthClientData (AuthProtect "auth-token")
-> (AuthClientData (AuthProtect "auth-token")
    -> Request -> Request)
-> AuthenticatedRequest (AuthProtect "auth-token")
forall a.
AuthClientData a
-> (AuthClientData a -> Request -> Request)
-> AuthenticatedRequest a
mkAuthenticatedRequest Text
AuthClientData (AuthProtect "auth-token")
secretKey Text -> Request -> Request
AuthClientData (AuthProtect "auth-token") -> Request -> Request
createAuthTokenHeader

createAuthTokenHeader :: Text -> Request -> Request
createAuthTokenHeader :: Text -> Request -> Request
createAuthTokenHeader Text
authData = HeaderName -> Text -> Request -> Request
forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"X-Auth-Token" Text
authData

type instance AuthClientData (AuthProtect "auth-token") = Text

scalewayBaseUrl :: BaseUrl
scalewayBaseUrl :: BaseUrl
scalewayBaseUrl = Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Https String
"api.scaleway.com" Int
443 String
""

runScalewayClientM :: (forall x. ClientError -> IO x) -> ClientM a -> IO a
runScalewayClientM :: forall a. (forall x. ClientError -> IO x) -> ClientM a -> IO a
runScalewayClientM forall x. ClientError -> IO x
errHandler ClientM a
action = do
  Manager
manager <- IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
  let clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
scalewayBaseUrl
  Either ClientError a
res <- ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
action ClientEnv
clientEnv
  case Either ClientError a
res of
    Left ClientError
err -> ClientError -> IO a
forall x. ClientError -> IO x
errHandler ClientError
err
    Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

defaultZone :: Zone
defaultZone :: Zone
defaultZone = Zone
NL1

getZone :: Maybe Text -> Maybe Text -> IO Zone
getZone :: Maybe Text -> Maybe Text -> IO Zone
getZone Maybe Text
maybeZoneFromConfFile Maybe Text
maybeZoneFromCliOpts =
  case (Maybe Text
maybeZoneFromConfFile, Maybe Text
maybeZoneFromCliOpts) of
    (Maybe Text
_, Just Text
zoneFromCliOpts) ->
      case Text -> Maybe Zone
zoneFromText Text
zoneFromCliOpts of
        Maybe Zone
Nothing ->
          String -> IO Zone
forall a. HasCallStack => String -> a
error (String -> IO Zone) -> (Text -> String) -> Text -> IO Zone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> IO Zone) -> Text -> IO Zone
forall a b. (a -> b) -> a -> b
$
            Text
"Could not parse zone specified in --zone option on cli: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
zoneFromCliOpts
        Just Zone
zone -> Zone -> IO Zone
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Zone
zone
    (Just Text
zoneFromConfFile, Maybe Text
_) ->
      case Text -> Maybe Zone
zoneFromText Text
zoneFromConfFile of
        Maybe Zone
Nothing ->
          String -> IO Zone
forall a. HasCallStack => String -> a
error (String -> IO Zone) -> (Text -> String) -> Text -> IO Zone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> IO Zone) -> Text -> IO Zone
forall a b. (a -> b) -> a -> b
$
            Text
"Could not parse zone specified in scaleway.defaultZone in config file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
zoneFromConfFile
        Just Zone
zone -> Zone -> IO Zone
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Zone
zone
    (Maybe Text
Nothing, Maybe Text
Nothing) -> Zone -> IO Zone
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Zone
defaultZone

getMaybeOrDefault :: Foldable t => a -> t (Maybe a) -> a
getMaybeOrDefault :: forall (t :: * -> *) a. Foldable t => a -> t (Maybe a) -> a
getMaybeOrDefault a
defVal t (Maybe a)
maybes = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
defVal (t (Maybe a) -> Maybe a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum t (Maybe a)
maybes)

defaultInstanceType :: Text
defaultInstanceType :: Text
defaultInstanceType = Text
"PLAY2-NANO"

getInstanceType :: Maybe Text -> Maybe Text -> Text
getInstanceType :: Maybe Text -> Maybe Text -> Text
getInstanceType Maybe Text
maybeInstanceTypeFromConfFile Maybe Text
maybeInstanceTypeFromCliOpts =
  Text -> [Maybe Text] -> Text
forall (t :: * -> *) a. Foldable t => a -> t (Maybe a) -> a
getMaybeOrDefault
    Text
defaultInstanceType
    [Maybe Text
maybeInstanceTypeFromCliOpts, Maybe Text
maybeInstanceTypeFromConfFile]

defaultImageId :: Text
defaultImageId :: Text
defaultImageId = Text
"ubuntu_noble"

getImageId :: Maybe Text -> Maybe Text -> Text
getImageId :: Maybe Text -> Maybe Text -> Text
getImageId Maybe Text
maybeImageIdFromConfFile Maybe Text
maybeImageIdFromCliOpts =
  Text -> [Maybe Text] -> Text
forall (t :: * -> *) a. Foldable t => a -> t (Maybe a) -> a
getMaybeOrDefault
    Text
defaultImageId
    [Maybe Text
maybeImageIdFromCliOpts, Maybe Text
maybeImageIdFromConfFile]

fetchPagedApi ::
  Monad m =>
  (Maybe PageNum -> m (Headers '[Header "x-total-count" Int] a)) ->
  (a -> a -> a) ->
  (a -> Int) ->
  m a
fetchPagedApi :: forall (m :: * -> *) a.
Monad m =>
(Maybe PageNum -> m (Headers '[Header "x-total-count" Int] a))
-> (a -> a -> a) -> (a -> Int) -> m a
fetchPagedApi Maybe PageNum -> m (Headers '[Header "x-total-count" Int] a)
fetchPage a -> a -> a
combineResults a -> Int
countResultsOnPage = do
  Headers a
page1Res HList '[Header "x-total-count" Int]
headers <- Maybe PageNum -> m (Headers '[Header "x-total-count" Int] a)
fetchPage (PageNum -> Maybe PageNum
forall a. a -> Maybe a
Just (PageNum -> Maybe PageNum) -> PageNum -> Maybe PageNum
forall a b. (a -> b) -> a -> b
$ Int -> PageNum
PageNum Int
1)
  let page1Count :: Int
page1Count = a -> Int
countResultsOnPage a
page1Res
  Int
totalCount <-
    case HList '[Header "x-total-count" Int]
headers of
      HCons ResponseHeader h x
h HList xs
HNil ->
        case ResponseHeader h x
h of
          Header x
totalCount -> Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
Int
totalCount
          ResponseHeader h x
_ -> String -> m Int
forall a. HasCallStack => String -> a
error String
"fetchPagedApi: could not find or decode header x-total-count for some reason"
  if Int
page1Count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
totalCount
    then a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
page1Res
    else do
      [a]
allRes <-
        ((Int, Int) -> m (Maybe (a, (Int, Int)))) -> (Int, Int) -> m [a]
forall (m :: * -> *) s a.
Monad m =>
(s -> m (Maybe (a, s))) -> s -> m [a]
unfoldM
          (\(Int
currTotal, Int
pageNumToFetch) ->
            if Int
currTotal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
totalCount
              then Maybe (a, (Int, Int)) -> m (Maybe (a, (Int, Int)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, (Int, Int))
forall a. Maybe a
Nothing
              else do
                Headers a
pageRes HList '[Header "x-total-count" Int]
_ <- Maybe PageNum -> m (Headers '[Header "x-total-count" Int] a)
fetchPage (PageNum -> Maybe PageNum
forall a. a -> Maybe a
Just (PageNum -> Maybe PageNum) -> PageNum -> Maybe PageNum
forall a b. (a -> b) -> a -> b
$ Int -> PageNum
PageNum Int
pageNumToFetch)
                let newTotal :: Int
newTotal = Int
currTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
countResultsOnPage a
pageRes
                    nextPageNum :: Int
nextPageNum = Int
pageNumToFetch Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                Maybe (a, (Int, Int)) -> m (Maybe (a, (Int, Int)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, (Int, Int)) -> m (Maybe (a, (Int, Int))))
-> Maybe (a, (Int, Int)) -> m (Maybe (a, (Int, Int)))
forall a b. (a -> b) -> a -> b
$ (a, (Int, Int)) -> Maybe (a, (Int, Int))
forall a. a -> Maybe a
Just (a
pageRes, (Int
newTotal, Int
nextPageNum))
          )
          (Int
page1Count, Int
2)
      a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ (a -> a -> a) -> a -> [a] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
combineResults a
page1Res [a]
allRes

unfoldM :: Monad m => (s -> m (Maybe (a, s))) -> s -> m [a]
unfoldM :: forall (m :: * -> *) s a.
Monad m =>
(s -> m (Maybe (a, s))) -> s -> m [a]
unfoldM s -> m (Maybe (a, s))
f s
s = do
  Maybe (a, s)
mres <- s -> m (Maybe (a, s))
f s
s
  case Maybe (a, s)
mres of
    Maybe (a, s)
Nothing -> [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just (a
a, s
s') -> ([a] -> [a]) -> m [a] -> m [a]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ((s -> m (Maybe (a, s))) -> s -> m [a]
forall (m :: * -> *) s a.
Monad m =>
(s -> m (Maybe (a, s))) -> s -> m [a]
unfoldM s -> m (Maybe (a, s))
f s
s')