Понимание, почему MVar не обновляется?

Question

Учитывая следующее веб-приложение "TinyUrl":

import Prelude ()
import Prelude.Compat
import Data.Aeson.Types
import GHC.Generics
import Lucid
import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import Servant.HTML.Lucid
import Control.Concurrent.MVar
import Data.Map
import Control.Monad.Except

type API = "tinyUrl" :> ValueAPI

type ValueAPI = Capture "value" String :> (
                       Get '[JSON] ResolvedTinyUrl
                  :<|> ReqBody '[JSON] UpdatedTinyUrl :> PutNoContent '[JSON] NoContent
        )

newtype TinyUrl = TinyUrl String deriving (Generic, Ord, Eq, Show)

instance ToJSON TinyUrl

newtype ResolvedTinyUrl = ResolvedTinyUrl { value :: TinyUrl } deriving Generic

data UpdatedTinyUrl = UpdatedTinyUrl
  { v :: String } deriving Generic

instance ToJSON ResolvedTinyUrl

instance FromJSON UpdatedTinyUrl

newtype ResolvedUrls = ResolvedUrls (MVar (Map TinyUrl String))

tinyUrlAPI :: Proxy API
tinyUrlAPI = Proxy

server :: IO (MVar (Map TinyUrl String)) -> Server API
server ioMap = tinyUrlOperations

  where tinyUrlOperations v =
          get v :<|> put v

          where get :: String -> Handler ResolvedTinyUrl
                get s = Handler $ do
                  map    <- lift $ ioMap
                  m      <- lift $ readMVar map
                  _      <- lift $ putStrLn ("m " ++ show m)
                  found  <- lift $ return $ Data.Map.lookup (TinyUrl s) m
                  case found of
                     Just a  -> return $ ResolvedTinyUrl (TinyUrl a)
                     Nothing -> (lift $ putStrLn ("did not find " ++ s)) >> throwError err404

                put :: String -> UpdatedTinyUrl -> Handler NoContent
                put key (UpdatedTinyUrl value) = Handler $ do
                 map     <- lift $ ioMap
                 m       <- lift $ takeMVar map
                 updated <- lift $ return $ Data.Map.insert (TinyUrl key) value m
                 _       <- lift $ putStrLn $ "updated:" ++ (show updated)
                 _       <- lift $ putMVar map updated
                 return NoContent


app :: IO (MVar (Map TinyUrl String)) -> Application
app map = serve tinyUrlAPI (server map)

main :: IO ()
main = run 8081 $ app (newMVar $ Data.Map.empty)

После локального запуска приложения я не понимаю, почему мой PUT на самом деле не обновляет MVar Map,

$curl -i -X PUT -H "Content-Type: application/json" -d '{"v" : "bar"}'  \
     localhost:8081/tinyUrl/foo
HTTP/1.1 204 No Content
Date: Fri, 20 Oct 2017 11:52:41 GMT
Server: Warp/3.2.13
Content-Type: application/json;charset=utf-8

$curl -i localhost:8081/tinyUrl/foo
HTTP/1.1 404 Not Found
Transfer-Encoding: chunked
Date: Fri, 20 Oct 2017 11:52:46 GMT
Server: Warp/3.2.13

Answer 1

Это выглядит неправильно:

server :: IO (MVar (Map TinyUrl String)) -> Server API
server ioMap = ...

ioMap выше IO действие, которое, в вашем случае, создаст новый MVar каждый раз, когда он используется. Ваши методы get/put каждый раз генерируют собственную карту и выбрасывают ее!

Вы хотите что-то вроде:

server :: MVar (Map TinyUrl String) -> Server API
server map = ...

app :: MVar (Map TinyUrl String) -> Application
app map = serve tinyUrlAPI (server map)

main :: IO ()
main = do
  map <- newMVar $ Data.Map.empty -- run this only once
  run 8081 $ app map