{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedRecordDot #-}

module Cloudy.Db where

import Cloudy.InstanceSetup.Types (InstanceSetup (..))
import Cloudy.NameGen (instanceNameGen)
import Cloudy.Path (getCloudyDbPath)
import Control.Exception (Exception, throwIO)
import Data.Aeson (eitherDecodeStrict, encode)
import qualified Data.ByteString as ByteString
import Data.Foldable (fold)
import Data.Int (Int64)
import Data.List (find)
import Data.Maybe (listToMaybe, catMaybes)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Time ( UTCTime, getCurrentTime )
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import Data.Traversable (for)
import Data.Void (Void)
import Database.SQLite.Simple (withConnection, Connection, execute_, Query, query_, FromRow (..), ToRow (..), execute, withTransaction, lastInsertRowId, query, Only (..), field)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))

createLocalDatabase :: Connection -> IO ()
createLocalDatabase :: Connection -> IO ()
createLocalDatabase Connection
conn = do
  Connection -> Query -> IO ()
execute_
    Connection
conn
    Query
"CREATE TABLE IF NOT EXISTS cloudy_instance \
    \  ( id INTEGER PRIMARY KEY AUTOINCREMENT \
    \  , name TEXT NOT NULL UNIQUE \
    \  , created_at INTEGER \
    \  , deleted_at INTEGER \
    \  , instance_setup TEXT \
    \  ) \
    \STRICT"
  Connection -> Query -> IO ()
execute_
    Connection
conn
    Query
"CREATE TABLE IF NOT EXISTS scaleway_instance \
    \  ( cloudy_instance_id INTEGER NOT NULL UNIQUE \
    \  , scaleway_zone TEXT NOT NULL \
    \  , scaleway_instance_id TEXT NOT NULL UNIQUE \
    \  , scaleway_ip_id TEXT NOT NULL \
    \  , scaleway_ip_address TEXT NOT NULL \
    \  , FOREIGN KEY (cloudy_instance_id) REFERENCES cloudy_instance(id) \
    \  ) \
    \STRICT"

withCloudyDb :: (Connection -> IO a) -> IO a
withCloudyDb :: forall a. (Connection -> IO a) -> IO a
withCloudyDb Connection -> IO a
action = do
  [Char]
dcutDbPath <- IO [Char]
getCloudyDbPath
  [Char] -> (Connection -> IO a) -> IO a
forall a. [Char] -> (Connection -> IO a) -> IO a
withSqliteConn [Char]
dcutDbPath ((Connection -> IO a) -> IO a) -> (Connection -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    Connection -> IO ()
createLocalDatabase Connection
conn
    -- TODO: Maybe create some sort of production build that doesn't check
    -- the invariants.
    Connection -> IO ()
assertDbInvariants Connection
conn
    a
res <- Connection -> IO a
action Connection
conn
    Connection -> IO ()
assertDbInvariants Connection
conn
    a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

withSqliteConn :: FilePath -> (Connection -> IO a) -> IO a
withSqliteConn :: forall a. [Char] -> (Connection -> IO a) -> IO a
withSqliteConn [Char]
dbPath Connection -> IO a
action =
  [Char] -> (Connection -> IO a) -> IO a
forall a. [Char] -> (Connection -> IO a) -> IO a
withConnection
      [Char]
dbPath
      (\Connection
conn -> do
        Connection -> Query -> IO ()
execute_
          Connection
conn
          -- Also consider using the following settings:
          --
          -- - `PRAGMA synchronous = NORMAL;`:
          --     Change the synchronization model.  NORMAL is faster than the
          --     default, and still safe with journal_mode=WAL.
          --
          -- - `PRAGMA cache_size = 1000000000;`:
          --     Change the maximum number of database disk pages that SQLite
          --     will hold in memory at once. Each page uses about 1.5K of
          --     memory. The default cache size is 2000.
          --
          -- More suggestions in https://kerkour.com/sqlite-for-servers
          Query
"PRAGMA journal_mode = WAL; -- better concurrency \
          \PRAGMA foreign_keys = true; -- enforce foreign key constraints \
          \PRAGMA busy_timeout = 5000; -- helps prevent SQLITE_BUSY errors"
        Connection -> IO a
action Connection
conn
      )

data QuerySingleErr = QuerySingleErr Query String
  deriving stock (QuerySingleErr -> QuerySingleErr -> Bool
(QuerySingleErr -> QuerySingleErr -> Bool)
-> (QuerySingleErr -> QuerySingleErr -> Bool) -> Eq QuerySingleErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QuerySingleErr -> QuerySingleErr -> Bool
== :: QuerySingleErr -> QuerySingleErr -> Bool
$c/= :: QuerySingleErr -> QuerySingleErr -> Bool
/= :: QuerySingleErr -> QuerySingleErr -> Bool
Eq, Int -> QuerySingleErr -> ShowS
[QuerySingleErr] -> ShowS
QuerySingleErr -> [Char]
(Int -> QuerySingleErr -> ShowS)
-> (QuerySingleErr -> [Char])
-> ([QuerySingleErr] -> ShowS)
-> Show QuerySingleErr
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QuerySingleErr -> ShowS
showsPrec :: Int -> QuerySingleErr -> ShowS
$cshow :: QuerySingleErr -> [Char]
show :: QuerySingleErr -> [Char]
$cshowList :: [QuerySingleErr] -> ShowS
showList :: [QuerySingleErr] -> ShowS
Show)
  deriving anyclass (Show QuerySingleErr
Typeable QuerySingleErr
(Typeable QuerySingleErr, Show QuerySingleErr) =>
(QuerySingleErr -> SomeException)
-> (SomeException -> Maybe QuerySingleErr)
-> (QuerySingleErr -> [Char])
-> Exception QuerySingleErr
SomeException -> Maybe QuerySingleErr
QuerySingleErr -> [Char]
QuerySingleErr -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> [Char]) -> Exception e
$ctoException :: QuerySingleErr -> SomeException
toException :: QuerySingleErr -> SomeException
$cfromException :: SomeException -> Maybe QuerySingleErr
fromException :: SomeException -> Maybe QuerySingleErr
$cdisplayException :: QuerySingleErr -> [Char]
displayException :: QuerySingleErr -> [Char]
Exception)

querySingleErr_ :: FromRow r => Connection -> Query -> IO r
querySingleErr_ :: forall r. FromRow r => Connection -> Query -> IO r
querySingleErr_ Connection
conn Query
q = do
  OnlyOne r
