{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cassandra.MigrateSchema (migrateSchema) where

import Cassandra (Client, Consistency (All, One), Keyspace (Keyspace), PrepQuery, QueryString (QueryString), R, S, Version (V4), W, params, query, query1, retry, runClient, write, x1)
import Cassandra.Schema
import Cassandra.Settings (Policy, defSettings, initialContactsPlain, setConnectTimeout, setContacts, setLogger, setMaxConnections, setPolicy, setPoolStripes, setPortNumber, setProtocolVersion, setResponseTimeout, setSendTimeout)
import Cassandra.Util (initCassandra)
import Control.Retry
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text (pack)
import Data.Text.Lazy (fromStrict)
import Data.Time.Clock
import Data.UUID (UUID)
import Database.CQL.IO (Policy (Policy, acceptable, current, display, hostCount, onEvent, select, setup), schema)
import Database.CQL.IO.Tinylog qualified as CT
import Imports hiding (All, fromString, init, intercalate, log)
import System.Logger qualified as Log

-- FUTUREWORK: We could use the System.Logger.Class here in the future, but we don't have a ReaderT IO here (yet)
migrateSchema :: Log.Logger -> MigrationOpts -> [Migration] -> IO ()
migrateSchema :: Logger -> MigrationOpts -> [Migration] -> IO ()
migrateSchema Logger
l MigrationOpts
o [Migration]
ms = do
  NonEmpty [Char]
hosts <- Text -> IO (NonEmpty [Char])
forall (m :: * -> *). MonadIO m => Text -> m (NonEmpty [Char])
initialContactsPlain (Text -> IO (NonEmpty [Char])) -> Text -> IO (NonEmpty [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack (MigrationOpts -> [Char]
migHost MigrationOpts
o)
  let cqlSettings :: Settings
cqlSettings =
        Logger -> Settings -> Settings
setLogger (Logger -> Logger
CT.mkLogger Logger
l)
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> Settings -> Settings
setContacts (NonEmpty [Char] -> [Char]
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty [Char]
hosts) (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NonEmpty.tail NonEmpty [Char]
hosts)
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> Settings -> Settings
setPortNumber (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> PortNumber) -> Word16 -> PortNumber
forall a b. (a -> b) -> a -> b
$ MigrationOpts -> Word16
migPort MigrationOpts
o)
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Settings -> Settings
setMaxConnections Int
1
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Settings -> Settings
setPoolStripes Int
1
          -- 'migrationPolicy' ensures we only talk to one host for all queries
          -- required for correct functioning of 'waitForSchemaConsistency'
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Policy -> Settings -> Settings
setPolicy IO Policy
migrationPolicy
          -- use higher timeouts on schema migrations to reduce the probability
          -- of a timeout happening during 'migAction' or 'metaInsert',
          -- as that can lead to a state where schema migrations cannot be re-run
          -- without manual action.
          -- (due to e.g. "cannot create table X, already exists" errors)
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Settings -> Settings
setConnectTimeout NominalDiffTime
20
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Settings -> Settings
setSendTimeout NominalDiffTime
20
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Settings -> Settings
setResponseTimeout NominalDiffTime
50
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Settings -> Settings
setProtocolVersion Version
V4
          (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
defSettings
  ClientState
cas <- Settings -> Maybe [Char] -> Logger -> IO ClientState
initCassandra Settings
cqlSettings MigrationOpts
o.migTlsCa Logger
l
  ClientState -> Client () -> IO ()
forall (m :: * -> *) a. MonadIO m => ClientState -> Client a -> m a
runClient ClientState
cas (Client () -> IO ()) -> Client () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let keyspace :: Keyspace
keyspace = Text -> Keyspace
Keyspace (Text -> Keyspace)
-> (MigrationOpts -> Text) -> MigrationOpts -> Keyspace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationOpts -> Text
migKeyspace (MigrationOpts -> Keyspace) -> MigrationOpts -> Keyspace
forall a b. (a -> b) -> a -> b
$ MigrationOpts
o
    Bool -> Client () -> Client ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOpts -> Bool
migReset MigrationOpts
o) (Client () -> Client ()) -> Client () -> Client ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> Client ()
info Text
"Dropping keyspace."
      Client (Maybe SchemaChange) -> Client ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Client (Maybe SchemaChange) -> Client ())
-> Client (Maybe SchemaChange) -> Client ()
forall a b. (a -> b) -> a -> b
$ QueryString S () ()
-> QueryParams () -> Client (Maybe SchemaChange)
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q S a () -> QueryParams a -> m (Maybe SchemaChange)
schema (Keyspace -> QueryString S () ()
dropKeyspace Keyspace
keyspace) (Consistency -> () -> QueryParams ()
forall a. Consistency -> a -> QueryParams a
params Consistency
All ())
    Keyspace -> ReplicationStrategy -> Client ()
createKeyspace Keyspace
keyspace (MigrationOpts -> ReplicationStrategy
migRepl MigrationOpts
o)
    Keyspace -> Client ()
useKeyspace Keyspace
keyspace
    Client (Maybe SchemaChange) -> Client ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Client (Maybe SchemaChange) -> Client ())
