Haskell/STM Dojo at Pub Hemingways, Jyväskylä, Finland on 2013-05-13.

KeyValueStorage-dojo.hs

{-# LANGUAGE OverloadedStrings #-}
module KeyValueStorage where

import Data.Functor
import Control.Concurrent.STM
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.ByteString.Char8 as BS
import Data.Map (Map)
import qualified Data.Map as M
import Data.List (intersperse)

type Storage = TVar (Map Text ByteString)

-- | Initializes key-value storage
initStorage :: IO Storage
initStorage = newTVarIO M.empty

-- | Retrieves a document from the storage. If no document is found,
-- wait until it is created.
waitDoc :: Storage -> Text -> IO ByteString
waitDoc db key = atomically $ do
  tieto <- readTVar db
  case M.lookup key tieto of
    Nothing -> retry
    Just a -> return a

-- | Retrieves a document from the storage. If no document is found,
-- return Nothing.
getDoc :: Storage -> Text -> IO (Maybe ByteString)
getDoc db key = atomically $ do
  tieto <- readTVar db
  return $ M.lookup key tieto

-- | Stores a document. If older document exists, it is
-- overwritten. In case of overwrite, True is returned.
putDoc :: Storage -> Text -> ByteString -> IO Bool
putDoc db key value = atomically $ do
  tieto <- readTVar db
  let oliko = M.member key tieto
  writeTVar db $ M.insert key value tieto
  return oliko

-- | Deletes a document. If no such document exists, return False.
delDoc :: Storage -> Text -> IO Bool
delDoc db key = atomically $ do
  tieto <- readTVar db
  let oliko = M.member key tieto
  writeTVar db $ M.delete key tieto
  return oliko

-- | List keys in the storage
getDocs :: Storage -> IO ByteString
getDocs db = atomically $ do
  tieto <- readTVar db
  return $ B.fromChunks $ intersperse "\n" $ map encodeUtf8 $ M.keys tieto

KeyValueStorage-problem.hs

{-# LANGUAGE OverloadedStrings #-}
module KeyValueStorage where

import Data.Functor
import Control.Concurrent.STM
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.ByteString.Char8 as BS
import Data.Map (Map)
import qualified Data.Map as M
import Data.List (intersperse)

type Storage = () -- TODO

-- | Initializes key-value storage
initStorage :: IO Storage
initStorage = return undefined

-- | Retrieves a document from the storage. If no document is found,
-- wait until it is created.
waitDoc :: Storage -> Text -> IO ByteString
waitDoc = undefined

-- | Retrieves a document from the storage. If no document is found,
-- return Nothing.
getDoc :: Storage -> Text -> IO (Maybe ByteString)
getDoc = undefined

-- | Stores a document. If older document exists, it is
-- overwritten. In case of overwrite, True is returned.
putDoc :: Storage -> Text -> ByteString -> IO Bool
putDoc = undefined

-- | Deletes a document. If no such document exists, return False.
delDoc :: Storage -> Text -> IO Bool
delDoc = undefined

-- | List documents in the storage
getDocs :: Storage -> IO ByteString
getDocs = undefined

KeyValueStorage-solution.hs

{-# LANGUAGE OverloadedStrings #-}
module KeyValueStorage where

import Data.Functor
import Control.Concurrent.STM
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.ByteString.Char8 as BS
import Data.Map (Map)
import qualified Data.Map as M
import Data.List (intersperse)

type Storage = TVar (Map Text ByteString)

-- | Initializes key-value storage
initStorage :: IO Storage
initStorage = newTVarIO M.empty

-- | Retrieves a document from the storage. If no document is found,
-- wait until it is created.
waitDoc :: Storage -> Text -> IO ByteString
waitDoc var key = atomically $ do
  m <- readTVar var
  case M.lookup key m of
    Nothing -> retry
    Just x  -> return x

-- | Retrieves a document from the storage. If no document is found,
-- return Nothing.
getDoc :: Storage -> Text -> IO (Maybe ByteString)
getDoc var key = M.lookup key <$> readTVarIO var

-- | Stores a document. If older document exists, it is
-- overwritten. In case of overwrite, True is returned.
putDoc :: Storage -> Text -> ByteString -> IO Bool
putDoc var key value = atomically $ do
  m <- readTVar var
  writeTVar var $ M.insert key value m
  return $ M.member key m

-- | Deletes a document. If no such document exists, return False.
delDoc :: Storage -> Text -> IO Bool
delDoc var key = atomically $ do
  m <- readTVar var
  if M.member key m
    then do writeTVar var $ M.delete key m 
            return True
    else return False

getDocs :: Storage -> IO ByteString
getDocs var = do
  m <- readTVarIO var
  return $ B.fromChunks $ intersperse "\n" $ map encodeUtf8 $ M.keys m

Web.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where 

import Control.Monad.IO.Class
import Data.ByteString.Lazy (ByteString,fromChunks)
import Data.Conduit
import Data.Conduit.List (consume)
import Network.HTTP.Types (ok200,badRequest400)
import Network.Wai
import Network.Wai.Handler.Warp (run)

import KeyValueStorage

main = do
    let port = 3000
    putStrLn $ "Listening on port " ++ show port
    var <- initStorage
    run port $ app var

app :: Storage -> Application
app var req = case (requestMethod req,pathInfo req) of
  ("GET",["doc",key,"wait"]) -> do
    doc <- liftIO $ waitDoc var key
    binaryResponse doc
  ("GET",["doc",key]) -> do
    mbDoc <- liftIO $ getDoc var key
    case mbDoc of
      Just doc -> binaryResponse doc
      Nothing -> bad "Document not found"
  ("DELETE",["doc",key]) -> do
    deleted <- liftIO $ delDoc var key
    if deleted 
      then good "Deleted"
      else bad "Not found"
  ("PUT",["doc",key]) -> do
      value <- requestBody req $$ sinkLbs
      overwritten <- liftIO $ putDoc var key value
      good $ if overwritten then "Overwritten" else "Created"
  ("GET",["dir"]) -> do
    values <- liftIO $ getDocs var
    good values
  _ -> bad "Unknown command"

bad,good :: Monad m => ByteString -> m Response
bad  = textualResponse badRequest400 
good = textualResponse ok200

textualResponse code text = return $
                            responseLBS code
                            [("Content-Type", "text/plain")]
                            text

binaryResponse x = return $
                   responseLBS ok200
                   [("Content-Type", "application/octet-stream")]
                   x

-- | Backported from conduit-1.0.5 module Data.Conduit.Binary
sinkLbs = fmap fromChunks consume