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 Locked a
fence <- forall (m :: * -> *) a. MonadIO m => IO (Fence m a)
newFence
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
maxTime IO a
act) forall a b. (a -> b) -> a -> b
$ \Either SomeException (Maybe a)
res -> Locked () -> IO ()
relock forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Partial, MonadIO m) =>
Fence m a -> a -> m ()
signalFence Fence Locked a
fence 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fence Locked a
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
Maybe a
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Fence m a -> IO (Maybe a)
testFence Fence m a
fence
case Maybe a
res of
Just a
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
Maybe a
Nothing -> forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Wait m a
Later forall a b. (a -> b) -> a -> b
$ 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
urls then forall a. Maybe a
Nothing else String -> Maybe (IO Conn)
connect forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [String]
urls) 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 <- forall a.
(Locked () -> IO ()) -> Seconds -> a -> IO a -> IO (Fence Locked a)
newLaterFence Locked () -> IO ()
relock Seconds
10 forall k v. HashMap k v
Map.empty 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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]
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO 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 = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
HashMap Key (Ver, [Key], Bloom [BS_Identity])
mp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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)<- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Ver
ver forall a. Eq a => a -> a -> Bool
== Ver
userVer) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
""
Right [BS_Identity]
vs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a e b.
MonadIO m =>
(a -> Wait m (Either e b)) -> [a] -> Wait m (Either e [b])
firstLeftWaitUnordered (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> Maybe b -> Either a b
maybeToEither ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Wait Locked (Maybe BS_Identity)
ask) [Key]
deps
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Hashable a => Bloom a -> a -> Bool
bloomTest Bloom [BS_Identity]
bloom [BS_Identity]
vs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
""
Fence Locked (BuildTree Key)
fence <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
(Locked () -> IO ()) -> Seconds -> a -> IO a -> IO (Fence Locked a)
newLaterFence Locked () -> IO ()
relock Seconds
10 forall a. Monoid a => a
mempty 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 forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
deps [BS_Identity]
vs
BuildTree Key
tree <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (BS_Identity
store, 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a e b.
MonadIO m =>
(a -> Wait m (Either e b)) -> [a] -> Wait m (Either e [b])
firstLeftWaitUnordered (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> Maybe b -> Either a b
maybeToEither ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Wait Locked (Maybe BS_Identity)
ask) [Key]
deps
Just BuildTree Key
tree<- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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]
depsforall a. a -> [a] -> [a]
:[[Key]]
ks) BuildTree Key
tree