onlyOneRes <- Connection -> Query -> IO (OnlyOne r)
forall r. FromRow r => Connection -> Query -> IO (OnlyOne r)
querySingle_ Connection
conn Query
q
  case OnlyOne r
onlyOneRes of
    OnlyOne r
r -> r -> IO r
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
    OnlyOne r
NoneExist -> QuerySingleErr -> IO r
forall e a. Exception e => e -> IO a
throwIO (QuerySingleErr -> IO r) -> QuerySingleErr -> IO r
forall a b. (a -> b) -> a -> b
$ Query -> [Char] -> QuerySingleErr
QuerySingleErr Query
q [Char]
"query returned NO results, expecting exactly one"
    OnlyOne r
MultipleExist -> QuerySingleErr -> IO r
forall e a. Exception e => e -> IO a
throwIO (QuerySingleErr -> IO r) -> QuerySingleErr -> IO r
forall a b. (a -> b) -> a -> b
$ Query -> [Char] -> QuerySingleErr
QuerySingleErr Query
q [Char]
"query returned multiple results, expecting exactly one"

data OnlyOne r = OnlyOne r | MultipleExist | NoneExist
  deriving stock ((forall a b. (a -> b) -> OnlyOne a -> OnlyOne b)
-> (forall a b. a -> OnlyOne b -> OnlyOne a) -> Functor OnlyOne
forall a b. a -> OnlyOne b -> OnlyOne a
forall a b. (a -> b) -> OnlyOne a -> OnlyOne b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> OnlyOne a -> OnlyOne b
fmap :: forall a b. (a -> b) -> OnlyOne a -> OnlyOne b
$c<$ :: forall a b. a -> OnlyOne b -> OnlyOne a
<$ :: forall a b. a -> OnlyOne b -> OnlyOne a
Functor, Int -> OnlyOne r -> ShowS
[OnlyOne r] -> ShowS
OnlyOne r -> [Char]
(Int -> OnlyOne r -> ShowS)
-> (OnlyOne r -> [Char])
-> ([OnlyOne r] -> ShowS)
-> Show (OnlyOne r)
forall r. Show r => Int -> OnlyOne r -> ShowS
forall r. Show r => [OnlyOne r] -> ShowS
forall r. Show r => OnlyOne r -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall r. Show r => Int -> OnlyOne r -> ShowS
showsPrec :: Int -> OnlyOne r -> ShowS
$cshow :: forall r. Show r => OnlyOne r -> [Char]
show :: OnlyOne r -> [Char]
$cshowList :: forall r. Show r => [OnlyOne r] -> ShowS
showList :: [OnlyOne r] -> ShowS
Show)

querySingle_ :: FromRow r => Connection -> Query -> IO (OnlyOne r)
querySingle_ :: forall r. FromRow r => Connection -> Query -> IO (OnlyOne r)
querySingle_ Connection
conn Query
q = do
  [r]
res <- Connection -> Query -> IO [r]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
q
  case [r]
