-- | 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 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