added example distributed key-value store served by servant

examples/distributedKeyValueServant.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TypeOperators              #-}
+
+
+module Main where
+
+import           Control.Applicative
+import           Control.Concurrent         (forkIO, threadDelay)
+import           Control.Concurrent.MVar
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Control.Monad.State
+import           Control.Monad.Trans.Except
+import           Data.Aeson
+import           Data.ByteString.Lazy       as DBL hiding (elemIndex, length)
+import           Data.Hashable
+import           Data.IORef
+import           Data.List
+import           Data.Map                   as M
+import           Data.Maybe
+import qualified Data.Text                  as DT
+import           Data.Typeable
+import           Data.UUID
+import           Data.UUID.Aeson
+import           Data.UUID.V4
+import           GHC.Generics
+import           Network.Wai
+import           Network.Wai.Handler.Warp   hiding (run)
+import           Servant                    hiding (Handler)
+import           Servant.API
+import           System.IO
+import           System.IO.Unsafe
+import           Transient.Base
+import           Transient.Internals
+import           Transient.Move
+import           Transient.Move.Utils
+
+
+newtype VendorId = VendorId UUID
+  deriving(Eq, Ord, FromHttpApiData)
+
+newtype ItemId = ItemId UUID
+  deriving(Eq, Ord, FromHttpApiData)
+
+type ItemApi =
+  "item" :> Get '[JSON] [Item] :<|>
+  "item" :> Capture "itemId" ItemId :> Capture "vendorId" VendorId :> Get '[JSON] Item
+
+itemApi :: Proxy ItemApi
+itemApi = Proxy
+
+-- * app
+
+instance FromHttpApiData UUID where
+  parseUrlPiece t = case fromText t of
+    Just u -> Right u
+    Nothing -> Left "Invalid UUID"
+
+run :: IO ()
+run = do
+  let port = 3000
+      settings =
+        setPort port $
+        setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show port)) defaultSettings
+  runSettings settings =<< mkApp
+
+mkApp :: IO Application
+mkApp = return $ serve itemApi server
+
+server :: Server ItemApi
+server =
+  getItems :<|>
+  getItemById
+
+type Handler = ExceptT ServantErr IO
+
+getItems :: Handler [Item]
+getItems = return [exampleItem]
+
+getItemById :: ItemId -> VendorId -> Handler Item
+getItemById i@(ItemId iid) v@(VendorId vid) = do
+  let h = hash $ toString iid ++ toString vid
+  liftIO $ runCloudIO' $ do
+    exit <- onAll $ getSData <|> error "no exit data"  ::Cloud (Exit (MVar (Either String (Maybe  Item))))
+    local $ liftIO (readIORef ref) >>= \dat -> modify (\s -> s{mfData= dat})
+    setData exit
+    nodes <- onAll getNodes
+    let num = h `rem` length nodes
+    let node = sort nodes !! num
+    m <- hashmap
+    quant <- runAt node $ return $ M.lookup (v, i) m
+    lliftIO $ print "after runAt"
+    lliftIO $ print quant
+    case quant of
+      Just q -> local $ exit (Item q "Item 1")
+      Nothing -> local $ exit (Item 0 "Item Unknown")
+    -- return $ Item h "Item Unknown"
+
+
+exampleItem :: Item
+exampleItem = Item 0 "example item"
+
+-- * item
+
+data Item
+  = Item {
+    itemId   :: Int,
+    itemText :: String
+  }
+  deriving (Eq, Show, Generic, Read)
+
+instance ToJSON Item
+instance FromJSON Item
+
+
+--connectionHandle = connect "localhost" 28015 Nothing
+hashmap :: Cloud (Map (VendorId, ItemId) Int)
+hashmap = onAll (return $ M.fromList [((VendorId . fromJust $ fromText "bacd5f20-8b46-4790-b93f-73c47b8def72", ItemId . fromJust $ fromText "db6af727-1007-4cae-bd24-f653b1c6e94e"), 10),
+                                      ((VendorId . fromJust $ fromText "8f833732-a199-4a74-aa55-a6cd7b19ab66", ItemId . fromJust $ fromText "d6693304-3849-4e69-ae31-1421ea320de4"), 10)])
+
+
+{-# NOINLINE ref #-}
+ref = unsafePerformIO $ newIORef (error "state should have been written here!")
+
+
+main :: IO ()
+main = runCloudIO' $ do
+    seed <- lliftIO $ createNode "localhost" 8000
+    node <- lliftIO $ createNode "localhost" 8000
+    m <- hashmap
+    connect node seed
+    local $ gets mfData >>= liftIO . writeIORef ref
+    nodes <- onAll getNodes
+    lliftIO $ print $ length nodes
+    -- let num = fromJust $ elemIndex node (sort nodes)
+    -- quant <- runAt (nodes !! num) $ return $ M.lookup num m
+    -- lliftIO $ print quant
+    (do i <- local $ getMailbox "mailbox" ; lliftIO $ print (i::Int))
+        <|> (do clustered $ local $ putMailbox "mailbox" (123::Int)  ; Control.Applicative.empty)
+        <|> lliftIO run