res of
    [] -> OnlyOne r -> IO (OnlyOne r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnlyOne r
forall r. OnlyOne r
NoneExist
    [r
r] -> OnlyOne r -> IO (OnlyOne r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnlyOne r -> IO (OnlyOne r)) -> OnlyOne r -> IO (OnlyOne r)
forall a b. (a -> b) -> a -> b
$ r -> OnlyOne r
forall r. r -> OnlyOne r
OnlyOne r
r
    r
_:[r]
_ -> OnlyOne r -> IO (OnlyOne r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnlyOne r
forall r. OnlyOne r
MultipleExist


-- | Query on a column with a UNIQUE constraint.  Throws an exception if
-- multiple values are returned.
queryUnique :: (ToRow a, FromRow r) => Connection -> Query -> a -> IO (Maybe r)
queryUnique :: forall a r.
(ToRow a, FromRow r) =>
Connection -> Query -> a -> IO (Maybe r)
queryUnique Connection
conn Query
q a
a = do
  [r]
res <- Connection -> Query -> a -> IO [r]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
q a
a
  case [r]
res of
    [] -> Maybe r -> IO (Maybe r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe r
forall a. Maybe a
Nothing
    [r
r] -> Maybe r -> IO (Maybe r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe r -> IO (Maybe r)) -> Maybe r -> IO (Maybe r)
forall a b. (a -> b) -> a -> b
$ r -> Maybe r
forall a. a -> Maybe a
Just r
r
    r
_:[r]
_ -> [Char] -> IO (Maybe r)
forall a. HasCallStack => [Char] -> a
error [Char]
"queryUnique: expecting only a single result at most, but got multiple results.  Is there really a UNIQUE constraint here?"

newtype CloudyInstanceId = CloudyInstanceId { CloudyInstanceId -> Int64
unCloudyInstanceId :: Int64 }
  deriving stock (CloudyInstanceId -> CloudyInstanceId -> Bool
(CloudyInstanceId -> CloudyInstanceId -> Bool)
-> (CloudyInstanceId -> CloudyInstanceId -> Bool)
-> Eq CloudyInstanceId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CloudyInstanceId -> CloudyInstanceId -> Bool
== :: CloudyInstanceId -> CloudyInstanceId -> Bool
$c/= :: CloudyInstanceId -> CloudyInstanceId -> Bool
/= :: CloudyInstanceId -> CloudyInstanceId -> Bool
Eq, Eq CloudyInstanceId
Eq CloudyInstanceId =>
(CloudyInstanceId -> CloudyInstanceId -> Ordering)
-> (CloudyInstanceId -> CloudyInstanceId -> Bool)
-> (CloudyInstanceId -> CloudyInstanceId -> Bool)
-> (CloudyInstanceId -> CloudyInstanceId -> Bool)
-> (CloudyInstanceId -> CloudyInstanceId -> Bool)
-> (CloudyInstanceId -> CloudyInstanceId -> CloudyInstanceId)
-> (CloudyInstanceId -> CloudyInstanceId -> CloudyInstanceId)
-> Ord CloudyInstanceId
CloudyInstanceId -> CloudyInstanceId -> Bool
CloudyInstanceId -> CloudyInstanceId -> Ordering
CloudyInstanceId -> CloudyInstanceId -> CloudyInstanceId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CloudyInstanceId -> CloudyInstanceId -> Ordering
compare :: CloudyInstanceId -> CloudyInstanceId -> Ordering
$c< :: CloudyInstanceId -> CloudyInstanceId -> Bool
< :: CloudyInstanceId -> CloudyInstanceId -> Bool
$c<= :: CloudyInstanceId -> CloudyInstanceId -> Bool
<= :: CloudyInstanceId -> CloudyInstanceId -> Bool
$c> :: CloudyInstanceId -> CloudyInstanceId -> Bool
> :: CloudyInstanceId -> CloudyInstanceId -> Bool
$c>= :: CloudyInstanceId -> CloudyInstanceId -> Bool
>= :: CloudyInstanceId -> CloudyInstanceId -> Bool
$cmax :: CloudyInstanceId -> CloudyInstanceId -> CloudyInstanceId
max :: CloudyInstanceId -> CloudyInstanceId -> CloudyInstanceId
$cmin :: CloudyInstanceId -> CloudyInstanceId -> CloudyInstanceId
min :: CloudyInstanceId -> CloudyInstanceId -> CloudyInstanceId
Ord, Int -> CloudyInstanceId -> ShowS
[CloudyInstanceId] -> ShowS
CloudyInstanceId -> [Char]
(Int -> CloudyInstanceId -> ShowS)
-> (CloudyInstanceId -> [Char])
-> ([CloudyInstanceId] -> ShowS)
-> Show CloudyInstanceId
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloudyInstanceId -> ShowS
showsPrec :: Int -> CloudyInstanceId -> ShowS
$cshow :: CloudyInstanceId -> [Char]
show :: CloudyInstanceId -> [Char]
$cshowList :: [CloudyInstanceId] -> ShowS
showList :: [CloudyInstanceId] -> ShowS
Show)
  deriving newtype (FieldParser CloudyInstanceId
FieldParser CloudyInstanceId -> FromField CloudyInstanceId
forall a. FieldParser a -> FromField a
$cfromField :: FieldParser CloudyInstanceId
fromField :: FieldParser CloudyInstanceId
FromField, CloudyInstanceId -> SQLData
(CloudyInstanceId -> SQLData) -> ToField CloudyInstanceId
forall a. (a -> SQLData) -> ToField a
$ctoField :: CloudyInstanceId -> SQLData
toField :: CloudyInstanceId -> SQLData
ToField)

data CloudyInstance = CloudyInstance
  { CloudyInstance -> CloudyInstanceId
id :: CloudyInstanceId
  , CloudyInstance -> Text
name :: Text
  , CloudyInstance -> Maybe UTCTime
createdAt :: Maybe UTCTime
  , CloudyInstance -> Maybe UTCTime
deletedAt :: Maybe UTCTime
  , CloudyInstance -> Maybe InstanceSetup
instanceSetup :: Maybe InstanceSetup
  }
  deriving stock (CloudyInstance -> CloudyInstance -> Bool
(CloudyInstance -> CloudyInstance -> Bool)
-> (CloudyInstance -> CloudyInstance -> Bool) -> Eq CloudyInstance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CloudyInstance -> CloudyInstance -> Bool
== :: CloudyInstance -> CloudyInstance -> Bool
$c/= :: CloudyInstance -> CloudyInstance -> Bool
/= :: CloudyInstance -> CloudyInstance -> Bool
Eq, Int -> CloudyInstance -> ShowS
[CloudyInstance] -> ShowS
CloudyInstance -> [Char]
(Int -> CloudyInstance -> ShowS)
-> (CloudyInstance -> [Char])
-> ([CloudyInstance] -> ShowS)
-> Show CloudyInstance
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloudyInstance -> ShowS
showsPrec :: Int -> CloudyInstance -> ShowS
$cshow :: CloudyInstance -> [Char]
show :: CloudyInstance -> [Char]
$cshowList :: [CloudyInstance] -> ShowS
showList :: [CloudyInstance] -> ShowS
Show)

instance FromRow CloudyInstance where
  fromRow :: RowParser CloudyInstance
fromRow = do
    CloudyInstanceId
id' <- RowParser CloudyInstanceId
forall a. FromField a => RowParser a
field
    Text
name <- RowParser Text
forall a. FromField a => RowParser a
field
    Maybe UTCTime
createdAt <- (Int64 -> UTCTime) -> Maybe Int64 -> Maybe UTCTime
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> UTCTime
utcTimeFromSqliteInt (Maybe Int64 -> Maybe UTCTime)
-> RowParser (Maybe Int64) -> RowParser (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser (Maybe Int64)
forall a. FromField a => RowParser a
field
    Maybe UTCTime
deletedAt <- (Int64 -> UTCTime) -> Maybe Int64 -> Maybe UTCTime
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> UTCTime
utcTimeFromSqliteInt (Maybe Int64 -> Maybe UTCTime)
-> RowParser (Maybe Int64) -> RowParser (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser (Maybe Int64)
forall a. FromField a => RowParser a
field
    Maybe InstanceSetup
instanceSetup <- (DbInstanceSetup -> InstanceSetup)
-> Maybe DbInstanceSetup -> Maybe InstanceSetup
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DbInstanceSetup -> InstanceSetup
unDbInstanceSetup (Maybe DbInstanceSetup -> Maybe InstanceSetup)
-> RowParser (Maybe DbInstanceSetup)
-> RowParser (Maybe InstanceSetup)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser (Maybe DbInstanceSetup)
forall a. FromField a => RowParser a
field
    CloudyInstance -> RowParser CloudyInstance
forall a. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CloudyInstance -> RowParser CloudyInstance)
-> CloudyInstance -> RowParser CloudyInstance
forall a b. (a -> b) -> a -> b
$ CloudyInstance { $sel:id:CloudyInstance :: CloudyInstanceId
id = CloudyInstanceId
id', Text
$sel:name:CloudyInstance :: Text
name :: Text
name, Maybe UTCTime
$sel:createdAt:CloudyInstance :: Maybe UTCTime
createdAt :: Maybe UTCTime
createdAt, Maybe UTCTime
$sel:deletedAt:CloudyInstance :: Maybe UTCTime
deletedAt :: Maybe UTCTime
deletedAt, Maybe InstanceSetup
$sel:instanceSetup:CloudyInstance :: Maybe InstanceSetup
instanceSetup :: Maybe InstanceSetup
instanceSetup }

-- | newtype to hold the 'FromField' instance for 'InstanceSetup', for use in
-- the 'FromRow' instance for 'CloudyInstance'.
--
-- The @instance_setup@ column in the @cloudy_instance@ table holds a
-- JSON-encoded 'InstanceSetup' value.
newtype DbInstanceSetup = DbInstanceSetup { DbInstanceSetup -> InstanceSetup
unDbInstanceSetup :: InstanceSetup }

instance FromField DbInstanceSetup where
  fromField :: FieldParser DbInstanceSetup
fromField Field
fld = do
    Text
rawInstanceSetup :: Text <- FieldParser Text
forall a. FromField a => FieldParser a
fromField Field
fld
    let eitherInstanceSetup :: Either [Char] InstanceSetup
eitherInstanceSetup = ByteString -> Either [Char] InstanceSetup
forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecodeStrict (ByteString -> Either [Char] InstanceSetup)
-> ByteString -> Either [Char] InstanceSetup
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
rawInstanceSetup
    case Either [Char] InstanceSetup
eitherInstanceSetup of
      Left [Char]
err -> [Char] -> Ok DbInstanceSetup
forall a. [Char] -> Ok a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Ok DbInstanceSetup) -> [Char] -> Ok DbInstanceSetup
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to json decode instance_setup column as InstanceSetup: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
err
      Right InstanceSetup
instanceSetup -> DbInstanceSetup -> Ok DbInstanceSetup
forall a. a -> Ok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbInstanceSetup -> Ok DbInstanceSetup)
-> DbInstanceSetup -> Ok DbInstanceSetup
forall a b. (a -> b) -> a -> b
$ InstanceSetup -> DbInstanceSetup
DbInstanceSetup InstanceSetup
instanceSetup

instance ToField DbInstanceSetup where
  toField :: DbInstanceSetup -> SQLData
toField (DbInstanceSetup InstanceSetup
instSetup) =
    Text -> SQLData
forall a. ToField a => a -> SQLData
toField (Text -> SQLData) -> Text -> SQLData
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
ByteString.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ InstanceSetup -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode InstanceSetup
instSetup

data ScalewayInstance = ScalewayInstance
  { ScalewayInstance -> CloudyInstanceId
cloudyInstanceId :: CloudyInstanceId
  , ScalewayInstance -> Text
scalewayZone :: Text
  , ScalewayInstance -> Text
scalewayInstanceId :: Text
  , ScalewayInstance -> Text
scalewayIpId :: Text
  , ScalewayInstance -> Text
scalewayIpAddress :: Text
  }
  deriving stock (ScalewayInstance -> ScalewayInstance -> Bool
(ScalewayInstance -> ScalewayInstance -> Bool)
-> (ScalewayInstance -> ScalewayInstance -> Bool)
-> Eq ScalewayInstance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScalewayInstance -> ScalewayInstance -> Bool
== :: ScalewayInstance -> ScalewayInstance -> Bool
$c/= :: ScalewayInstance -> ScalewayInstance -> Bool
/= :: ScalewayInstance -> ScalewayInstance -> Bool
Eq, Int -> ScalewayInstance -> ShowS
[ScalewayInstance] -> ShowS
ScalewayInstance -> [Char]
(Int -> ScalewayInstance -> ShowS)
-> (ScalewayInstance -> [Char])
-> ([ScalewayInstance] -> ShowS)
-> Show ScalewayInstance
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScalewayInstance -> ShowS
showsPrec :: Int -> ScalewayInstance -> ShowS
$cshow :: ScalewayInstance -> [Char]
show :: ScalewayInstance -> [Char]
$cshowList :: [ScalewayInstance] -> ShowS
showList :: [ScalewayInstance] -> ShowS
Show)

instance FromRow ScalewayInstance where
  fromRow :: RowParser ScalewayInstance
fromRow = do
    CloudyInstanceId
cloudyInstanceId <- RowParser CloudyInstanceId
forall a. FromField a => RowParser a
field
    Text
scalewayZone <- RowParser Text
forall a. FromField a => RowParser a
field
    Text
scalewayInstanceId <- RowParser Text
forall a. FromField a => RowParser a
field
    Text
scalewayIpId <- RowParser Text
forall a. FromField a => RowParser a
field
    Text
scalewayIpAddress <- RowParser Text
forall a. FromField a => RowParser a
field
    ScalewayInstance -> RowParser ScalewayInstance
forall a. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalewayInstance -> RowParser ScalewayInstance)
-> ScalewayInstance -> RowParser ScalewayInstance
forall a b. (a -> b) -> a -> b
$ ScalewayInstance { CloudyInstanceId
$sel:cloudyInstanceId:ScalewayInstance :: CloudyInstanceId
cloudyInstanceId :: CloudyInstanceId
cloudyInstanceId, Text
$sel:scalewayZone:ScalewayInstance :: Text
scalewayZone :: Text
scalewayZone, Text
$sel:scalewayInstanceId:ScalewayInstance :: Text
scalewayInstanceId :: Text
scalewayInstanceId, Text
$sel:scalewayIpId:ScalewayInstance :: Text
scalewayIpId :: Text
scalewayIpId, Text
$sel:scalewayIpAddress:ScalewayInstance :: Text
scalewayIpAddress :: Text
scalewayIpAddress }

instance ToRow ScalewayInstance where
  toRow :: ScalewayInstance -> [SQLData]
toRow ScalewayInstance {CloudyInstanceId
$sel:cloudyInstanceId:ScalewayInstance :: ScalewayInstance -> CloudyInstanceId
cloudyInstanceId :: CloudyInstanceId
cloudyInstanceId, Text
$sel:scalewayZone:ScalewayInstance :: ScalewayInstance -> Text
scalewayZone :: Text
scalewayZone, Text
$sel:scalewayInstanceId:ScalewayInstance :: ScalewayInstance -> Text
scalewayInstanceId :: Text
scalewayInstanceId, Text
$sel:scalewayIpId:ScalewayInstance :: ScalewayInstance -> Text
scalewayIpId :: Text
scalewayIpId, Text
$sel:scalewayIpAddress:ScalewayInstance :: ScalewayInstance -> Text
scalewayIpAddress :: Text
scalewayIpAddress} =
    (CloudyInstanceId, Text, Text, Text, Text) -> [SQLData]
forall a. ToRow a => a -> [SQLData]
toRow (CloudyInstanceId
cloudyInstanceId, Text
scalewayZone, Text
scalewayInstanceId, Text
scalewayIpId, Text
scalewayIpAddress)

data InstanceInfo
  = CloudyScalewayInstance CloudyInstance ScalewayInstance
  | CloudyAwsInstance CloudyInstance Void {- TODO: actually implement AWS stuff -}
  deriving stock Int -> InstanceInfo -> ShowS
[InstanceInfo] -> ShowS
InstanceInfo -> [Char]
(Int -> InstanceInfo -> ShowS)
-> (InstanceInfo -> [Char])
-> ([InstanceInfo] -> ShowS)
-> Show InstanceInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InstanceInfo -> ShowS
showsPrec :: Int -> InstanceInfo -> ShowS
$cshow :: InstanceInfo -> [Char]
show :: InstanceInfo -> [Char]
$cshowList :: [InstanceInfo] -> ShowS
showList :: [InstanceInfo] -> ShowS
Show

cloudyInstanceFromInstanceInfo :: InstanceInfo -> CloudyInstance
cloudyInstanceFromInstanceInfo :: InstanceInfo -> CloudyInstance
cloudyInstanceFromInstanceInfo = \case
  CloudyScalewayInstance CloudyInstance
cloudyInstance ScalewayInstance
_ -> CloudyInstance
cloudyInstance
  CloudyAwsInstance CloudyInstance
cloudyInstance Void
_ -> CloudyInstance
cloudyInstance

newCloudyInstance :: Connection -> IO (CloudyInstanceId, Text)
newCloudyInstance :: Connection -> IO (CloudyInstanceId, Text)
newCloudyInstance Connection
conn = Connection
-> IO (CloudyInstanceId, Text) -> IO (CloudyInstanceId, Text)
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn IO (CloudyInstanceId, Text)
go
  where
    go :: IO (CloudyInstanceId, Text)
    go :: IO (CloudyInstanceId, Text)
go = do
      Text
possibleName <- IO Text
instanceNameGen
      Maybe CloudyInstance
maybeInstance <- Connection -> Text -> IO (Maybe CloudyInstance)
findCloudyInstanceByNameWithDeleted Connection
conn Text
possibleName
      case Maybe CloudyInstance
maybeInstance of
        -- No instance exists with this name yet. Insert a new blank instance.
        Maybe CloudyInstance
Nothing -> do
          Connection -> Query -> Only Text -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute
            Connection
conn
            Query
"INSERT INTO cloudy_instance \
            \(name) \
            \VALUES (?)"
            (Text -> Only Text
forall a. a -> Only a
Only Text
possibleName)
          Int64
cloudyInstanceId <- Connection -> IO Int64
lastInsertRowId Connection
conn
          (CloudyInstanceId, Text) -> IO (CloudyInstanceId, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> CloudyInstanceId
CloudyInstanceId Int64
cloudyInstanceId, Text
possibleName)
        -- An instance already exists with this name, try again.
        Just CloudyInstance
_ -> IO (CloudyInstanceId, Text)
go

-- | Return a cloudy instance matching the given name.
-- This will return an instance even if it has already been deleted.
findCloudyInstanceByNameWithDeleted :: Connection -> Text -> IO (Maybe CloudyInstance)
findCloudyInstanceByNameWithDeleted :: Connection -> Text -> IO (Maybe CloudyInstance)
findCloudyInstanceByNameWithDeleted Connection
conn Text
cloudyInstanceName = do
  [CloudyInstance] -> Maybe CloudyInstance
forall a. [a] -> Maybe a
listToMaybe ([CloudyInstance] -> Maybe CloudyInstance)
-> IO [CloudyInstance] -> IO (Maybe CloudyInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Connection -> Query -> Only Text -> IO [CloudyInstance]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query
      Connection
conn
      Query
"SELECT id, name, created_at, deleted_at, instance_setup \
      \FROM cloudy_instance \
      \WHERE name == ? \
      \ORDER BY id"
      (Text -> Only Text
forall a. a -> Only a
Only Text
cloudyInstanceName)

findCloudyInstanceIdByName :: Connection -> Text -> IO (Maybe CloudyInstanceId)
findCloudyInstanceIdByName :: Connection -> Text -> IO (Maybe CloudyInstanceId)
findCloudyInstanceIdByName Connection
conn Text
cloudyInstanceName = do
  (Only CloudyInstanceId -> CloudyInstanceId)
-> Maybe (Only CloudyInstanceId) -> Maybe CloudyInstanceId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only CloudyInstanceId -> CloudyInstanceId
forall a. Only a -> a
fromOnly (Maybe (Only CloudyInstanceId) -> Maybe CloudyInstanceId)
-> ([Only CloudyInstanceId] -> Maybe (Only CloudyInstanceId))
-> [Only CloudyInstanceId]
-> Maybe CloudyInstanceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only CloudyInstanceId] -> Maybe (Only CloudyInstanceId)
forall a. [a] -> Maybe a
listToMaybe ([Only CloudyInstanceId] -> Maybe CloudyInstanceId)
-> IO [Only CloudyInstanceId] -> IO (Maybe CloudyInstanceId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Connection -> Query -> Only Text -> IO [Only CloudyInstanceId]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query
      Connection
conn
      Query
"SELECT id \
      \FROM cloudy_instance \
      \WHERE name == ? AND deleted_at IS NULL"
      (Text -> Only Text
forall a. a -> Only a
Only Text
cloudyInstanceName)

findCloudyInstanceById :: Connection -> CloudyInstanceId -> IO (Maybe CloudyInstance)
findCloudyInstanceById :: Connection -> CloudyInstanceId -> IO (Maybe CloudyInstance)
findCloudyInstanceById Connection
conn CloudyInstanceId
cloudyInstanceId = do
  [CloudyInstance] -> Maybe CloudyInstance
forall a. [a] -> Maybe a
listToMaybe ([CloudyInstance] -> Maybe CloudyInstance)
-> IO [CloudyInstance] -> IO (Maybe CloudyInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Connection -> Query -> Only CloudyInstanceId -> IO [CloudyInstance]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query
      Connection
conn
      Query
"SELECT id, name, created_at, deleted_at, instance_setup \
      \FROM cloudy_instance \
      \WHERE id == ? AND deleted_at IS NULL AND created_at IS NOT NULL"
      (CloudyInstanceId -> Only CloudyInstanceId
forall a. a -> Only a
Only CloudyInstanceId
cloudyInstanceId)

findAllCloudyInstances :: Connection -> IO [CloudyInstance]
findAllCloudyInstances :: Connection -> IO [CloudyInstance]
findAllCloudyInstances Connection
conn =
  Connection -> Query -> IO [CloudyInstance]
forall r. FromRow r => Connection -> Query -> IO [r]
query_
    Connection
conn
    Query
"SELECT id, name, created_at, deleted_at, instance_setup \
    \FROM cloudy_instance \
    \WHERE deleted_at IS NULL AND created_at IS NOT NULL \
    \ORDER BY id"

setCloudyInstanceDeleted :: Connection -> CloudyInstanceId -> IO ()
setCloudyInstanceDeleted :: Connection -> CloudyInstanceId -> IO ()
setCloudyInstanceDeleted Connection
conn CloudyInstanceId
cloudyInstanceId = do
    UTCTime
currTime <- IO UTCTime
getCurrentTime
    Connection -> Query -> (Int64, CloudyInstanceId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute
      Connection
conn
      Query
"UPDATE cloudy_instance \
      \SET deleted_at = ? \
      \WHERE id = ?"
      (UTCTime -> Int64
utcTimeToSqliteInt UTCTime
currTime, CloudyInstanceId
cloudyInstanceId)

newScalewayInstance ::
  Connection ->
  UTCTime ->
  CloudyInstanceId ->
  Maybe InstanceSetup ->
  -- | Scaleway Zone
  Text ->
  -- | Scaleway Instance Id
  Text ->
  -- | Scaleway IP Id
  Text ->
  -- | Scaleway IP Address
  Text ->
  IO ()
newScalewayInstance :: Connection
-> UTCTime
-> CloudyInstanceId
-> Maybe InstanceSetup
-> Text
-> Text
-> Text
-> Text
-> IO ()
newScalewayInstance Connection
conn UTCTime
creationTime CloudyInstanceId
cloudyInstanceId Maybe InstanceSetup
instSetup Text
scalewayZone Text
scalewayInstanceId Text
scalewayIpId Text
scalewayIpAddress =
  Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Connection
-> Query
-> (Int64, Maybe DbInstanceSetup, CloudyInstanceId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute
      Connection
conn
      Query
"UPDATE cloudy_instance \
      \SET created_at = ?, instance_setup = ? \
      \WHERE id = ?"
      (UTCTime -> Int64
utcTimeToSqliteInt UTCTime
creationTime, (InstanceSetup -> DbInstanceSetup)
-> Maybe InstanceSetup -> Maybe DbInstanceSetup
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InstanceSetup -> DbInstanceSetup
DbInstanceSetup Maybe InstanceSetup
instSetup, CloudyInstanceId
cloudyInstanceId)
    Connection -> Query -> ScalewayInstance -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute
      Connection
conn
      Query
"INSERT INTO scaleway_instance \
      \(cloudy_instance_id, scaleway_zone, scaleway_instance_id, scaleway_ip_id, scaleway_ip_address) \
      \VALUES (?, ?, ?, ?, ?)"
      ScalewayInstance { CloudyInstanceId
$sel:cloudyInstanceId:ScalewayInstance :: CloudyInstanceId
cloudyInstanceId :: CloudyInstanceId
cloudyInstanceId, Text
$sel:scalewayZone:ScalewayInstance :: Text
scalewayZone :: Text
scalewayZone, Text
$sel:scalewayInstanceId:ScalewayInstance :: Text
scalewayInstanceId :: Text
scalewayInstanceId, Text
$sel:scalewayIpId:ScalewayInstance :: Text
scalewayIpId :: Text
scalewayIpId, Text
$sel:scalewayIpAddress:ScalewayInstance :: Text
scalewayIpAddress :: Text
scalewayIpAddress }

findScalewayInstanceByCloudyInstanceId :: Connection -> CloudyInstanceId -> IO (Maybe ScalewayInstance)
findScalewayInstanceByCloudyInstanceId :: Connection -> CloudyInstanceId -> IO (Maybe ScalewayInstance)
findScalewayInstanceByCloudyInstanceId Connection
conn CloudyInstanceId
cloudyInstanceId =
  [ScalewayInstance] -> Maybe ScalewayInstance
forall a. [a] -> Maybe a
listToMaybe ([ScalewayInstance] -> Maybe ScalewayInstance)
-> IO [ScalewayInstance] -> IO (Maybe ScalewayInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Connection
-> Query -> Only CloudyInstanceId -> IO [ScalewayInstance]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query
      Connection
conn
      Query
"SELECT cloudy_instance_id, scaleway_zone, scaleway_instance_id, scaleway_ip_id, scaleway_ip_address \
      \FROM scaleway_instance \
      \WHERE cloudy_instance_id == ?"
      (CloudyInstanceId -> Only CloudyInstanceId
forall a. a -> Only a
Only CloudyInstanceId
cloudyInstanceId)

findAllScalewayInstances :: Connection -> IO [ScalewayInstance]
findAllScalewayInstances :: Connection -> IO [ScalewayInstance]
findAllScalewayInstances Connection
conn =
  Connection -> Query -> IO [ScalewayInstance]
forall r. FromRow r => Connection -> Query -> IO [r]
query_
    Connection
conn
    Query
"SELECT \
    \  scaleway_instance.cloudy_instance_id, \
    \  scaleway_instance.scaleway_zone, \
    \  scaleway_instance.scaleway_instance_id, \
    \  scaleway_instance.scaleway_ip_id, \
    \  scaleway_instance.scaleway_ip_address \
    \FROM scaleway_instance \
    \INNER JOIN cloudy_instance ON scaleway_instance.cloudy_instance_id == cloudy_instance.id \
    \WHERE cloudy_instance.deleted_at IS NULL AND cloudy_instance.created_at IS NOT NULL"


-- | Return a single CloudyInstanceId if there is exactly one in the database that
-- is not already deleted.
findOnlyOneInstanceId :: Connection -> IO (OnlyOne CloudyInstanceId)
findOnlyOneInstanceId :: Connection -> IO (OnlyOne CloudyInstanceId)
findOnlyOneInstanceId Connection
conn = do
  OnlyOne (Only CloudyInstanceId)
onlyOneInstId <-
    Connection -> Query -> IO (OnlyOne (Only CloudyInstanceId))
forall r. FromRow r => Connection -> Query -> IO (OnlyOne r)
querySingle_
      Connection
conn
      Query
"SELECT id \
      \FROM cloudy_instance \
      \WHERE deleted_at IS NULL"
  OnlyOne CloudyInstanceId -> IO (OnlyOne CloudyInstanceId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnlyOne CloudyInstanceId -> IO (OnlyOne CloudyInstanceId))
-> OnlyOne CloudyInstanceId -> IO (OnlyOne CloudyInstanceId)
forall a b. (a -> b) -> a -> b
$ (Only CloudyInstanceId -> CloudyInstanceId)
-> OnlyOne (Only CloudyInstanceId) -> OnlyOne CloudyInstanceId
forall a b. (a -> b) -> OnlyOne a -> OnlyOne b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only CloudyInstanceId -> CloudyInstanceId
forall a. Only a -> a
fromOnly OnlyOne (Only CloudyInstanceId)
onlyOneInstId

utcTimeToSqliteInt :: UTCTime -> Int64
utcTimeToSqliteInt :: UTCTime -> Int64
utcTimeToSqliteInt = POSIXTime -> Int64
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int64) -> (UTCTime -> POSIXTime) -> UTCTime -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds

utcTimeFromSqliteInt :: Int64 -> UTCTime
utcTimeFromSqliteInt :: Int64 -> UTCTime
utcTimeFromSqliteInt = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> (Int64 -> POSIXTime) -> Int64 -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instanceInfoForId :: Connection -> CloudyInstanceId -> IO (Maybe InstanceInfo)
instanceInfoForId :: Connection -> CloudyInstanceId -> IO (Maybe InstanceInfo)
instanceInfoForId Connection
conn CloudyInstanceId
cloudyInstanceId = Connection -> IO (Maybe InstanceInfo) -> IO (Maybe InstanceInfo)
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn (IO (Maybe InstanceInfo) -> IO (Maybe InstanceInfo))
-> IO (Maybe InstanceInfo) -> IO (Maybe InstanceInfo)
forall a b. (a -> b) -> a -> b
$ do
  Maybe CloudyInstance
maybeCloudyInstance <- Connection -> CloudyInstanceId -> IO (Maybe CloudyInstance)
findCloudyInstanceById Connection
conn CloudyInstanceId
cloudyInstanceId
  case Maybe CloudyInstance
maybeCloudyInstance of
    Maybe CloudyInstance
Nothing -> Maybe InstanceInfo -> IO (Maybe InstanceInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InstanceInfo
forall a. Maybe a
Nothing
    Just CloudyInstance
cloudyInstance -> do
      Maybe ScalewayInstance
maybeCloudyInstanceId <- Connection -> CloudyInstanceId -> IO (Maybe ScalewayInstance)
findScalewayInstanceByCloudyInstanceId Connection
conn CloudyInstance
cloudyInstance.id
      Maybe InstanceInfo -> IO (Maybe InstanceInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe InstanceInfo -> IO (Maybe InstanceInfo))
-> Maybe InstanceInfo -> IO (Maybe InstanceInfo)
forall a b. (a -> b) -> a -> b
$ (ScalewayInstance -> InstanceInfo)
-> Maybe ScalewayInstance -> Maybe InstanceInfo
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CloudyInstance -> ScalewayInstance -> InstanceInfo
CloudyScalewayInstance CloudyInstance
cloudyInstance) Maybe ScalewayInstance
maybeCloudyInstanceId

findAllInstanceInfos :: Connection -> IO [InstanceInfo]
findAllInstanceInfos :: Connection -> IO [InstanceInfo]
findAllInstanceInfos Connection
conn = Connection -> IO [InstanceInfo] -> IO [InstanceInfo]
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn (IO [InstanceInfo] -> IO [InstanceInfo])
-> IO [InstanceInfo] -> IO [InstanceInfo]
forall a b. (a -> b) -> a -> b
$ do
  [CloudyInstance]
cloudyInstances <- Connection -> IO [CloudyInstance]
findAllCloudyInstances Connection
conn
  [ScalewayInstance]
scalewayInstances <- Connection -> IO [ScalewayInstance]
findAllScalewayInstances Connection
conn
  [CloudyInstance]
-> (CloudyInstance -> IO InstanceInfo) -> IO [InstanceInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [CloudyInstance]
cloudyInstances ((CloudyInstance -> IO InstanceInfo) -> IO [InstanceInfo])
-> (CloudyInstance -> IO InstanceInfo) -> IO [InstanceInfo]
forall a b. (a -> b) -> a -> b
$ \CloudyInstance
cloudyInstance -> do
    let maybeScalewayInstance :: Maybe ScalewayInstance
maybeScalewayInstance =
          (ScalewayInstance -> Bool)
-> [ScalewayInstance] -> Maybe ScalewayInstance
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
            (\ScalewayInstance
scalewayInst -> ScalewayInstance
scalewayInst.cloudyInstanceId CloudyInstanceId -> CloudyInstanceId -> Bool
forall a. Eq a => a -> a -> Bool
== CloudyInstance
cloudyInstance.id)
            [ScalewayInstance]
scalewayInstances
    case Maybe ScalewayInstance
maybeScalewayInstance of
      Maybe ScalewayInstance
Nothing ->
        [Char] -> IO InstanceInfo
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO InstanceInfo) -> [Char] -> IO InstanceInfo
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find scaleway instance for cloudyInstance: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> CloudyInstance -> [Char]
forall a. Show a => a -> [Char]
show CloudyInstance
cloudyInstance
      Just ScalewayInstance
scalewayInstance ->
        InstanceInfo -> IO InstanceInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstanceInfo -> IO InstanceInfo)
-> InstanceInfo -> IO InstanceInfo
forall a b. (a -> b) -> a -> b
$ CloudyInstance -> ScalewayInstance -> InstanceInfo
CloudyScalewayInstance CloudyInstance
cloudyInstance ScalewayInstance
scalewayInstance


data DbInvariantErr
  = CloudyInstanceHasNoProviderInstance CloudyInstanceId
  | CloudyInstanceHasMultipleProviderInstances CloudyInstanceId
  | CloudyInstanceHasNullCreatedAt CloudyInstanceId
  deriving stock Int -> DbInvariantErr -> ShowS
[DbInvariantErr] -> ShowS
DbInvariantErr -> [Char]
(Int -> DbInvariantErr -> ShowS)
-> (DbInvariantErr -> [Char])
-> ([DbInvariantErr] -> ShowS)
-> Show DbInvariantErr
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DbInvariantErr -> ShowS
showsPrec :: Int -> DbInvariantErr -> ShowS
$cshow :: DbInvariantErr -> [Char]
show :: DbInvariantErr -> [Char]
$cshowList :: [DbInvariantErr] -> ShowS
showList :: [DbInvariantErr] -> ShowS
Show

assertDbInvariants :: Connection -> IO ()
assertDbInvariants :: Connection -> IO ()
assertDbInvariants Connection
conn = Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  [DbInvariantErr]
invariantErrors :: [DbInvariantErr] <-
    [IO [DbInvariantErr]] -> IO [DbInvariantErr]
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
      [ Connection -> IO [DbInvariantErr]
invariantEveryCloudyInstHasExactlyOneProviderInst Connection
conn
      , Connection -> IO [DbInvariantErr]
invariantCloudyInstCorectDates Connection
conn
      -- TODO: add invariant that says two non-deleted scaleway servers should
      -- never have the same IP addresses
      ]
  case [DbInvariantErr]
invariantErrors of
    [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [DbInvariantErr]
_ ->
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"assertDbInvariants: DB invariants have been violated: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [DbInvariantErr] -> [Char]
forall a. Show a => a -> [Char]
show [DbInvariantErr]
invariantErrors

-- | There needs to be EXACTLY ONE corresponding cloud provider instance for each
-- cloudy instance.
invariantEveryCloudyInstHasExactlyOneProviderInst :: Connection -> IO [DbInvariantErr]
invariantEveryCloudyInstHasExactlyOneProviderInst :: Connection -> IO [DbInvariantErr]
invariantEveryCloudyInstHasExactlyOneProviderInst Connection
conn = do
  [CloudyInstanceId]
allCloudyInstIds <- (Only CloudyInstanceId -> CloudyInstanceId)
-> [Only CloudyInstanceId] -> [CloudyInstanceId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only CloudyInstanceId -> CloudyInstanceId
forall a. Only a -> a
fromOnly ([Only CloudyInstanceId] -> [CloudyInstanceId])
-> IO [Only CloudyInstanceId] -> IO [CloudyInstanceId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [Only CloudyInstanceId]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT id FROM cloudy_instance"
  [Maybe DbInvariantErr]
maybeErrs <- [CloudyInstanceId]
-> (CloudyInstanceId -> IO (Maybe DbInvariantErr))
-> IO [Maybe DbInvariantErr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [CloudyInstanceId]
allCloudyInstIds CloudyInstanceId -> IO (Maybe DbInvariantErr)
checkCloudyInstProviders
  [DbInvariantErr] -> IO [DbInvariantErr]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DbInvariantErr] -> IO [DbInvariantErr])
-> [DbInvariantErr] -> IO [DbInvariantErr]
forall a b. (a -> b) -> a -> b
$ [Maybe DbInvariantErr] -> [DbInvariantErr]
forall a. [Maybe a] -> [a]
catMaybes [Maybe DbInvariantErr]
maybeErrs
  where
    checkCloudyInstProviders :: CloudyInstanceId -> IO (Maybe DbInvariantErr)
    checkCloudyInstProviders :: CloudyInstanceId -> IO (Maybe DbInvariantErr)
checkCloudyInstProviders CloudyInstanceId
cloudyInstId = do
      Maybe Text
maybeScalewayInstId :: Maybe Text <-
        (Only Text -> Text) -> Maybe (Only Text) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only Text -> Text
forall a. Only a -> a
fromOnly (Maybe (Only Text) -> Maybe Text)
-> IO (Maybe (Only Text)) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Connection
-> Query -> Only CloudyInstanceId -> IO (Maybe (Only Text))
forall a r.
(ToRow a, FromRow r) =>
Connection -> Query -> a -> IO (Maybe r)
queryUnique
            Connection
conn
            Query
"SELECT scaleway_instance_id \
            \FROM scaleway_instance \
            \WHERE cloudy_instance_id == ?"
            (CloudyInstanceId -> Only CloudyInstanceId
forall a. a -> Only a
Only CloudyInstanceId
cloudyInstId)
      case Maybe Text
maybeScalewayInstId of
        Just Text
_scalewayInstId -> Maybe DbInvariantErr -> IO (Maybe DbInvariantErr)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DbInvariantErr
forall a. Maybe a
Nothing
        Maybe Text
Nothing -> Maybe DbInvariantErr -> IO (Maybe DbInvariantErr)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DbInvariantErr -> IO (Maybe DbInvariantErr))
-> Maybe DbInvariantErr -> IO (Maybe DbInvariantErr)
forall a b. (a -> b) -> a -> b
$ DbInvariantErr -> Maybe DbInvariantErr
forall a. a -> Maybe a
Just (DbInvariantErr -> Maybe DbInvariantErr)
-> DbInvariantErr -> Maybe DbInvariantErr
forall a b. (a -> b) -> a -> b
$ CloudyInstanceId -> DbInvariantErr
CloudyInstanceHasNoProviderInstance CloudyInstanceId
cloudyInstId

-- | Cloudy instances should always have a @created_at@ value that is non-null.
--
-- The only time a Cloudy instance can have a @created_at@ value that is null
-- is within the Create CLI command.  Although this invariant should hold both
-- before and after the Create CLI command.
invariantCloudyInstCorectDates :: Connection -> IO [DbInvariantErr]
invariantCloudyInstCorectDates :: Connection -> IO [DbInvariantErr]
invariantCloudyInstCorectDates Connection
conn = do
  [CloudyInstanceId]
instIds <-
    (Only CloudyInstanceId -> CloudyInstanceId)
-> [Only CloudyInstanceId] -> [CloudyInstanceId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only CloudyInstanceId -> CloudyInstanceId
forall a. Only a -> a
fromOnly ([Only CloudyInstanceId] -> [CloudyInstanceId])
-> IO [Only CloudyInstanceId] -> IO [CloudyInstanceId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Connection -> Query -> IO [Only CloudyInstanceId]
forall r. FromRow r => Connection -> Query -> IO [r]
query_
        Connection
conn
        Query
"SELECT id FROM cloudy_instance WHERE created_at is NULL"
  [DbInvariantErr] -> IO [DbInvariantErr]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DbInvariantErr] -> IO [DbInvariantErr])
-> [DbInvariantErr] -> IO [DbInvariantErr]
forall a b. (a -> b) -> a -> b
$ (CloudyInstanceId -> DbInvariantErr)
-> [CloudyInstanceId] -> [DbInvariantErr]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CloudyInstanceId -> DbInvariantErr
CloudyInstanceHasNullCreatedAt [CloudyInstanceId]
instIds