-- | The endpoints on the server
module Development.Shake.Internal.History.Cloud(
    Cloud, newCloud, addCloud, lookupCloud
    ) where

import Development.Shake.Internal.Value
import Development.Shake.Internal.Core.Database
import Development.Shake.Internal.History.Types
import Development.Shake.Internal.History.Network
import Development.Shake.Internal.History.Server
import Development.Shake.Internal.History.Bloom
import Control.Concurrent.Extra
import System.Time.Extra
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import General.Fence
import qualified Data.HashMap.Strict as Map
import Data.Typeable
import Data.Either.Extra
import General.Binary
import General.Extra
import General.Wait


type Initial = Map.HashMap Key (Ver, [Key], Bloom [BS_Identity])

data Cloud = Cloud Server (Locked () -> IO ()) (Fence Locked Initial)


newLaterFence :: (Locked () -> IO ()) -> Seconds -> a -> IO a -> IO (Fence Locked a)
newLaterFence :: forall a.
(Locked () -> IO ()) -> Seconds -> a -> IO a -> IO (Fence Locked a)
newLaterFence Locked () -> IO ()
relock Seconds
maxTime a
def IO a
act = do
    fence <- IO (Fence Locked a)
forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
    forkFinally (timeout maxTime act) $ \Either SomeException (Maybe a)
res -> Locked () -> IO ()
relock (Locked () -> IO ()) -> Locked () -> IO ()
forall a b. (a -> b) -> a -> b
$ Fence Locked a -> a -> Locked ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
Fence m a -> a -> m ()
signalFence Fence Locked a
fence (a -> Locked ()) -> a -> Locked ()
forall a b. (a -> b) -> a -> b
$ case Either SomeException (Maybe a)
res of
        Right (Just a
v) -> a
v
        Either SomeException (Maybe a)
_ -> a
def
    pure fence

laterFence :: MonadIO m => Fence m a -> Wait m a
laterFence :: forall (m :: * -> *) a. MonadIO m => Fence m a -> Wait m a
laterFence Fence m a
fence = do
    res <- IO (Maybe a) -> Wait m (Maybe a)
forall a. IO a -> Wait m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> Wait m (Maybe a))
-> IO (Maybe a) -> Wait m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Fence m a -> IO (Maybe a)
forall (m :: * -> *) a. Fence m a -> IO (Maybe a)
testFence Fence m a
fence
    case res of
        Just a
v -> a -> Wait m a
forall a. a -> Wait m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
        Maybe a
Nothing -> ((a -> m ()) -> m ()) -> Wait m a
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later (((a -> m ()) -> m ()) -> Wait m a)
-> ((a -> m ()) -> m ()) -> Wait m a
forall a b. (a -> b) -> a -> b
$ Fence m a -> (a -> m ()) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Fence m a -> (a -> m ()) -> m ()
waitFence Fence m a
fence


newCloud :: (Locked () -> IO ()) -> Map.HashMap TypeRep (BinaryOp Key) -> Ver -> [(TypeRep, Ver)] -> [String] -> Maybe (IO Cloud)
newCloud :: (Locked () -> IO ())
-> HashMap TypeRep (BinaryOp Key)
-> Ver
-> [(TypeRep, Ver)]
-> [String]
-> Maybe (IO Cloud)
newCloud Locked () -> IO ()
relock HashMap TypeRep (BinaryOp Key)
binop Ver
globalVer [(TypeRep, Ver)]
ruleVer [String]
urls = ((IO Conn -> IO Cloud) -> Maybe (IO Conn) -> Maybe (IO Cloud))
-> Maybe (IO Conn) -> (IO Conn -> IO Cloud) -> Maybe (IO Cloud)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (IO Conn -> IO Cloud) -> Maybe (IO Conn) -> Maybe (IO Cloud)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
urls then Maybe (IO Conn)
forall a. Maybe a
Nothing else String -> Maybe (IO Conn)
connect (String -> Maybe (IO Conn)) -> String -> Maybe (IO Conn)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
urls) ((IO Conn -> IO Cloud) -> Maybe (IO Cloud))
-> (IO Conn -> IO Cloud) -> Maybe (IO Cloud)
forall a b. (a -> b) -> a -> b
$ \IO Conn
conn -> do
    conn <- IO Conn
conn
    server <- newServer conn binop globalVer
    fence <- newLaterFence relock 10 Map.empty $ do
        xs <- serverAllKeys server ruleVer
        pure $ Map.fromList [(k,(v,ds,test)) | (k,v,ds,test) <- xs]
    pure $ Cloud server relock fence


addCloud :: Cloud -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()
addCloud :: Cloud
-> Key
-> Ver
-> Ver
-> [[(Key, BS_Identity)]]
-> BS_Identity
-> [String]
-> IO ()
addCloud (Cloud Server
server Locked () -> IO ()
_ Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
_) Key
x1 Ver
x2 Ver
x3 [[(Key, BS_Identity)]]
x4 BS_Identity
x5 [String]
x6 = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Server
-> Key
-> Ver
-> Ver
-> [[(Key, BS_Identity)]]
-> BS_Identity
-> [String]
-> IO ()
serverUpload Server
server Key
x1 Ver
x2 Ver
x3 [[(Key, BS_Identity)]]
x4 BS_Identity
x5 [String]
x6


