Created
May 14, 2013 08:38
-
-
Save anonymous/5574535 to your computer and use it in GitHub Desktop.
Haskell/STM Dojo at Pub Hemingways, Jyväskylä, Finland on 2013-05-13.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment