-- | 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 :: (Locked () -> IO ()) -> Seconds -> a -> IO a -> IO (Fence Locked a)
newLaterFence Locked () -> IO ()
relock Seconds
maxTime a
def IO a
act = do
    Fence Locked a
fence <- IO (Fence Locked a)
forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
    IO (Maybe a)
-> (Either SomeException (Maybe a) -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Seconds -> IO a -> IO (Maybe a)
forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
maxTime IO a
act) ((Either SomeException (Maybe a) -> IO ()) -> IO ThreadId)
-> (Either SomeException (Maybe a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \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.
(Partial, 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
    Fence Locked a -> IO (Fence Locked a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fence Locked a
fence

laterFence :: MonadIO m => Fence m a -> Wait m a
laterFence :: Fence m a -> Wait m a
laterFence Fence m a
fence = do
    Maybe a
res <- IO (Maybe a) -> Wait m (Maybe 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 Maybe a
res of
        Just a
v -> 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (if [String] -> 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. [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
conn <- IO Conn
conn
    Server
server <- Conn -> HashMap TypeRep (BinaryOp Key) -> Ver -> IO Server
newServer Conn
conn HashMap TypeRep (BinaryOp Key)
binop Ver
globalVer
    Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
fence <- (Locked () -> IO ())
-> Seconds
-> HashMap Key (Ver, [Key], Bloom [BS_Identity])
-> IO (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
-> IO
     (Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity])))
forall a.
(Locked () -> IO ()) -> Seconds -> a -> IO a -> IO (Fence Locked a)
newLaterFence Locked () -> IO ()
relock Seconds
10 HashMap Key (Ver, [Key], Bloom [BS_Identity])
forall k v. HashMap k v
Map.empty (IO (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
 -> IO
      (Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))))
-> IO (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
-> IO
     (Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity])))
forall a b. (a -> b) -> a -> b
$ do
        [(Key, Ver, [Key], Bloom [BS_Identity])]
xs <- Server
-> [(TypeRep, Ver)] -> IO [(Key, Ver, [Key], Bloom [BS_Identity])]
serverAllKeys Server
server [(TypeRep, Ver)]
ruleVer
        HashMap Key (Ver, [Key], Bloom [BS_Identity])
-> IO (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Key (Ver, [Key], Bloom [BS_Identity])
 -> IO (HashMap Key (Ver, [Key], Bloom [BS_Identity])))
-> HashMap Key (Ver, [Key], Bloom [BS_Identity])
-> IO (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
forall a b. (a -> b) -> a -> b
$ [(Key, (Ver, [Key], Bloom [BS_Identity]))]
-> HashMap Key (Ver, [Key], Bloom [BS_Identity])
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(Key
k,(Ver
v,[Key]
ds,Bloom [BS_Identity]
test)) | (Key
k,Ver
v,[Key]
ds,Bloom [BS_Identity]
test) <- [(Key, Ver, [Key], Bloom [BS_Identity])]
xs]
    Cloud -> IO Cloud
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cloud -> IO Cloud) -> Cloud -> IO Cloud
forall a b. (a -> b) -> a -> b
$ Server
-> (Locked () -> IO ())
-> Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
-> Cloud
Cloud Server
server Locked () -> IO ()
relock Fence Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
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
    HashMap Key (Ver, [Key], Bloom [BS_Identity])
mp <- Wait Locked (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
-> MaybeT
     (Wait Locked) (HashMap Key (Ver, [Key], Bloom [BS_Identity]))
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
ver, [Key]
deps, Bloom [BS_Identity]
bloom)<- Maybe (Ver, [Key], Bloom [BS_Identity])
-> MaybeT (Wait Locked) (Maybe (Ver, [Key], Bloom [BS_Identity]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Ver, [Key], Bloom [BS_Identity])
 -> MaybeT (Wait Locked) (Maybe (Ver, [Key], Bloom [BS_Identity])))
-> Maybe (Ver, [Key], Bloom [BS_Identity])
-> MaybeT (Wait Locked) (Maybe (Ver, [Key], Bloom [BS_Identity]))
forall a b. (a -> b) -> a -> b
$ Key
-> HashMap Key (Ver, [Key], Bloom [BS_Identity])
-> Maybe (Ver, [Key], Bloom [BS_Identity])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Key
key HashMap Key (Ver, [Key], Bloom [BS_Identity])
mp
    Bool -> MaybeT (Wait Locked) () -> MaybeT (Wait Locked) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Ver
ver Ver -> Ver -> Bool
forall a. Eq a => a -> a -> Bool
== Ver
userVer) (MaybeT (Wait Locked) () -> MaybeT (Wait Locked) ())
-> MaybeT (Wait Locked) () -> MaybeT (Wait Locked) ()
forall a b. (a -> b) -> a -> b
$ String -> MaybeT (Wait Locked) ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
""
    Right [BS_Identity]