-> Client (Maybe SchemaChange) -> Client ()
forall a b. (a -> b) -> a -> b
$ QueryString S () ()
-> QueryParams () -> Client (Maybe SchemaChange)
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q S a () -> QueryParams a -> m (Maybe SchemaChange)
schema QueryString S () ()
metaCreate (Consistency -> () -> QueryParams ()
forall a. Consistency -> a -> QueryParams a
params Consistency
All ())
    [Migration]
migrations <- Maybe Int32 -> [Migration]
newer (Maybe Int32 -> [Migration])
-> Client (Maybe Int32) -> Client [Migration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client (Maybe Int32)
schemaVersion
    if [Migration] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Migration]
migrations
      then Text -> Client ()
info Text
"No new migrations."
      else Text -> Client ()
info Text
"New migrations found."
    [Migration] -> (Migration -> Client ()) -> Client ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Migration]
migrations ((Migration -> Client ()) -> Client ())
-> (Migration -> Client ()) -> Client ()
forall a b. (a -> b) -> a -> b
$ \Migration {Int32
Text
Client ()
migVersion :: Int32
migText :: Text
migAction :: Client ()
$sel:migVersion:Migration :: Migration -> Int32
$sel:migText:Migration :: Migration -> Text
$sel:migAction:Migration :: Migration -> Client ()
..} -> do
      Text -> Client ()
info (Text -> Client ()) -> Text -> Client ()
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (Int32 -> [Char]
forall a. Show a => a -> [Char]
show Int32
migVersion) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
migText
      Client ()
migAction
      UTCTime
now <- IO UTCTime -> Client UTCTime
forall a. IO a -> Client a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      QueryString W (Int32, Text, UTCTime) ()
-> QueryParams (Int32, Text, UTCTime) -> Client ()
forall (m :: * -> *) a (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, RunQ q) =>
q W a () -> QueryParams a -> m ()
write QueryString W (Int32, Text, UTCTime) ()
metaInsert (Consistency
-> (Int32, Text, UTCTime) -> QueryParams (Int32, Text, UTCTime)
forall a. Consistency -> a -> QueryParams a
params Consistency
All (Int32
migVersion, Text
migText, UTCTime
now))
      Text -> Client ()
info Text
"Waiting for schema version consistency across peers..."
      Client ()
waitForSchemaConsistency
      Text -> Client ()
info Text
"... done waiting."
  where
    newer :: Maybe Int32 -> [Migration]
newer Maybe Int32
v =
      (Migration -> Bool) -> [Migration] -> [Migration]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Int32 -> Bool)
-> (Int32 -> Int32 -> Bool) -> Maybe Int32 -> Int32 -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Int32 -> Bool
forall a b. a -> b -> a
const Bool
False) Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
(>=) Maybe Int32
v (Int32 -> Bool) -> (Migration -> Int32) -> Migration -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration -> Int32
migVersion)
        ([Migration] -> [Migration])
-> ([Migration] -> [Migration]) -> [Migration] -> [Migration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Migration -> Migration -> Ordering) -> [Migration] -> [Migration]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\Migration
x Migration
y -> Migration -> Int32
migVersion Migration
x Int32 -> Int32 -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Migration -> Int32
migVersion Migration
y)
        ([Migration] -> [Migration]) -> [Migration] -> [Migration]
forall a b. (a -> b) -> a -> b
$ [Migration]
ms
    info :: Text -> Client ()
info = IO () -> Client ()
forall a. IO a -> Client a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Client ()) -> (Text -> IO ()) -> Text -> Client ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> Level -> (Msg -> Msg) -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
Log.log Logger
l Level
Log.Info ((Msg -> Msg) -> IO ()) -> (Text -> Msg -> Msg) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
Log.msg
    dropKeyspace :: Keyspace -> QueryString S () ()
    dropKeyspace :: Keyspace -> QueryString S () ()