lookupCloud :: Cloud -> (Key -> Wait Locked (Maybe BS_Identity)) -> Key -> Ver -> Ver -> Wait Locked (Maybe (BS_Store, [[Key]], IO ()))
lookupCloud :: Cloud
-> (Key -> Wait Locked (Maybe BS_Identity))
-> Key
-> Ver
-> Ver
-> Wait Locked (Maybe (BS_Identity, [[Key]], IO ()))
lookupCloud (Cloud Server
server Locked () -> IO ()
relock Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
initial) Key -> Wait Locked (Maybe BS_Identity)
ask Key
key Ver
builtinVer Ver
userVer = MaybeT (Wait Locked) (BS_Identity, [[Key]], IO ())
-> Wait Locked (Maybe (BS_Identity, [[Key]], IO ()))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (Wait Locked) (BS_Identity, [[Key]], IO ())
 -> Wait Locked (Maybe (BS_Identity, [[Key]], IO ())))
-> MaybeT (Wait Locked) (BS_Identity, [[Key]], IO ())
-> Wait Locked (Maybe (BS_Identity, [[Key]], IO ()))
forall a b. (a -> b) -> a -> b
$ do
    mp <- Wait Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
-> MaybeT
     (Wait Locked) (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Wait Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
 -> MaybeT
      (Wait Locked) (HashMap Key (Ver, [Key], Bloom [BS_Identity])))
-> Wait Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
-> MaybeT
     (Wait Locked) (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
forall a b. (a -> b) -> a -> b
$ Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
-> Wait Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
forall (m :: * -> *) a. MonadIO m => Fence m a -> Wait m a
laterFence Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
initial
    Just (ver, deps, bloom)<- pure $ Map.lookup key mp
    unless (ver == userVer) $ fail ""
    Right vs <- lift $ firstLeftWaitUnordered (fmap (maybeToEither ()) . ask) deps
    unless (bloomTest bloom vs) $ fail ""
    fence <- liftIO $ newLaterFence relock 10 mempty $ serverOneKey server key builtinVer userVer $ zip deps vs
    tree <- lift $ laterFence fence
    f [deps] tree
    where
        f :: [[Key]] -> BuildTree Key -> MaybeT (Wait Locked) (BS_Store, [[Key]], IO ())
        f :: [[Key]]
-> BuildTree Key
-> MaybeT (Wait Locked) (BS_Identity, [[Key]], IO ())
f [[Key]]
ks (Done BS_Identity
store [(String, FileSize, FileHash)]
xs) = (BS_Identity, [[Key]], IO ())
-> MaybeT (Wait Locked) (BS_Identity, [[Key]], IO ())
forall a. a -> MaybeT (Wait Locked) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BS_Identity
store, [[Key]] -> [[Key]]
forall a. [a] -> [a]
reverse [[Key]]
ks, Server -> Key -> [(String, FileSize, FileHash)] -> IO ()
serverDownloadFiles Server
server Key
key [(String, FileSize, FileHash)]
xs)
        f [[Key]]
ks (Depend [Key]
deps [([BS_Identity], BuildTree Key)]
trees) = do
            Right vs <- Wait Locked (Either () [BS_Identity])
-> MaybeT (Wait Locked) (Either () [BS_Identity])
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Wait Locked (Either () [BS_Identity])
 -> MaybeT (Wait Locked) (Either () [BS_Identity]))
-> Wait Locked (Either () [BS_Identity])
-> MaybeT (Wait Locked) (Either () [BS_Identity])
forall a b. (a -> b) -> a -> b
$ (Key -> Wait Locked (Either () BS_Identity))
-> [Key] -> Wait Locked (Either () [BS_Identity])
forall (m :: * -> *) a e b.
MonadIO m =>
(a -> Wait m (Either e b)) -> [a] -> Wait m (Either e [b])
firstLeftWaitUnordered ((Maybe BS_Identity -> Either () BS_Identity)
-> Wait Locked (Maybe BS_Identity)
-> Wait Locked (Either () BS_Identity)
forall a b. (a -> b) -> Wait Locked a -> Wait Locked b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Maybe BS_Identity -> Either () BS_Identity
forall a b. a -> Maybe b -> Either a b
maybeToEither ()) (Wait Locked (Maybe BS_Identity)
 -> Wait Locked (Either () BS_Identity))
-> (Key -> Wait Locked (Maybe BS_Identity))
-> Key
-> Wait Locked (Either () BS_Identity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Wait Locked (Maybe BS_Identity)
ask) [Key]
deps
            Just tree<- pure $ lookup vs trees
            f (deps:ks) tree