vs <- Wait Locked (Either () [BS_Identity])
-> MaybeT (Wait Locked) (Either () [BS_Identity])
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 (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
    Bool -> MaybeT (Wait Locked) () -> MaybeT (Wait Locked) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bloom [BS_Identity] -> [BS_Identity] -> Bool
forall a. Hashable a => Bloom a -> a -> Bool
bloomTest Bloom [BS_Identity]
bloom [BS_Identity]
vs) (MaybeT (Wait Locked) () -> MaybeT (Wait Locked) ())
-> MaybeT (Wait Locked) () -> MaybeT (Wait Locked) ()
forall a b. (a -> b) -> a -> b
$ String -> MaybeT (Wait Locked) ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
""
    Fence Locked (BuildTree Key)
fence <- IO (Fence Locked (BuildTree Key))
-> MaybeT (Wait Locked) (Fence Locked (BuildTree Key))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Fence Locked (BuildTree Key))
 -> MaybeT (Wait Locked) (Fence Locked (BuildTree Key)))
-> IO (Fence Locked (BuildTree Key))
-> MaybeT (Wait Locked) (Fence Locked (BuildTree Key))
forall a b. (a -> b) -> a -> b
$ (Locked () -> IO ())
-> Seconds
-> BuildTree Key
-> IO (BuildTree Key)
-> IO (Fence Locked (BuildTree Key))
forall a.
(Locked () -> IO ()) -> Seconds -> a -> IO a -> IO (Fence Locked a)
newLaterFence Locked () -> IO ()
relock Seconds
10 BuildTree Key
forall a. Monoid a => a
mempty (IO (BuildTree Key) -> IO (Fence Locked (BuildTree Key)))
-> IO (BuildTree Key) -> IO (Fence Locked (BuildTree Key))
forall a b. (a -> b) -> a -> b
$ Server
-> Key -> Ver -> Ver -> [(Key, BS_Identity)] -> IO (BuildTree Key)
serverOneKey Server
server Key
key Ver
builtinVer Ver
userVer ([(Key, BS_Identity)] -> IO (BuildTree Key))
-> [(Key, BS_Identity)] -> IO (BuildTree Key)
forall a b. (a -> b) -> a -> b
$ [Key] -> [BS_Identity] -> [(Key, BS_Identity)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
deps [BS_Identity]
vs
    BuildTree Key
tree <- Wait Locked (BuildTree Key) -> MaybeT (Wait Locked) (BuildTree Key)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Wait Locked (BuildTree Key)
 -> MaybeT (Wait Locked) (BuildTree Key))
-> Wait Locked (BuildTree Key)
-> MaybeT (Wait Locked) (BuildTree Key)
forall a b. (a -> b) -> a -> b
$ Fence Locked (BuildTree Key) -> Wait Locked (BuildTree Key)
forall (m :: * -> *) a. MonadIO m => Fence m a -> Wait m a
laterFence Fence Locked (BuildTree Key)
fence
    [[Key]]
-> BuildTree Key
-> MaybeT (Wait Locked) (BS_Identity, [[Key]], IO ())
f [[Key]
deps] BuildTree Key
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 (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 [BS_Identity]
vs <- Wait Locked (Either () [BS_Identity])
-> MaybeT (Wait Locked) (Either () [BS_Identity])
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 (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 BuildTree Key
tree<- Maybe (BuildTree Key)
-> MaybeT (Wait Locked) (Maybe (BuildTree Key))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (BuildTree Key)
 -> MaybeT (Wait Locked) (Maybe (BuildTree Key)))
-> Maybe (BuildTree Key)
-> MaybeT (Wait Locked) (Maybe (BuildTree Key))
forall a b. (a -> b) -> a -> b
$ [BS_Identity]
-> [([BS_Identity], BuildTree Key)] -> Maybe (BuildTree Key)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [BS_Identity]
vs [([BS_Identity], BuildTree Key)]
trees
            [[Key]]
-> BuildTree Key
-> MaybeT (Wait Locked) (BS_Identity, [[Key]], IO ())
f ([Key]
deps[Key] -> [[Key]] -> [[Key]]
forall a. a -> [a] -> [a]
:[[Key]]
ks) BuildTree Key
tree