dropKeyspace (Keyspace Text
k) = Text -> QueryString S () ()
forall k a b. Text -> QueryString k a b
QueryString (Text -> QueryString S () ()) -> Text -> QueryString S () ()
forall a b. (a -> b) -> a -> b
$ Text
"drop keyspace if exists \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
fromStrict Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
    metaCreate :: QueryString S () ()
    metaCreate :: QueryString S () ()
metaCreate = QueryString S () ()
"create columnfamily if not exists meta (id int, version int, descr text, date timestamp, primary key (id, version))"
    metaInsert :: QueryString W (Int32, Text, UTCTime) ()
    metaInsert :: QueryString W (Int32, Text, UTCTime) ()
metaInsert = QueryString W (Int32, Text, UTCTime) ()
"insert into meta (id, version, descr, date) values (1,?,?,?)"

-- | Retrieve and compare local and peer system schema versions.
-- if they don't match, retry once per second for 30 seconds
waitForSchemaConsistency :: Client ()
waitForSchemaConsistency :: Client ()
waitForSchemaConsistency = do
  Client (UUID, [UUID]) -> Client ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Client (UUID, [UUID]) -> Client ())
-> Client (UUID, [UUID]) -> Client ()
forall a b. (a -> b) -> a -> b
$ Int
-> ((UUID, [UUID]) -> Bool)
-> Client (UUID, [UUID])
-> Client (UUID, [UUID])
forall (m :: * -> *) a.
MonadIO m =>
Int -> (a -> Bool) -> m a -> m a
retryWhileN Int
30 (UUID, [UUID]) -> Bool
inDisagreement Client (UUID, [UUID])
getSystemVersions
  where
    getSystemVersions :: Client (UUID, [UUID])
    getSystemVersions :: Client (UUID, [UUID])
getSystemVersions = do
      -- These two sub-queries must be made to the same node.
      -- (comparing local from node A and peers from node B wouldn't be correct)
      -- using the custom 'migrationPolicy' when connecting to cassandra ensures this.
      Maybe UUID
mbLocalVersion <- Client (Maybe UUID)
systemLocalVersion
      [UUID]
peers <- Client [UUID]
systemPeerVersions
      case Maybe UUID
mbLocalVersion of
        Just UUID
localVersion -> (UUID, [UUID]) -> Client (UUID, [UUID])
forall a. a -> Client a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UUID, [UUID]) -> Client (UUID, [UUID]))
-> (UUID, [UUID]) -> Client (UUID, [UUID])
forall a b. (a -> b) -> a -> b
$ (UUID
localVersion, [UUID]
peers)
        Maybe UUID
Nothing -> [Char] -> Client (UUID, [UUID])
forall a. HasCallStack => [Char] -> a
error [Char]
"No system_version in system.local (should never happen)"
    inDisagreement :: (UUID, [UUID]) -> Bool
    inDisagreement :: (UUID, [UUID]) -> Bool
inDisagreement (UUID
localVersion, [UUID]
peers) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (UUID -> Bool) -> [UUID] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
== UUID
localVersion) [UUID]
peers
    systemLocalVersion :: Client (Maybe UUID)
    systemLocalVersion :: Client (Maybe UUID)
systemLocalVersion = (Identity UUID -> UUID) -> Maybe (Identity UUID) -> Maybe UUID
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity UUID -> UUID
forall a. Identity a -> a
runIdentity (Maybe (Identity UUID) -> Maybe UUID)
-> Client (Maybe (Identity UUID)) -> Client (Maybe UUID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client (Maybe (Identity UUID))
qry
      where
        qry :: Client (Maybe (Identity UUID))
qry = RetrySettings
-> Client (Maybe (Identity UUID)) -> Client (Maybe (Identity UUID))
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery R () (Identity UUID)
-> QueryParams () -> Client (Maybe (Identity UUID))
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m (Maybe b)
query1 PrepQuery R () (Identity UUID)
cql (Consistency -> () -> QueryParams ()
forall a. Consistency -> a -> QueryParams a
params Consistency
One ()))
        cql :: PrepQuery R () (Identity UUID)
        cql :: PrepQuery R () (Identity UUID)
cql = PrepQuery R () (Identity UUID)
"select schema_version from system.local"
    systemPeerVersions :: Client [UUID]
    systemPeerVersions :: Client [UUID]
systemPeerVersions = (Identity UUID -> UUID) -> [Identity UUID] -> [UUID]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity UUID -> UUID
forall a. Identity a -> a
runIdentity ([Identity UUID] -> [UUID])
-> Client [Identity UUID] -> Client [UUID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client [Identity UUID]
qry
      where
        qry :: Client [Identity UUID]
qry = RetrySettings -> Client [Identity UUID] -> Client [Identity UUID]
forall (m :: * -> *) a.
MonadClient m =>
RetrySettings -> m a -> m a
retry RetrySettings
x1 (PrepQuery R () (Identity UUID)
-> QueryParams () -> Client [Identity UUID]
forall (m :: * -> *) a b (q :: * -> * -> * -> *).
(MonadClient m, Tuple a, Tuple b, RunQ q) =>
q R a b -> QueryParams a -> m [b]
query PrepQuery R () (Identity UUID)
cql (Consistency -> () -> QueryParams ()
forall a. Consistency -> a -> QueryParams a
params Consistency
One ()))
        cql :: PrepQuery R () (Identity UUID)
        cql :: PrepQuery R () (Identity UUID)
cql = PrepQuery R () (Identity UUID)
"select schema_version from system.peers"

retryWhileN :: (MonadIO m) => Int -> (a -> Bool) -> m a -> m a
retryWhileN :: forall (m :: * -> *) a.
MonadIO m =>
Int -> (a -> Bool) -> m a -> m a
retryWhileN Int
n a -> Bool
f m a
m =
  RetryPolicyM m
-> (RetryStatus -> a -> m Bool) -> (RetryStatus -> m a) -> m a
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying
    (Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
1000000 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
n)
    ((a -> m Bool) -> RetryStatus -> a -> m Bool
forall a b. a -> b -> a
const (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> (a -> Bool) -> a -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
f))
    (m a -> RetryStatus -> m a
forall a b. a -> b -> a
const m a
m)

-- | The migrationPolicy selects only one and always the same host
migrationPolicy :: IO Policy
migrationPolicy :: IO Policy
migrationPolicy = do
  IORef (Maybe Host)
h <- Maybe Host -> IO (IORef (Maybe Host))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe Host
forall a. Maybe a
Nothing
  Policy -> IO Policy
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Policy -> IO Policy) -> Policy -> IO Policy
forall a b. (a -> b) -> a -> b
$
    Policy
      { setup :: [Host] -> [Host] -> IO ()
setup = IORef (Maybe Host) -> [Host] -> [Host] -> IO ()
forall {m :: * -> *} {a} {p}.
MonadIO m =>
IORef (Maybe a) -> [a] -> p -> m ()
setHost IORef (Maybe Host)
h,
        onEvent :: HostEvent -> IO ()
onEvent = IO () -> HostEvent -> IO ()
forall a b. a -> b -> a
const (IO () -> HostEvent -> IO ()) -> IO () -> HostEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
        select :: IO (Maybe Host)
select = IORef (Maybe Host) -> IO (Maybe Host)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe Host)
h,
        acceptable :: Host -> IO Bool
acceptable = IO Bool -> Host -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> Host -> IO Bool) -> IO Bool -> Host -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True,
        hostCount :: IO Word
hostCount = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> (Maybe Host -> Int) -> Maybe Host -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Host] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Host] -> Int) -> (Maybe Host -> [Host]) -> Maybe Host -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Host -> [Host]
forall a. Maybe a -> [a]
maybeToList (Maybe Host -> Word) -> IO (Maybe Host) -> IO Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe Host) -> IO (Maybe Host)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe Host)
h,
        display :: IO [Char]
display = ([Char]
"migrationPolicy: " ++) ([Char] -> [Char])
-> (Maybe Host -> [Char]) -> Maybe Host -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Host -> [Char]
forall a. Show a => a -> [Char]
show (Maybe Host -> [Char]) -> IO (Maybe Host) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe Host) -> IO (Maybe Host)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe Host)
h,
        current :: IO [Host]
current = Maybe Host -> [Host]
forall a. Maybe a -> [a]
maybeToList (Maybe Host -> [Host]) -> IO (Maybe Host) -> IO [Host]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe Host) -> IO (Maybe Host)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe Host)
h
      }
  where
    setHost :: IORef (Maybe a) -> [a] -> p -> m ()
setHost IORef (Maybe a)
h (a
a : [a]
_) p
_ = IORef (Maybe a) -> Maybe a -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe a)
h (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
    setHost IORef (Maybe a)
_ [a]
_ p
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()